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