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;
  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_Load;
  53   procedure r_Common_Free;
  54
  55 implementation
  56
  57   uses Math, SysUtils, g_base, e_log, utils, r_draw, r_fonts, g_options;
  58
  59   procedure r_Common_GetBasePoint (x, y, w, h: Integer; p: TBasePoint; out xx, yy: Integer);
  60   begin
  61     case p of
  62       TBasePoint.BP_LEFTUP,  TBasePoint.BP_LEFT,   TBasePoint.BP_LEFTDOWN:  xx := x;
  63       TBasePoint.BP_UP,      TBasePoint.BP_CENTER, TBasePoint.BP_DOWN:      xx := x - w div 2;
  64       TBasePoint.BP_RIGHTUP, TBasePoint.BP_RIGHT,  TBasePoint.BP_RIGHTDOWN: xx := x - w;
  65     end;
  66     case p of
  67       TBasePoint.BP_LEFTUP,   TBasePoint.BP_UP,     TBasePoint.BP_RIGHTUP:   yy := y;
  68       TBasePoint.BP_LEFT,     TBasePoint.BP_CENTER, TBasePoint.BP_RIGHT:     yy := y - h div 2;
  69       TBasePoint.BP_LEFTDOWN, TBasePoint.BP_DOWN,   TBasePoint.BP_RIGHTDOWN: yy := y - h;
  70     end;
  71   end;
  72
  73   procedure r_Common_DrawText (const text: AnsiString; x, y: Integer; r, g, b, a: Byte; f: TGLFont; p: TBasePoint);
  74     var xx, yy, w, h: Integer;
  75   begin
  76     xx := x; yy := y;
  77     if p <> TBasePoint.BP_LEFTUP then
  78     begin
  79       r_Draw_GetTextSize(text, f, w, h);
  80       r_Common_GetBasePoint(x, y, w, h, p, xx, yy);
  81     end;
  82     r_Draw_Text(text, xx, yy, r, g, b, a, f);
  83   end;
  84
  85   procedure r_Common_DrawTexture (img: TGLTexture; x, y, w, h: Integer; p: TBasePoint);
  86   begin
  87     r_Common_GetBasePoint(x, y, w, h, p, x, y);
  88     r_Draw_TextureRepeat(img, x, y, w, h, false, 255, 255, 255, 255, false);
  89   end;
  90
  91   procedure r_Common_GetFormatTextSize (const text: AnsiString; f: TGLFont; out w, h: Integer);
  92     var i, cw, ch, cln, curw, curh, maxw, maxh: Integer;
  93   begin
  94     curw := 0; curh := 0; maxw := 0; maxh := 0;
  95     r_Draw_GetTextSize('W', f, cw, cln);
  96     for i := 1 to Length(text) do
  97     begin
  98       case text[i] of
  99         #10:
 100         begin
 101           maxw := MAX(maxw, curw);
 102           curh := curh + cln;
 103           curw := 0;
 104         end;
 105         #1, #2, #3, #4, #18, #19, #20, #21:
 106         begin
 107           // skip color modifiers
 108         end;
 109         otherwise
 110         begin
 111           r_Draw_GetTextSize(text[i], f, cw, ch);
 112           maxh := MAX(maxh, curh + ch);
 113           curw := curw + cw;
 114         end;
 115       end;
 116     end;
 117     w := MAX(maxw, curw);
 118     h := MAX(maxh, curh);
 119   end;
 120
 121   procedure r_Common_DrawFormatText (const text: AnsiString; x, y: Integer; a: Byte; f: TGLFont; p: TBasePoint);
 122     const
 123       colors: array [boolean, 0..5] of TRGB = (
 124         ((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)),
 125         ((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))
 126       );
 127     var
 128       i, xx, yy, cx, cy, w, h, cw, ch, cln, color: Integer; dark: Boolean;
 129   begin
 130     xx := x; yy := y;
 131     if p <> TBasePoint.BP_LEFTUP then
 132     begin
 133       r_Common_GetFormatTextSize(text, f, w, h);
 134       r_Common_GetBasePoint(x, y, w, h, p, xx, yy);
 135     end;
 136     cx := xx; cy := yy; color := 5; dark := false;
 137     r_Draw_GetTextSize('W', f, cw, cln);
 138     for i := 1 to Length(text) do
 139     begin
 140       case text[i] of
 141         #10:
 142         begin
 143           cx := xx;
 144           INC(cy, cln);
 145         end;
 146         #1: color := 0;
 147         #2: color := 5;
 148         #3: dark := true;
 149         #4: dark := false;
 150         #18: color := 1;
 151         #19: color := 2;
 152         #20: color := 4;
 153         #21: color := 3;
 154         otherwise
 155         begin
 156           r_Draw_GetTextSize(text[i], f, cw, ch);
 157           r_Draw_Text(text[i], cx, cy, colors[dark, color].R, colors[dark, color].G, colors[dark, color].B, a, f);
 158           INC(cx, cw);
 159         end;
 160       end;
 161     end;
 162   end;
 163
 164   function r_Common_TimeToStr (t: LongWord): AnsiString;
 165     var h, m, s: Integer;
 166   begin
 167     h := t div 1000 div 3600;
 168     m := t div 1000 div 60 mod 60;
 169     s := t div 1000 mod 60;
 170     result := Format('%d:%.2d:%.2d', [h, m, s]);
 171   end;
 172
 173   (* ---------  --------- *)
 174
 175   procedure r_Common_FreeThis (var here: THereTexture);
 176   begin
 177     here.name := '';
 178     if here.id <> nil then
 179       here.id.Free;
 180     here.id := nil;
 181   end;
 182
 183   function r_Common_LoadThis (const name: AnsiString; var here: THereTexture): Boolean;
 184   begin
 185     if name <> here.name then
 186       r_Common_FreeThis(here);
 187     if (name <> '') and (here.name <> name) then
 188       here.id := r_Textures_LoadFromFile(name);
 189
 190     result := here.id <> nil;
 191
 192     if result then
 193       here.name := name;
 194   end;
 195
 196   procedure r_Common_CalcAspect (ow, oh, nw, nh: LongInt; horizontal: Boolean; out ww, hh: LongInt);
 197   begin
 198     if horizontal then
 199     begin
 200       ww := nw;
 201       hh := nw * oh div ow;
 202     end
 203     else
 204     begin
 205       ww := nh * ow div oh;
 206       hh := nh;
 207     end;
 208   end;
 209
 210   function r_Common_LoadFont (const name: AnsiString): TGLFont;
 211     var info: TFontInfo; skiphack: Integer;
 212   begin
 213     result := nil;
 214     if name = 'STD' then skiphack := 144 else skiphack := 0;
 215     if r_Font_LoadInfoFromFile(GameWad + ':FONTS/' + name + 'TXT', info) then
 216       result := r_Textures_LoadFontFromFile(GameWad + ':FONTS/' + name + 'FONT', info, skiphack, true);
 217     if result = nil then
 218       e_logwritefln('failed to load font %s', [name]);
 219   end;
 220
 221   procedure r_Common_Load;
 222   begin
 223     stdfont := r_Common_LoadFont('STD');
 224     smallfont := r_Common_LoadFont('SMALL');
 225     menufont := r_Common_LoadFont('MENU');
 226   end;
 227
 228   procedure r_Common_Free;
 229   begin
 230     menufont.Free;
 231     smallfont.Free;
 232     stdfont.Free;
 233   end;
 234
 235 end.