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, r_fonts, 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   var
  40     r_Common_ProcessLoadingCallback: TProcedure;
  41
  42   procedure r_Common_FreeAndNil (var obj);
  43   procedure r_Common_FreeMemAndNil (var p);
  44
  45   function  r_Common_LoadThis (const name: AnsiString; var here: THereTexture): Boolean;
  46   procedure r_Common_FreeThis (var here: THereTexture);
  47
  48   procedure r_Common_CalcAspect (ow, oh, nw, nh: LongInt; horizontal: Boolean; out ww, hh: LongInt);
  49
  50   procedure r_Common_GetBasePoint (x, y, w, h: Integer; p: TBasePoint; out xx, yy: Integer);
  51   procedure r_Common_DrawText (const text: AnsiString; x, y: Integer; r, g, b, a: Byte; f: TGLFont; p: TBasePoint);
  52   procedure r_Common_DrawTexture (img: TGLTexture; x, y, w, h: Integer; p: TBasePoint);
  53   procedure r_Common_GetFormatTextSize (const text: AnsiString; f: TGLFont; out w, h: Integer);
  54   procedure r_Common_DrawFormatText (const text: AnsiString; x, y: Integer; a: Byte; f: TGLFont; p: TBasePoint);
  55
  56   function r_Common_TimeToStr (t: LongWord): AnsiString;
  57
  58   procedure r_Common_GetObjectPos (const obj: TObj; out x, y: Integer);
  59   procedure r_Common_GetPlayerPos (const p: TPlayer; out x, y: Integer);
  60   procedure r_Common_GetCameraPos (const p: TPlayer; center: Boolean; out x, y: Integer);
  61   function  r_Common_GetPosByUID (uid: WORD; out obj: TObj; out x, y: Integer): Boolean;
  62
  63   procedure r_Common_DrawBackgroundImage (img: TGLTexture);
  64   procedure r_Common_DrawBackground (const name: AnsiString);
  65
  66   procedure r_Common_ClearLoading;
  67   procedure r_Common_SetLoading (const text: String; maxval: Integer);
  68   procedure r_Common_StepLoading (incval: Integer);
  69   procedure r_Common_DrawLoading (force: Boolean);
  70
  71   function r_Common_LoadTextureFromFile (const filename: AnsiString; log: Boolean = True): TGLTexture;
  72   function r_Common_LoadTextureMultiFromFile (const filename: AnsiString; log: Boolean = True): TGLMultiTexture;
  73   function r_Common_LoadTextureMultiFromFileAndInfo (const filename: AnsiString; w, h, count: Integer; log: Boolean = True): TGLMultiTexture;
  74   function r_Common_LoadTextureMultiTextFromFile (const filename: AnsiString; var txt: TAnimTextInfo; log: Boolean = True): TGLMultiTexture;
  75   function r_Common_LoadTextureStreamFromFile (const filename: AnsiString; w, h, count, cw: Integer; st: TGLTextureArray; rs: TRectArray; log: Boolean = True): Boolean;
  76   function r_Common_LoadTextureFontFromFile (const filename: AnsiString; constref f: TFontInfo; font2enc: TConvProc; log: Boolean = true): TGLFont;
  77
  78   procedure r_Common_Load;
  79   procedure r_Common_Free;
  80
  81 implementation
  82
  83   uses
  84     Math, SysUtils,
  85     e_log, utils,
  86     g_base, g_basic, g_options, g_game, g_map,
  87     {$IFDEF ENABLE_CORPSES}
  88       g_corpses,
  89     {$ENDIF}
  90     r_draw, r_loadscreen
  91   ;
  92
  93   var
  94     BackgroundTexture: THereTexture;
  95
  96   procedure r_Common_FreeAndNil (var obj);
  97     var temp: TObject;
  98   begin
  99     temp := TObject(obj);
 100     Pointer(obj) := nil;
 101     if temp <> nil then
 102       temp.Free;
 103   end;
 104
 105   procedure r_Common_FreeMemAndNil (var p);
 106     var temp: Pointer;
 107   begin
 108     temp := Pointer(p);
 109     Pointer(p) := nil;
 110     if temp <> nil then
 111       FreeMem(temp)
 112   end;
 113
 114   procedure r_Common_GetObjectPos (const obj: TObj; out x, y: Integer);
 115     var fx, fy: Integer;
 116   begin
 117     obj.Lerp(gLerpFactor, fx, fy);
 118     x := fx;
 119     y := fy + obj.slopeUpLeft;
 120   end;
 121
 122   procedure r_Common_GetPlayerPos (const p: TPlayer; out x, y: Integer);
 123     var fx, fy, fSlope: Integer;
 124   begin
 125     ASSERT(p <> nil);
 126     p.obj.Lerp(gLerpFactor, fx, fy);
 127     fSlope := nlerp(p.SlopeOld, p.obj.slopeUpLeft, gLerpFactor);
 128     x := fx;
 129     y := fy + fSlope;
 130   end;
 131
 132 {$IFDEF ENABLE_CORPSES}
 133   function r_Common_GetPlayerCorpse (const p: TPlayer): TCorpse;
 134   begin
 135     result := nil;
 136     if (p <> nil) and (p.Alive = false) and (p.Spectator = false) and (p.Corpse >= 0) then
 137       if (gCorpses <> nil) and (gCorpses[p.Corpse] <> nil) and (gCorpses[p.Corpse].PlayerUID = p.UID) then
 138         result := gCorpses[p.Corpse];
 139   end;
 140 {$ENDIF}
 141
 142   procedure r_Common_GetCameraPos (const p: TPlayer; center: Boolean; out x, y: Integer);
 143     {$IFDEF ENABLE_CORPSES}
 144       var corpse: TCorpse;
 145     {$ENDIF}
 146   begin
 147 {$IFDEF ENABLE_CORPSES}
 148     corpse := r_Common_GetPlayerCorpse(p);
 149     if corpse <> nil then
 150     begin
 151       r_Common_GetObjectPos(corpse.obj, x, y);
 152       if center then
 153       begin
 154         x := x + corpse.obj.rect.width div 2;
 155         y := y + corpse.obj.rect.height div 2;
 156       end;
 157     end
 158     else
 159 {$ENDIF}
 160     if p <> nil then
 161     begin
 162       r_Common_GetPlayerPos(p, x, y);
 163       y := y - nlerp(p.IncCamOld, p.IncCam, gLerpFactor);
 164       if center then
 165       begin
 166         x := x + p.obj.rect.width div 2;
 167         y := y + p.obj.rect.height div 2;
 168       end;
 169     end
 170     else
 171     begin
 172       x := 0;
 173       y := 0;
 174       if center then
 175       begin
 176         x := x + gMapInfo.Width div 2;
 177         y := y + gMapInfo.Height div 2;
 178       end;
 179     end;
 180   end;
 181
 182   function r_Common_GetPosByUID (uid: WORD; out obj: TObj; out x, y: Integer): Boolean;
 183     var p: TPlayer; found: Boolean;
 184   begin
 185     found := false;
 186     if g_GetUIDType(uid) = UID_PLAYER then
 187     begin
 188       p := g_Player_Get(uid);
 189       found := p <> nil;
 190       if found then
 191       begin
 192         r_Common_GetPlayerPos(p, x, y);
 193         obj := p.obj;
 194       end;
 195     end
 196     else if GetPos(uid, @obj) then
 197     begin
 198       found := true;
 199       r_Common_GetObjectPos(obj, x, y);
 200     end;
 201     result := found;
 202   end;
 203
 204   procedure r_Common_GetBasePoint (x, y, w, h: Integer; p: TBasePoint; out xx, yy: Integer);
 205   begin
 206     case p of
 207       TBasePoint.BP_LEFTUP,  TBasePoint.BP_LEFT,   TBasePoint.BP_LEFTDOWN:  xx := x;
 208       TBasePoint.BP_UP,      TBasePoint.BP_CENTER, TBasePoint.BP_DOWN:      xx := x - w div 2;
 209       TBasePoint.BP_RIGHTUP, TBasePoint.BP_RIGHT,  TBasePoint.BP_RIGHTDOWN: xx := x - w;
 210     end;
 211     case p of
 212       TBasePoint.BP_LEFTUP,   TBasePoint.BP_UP,     TBasePoint.BP_RIGHTUP:   yy := y;
 213       TBasePoint.BP_LEFT,     TBasePoint.BP_CENTER, TBasePoint.BP_RIGHT:     yy := y - h div 2;
 214       TBasePoint.BP_LEFTDOWN, TBasePoint.BP_DOWN,   TBasePoint.BP_RIGHTDOWN: yy := y - h;
 215     end;
 216   end;
 217
 218   procedure r_Common_DrawText (const text: AnsiString; x, y: Integer; r, g, b, a: Byte; f: TGLFont; p: TBasePoint);
 219     var xx, yy, w, h: Integer;
 220   begin
 221     xx := x; yy := y;
 222     if p <> TBasePoint.BP_LEFTUP then
 223     begin
 224       r_Draw_GetTextSize(text, f, w, h);
 225       r_Common_GetBasePoint(x, y, w, h, p, xx, yy);
 226     end;
 227     r_Draw_Text(text, xx, yy, r, g, b, a, f);
 228   end;
 229
 230   procedure r_Common_DrawTexture (img: TGLTexture; x, y, w, h: Integer; p: TBasePoint);
 231   begin
 232     r_Common_GetBasePoint(x, y, w, h, p, x, y);
 233     r_Draw_TextureRepeat(img, x, y, w, h, false, 255, 255, 255, 255, false);
 234   end;
 235
 236   procedure r_Common_GetFormatTextSize (const text: AnsiString; f: TGLFont; out w, h: Integer);
 237     var i, cw, ch, cln, curw, curh, maxw, maxh: Integer;
 238   begin
 239     curw := 0; curh := 0; maxw := 0; maxh := 0;
 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           maxw := MAX(maxw, curw);
 247           curh := curh + cln;
 248           curw := 0;
 249         end;
 250         #1, #2, #3, #4, #18, #19, #20, #21:
 251         begin
 252           // skip color modifiers
 253         end;
 254         otherwise
 255         begin
 256           r_Draw_GetTextSize(text[i], f, cw, ch);
 257           maxh := MAX(maxh, curh + ch);
 258           curw := curw + cw;
 259         end;
 260       end;
 261     end;
 262     w := MAX(maxw, curw);
 263     h := MAX(maxh, curh);
 264   end;
 265
 266   procedure r_Common_DrawFormatText (const text: AnsiString; x, y: Integer; a: Byte; f: TGLFont; p: TBasePoint);
 267     const
 268       colors: array [boolean, 0..5] of TRGB = (
 269         ((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)),
 270         ((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))
 271       );
 272     var
 273       i, xx, yy, cx, cy, w, h, cw, ch, cln, color: Integer; dark: Boolean;
 274   begin
 275     xx := x; yy := y;
 276     if p <> TBasePoint.BP_LEFTUP then
 277     begin
 278       r_Common_GetFormatTextSize(text, f, w, h);
 279       r_Common_GetBasePoint(x, y, w, h, p, xx, yy);
 280     end;
 281     cx := xx; cy := yy; color := 5; dark := false;
 282     r_Draw_GetTextSize('W', f, cw, cln);
 283     for i := 1 to Length(text) do
 284     begin
 285       case text[i] of
 286         #10:
 287         begin
 288           cx := xx;
 289           INC(cy, cln);
 290         end;
 291         #1: color := 0;
 292         #2: color := 5;
 293         #3: dark := true;
 294         #4: dark := false;
 295         #18: color := 1;
 296         #19: color := 2;
 297         #20: color := 4;
 298         #21: color := 3;
 299         otherwise
 300         begin
 301           r_Draw_GetTextSize(text[i], f, cw, ch);
 302           r_Draw_Text(text[i], cx, cy, colors[dark, color].R, colors[dark, color].G, colors[dark, color].B, a, f);
 303           INC(cx, cw);
 304         end;
 305       end;
 306     end;
 307   end;
 308
 309   function r_Common_TimeToStr (t: LongWord): AnsiString;
 310     var h, m, s: Integer;
 311   begin
 312     h := t div 1000 div 3600;
 313     m := t div 1000 div 60 mod 60;
 314     s := t div 1000 mod 60;
 315     result := Format('%d:%.2d:%.2d', [h, m, s]);
 316   end;
 317
 318   (* ---------  --------- *)
 319
 320   procedure r_Common_FreeThis (var here: THereTexture);
 321   begin
 322     here.name := '';
 323     r_Common_FreeAndNil(here.id);
 324   end;
 325
 326   function r_Common_LoadThis (const name: AnsiString; var here: THereTexture): Boolean;
 327   begin
 328     if name <> here.name then
 329       r_Common_FreeThis(here);
 330     if (name <> '') and (here.name <> name) then
 331       here.id := r_Textures_LoadFromFile(name);
 332
 333     result := here.id <> nil;
 334
 335     if result then
 336       here.name := name;
 337   end;
 338
 339   procedure r_Common_CalcAspect (ow, oh, nw, nh: LongInt; horizontal: Boolean; out ww, hh: LongInt);
 340   begin
 341     if horizontal then
 342     begin
 343       ww := nw;
 344       hh := nw * oh div ow;
 345     end
 346     else
 347     begin
 348       ww := nh * ow div oh;
 349       hh := nh;
 350     end;
 351   end;
 352
 353   procedure r_Common_DrawBackgroundImage (img: TGLTexture);
 354     var fw, w, h: LongInt;
 355   begin
 356     if img <> nil then
 357     begin
 358       img := BackgroundTexture.id;
 359       if img.width = img.height then fw := img.width * 4 div 3 else fw := img.width; // fix aspect 4:3
 360       r_Common_CalcAspect(fw, img.height, gScreenWidth, gScreenHeight, false, w, h);
 361       r_Draw_Texture(img, gScreenWidth div 2 - w div 2, 0, w, h, false, 255, 255, 255, 255, false);
 362     end
 363   end;
 364
 365   procedure r_Common_DrawBackground (const name: AnsiString);
 366   begin
 367     if r_Common_LoadThis(name, BackgroundTexture) then
 368       r_Common_DrawBackgroundImage(BackgroundTexture.id)
 369   end;
 370
 371   function r_Common_Std2Win (i: Integer): Integer;
 372   begin
 373     case i of
 374       0..223:   result := i + 32;
 375       224..255: result := i - 224;
 376       otherwise result := -1;
 377     end
 378   end;
 379
 380   function r_Common_LoadFont (const name: AnsiString): TGLFont;
 381     var info: TFontInfo; p: TConvProc;
 382   begin
 383     result := nil;
 384     if name = 'STD' then p := @r_Common_Std2Win else p := nil;
 385     if r_Font_LoadInfoFromFile(GameWad + ':FONTS/' + name + 'TXT', info) then
 386       result := r_Common_LoadTextureFontFromFile(GameWad + ':FONTS/' + name + 'FONT', info, p, true);
 387     if result = nil then
 388       e_logwritefln('failed to load font %s', [name]);
 389   end;
 390
 391   procedure r_Common_Load;
 392   begin
 393     r_Common_SetLoading('Fonts', 3);
 394     menufont := r_Common_LoadFont('MENU');
 395     smallfont := r_Common_LoadFont('SMALL');
 396     stdfont := r_Common_LoadFont('STD');
 397     BackgroundTexture := DEFAULT(THereTexture);
 398   end;
 399
 400   procedure r_Common_Free;
 401   begin
 402     r_Common_FreeThis(BackgroundTexture);
 403     FreeAndNil(menufont);
 404     FreeAndNil(smallfont);
 405     FreeAndNil(stdfont);
 406   end;
 407
 408   (* --------- Loading screen helpers --------- *)
 409
 410   procedure r_Common_ProcessLoading;
 411   begin
 412     if @r_Common_ProcessLoadingCallback <> nil then
 413       r_Common_ProcessLoadingCallback;
 414   end;
 415
 416   procedure r_Common_DrawLoading (force: Boolean);
 417   begin
 418     r_LoadScreen_Draw(force);
 419     r_Common_ProcessLoading;
 420   end;
 421
 422   procedure r_Common_ClearLoading;
 423   begin
 424     r_LoadScreen_Clear;
 425     r_Common_DrawLoading(true);
 426   end;
 427
 428   procedure r_Common_SetLoading (const text: String; maxval: Integer);
 429   begin
 430     r_LoadScreen_Set(text, maxval);
 431     r_Common_DrawLoading(true);
 432   end;
 433
 434   procedure r_Common_StepLoading (incval: Integer);
 435   begin
 436     r_LoadScreen_Step(incval);
 437     r_Common_DrawLoading(false);
 438   end;
 439
 440   function r_Common_LoadTextureFromFile (const filename: AnsiString; log: Boolean = True): TGLTexture;
 441   begin
 442     result := r_Textures_LoadFromFile(filename, log);
 443     r_Common_StepLoading(1);
 444   end;
 445
 446   function r_Common_LoadTextureMultiFromFile (const filename: AnsiString; log: Boolean = True): TGLMultiTexture;
 447   begin
 448     result := r_Textures_LoadMultiFromFile(filename, log);
 449     r_Common_StepLoading(1);
 450   end;
 451
 452   function r_Common_LoadTextureMultiFromFileAndInfo (const filename: AnsiString; w, h, count: Integer; log: Boolean = True): TGLMultiTexture;
 453   begin
 454     result := r_Textures_LoadMultiFromFileAndInfo(filename, w, h, count, log);
 455     r_Common_StepLoading(1);
 456   end;
 457
 458   function r_Common_LoadTextureMultiTextFromFile (const filename: AnsiString; var txt: TAnimTextInfo; log: Boolean = True): TGLMultiTexture;
 459   begin
 460     result := r_Textures_LoadMultiTextFromFile(filename, txt, log);
 461     r_Common_StepLoading(1);
 462   end;
 463
 464   function r_Common_LoadTextureStreamFromFile (const filename: AnsiString; w, h, count, cw: Integer; st: TGLTextureArray; rs: TRectArray; log: Boolean = True): Boolean;
 465   begin
 466     r_Textures_LoadStreamFromFile(filename, w, h, count, cw, st, rs, log);
 467     r_Common_StepLoading(1);
 468   end;
 469
 470   function r_Common_LoadTextureFontFromFile (const filename: AnsiString; constref f: TFontInfo; font2enc: TConvProc; log: Boolean = true): TGLFont;
 471   begin
 472     result := r_Textures_LoadFontFromFile (filename, f, font2enc, log);
 473     r_Common_StepLoading(1);
 474   end;
 475
 476 end.