src/game/renders/opengl/r_textures.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_textures;
  17
  18 interface
  19
  20   uses
  21     {$I ../../../nogl/noGLuses.inc}
  22     g_base, g_animations,  // TRectHW, TAnimInfo
  23     utils,
  24     r_atlas, r_fonts
  25   ;
  26
  27   type
  28     TGLHints = (txNoRepeat);
  29     TGLHintsSet = set of TGLHints;
  30
  31     TGLAtlas = class;
  32
  33     TGLAtlasNode = class (TAtlasNode)
  34       private
  35         mBase: TGLAtlas;
  36
  37       public
  38         constructor Create (base: TGLAtlas);
  39         destructor Destroy; override;
  40
  41         function GetID (): GLuint;
  42
  43         property base: TGLAtlas read mBase;
  44         property id: GLuint read GetID;
  45     end;
  46
  47     TGLAtlas = class (TAtlas)
  48       private
  49         mID: GLuint;
  50         mFilter: Boolean;
  51
  52       public
  53         constructor Create (ww, hh: Integer; id: GLuint);
  54         destructor Destroy; override;
  55
  56         function CreateNode (): TGLAtlasNode; override;
  57         function Alloc (ww, hh: Integer): TGLAtlasNode; overload;
  58
  59         property id: GLuint read mID write mID default 0;
  60         property filter: Boolean read mFilter write mFilter;
  61     end;
  62
  63     TGLTexture = class
  64       private
  65         mWidth: Integer;
  66         mHeight: Integer;
  67         mCols: Integer;
  68         mTile: array of TGLAtlasNode;
  69         mHints: TGLHintsSet;
  70         mFilter: Boolean;
  71
  72       public
  73         destructor Destroy; override;
  74
  75         function GetTile (col, line: Integer): TGLAtlasNode;
  76
  77         function GetLines (): Integer; inline;
  78
  79         property width: Integer read mWidth;
  80         property height: Integer read mHeight;
  81         property cols: Integer read mCols;
  82         property lines: Integer read GetLines;
  83         property hints: TGLHintsSet read mHints;
  84         property filter: Boolean read mFilter write mFilter;
  85     end;
  86
  87     TGLMultiTexture = class
  88       private
  89         mTexture: array of TGLTexture;
  90
  91       public
  92         destructor Destroy; override;
  93
  94         function GetWidth (): Integer; inline;
  95         function GetHeight (): Integer; inline;
  96         function GetCount (): Integer; inline;
  97         function GetTexture (i: Integer): TGLTexture; {inline;}
  98
  99         property width: Integer read GetWidth;
 100         property height: Integer read GetHeight;
 101         property count: Integer read GetCount;
 102     end;
 103
 104     TGLTextureArray = array of TGLTexture;
 105
 106     TRectArray = array of TRectWH;
 107
 108     TGLFont = class sealed (TFont)
 109       private
 110         info: TFontInfo;
 111         ch: TGLTextureArray;
 112
 113       public
 114         destructor Destroy; override;
 115         function GetChar (c: AnsiChar): TGLTexture;
 116         function GetWidth (c: AnsiChar): Integer;
 117         function GetMaxWidth (): Integer;
 118         function GetMaxHeight (): Integer;
 119         function GetSpace (): Integer;
 120     end;
 121
 122     TAnimTextInfo = record
 123       name: AnsiString;
 124       w, h: Integer;
 125       anim: TAnimInfo;
 126     end;
 127
 128     TConvProc = function (x: Integer): Integer;
 129
 130   procedure r_Textures_Initialize;
 131   procedure r_Textures_Finalize;
 132
 133   function r_Textures_LoadFromFile (const filename: AnsiString; hints: TGLHintsSet; log: Boolean = True): TGLTexture;
 134   function r_Textures_LoadMultiFromFile (const filename: AnsiString; hints: TGLHintsSet; log: Boolean = True): TGLMultiTexture;
 135   function r_Textures_LoadMultiFromFileAndInfo (const filename: AnsiString; w, h, count: Integer; hints: TGLHintsSet; log: Boolean = True): TGLMultiTexture;
 136   function r_Textures_LoadMultiTextFromFile (const filename: AnsiString; var txt: TAnimTextInfo; hints: TGLHintsSet; log: Boolean = True): TGLMultiTexture;
 137
 138   function r_Textures_LoadStreamFromFile (const filename: AnsiString; w, h, count, cw: Integer; st: TGLTextureArray; rs: TRectArray; hints: TGLHintsSet; log: Boolean = True): Boolean;
 139
 140   function r_Textures_LoadFontFromFile (const filename: AnsiString; constref f: TFontInfo; font2enc: TConvProc; log: Boolean = true): TGLFont;
 141
 142   procedure r_Textures_GL_Bind (id: GLuint);
 143
 144 implementation
 145
 146   uses
 147     SysUtils, Classes,
 148     r_common,
 149     e_log, e_res, WADReader, Config,
 150     g_console, // cvar declaration
 151     Imaging, ImagingTypes, ImagingUtility
 152   ;
 153
 154   var
 155     r_GL_MaxTexSize: WORD;
 156     r_GL_RepeatOpt: Boolean;
 157     maxTileSize: Integer;
 158     atl, ratl: array of TGLAtlas;
 159     currentTexture2D: GLuint;
 160
 161   function r_Textures_GL_GetError (msg: AnsiString): Boolean;
 162     var code: GLenum; s: AnsiString;
 163   begin
 164     code := glGetError();
 165     if code <> GL_NO_ERROR then
 166     begin
 167       case code of
 168         GL_INVALID_ENUM: s := 'GL_INVALID_ENUM';
 169         GL_INVALID_VALUE: s := 'GL_INVALID_VALUE';
 170         GL_INVALID_OPERATION: s := 'GL_INVALID_OPERATION';
 171         GL_STACK_OVERFLOW: s := 'GL_STACK_OVERFLOW';
 172         GL_STACK_UNDERFLOW: s := 'GL_STACK_UNDERFLOW';
 173         GL_OUT_OF_MEMORY: s := 'GL_OUT_OF_MEMORY';
 174         GL_TABLE_TOO_LARGE: s := 'GL_TABLE_TOO_LARGE';
 175         otherwise s := '';
 176       end;
 177       if s = '' then
 178         e_LogWritefln('%s: %s', [msg, s])
 179       else
 180         e_LogWritefln('%s: error code %s', [msg, code]);
 181     end;
 182     result := code <> GL_NO_ERROR;
 183   end;
 184
 185   procedure r_Textures_GL_ClearError;
 186     var code: GLenum;
 187   begin
 188     repeat
 189       code := glGetError();
 190     until code = GL_NO_ERROR;
 191   end;
 192
 193   procedure r_Textures_GL_Bind (id: GLuint);
 194   begin
 195     if id <> currentTexture2D then
 196     begin
 197       glBindTexture(GL_TEXTURE_2D, id);
 198       currentTexture2D := id;
 199     end
 200   end;
 201
 202   function r_Textures_GL_BindAndCheck (id: GLuint): Boolean;
 203   begin
 204     result := true;
 205     if id <> currentTexture2D then
 206     begin
 207       r_Textures_GL_ClearError;
 208       glBindTexture(GL_TEXTURE_2D, id);
 209       result := not r_Textures_GL_GetError('failed to bind texture');
 210       if result = true then
 211         currentTexture2D := id;
 212     end
 213   end;
 214
 215   (* --------- TGLAtlasNode --------- *)
 216
 217   constructor TGLAtlasNode.Create (base: TGLAtlas);
 218   begin
 219     ASSERT(base <> nil);
 220     inherited Create();
 221     self.mBase := base;
 222   end;
 223
 224   destructor TGLAtlasNode.Destroy;
 225   begin
 226     inherited;
 227   end;
 228
 229   function TGLAtlasNode.GetID (): GLuint;
 230   begin
 231     result := self.base.id
 232   end;
 233
 234   function r_Textures_UpdateNode (n: TGLAtlasNode; data: Pointer; x, y, w, h: Integer): Boolean;
 235   begin
 236     ASSERT(n <> nil);
 237     // ASSERT(n.leaf);
 238     ASSERT(n.base <> nil);
 239     ASSERT(data <> nil);
 240     ASSERT(x >= 0);
 241     ASSERT(y >= 0);
 242     ASSERT(n.l + x + w - 1 <= n.r);
 243     ASSERT(n.t + y + h - 1 <= n.b);
 244     ASSERT(n.id > 0);
 245     result := false;
 246     if r_Textures_GL_BindAndCheck(n.id) then
 247     begin
 248       glTexSubImage2D(GL_TEXTURE_2D, 0, n.l + x, n.t + y, w, h, GL_RGBA, GL_UNSIGNED_BYTE, data);
 249       result := not r_Textures_GL_GetError('failed to update atlas node');
 250       r_Textures_GL_Bind(0);
 251     end;
 252   end;
 253
 254   (* --------- TGLAtlas --------- *)
 255
 256   constructor TGLAtlas.Create (ww, hh: Integer; id: GLuint);
 257   begin
 258     ASSERT(ww > 0);
 259     ASSERT(hh > 0);
 260     inherited Create(ww, hh);
 261     self.mID := id;
 262     self.mFilter := false;
 263   end;
 264
 265   destructor TGLAtlas.Destroy;
 266   begin
 267     inherited;
 268   end;
 269
 270   function TGLAtlas.CreateNode (): TGLAtlasNode;
 271   begin
 272     result := TGLAtlasNode.Create(self);
 273   end;
 274
 275   function TGLAtlas.Alloc (ww, hh: Integer): TGLAtlasNode;
 276   begin
 277     result := TGLAtlasNode(inherited Alloc(ww, hh));
 278   end;
 279
 280   procedure r_Textures_AllocHWTexture (w, h: Integer; out id: GLuint; out ok: Boolean);
 281   begin
 282     id := 0; ok := false;
 283     r_Textures_GL_ClearError;
 284     glGenTextures(1, @id);
 285     if not r_Textures_GL_GetError('failed to allocate texture id') then
 286     begin
 287       if r_Textures_GL_BindAndCheck(id) then
 288       begin
 289         glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
 290         glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);
 291         glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
 292         glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);
 293         r_Textures_GL_ClearError;
 294         glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, w, h, 0, GL_RGBA, GL_UNSIGNED_BYTE, nil);
 295         ok := not r_Textures_GL_GetError('failed to allocate hardware texture');
 296         r_Textures_GL_Bind(0);
 297       end;
 298       if ok = false then
 299       begin
 300         glDeleteTextures(1, @id);
 301         id := 0;
 302       end;
 303     end;
 304   end;
 305
 306   function r_Textures_AllocAtlas (): TGLAtlas;
 307     var i: Integer; id: GLuint; ok: Boolean;
 308   begin
 309     result := nil;
 310     r_Textures_AllocHWTexture(maxTileSize, maxTileSize, id, ok);
 311     if ok then
 312     begin
 313       i := Length(atl);
 314       SetLength(atl, i + 1);
 315       atl[i] := TGLAtlas.Create(maxTileSize, maxTileSize, id);
 316       result := atl[i];
 317     end;
 318   end;
 319
 320   function r_Textures_AllocRepeatAtlas (w, h: Integer): TGLAtlas;
 321     var i: Integer; id: GLuint; ok: Boolean;
 322   begin
 323     result := nil;
 324     r_Textures_AllocHWTexture(w, h, id, ok);
 325     if ok then
 326     begin
 327       i := Length(ratl);
 328       SetLength(ratl, i + 1);
 329       ratl[i] := TGLAtlas.Create(w, h, id);
 330       result := ratl[i];
 331     end;
 332   end;
 333
 334   function r_Textures_AllocNode (w, h: Integer): TGLAtlasNode;
 335     var i: Integer; n: TGLAtlasNode; a: TGLAtlas;
 336   begin
 337     n := nil;
 338     if atl <> nil then
 339     begin
 340       i := High(atl);
 341       while (i >= 0) and (n = nil) do
 342       begin
 343         n := atl[i].Alloc(w, h);
 344         Dec(i);
 345       end;
 346     end;
 347     if n = nil then
 348     begin
 349       a := r_Textures_AllocAtlas();
 350       if a <> nil then
 351         n := a.Alloc(w, h);
 352     end;
 353     result := n
 354   end;
 355
 356   function r_Textures_AllocRepeatNode (w, h: Integer): TGLAtlasNode;
 357     var i: Integer; n: TGLAtlasNode; a: TGLAtlas;
 358   begin
 359     n := nil; a := nil;
 360     if ratl <> nil then
 361     begin
 362       i := High(ratl);
 363       while (i >= 0) and (ratl[i] <> nil) do DEC(i);
 364       if i >= 0 then a := ratl[i];
 365     end;
 366     if a = nil then a := r_Textures_AllocRepeatAtlas(w, h);
 367     if a <> nil then
 368     begin
 369       n := a.Alloc(w, h);
 370       if n = nil then
 371       begin
 372         i := High(ratl); while (i >= 0) and (ratl[i] <> a) do DEC(i);
 373         if i >= 0 then ratl[i] := nil;
 374         r_Common_FreeAndNil(a);
 375       end;
 376     end;
 377     result := n
 378   end;
 379
 380   (* --------- TGLTexture --------- *)
 381
 382   destructor TGLTexture.Destroy;
 383     var i: Integer; a: TGLAtlas;
 384   begin
 385     if self.mTile <> nil then
 386     begin
 387       if TGLHints.txNoRepeat in self.hints then (* non repeatable texture -> delete tiles only *)
 388       begin
 389         for i := 0 to High(self.mTile) do
 390         begin
 391           if self.mTile[i] <> nil then
 392           begin
 393             self.mTile[i].Dealloc;
 394             self.mTile[i] := nil
 395           end
 396         end
 397       end
 398       else (* repeatable texture -> delete whole atlas *)
 399       begin
 400         a := self.mTile[0].base;
 401         i := High(ratl); while (i >= 0) and (ratl[i] <> a) do DEC(i);
 402         if i >= 0 then ratl[i] := nil;
 403         r_Common_FreeAndNil(a);
 404       end;
 405       SetLength(self.mTile, 0);
 406     end;
 407     inherited;
 408   end;
 409
 410   function TGLTexture.GetLines (): Integer;
 411   begin
 412     ASSERT(self.mTile <> nil);
 413     result := Length(self.mTile) div self.mCols
 414   end;
 415
 416   function TGLTexture.GetTile (col, line: Integer): TGLAtlasNode;
 417     var i: Integer;
 418   begin
 419     ASSERT(col >= 0);
 420     ASSERT(col <= mCols);
 421     ASSERT(self.mTile <> nil);
 422     i := line * mCols + col;
 423     ASSERT(i >= 0);
 424     ASSERT(i < Length(mTile));
 425     result := mTile[i];
 426     ASSERT(result <> nil)
 427   end;
 428
 429   function r_Textures_Alloc (w, h: Integer; hints: TGLHintsSet): TGLTexture;
 430     var x, y, mw, mh, cols, lines: Integer; t: TGLTexture;
 431   begin
 432     ASSERT(w > 0);
 433     ASSERT(h > 0);
 434     if TGLHints.txNoRepeat in hints then
 435     begin
 436       cols := (w + maxTileSize - 1) div maxTileSize;
 437       lines := (h + maxTileSize - 1) div maxTileSize;
 438       t := TGLTexture.Create;
 439       t.mWidth := w;
 440       t.mHeight := h;
 441       t.mCols := cols;
 442       // t.mLines := lines;
 443       t.mHints := hints;
 444       t.mFilter := false;
 445       SetLength(t.mTile, cols * lines);
 446       for y := 0 to lines - 1 do
 447       begin
 448         mh := Min(maxTileSize, h - y * maxTileSize);
 449         ASSERT(mh > 0);
 450         for x := 0 to cols - 1 do
 451         begin
 452           mw := Min(maxTileSize, w - x * maxTileSize);
 453           ASSERT(mw > 0);
 454           t.mTile[y * cols + x] := r_Textures_AllocNode(mw, mh);
 455         end
 456       end;
 457     end
 458     else
 459     begin
 460       t := TGLTexture.Create;
 461       t.mWidth := w;
 462       t.mHeight := h;
 463       t.mCols := 1;
 464       // t.mLines := 1
 465       t.mHints := hints;
 466       SetLength(t.mTile, 1);
 467       t.mTile[0] := r_Textures_AllocRepeatNode(w, h);
 468     end;
 469     result := t;
 470   end;
 471
 472   (* --------- TGLMultiTexture --------- *)
 473
 474   destructor TGLMultiTexture.Destroy;
 475     var i: Integer;
 476   begin
 477     for i := 0 to self.count - 1 do
 478       r_Common_FreeAndNil(self.mTexture[i]);
 479     SetLength(self.mTexture, 0);
 480     inherited;
 481   end;
 482
 483   function TGLMultiTexture.GetWidth (): Integer;
 484   begin
 485     result := self.mTexture[0].width
 486   end;
 487
 488   function TGLMultiTexture.GetHeight (): Integer;
 489   begin
 490     result := self.mTexture[0].height
 491   end;
 492
 493   function TGLMultiTexture.GetCount (): Integer;
 494   begin
 495     result := Length(self.mTexture)
 496   end;
 497
 498   function TGLMultiTexture.GetTexture (i: Integer): TGLTexture;
 499   begin
 500     ASSERT(i >= 0);
 501     ASSERT(i < self.count);
 502     result := self.mTexture[i];
 503     ASSERT(result <> nil);
 504   end;
 505
 506   (* --------- Init / Fin --------- *)
 507
 508   function IsPOT (v: LongWord): Boolean;
 509   begin
 510     result := (v <> 0) and ((v and (v - 1)) = 0)
 511   end;
 512
 513   function NextPOT (v: LongWord): LongWord;
 514   begin
 515     DEC(v);
 516     v := v or (v >> 1);
 517     v := v or (v >> 2);
 518     v := v or (v >> 4);
 519     v := v or (v >> 8);
 520     v := v or (v >> 16);
 521     INC(v);
 522     result := v;
 523   end;
 524
 525   function r_Textures_GetMaxHardwareSize (): Integer;
 526     var size: GLint = 0;
 527   begin
 528     if r_GL_MaxTexSize <= 0 then
 529     begin
 530       // auto, max possible reccomended by driver
 531       glGetIntegerv(GL_MAX_TEXTURE_SIZE, @size);
 532       size := size div 2; (* hack: on some devices max size may produce invalid texture *)
 533       if size < 64 then size := 64; (* at least 64x64 are guarantied by specification *)
 534     end
 535     else
 536     begin
 537       // selected by user
 538       if IsPOT(r_GL_MaxTexSize) then
 539         size := r_GL_MaxTexSize
 540       else
 541         size := NextPOT(r_GL_MaxTexSize);
 542     end;
 543     result := size;
 544   end;
 545
 546   procedure r_Textures_Initialize;
 547   begin
 548     currentTexture2D := 0;
 549     maxTileSize := r_Textures_GetMaxHardwareSize();
 550     e_LogWritefln('Texture Tile Size: %s', [maxTileSize]);
 551   end;
 552
 553   procedure r_Textures_Finalize;
 554     var i: Integer;
 555   begin
 556     if atl <> nil then
 557     begin
 558       for i := 0 to High(atl) do
 559       begin
 560         if atl[i] <> nil then
 561         begin
 562           glDeleteTextures(1, @atl[i].id);
 563           atl[i].id := 0;
 564           r_Common_FreeAndNil(atl[i]);
 565         end;
 566       end;
 567     end;
 568     SetLength(atl, 0);
 569
 570     if ratl <> nil then
 571     begin
 572       for i := 0 to High(ratl) do
 573       begin
 574         if ratl[i] <> nil then
 575         begin
 576           glDeleteTextures(1, @ratl[i].id);
 577           ratl[i].id := 0;
 578           r_Common_FreeAndNil(ratl[i]);
 579         end;
 580       end;
 581     end;
 582     SetLength(ratl, 0);
 583   end;
 584
 585   function r_Textures_FixImageData (var img: TImageData): Boolean;
 586   begin
 587     result := false;
 588     if ConvertImage(img, TImageFormat.ifA8R8G8B8) then
 589       if SwapChannels(img, ChannelRed, ChannelBlue) then // wtf
 590         result := true;
 591   end;
 592
 593   function r_Textures_ValidRepeatTexture (w, h: Integer; hints: TGLHintsSet): Boolean;
 594   begin
 595     result := r_GL_RepeatOpt and
 596               not (TGLHints.txNoRepeat in hints) and
 597               (w <= maxTileSize) and
 598               (h <= maxTileSize) and
 599               IsPOT(w) and
 600               IsPOT(h)
 601   end;
 602
 603   function r_Textures_LoadFromImage (var img: TImageData; hints: TGLHintsSet): TGLTexture; // !!!
 604     var t: TGLTexture; n: TGLAtlasNode; c: TDynImageDataArray; cw, ch, i, j: LongInt; ok: Boolean;
 605   begin
 606     t := nil; ok := false;
 607     if r_Textures_ValidRepeatTexture(img.width, img.height, hints) then
 608     begin
 609       t := r_Textures_Alloc(img.width, img.height, hints - [TGLHints.txNoRepeat]);
 610       if t <> nil then
 611       begin
 612         n := t.GetTile(0, 0);
 613         ASSERT(n <> nil);
 614         ok := r_Textures_UpdateNode(n, img.bits, 0, 0, n.width, n.height);
 615       end
 616     end
 617     else if SplitImage(img, c, maxTileSize, maxTileSize, cw, ch, False) then
 618     begin
 619       t := r_Textures_Alloc(img.width, img.height, hints + [TGLHints.txNoRepeat]);
 620       if t <> nil then
 621       begin
 622         ok := true;
 623         ASSERT(cw = t.cols);
 624         ASSERT(ch = t.lines);
 625         for j := 0 to ch - 1 do
 626         begin
 627           for i := 0 to cw - 1 do
 628           begin
 629             n := t.GetTile(i, j);
 630             if n <> nil then
 631               ok := ok and r_Textures_UpdateNode(n, c[j * cw + i].bits, 0, 0, n.width, n.height)
 632           end
 633         end;
 634       end;
 635       FreeImagesInArray(c);
 636     end;
 637     if ok = false then
 638       r_Common_FreeAndNil(t);
 639     result := t
 640   end;
 641
 642   function r_Textures_LoadFromMemory (data: Pointer; size: LongInt; hints: TGLHintsSet): TGLTexture;
 643     var img: TImageData;
 644   begin
 645     result := nil;
 646     if (data <> nil) and (size > 0) then
 647     begin
 648       InitImage(img);
 649       try
 650         if LoadImageFromMemory(data, size, img) then
 651           if r_Textures_FixImageData(img) then
 652             result := r_Textures_LoadFromImage(img, hints)
 653       except
 654       end;
 655       FreeImage(img);
 656     end;
 657   end;
 658
 659   function r_Textures_LoadFromFile (const filename: AnsiString; hints: TGLHintsSet; log: Boolean = True): TGLTexture;
 660     var wad: TWADFile; wadName, resName: AnsiString; data: Pointer; size: Integer;
 661   begin
 662     result := nil;
 663     wadName := g_ExtractWadName(filename);
 664     wad := TWADFile.Create();
 665     if wad.ReadFile(wadName) then
 666     begin
 667       resName := g_ExtractFilePathName(filename);
 668       if wad.GetResource(resName, data, size, log) then
 669       begin
 670         result := r_Textures_LoadFromMemory(data, size, hints);
 671         FreeMem(data);
 672       end;
 673       wad.Free
 674     end
 675   end;
 676
 677   function r_Textures_LoadMultiFromImageAndInfo (var img: TImageData; w, h, c: Integer; hints: TGLHintsSet): TGLMultiTexture;
 678     var t: TImageData; a: array of TGLTexture; i: Integer; m: TGLMultiTexture;
 679   begin
 680     ASSERT(w >= 0);
 681     ASSERT(h >= 0);
 682     ASSERT(c >= 1);
 683     result := nil;
 684     SetLength(a, c);
 685     for i := 0 to c - 1 do
 686     begin
 687       InitImage(t);
 688       if NewImage(w, h, img.Format, t) then
 689         if CopyRect(img, w * i, 0, w, h, t, 0, 0) then
 690           a[i] := r_Textures_LoadFromImage(t, hints);
 691       ASSERT(a[i] <> nil);
 692       FreeImage(t);
 693     end;
 694     m := TGLMultiTexture.Create();
 695     m.mTexture := a;
 696     ASSERT(m.mTexture <> nil);
 697     result := m;
 698   end;
 699
 700   function r_Textures_LoadMultiFromDataAndInfo (data: Pointer; size: LongInt; w, h, c: Integer; hints: TGLHintsSet): TGLMultiTexture;
 701     var img: TImageData;
 702   begin
 703     ASSERT(w > 0);
 704     ASSERT(h > 0);
 705     ASSERT(c >= 1);
 706     result := nil;
 707     if (data <> nil) and (size > 0) then
 708     begin
 709       InitImage(img);
 710       try
 711         if LoadImageFromMemory(data, size, img) then
 712           if r_Textures_FixImageData(img) then
 713             result := r_Textures_LoadMultiFromImageAndInfo(img, w, h, c, hints)
 714       except
 715       end;
 716       FreeImage(img);
 717     end;
 718   end;
 719
 720   function r_Textures_LoadTextFromMemory (data: Pointer; size: LongInt; var text: TAnimTextInfo): Boolean;
 721     var cfg: TConfig;
 722   begin
 723     result := false;
 724     if data <> nil then
 725     begin
 726       cfg := TConfig.CreateMem(data, size);
 727       if cfg <> nil then
 728       begin
 729         text.name := cfg.ReadStr('', 'resource', '');
 730         text.w := cfg.ReadInt('', 'framewidth', 0);
 731         text.h := cfg.ReadInt('', 'frameheight', 0);
 732         text.anim.loop := true;
 733         text.anim.delay := cfg.ReadInt('', 'waitcount', 0);
 734         text.anim.frames := cfg.ReadInt('', 'framecount', 0);
 735         text.anim.back := cfg.ReadBool('', 'backanim', false);
 736         if text.w <= 0 then e_LogWritefln('Warning: bad animation width %s for %s', [text.w, text.name]);
 737         if text.h <= 0 then e_LogWritefln('Warning: bad animation height %s for %s', [text.h, text.name]);
 738         if text.anim.delay <= 0 then e_LogWritefln('Warning: bad animation delay %s for %s', [text.anim.delay, text.name]);
 739         if text.anim.frames <= 0 then e_LogWritefln('Warning: bad animation frame count %s for %s', [text.anim.frames, text.name]);
 740         text.w := MAX(0, text.w);
 741         text.h := MAX(0, text.h);
 742         text.anim.delay := MAX(1, text.anim.delay);
 743         text.anim.frames := MAX(1, text.anim.frames);
 744         cfg.Free;
 745         result := (text.name <> '') and (text.w > 0) and (text.h > 0) and (text.anim.delay > 0) and (text.anim.frames > 0);
 746       end;
 747     end;
 748   end;
 749
 750   function r_Textures_LoadMultiFromWad (wad: TWADFile; var txt: TAnimTextInfo; hints: TGLHintsSet): TGLMultiTexture;
 751     var data: Pointer; size: LongInt; img: TImageData;
 752   begin
 753     ASSERT(wad <> nil);
 754     result := nil;
 755     if wad.GetResource('TEXT/ANIM', data, size) then
 756     begin
 757       if r_Textures_LoadTextFromMemory(data, size, txt) then
 758       begin
 759         FreeMem(data);
 760         if wad.GetResource('TEXTURES/' + txt.name, data, size) then
 761         begin
 762           InitImage(img);
 763           try
 764             if LoadImageFromMemory(data, size, img) then
 765               if r_Textures_FixImageData(img) then
 766                 result := r_Textures_LoadMultiFromImageAndInfo(img, txt.w, txt.h, txt.anim.frames, hints);
 767           finally
 768             FreeMem(data);
 769           end;
 770           FreeImage(img);
 771         end;
 772       end
 773       else
 774         FreeMem(data);
 775     end;
 776   end;
 777
 778   function r_Textures_LoadMultiFromMemory (data: Pointer; size: LongInt; var txt: TAnimTextInfo; hints: TGLHintsSet): TGLMultiTexture;
 779     var wad: TWADFile; t: TGLTexture; m: TGLMultiTexture;
 780   begin
 781     result := nil;
 782     if (data <> nil) and (size > 0) then
 783     begin
 784       t := r_Textures_LoadFromMemory(data, size, hints);
 785       if t <> nil then
 786       begin
 787         m := TGLMultiTexture.Create();
 788         SetLength(m.mTexture, 1);
 789         m.mTexture[0] := t;
 790         txt.name := '';
 791         txt.w := m.width;
 792         txt.h := m.height;
 793         txt.anim.loop := true;
 794         txt.anim.delay := 1;
 795         txt.anim.frames := 1;
 796         txt.anim.back := false;
 797         result := m;
 798       end
 799       else if IsWadData(data, size) then
 800       begin
 801         wad := TWADFile.Create();
 802         if wad.ReadMemory(data, size) then
 803         begin
 804           result := r_Textures_LoadMultiFromWad(wad, txt, hints);
 805           wad.Free;
 806         end
 807       end
 808     end
 809   end;
 810
 811   function r_Textures_LoadMultiTextFromFile (const filename: AnsiString; var txt: TAnimTextInfo; hints: TGLHintsSet; log: Boolean = True): TGLMultiTexture;
 812     var wad: TWADFile; wadName, resName: AnsiString; data: Pointer; size: Integer;
 813   begin
 814     result := nil;
 815     wadName := g_ExtractWadName(filename);
 816     wad := TWADFile.Create();
 817     if wad.ReadFile(wadName) then
 818     begin
 819       resName := g_ExtractFilePathName(filename);
 820       if wad.GetResource(resName, data, size, log) then
 821       begin
 822         result := r_Textures_LoadMultiFromMemory(data, size, txt, hints);
 823         FreeMem(data);
 824       end;
 825       wad.Free
 826     end
 827   end;
 828
 829   function r_Textures_LoadMultiFromFile (const filename: AnsiString; hints: TGLHintsSet; log: Boolean = True): TGLMultiTexture;
 830     var txt: TAnimTextInfo;
 831   begin
 832     result := r_Textures_LoadMultiTextFromFile(filename, txt, hints, log);
 833   end;
 834
 835   function r_Textures_LoadMultiFromFileAndInfo (const filename: AnsiString; w, h, count: Integer; hints: TGLHintsSet; log: Boolean = True): TGLMultiTexture;
 836     var wad: TWADFile; wadName, resName: AnsiString; data: Pointer; size: Integer;
 837   begin
 838     ASSERT(w > 0);
 839     ASSERT(h > 0);
 840     ASSERT(count >= 1);
 841     result := nil;
 842     wadName := g_ExtractWadName(filename);
 843     wad := TWADFile.Create();
 844     if wad.ReadFile(wadName) then
 845     begin
 846       resName := g_ExtractFilePathName(filename);
 847       if wad.GetResource(resName, data, size, log) then
 848       begin
 849         result := r_Textures_LoadMultiFromDataAndInfo(data, size, w, h, count, hints);
 850         FreeMem(data);
 851       end;
 852       wad.Free
 853     end
 854   end;
 855
 856   function r_Textures_GetRect (var img: TImageData): TRectWH;
 857     var i, j, w, h: Integer; done: Boolean;
 858
 859     function IsVoid (i, j: Integer): Boolean; inline;
 860     begin
 861       result := GetPixel32(img, i, j).Channels[3] = 0
 862     end;
 863
 864   begin
 865     w := img.Width;
 866     h := img.Height;
 867
 868     (* trace x from right to left *)
 869     done := false; i := 0;
 870     while not done and (i < w) do
 871     begin
 872       j := 0;
 873       while (j < h) and IsVoid(i, j) do inc(j);
 874       done := (j < h) and (IsVoid(i, j) = false);
 875       result.x := i;
 876       inc(i);
 877     end;
 878
 879     (* trace y from up to down *)
 880     done := false; j := 0;
 881     while not done and (j < h) do
 882     begin
 883       i := 0;
 884       while (i < w) and IsVoid(i, j) do inc(i);
 885       done := (i < w) and (IsVoid(i, j) = false);
 886       result.y := j;
 887       inc(j);
 888     end;
 889
 890     (* trace x from right to left *)
 891     done := false; i := w - 1;
 892     while not done and (i >= 0) do
 893     begin
 894       j := 0;
 895       while (j < h) and IsVoid(i, j) do inc(j);
 896       done := (j < h) and (IsVoid(i, j) = false);
 897       result.width := i - result.x + 1;
 898       dec(i);
 899     end;
 900
 901     (* trace y from down to up *)
 902     done := false; j := h - 1;
 903     while not done and (j >= 0) do
 904     begin
 905       i := 0;
 906       while (i < w) and IsVoid(i, j) do inc(i);
 907       done := (i < w) and (IsVoid(i, j) = false);
 908       result.height := j - result.y + 1;
 909       dec(j);
 910     end;
 911   end;
 912
 913   function r_Textures_LoadStreamFromImage (var img: TImageData; w, h, c, cw: Integer; st: TGLTextureArray; rs: TRectArray; hints: TGLHintsSet): Boolean;
 914     var i, x, y: Integer; t: TImageData;
 915   begin
 916     ASSERT(w >= 0);
 917     ASSERT(h >= 0);
 918     ASSERT(c >= 1);
 919     ASSERT(cw >= 1);
 920     ASSERT((st <> nil) and (Length(st) >= c));
 921     ASSERT((rs = nil) or (Length(rs) >= c));
 922     result := true;
 923     for i := 0 to c - 1 do
 924     begin
 925       x := i mod cw;
 926       y := i div cw;
 927       InitImage(t);
 928       st[i] := nil;
 929       if NewImage(w, h, img.Format, t) then
 930       begin
 931         if CopyRect(img, x * w, y * h, w, h, t, 0, 0) then
 932         begin
 933           if rs <> nil then
 934             rs[i] := r_Textures_GetRect(t);
 935           st[i] := r_Textures_LoadFromImage(t, hints);
 936         end;
 937       end;
 938       ASSERT(st[i] <> nil);
 939       FreeImage(t);
 940     end;
 941   end;
 942
 943   function r_Textures_LoadStreamFromMemory (data: Pointer; size: LongInt; w, h, c, cw: Integer; st: TGLTextureArray; rs: TRectArray; hints: TGLHintsSet): Boolean;
 944     var img: TImageData;
 945   begin
 946     ASSERT(w >= 0);
 947     ASSERT(h >= 0);
 948     ASSERT(c >= 1);
 949     ASSERT(cw >= 1);
 950     ASSERT((st <> nil) and (Length(st) >= c));
 951     ASSERT((rs = nil) or (Length(rs) >= c));
 952     result := false;
 953     if (data <> nil) and (size > 0) then
 954     begin
 955       InitImage(img);
 956       try
 957         if LoadImageFromMemory(data, size, img) then
 958         begin
 959           if r_Textures_FixImageData(img) then
 960           begin
 961             result := r_Textures_LoadStreamFromImage(img, w, h, c, cw, st, rs, hints)
 962           end;
 963         end;
 964       except
 965       end;
 966       FreeImage(img);
 967     end;
 968   end;
 969
 970   function r_Textures_LoadStreamFromFile (const filename: AnsiString; w, h, count, cw: Integer; st: TGLTextureArray; rs: TRectArray; hints: TGLHintsSet; log: Boolean = True): Boolean;
 971     var wad: TWADFile; wadName, resName: AnsiString; data: Pointer; size: Integer;
 972   begin
 973     ASSERT(w > 0);
 974     ASSERT(h > 0);
 975     ASSERT(count >= 1);
 976     ASSERT(cw >= 1);
 977     ASSERT((st <> nil) and (Length(st) >= count));
 978     ASSERT((rs = nil) or (Length(rs) >= count));
 979     result := false;
 980     wadName := g_ExtractWadName(filename);
 981     wad := TWADFile.Create();
 982     if wad.ReadFile(wadName) then
 983     begin
 984       resName := g_ExtractFilePathName(filename);
 985       if wad.GetResource(resName, data, size, log) then
 986       begin
 987         result := r_Textures_LoadStreamFromMemory(data, size, w, h, count, cw, st, rs, hints);
 988         FreeMem(data);
 989       end;
 990       wad.Free
 991     end;
 992   end;
 993
 994   (* --------- TGLFont --------- *)
 995
 996   function r_Textures_LoadFontFromFile (const filename: AnsiString; constref f: TFontInfo; font2enc: TConvProc; log: Boolean = true): TGLFont;
 997     var i, ch: Integer; st, stch: TGLTextureArray; font: TGLFont;
 998   begin
 999     result := nil;
1000     SetLength(st, 256);
1001     if r_Textures_LoadStreamFromFile(filename, f.w, f.h, 256, 16, st, nil, [TGLHints.txNoRepeat], log) then
1002     begin
1003       font := TGLFont.Create();
1004       font.info := f;
1005       font.ch := st;
1006       if Assigned(font2enc) then
1007       begin
1008         SetLength(stch, 256);
1009         for i := 0 to 255 do
1010         begin
1011           ch := font2enc(i);
1012           ASSERT((ch >= 0) and (ch <= 255));
1013           stch[ch] := st[i];
1014         end;
1015         font.ch := stch;
1016         SetLength(st, 0);
1017       end;
1018       result := font;
1019     end;
1020   end;
1021
1022   destructor TGLFont.Destroy;
1023     var i: Integer;
1024   begin
1025     if self.ch <> nil then
1026       for i := 0 to High(self.ch) do
1027         self.ch[i].Free;
1028     self.ch := nil;
1029   end;
1030
1031   function TGLFont.GetChar (c: AnsiChar): TGLTexture;
1032   begin
1033     result := self.ch[ORD(c)];
1034   end;
1035
1036   function TGLFont.GetWidth (c: AnsiChar): Integer;
1037   begin
1038     result := self.info.ch[c].w;
1039     if result = 0 then
1040       result := self.info.w;
1041     if self.info.kern < 0 then
1042       result := result + self.info.kern;
1043   end;
1044
1045   function TGLFont.GetMaxWidth (): Integer;
1046   begin
1047     result := self.info.w;
1048     if self.info.kern < 0 then
1049       result := result + self.info.kern;
1050   end;
1051
1052   function TGLFont.GetMaxHeight (): Integer;
1053   begin
1054     result := self.info.h;
1055   end;
1056
1057   function TGLFont.GetSpace (): Integer;
1058   begin
1059     result := self.info.kern;
1060   end;
1061
1062 initialization
1063   conRegVar('r_gl_maxtexsize', @r_GL_MaxTexSize, '', '');
1064   conRegVar('r_gl_repeat', @r_GL_RepeatOpt, '', '');
1065   r_GL_MaxTexSize := 0; // default is automatic value
1066   r_GL_RepeatOpt := true;
1067 end.