DEADSOFTWARE

gl: more checks while texture loading
[d2df-sdl.git] / 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;
18 interface
20 uses
21 {$I ../../../nogl/noGLuses.inc}
22 g_base, g_animations, // TRectHW, TAnimInfo
23 utils,
24 r_atlas, r_fonts
25 ;
27 type
28 TGLHints = (txNoRepeat);
29 TGLHintsSet = set of TGLHints;
31 TGLAtlas = class;
33 TGLAtlasNode = class (TAtlasNode)
34 private
35 mBase: TGLAtlas;
37 public
38 constructor Create (base: TGLAtlas);
39 destructor Destroy; override;
41 function GetID (): GLuint;
43 property base: TGLAtlas read mBase;
44 property id: GLuint read GetID;
45 end;
47 TGLAtlas = class (TAtlas)
48 private
49 mID: GLuint;
50 mFilter: Boolean;
52 public
53 constructor Create (ww, hh: Integer; id: GLuint);
54 destructor Destroy; override;
56 function CreateNode (): TGLAtlasNode; override;
57 function Alloc (ww, hh: Integer): TGLAtlasNode; overload;
59 property id: GLuint read mID write mID default 0;
60 property filter: Boolean read mFilter write mFilter;
61 end;
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;
72 public
73 destructor Destroy; override;
75 function GetTile (col, line: Integer): TGLAtlasNode;
77 function GetLines (): Integer; inline;
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;
87 TGLMultiTexture = class
88 private
89 mTexture: array of TGLTexture;
91 public
92 destructor Destroy; override;
94 function GetWidth (): Integer; inline;
95 function GetHeight (): Integer; inline;
96 function GetCount (): Integer; inline;
97 function GetTexture (i: Integer): TGLTexture; {inline;}
99 property width: Integer read GetWidth;
100 property height: Integer read GetHeight;
101 property count: Integer read GetCount;
102 end;
104 TGLTextureArray = array of TGLTexture;
106 TRectArray = array of TRectWH;
108 TGLFont = class sealed (TFont)
109 private
110 info: TFontInfo;
111 ch: TGLTextureArray;
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;
122 TAnimTextInfo = record
123 name: AnsiString;
124 w, h: Integer;
125 anim: TAnimInfo;
126 end;
128 TConvProc = function (x: Integer): Integer;
130 procedure r_Textures_Initialize;
131 procedure r_Textures_Finalize;
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;
138 function r_Textures_LoadStreamFromFile (const filename: AnsiString; w, h, count, cw: Integer; st: TGLTextureArray; rs: TRectArray; hints: TGLHintsSet; log: Boolean = True): Boolean;
140 function r_Textures_LoadFontFromFile (const filename: AnsiString; constref f: TFontInfo; font2enc: TConvProc; log: Boolean = true): TGLFont;
142 procedure r_Textures_GL_Bind (id: GLuint);
144 implementation
146 uses
147 SysUtils, Classes,
148 r_common,
149 e_log, e_res, WADReader, Config,
150 g_console, // cvar declaration
151 Imaging, ImagingTypes, ImagingUtility
154 var
155 r_GL_MaxTexSize: WORD;
156 r_GL_RepeatOpt: Boolean;
157 maxTileSize: Integer;
158 atl, ratl: array of TGLAtlas;
159 currentTexture2D: GLuint;
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;
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;
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;
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;
215 (* --------- TGLAtlasNode --------- *)
217 constructor TGLAtlasNode.Create (base: TGLAtlas);
218 begin
219 ASSERT(base <> nil);
220 inherited Create();
221 self.mBase := base;
222 end;
224 destructor TGLAtlasNode.Destroy;
225 begin
226 inherited;
227 end;
229 function TGLAtlasNode.GetID (): GLuint;
230 begin
231 result := self.base.id
232 end;
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;
254 (* --------- TGLAtlas --------- *)
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;
265 destructor TGLAtlas.Destroy;
266 begin
267 inherited;
268 end;
270 function TGLAtlas.CreateNode (): TGLAtlasNode;
271 begin
272 result := TGLAtlasNode.Create(self);
273 end;
275 function TGLAtlas.Alloc (ww, hh: Integer): TGLAtlasNode;
276 begin
277 result := TGLAtlasNode(inherited Alloc(ww, hh));
278 end;
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;
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;
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;
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;
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;
380 (* --------- TGLTexture --------- *)
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;
410 function TGLTexture.GetLines (): Integer;
411 begin
412 ASSERT(self.mTile <> nil);
413 result := Length(self.mTile) div self.mCols
414 end;
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;
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;
472 (* --------- TGLMultiTexture --------- *)
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;
483 function TGLMultiTexture.GetWidth (): Integer;
484 begin
485 result := self.mTexture[0].width
486 end;
488 function TGLMultiTexture.GetHeight (): Integer;
489 begin
490 result := self.mTexture[0].height
491 end;
493 function TGLMultiTexture.GetCount (): Integer;
494 begin
495 result := Length(self.mTexture)
496 end;
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;
506 (* --------- Init / Fin --------- *)
508 function IsPOT (v: LongWord): Boolean;
509 begin
510 result := (v <> 0) and ((v and (v - 1)) = 0)
511 end;
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;
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;
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;
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);
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
856 function r_Textures_GetRect (var img: TImageData): TRectWH;
857 var i, j, w, h: Integer; done: Boolean;
859 function IsVoid (i, j: Integer): Boolean; inline;
860 begin
861 result := GetPixel32(img, i, j).Channels[3] = 0
862 end;
864 begin
865 w := img.Width;
866 h := img.Height;
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;
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;
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;
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;
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;
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;
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;
994 (* --------- TGLFont --------- *)
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;
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;
1031 function TGLFont.GetChar (c: AnsiChar): TGLTexture;
1032 begin
1033 result := self.ch[ORD(c)];
1034 end;
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;
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;
1052 function TGLFont.GetMaxHeight (): Integer;
1053 begin
1054 result := self.info.h;
1055 end;
1057 function TGLFont.GetSpace (): Integer;
1058 begin
1059 result := self.info.kern;
1060 end;
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.