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