src/game/renders/opengl/r_common.pas

   1 (* Copyright (C)  Doom 2D: Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, version 3 of the License ONLY.
   6  *
   7  * This program is distributed in the hope that it will be useful,
   8  * but WITHOUT ANY WARRANTY; without even the implied warranty of
   9  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  10  * GNU General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU General Public License
  13  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  14  *)
  15 {$INCLUDE ../../../shared/a_modes.inc}
  16 unit r_common;
  17
  18 interface
  19
  20   uses r_textures, g_player, g_phys;
  21
  22   type
  23     TBasePoint = (
  24       BP_LEFTUP,   BP_UP,     BP_RIGHTUP,
  25       BP_LEFT,     BP_CENTER, BP_RIGHT,
  26       BP_LEFTDOWN, BP_DOWN,   BP_RIGHTDOWN
  27     );
  28
  29     THereTexture = record
  30       name: AnsiString;
  31       id: TGLTexture;
  32     end;
  33
  34   var
  35     stdfont: TGLFont;
  36     smallfont: TGLFont;
  37     menufont: TGLFont;
  38
  39   function  r_Common_LoadThis (const name: AnsiString; var here: THereTexture): Boolean;
  40   procedure r_Common_FreeThis (var here: THereTexture);
  41
  42   procedure r_Common_CalcAspect (ow, oh, nw, nh: LongInt; horizontal: Boolean; out ww, hh: LongInt);
  43
  44   procedure r_Common_GetBasePoint (x, y, w, h: Integer; p: TBasePoint; out xx, yy: Integer);
  45   procedure r_Common_DrawText (const text: AnsiString; x, y: Integer; r, g, b, a: Byte; f: TGLFont; p: TBasePoint);
  46   procedure r_Common_DrawTexture (img: TGLTexture; x, y, w, h: Integer; p: TBasePoint);
  47   procedure r_Common_GetFormatTextSize (const text: AnsiString; f: TGLFont; out w, h: Integer);
  48   procedure r_Common_DrawFormatText (const text: AnsiString; x, y: Integer; a: Byte; f: TGLFont; p: TBasePoint);
  49
  50   function r_Common_TimeToStr (t: LongWord): AnsiString;
  51
  52   procedure r_Common_GetObjectPos (const obj: TObj; out x, y: Integer);
  53   procedure r_Common_GetPlayerPos (const p: TPlayer; out x, y: Integer);
  54   procedure r_Common_GetCameraPos (const p: TPlayer; center: Boolean; out x, y: Integer);
  55   function  r_Common_GetPosByUID (uid: WORD; out obj: TObj; out x, y: Integer): Boolean;
  56
  57   procedure r_Common_Load;
  58   procedure r_Common_Free;
  59
  60 implementation
  61
  62   uses
  63     Math, SysUtils,
  64     e_log, utils,
  65     g_base, g_basic, g_options, g_game, g_map,
  66     {$IFDEF ENABLE_CORPSES}
  67       g_corpses,
  68     {$ENDIF}
  69     r_draw, r_fonts
  70   ;
  71
  72   procedure r_Common_GetObjectPos (const obj: TObj; out x, y: Integer);
  73     var fx, fy: Integer;
  74   begin
  75     obj.Lerp(gLerpFactor, fx, fy);
  76     x := fx;
  77     y := fy + obj.slopeUpLeft;
  78   end;
  79
  80   procedure r_Common_GetPlayerPos (const p: TPlayer; out x, y: Integer);
  81     var fx, fy, fSlope: Integer;
  82   begin
  83     ASSERT(p <> nil);
  84     p.obj.Lerp(gLerpFactor, fx, fy);
  85     fSlope := nlerp(p.SlopeOld, p.obj.slopeUpLeft, gLerpFactor);
  86     x := fx;
  87     y := fy + fSlope;
  88   end;
  89
  90 {$IFDEF ENABLE_CORPSES}
  91   function r_Common_GetPlayerCorpse (const p: TPlayer): TCorpse;
  92   begin
  93     result := nil;
  94     if (p <> nil) and (p.Alive = false) and (p.Spectator = false) and (p.Corpse >= 0) then
  95       if (gCorpses <> nil) and (gCorpses[p.Corpse] <> nil) and (gCorpses[p.Corpse].PlayerUID = p.UID) then
  96         result := gCorpses[p.Corpse];
  97   end;
  98 {$ENDIF}
  99
 100   procedure r_Common_GetCameraPos (const p: TPlayer; center: Boolean; out x, y: Integer);
 101     {$IFDEF ENABLE_CORPSES}
 102       var corpse: TCorpse;
 103     {$ENDIF}
 104   begin
 105 {$IFDEF ENABLE_CORPSES}
 106     corpse := r_Common_GetPlayerCorpse(p);
 107     if corpse <> nil then
 108     begin
 109       r_Common_GetObjectPos(corpse.obj, x, y);
 110       if center then
 111       begin
 112         x := x + corpse.obj.rect.width div 2;
 113         y := y + corpse.obj.rect.height div 2;
 114       end;
 115     end
 116     else
 117 {$ENDIF}
 118     if p <> nil then
 119     begin
 120       r_Common_GetPlayerPos(p, x, y);
 121       y := y - nlerp(p.IncCamOld, p.IncCam, gLerpFactor);
 122       if center then
 123       begin
 124         x := x + p.obj.rect.width div 2;
 125         y := y + p.obj.rect.height div 2;
 126       end;
 127     end
 128     else
 129     begin
 130       x := 0;
 131       y := 0;
 132       if center then
 133       begin
 134         x := x + gMapInfo.Width div 2;
 135         y := y + gMapInfo.Height div 2;
 136       end;
 137     end;
 138   end;
 139
 140   function r_Common_GetPosByUID (uid: WORD; out obj: TObj; out x, y: Integer): Boolean;
 141     var p: TPlayer; found: Boolean;
 142   begin
 143     found := false;
 144     if g_GetUIDType(uid) = UID_PLAYER then
 145     begin
 146       p := g_Player_Get(uid);
 147       found := p <> nil;
 148       if found then
 149       begin
 150         r_Common_GetPlayerPos(p, x, y);
 151         obj := p.obj;
 152       end;
 153     end
 154     else if GetPos(uid, @obj) then
 155     begin
 156       found := true;
 157       r_Common_GetObjectPos(obj, x, y);
 158     end;
 159     result := found;
 160   end;
 161
 162   procedure r_Common_GetBasePoint (x, y, w, h: Integer; p: TBasePoint; out xx, yy: Integer);
 163   begin
 164     case p of
 165       TBasePoint.BP_LEFTUP,  TBasePoint.BP_LEFT,   TBasePoint.BP_LEFTDOWN:  xx := x;
 166       TBasePoint.BP_UP,      TBasePoint.BP_CENTER, TBasePoint.BP_DOWN:      xx := x - w div 2;
 167       TBasePoint.BP_RIGHTUP, TBasePoint.BP_RIGHT,  TBasePoint.BP_RIGHTDOWN: xx := x - w;
 168     end;
 169     case p of
 170       TBasePoint.BP_LEFTUP,   TBasePoint.BP_UP,     TBasePoint.BP_RIGHTUP:   yy := y;
 171       TBasePoint.BP_LEFT,     TBasePoint.BP_CENTER, TBasePoint.BP_RIGHT:     yy := y - h div 2;
 172       TBasePoint.BP_LEFTDOWN, TBasePoint.BP_DOWN,   TBasePoint.BP_RIGHTDOWN: yy := y - h;
 173     end;
 174   end;
 175
 176   procedure r_Common_DrawText (const text: AnsiString; x, y: Integer; r, g, b, a: Byte; f: TGLFont; p: TBasePoint);
 177     var xx, yy, w, h: Integer;
 178   begin
 179     xx := x; yy := y;
 180     if p <> TBasePoint.BP_LEFTUP then
 181     begin
 182       r_Draw_GetTextSize(text, f, w, h);
 183       r_Common_GetBasePoint(x, y, w, h, p, xx, yy);
 184     end;
 185     r_Draw_Text(text, xx, yy, r, g, b, a, f);
 186   end;
 187
 188   procedure r_Common_DrawTexture (img: TGLTexture; x, y, w, h: Integer; p: TBasePoint);
 189   begin
 190     r_Common_GetBasePoint(x, y, w, h, p, x, y);
 191     r_Draw_TextureRepeat(img, x, y, w, h, false, 255, 255, 255, 255, false);
 192   end;
 193
 194   procedure r_Common_GetFormatTextSize (const text: AnsiString; f: TGLFont; out w, h: Integer);
 195     var i, cw, ch, cln, curw, curh, maxw, maxh: Integer;
 196   begin
 197     curw := 0; curh := 0; maxw := 0; maxh := 0;
 198     r_Draw_GetTextSize('W', f, cw, cln);
 199     for i := 1 to Length(text) do
 200     begin
 201       case text[i] of
 202         #10:
 203         begin
 204           maxw := MAX(maxw, curw);
 205           curh := curh + cln;
 206           curw := 0;
 207         end;
 208         #1, #2, #3, #4, #18, #19, #20, #21:
 209         begin
 210           // skip color modifiers
 211         end;
 212         otherwise
 213         begin
 214           r_Draw_GetTextSize(text[i], f, cw, ch);
 215           maxh := MAX(maxh, curh + ch);
 216           curw := curw + cw;
 217         end;
 218       end;
 219     end;
 220     w := MAX(maxw, curw);
 221     h := MAX(maxh, curh);
 222   end;
 223
 224   procedure r_Common_DrawFormatText (const text: AnsiString; x, y: Integer; a: Byte; f: TGLFont; p: TBasePoint);
 225     const
 226       colors: array [boolean, 0..5] of TRGB = (
 227         ((R:$00; G:$00; B:$00), (R:$FF; G:$00; B:$00), (R:$00; G:$FF; B:$00), (R:$FF; G:$FF; B:$00), (R:$00; G:$00; B:$FF), (R:$FF; G:$FF; B:$FF)),
 228         ((R:$00; G:$00; B:$00), (R:$7F; G:$00; B:$00), (R:$00; G:$7F; B:$00), (R:$FF; G:$7F; B:$00), (R:$00; G:$00; B:$7F), (R:$7F; G:$7F; B:$7F))
 229       );
 230     var
 231       i, xx, yy, cx, cy, w, h, cw, ch, cln, color: Integer; dark: Boolean;
 232   begin
 233     xx := x; yy := y;
 234     if p <> TBasePoint.BP_LEFTUP then
 235     begin
 236       r_Common_GetFormatTextSize(text, f, w, h);
 237       r_Common_GetBasePoint(x, y, w, h, p, xx, yy);
 238     end;
 239     cx := xx; cy := yy; color := 5; dark := false;
 240     r_Draw_GetTextSize('W', f, cw, cln);
 241     for i := 1 to Length(text) do
 242     begin
 243       case text[i] of
 244         #10:
 245         begin
 246           cx := xx;
 247           INC(cy, cln);
 248         end;
 249         #1: color := 0;
 250         #2: color := 5;
 251         #3: dark := true;
 252         #4: dark := false;
 253         #18: color := 1;
 254         #19: color := 2;
 255         #20: color := 4;
 256         #21: color := 3;
 257         otherwise
 258         begin
 259           r_Draw_GetTextSize(text[i], f, cw, ch);
 260           r_Draw_Text(text[i], cx, cy, colors[dark, color].R, colors[dark, color].G, colors[dark, color].B, a, f);
 261           INC(cx, cw);
 262         end;
 263       end;
 264     end;
 265   end;
 266
 267   function r_Common_TimeToStr (t: LongWord): AnsiString;
 268     var h, m, s: Integer;
 269   begin
 270     h := t div 1000 div 3600;
 271     m := t div 1000 div 60 mod 60;
 272     s := t div 1000 mod 60;
 273     result := Format('%d:%.2d:%.2d', [h, m, s]);
 274   end;
 275
 276   (* ---------  --------- *)
 277
 278   procedure r_Common_FreeThis (var here: THereTexture);
 279   begin
 280     here.name := '';
 281     if here.id <> nil then
 282       here.id.Free;
 283     here.id := nil;
 284   end;
 285
 286   function r_Common_LoadThis (const name: AnsiString; var here: THereTexture): Boolean;
 287   begin
 288     if name <> here.name then
 289       r_Common_FreeThis(here);
 290     if (name <> '') and (here.name <> name) then
 291       here.id := r_Textures_LoadFromFile(name);
 292
 293     result := here.id <> nil;
 294
 295     if result then
 296       here.name := name;
 297   end;
 298
 299   procedure r_Common_CalcAspect (ow, oh, nw, nh: LongInt; horizontal: Boolean; out ww, hh: LongInt);
 300   begin
 301     if horizontal then
 302     begin
 303       ww := nw;
 304       hh := nw * oh div ow;
 305     end
 306     else
 307     begin
 308       ww := nh * ow div oh;
 309       hh := nh;
 310     end;
 311   end;
 312
 313   function r_Common_LoadFont (const name: AnsiString): TGLFont;
 314     var info: TFontInfo; skiphack: Integer;
 315   begin
 316     result := nil;
 317     if name = 'STD' then skiphack := 144 else skiphack := 0;
 318     if r_Font_LoadInfoFromFile(GameWad + ':FONTS/' + name + 'TXT', info) then
 319       result := r_Textures_LoadFontFromFile(GameWad + ':FONTS/' + name + 'FONT', info, skiphack, true);
 320     if result = nil then
 321       e_logwritefln('failed to load font %s', [name]);
 322   end;
 323
 324   procedure r_Common_Load;
 325   begin
 326     stdfont := r_Common_LoadFont('STD');
 327     smallfont := r_Common_LoadFont('SMALL');
 328     menufont := r_Common_LoadFont('MENU');
 329   end;
 330
 331   procedure r_Common_Free;
 332   begin
 333     menufont.Free;
 334     smallfont.Free;
 335     stdfont.Free;
 336   end;
 337
 338 end.