DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / d2df-sdl.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
added license info
[d2df-sdl.git] / src / engine / e_graphics.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, either version 3 of the License, or
6 * (at your option) any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this program. If not, see <http://www.gnu.org/licenses/>.
15 *)
16 {$MODE DELPHI}
17 unit e_graphics;
18
19 interface
20
21 uses
22 SysUtils, Classes, Math, e_log, e_textures, SDL2, GL, GLExt, MAPDEF, ImagingTypes, Imaging, ImagingUtility;
23
24 type
25 TMirrorType=(M_NONE, M_HORIZONTAL, M_VERTICAL);
26 TBlending=(B_NONE, B_BLEND, B_FILTER, B_INVERT);
27
28 TPoint2i = record
29 X, Y: Integer;
30 end;
31
32 TPoint = MAPDEF.TPoint; // TODO: create an utiltypes.pas or something
33 // for other types like rect as well
34
35 TPoint2f = record
36 X, Y: Double;
37 end;
38
39 TRect = record
40 Left, Top, Right, Bottom: Integer;
41 end;
42
43 TRectWH = record
44 X, Y: Integer;
45 Width, Height: Word;
46 end;
47
48 TRGB = packed record
49 R, G, B: Byte;
50 end;
51
52 PPoint = ^TPoint;
53 PPoint2f = ^TPoint2f;
54 PRect = ^TRect;
55 PRectWH = ^TRectWH;
56
57
58 //------------------------------------------------------------------
59 // ïðîòîòèïû ôóíêöèé
60 //------------------------------------------------------------------
61 procedure e_InitGL();
62 procedure e_SetViewPort(X, Y, Width, Height: Word);
63 procedure e_ResizeWindow(Width, Height: Integer);
64
65 procedure e_Draw(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
66 Blending: Boolean; Mirror: TMirrorType = M_NONE);
67 procedure e_DrawAdv(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
68 Blending: Boolean; Angle: Single; RC: PPoint; Mirror: TMirrorType = M_NONE);
69 procedure e_DrawSize(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
70 Blending: Boolean; Width, Height: Word; Mirror: TMirrorType = M_NONE);
71 procedure e_DrawSizeMirror(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
72 Blending: Boolean; Width, Height: Word; Mirror: TMirrorType = M_NONE);
73 procedure e_DrawFill(ID: DWORD; X, Y: Integer; XCount, YCount: Word; Alpha: Integer;
74 AlphaChannel: Boolean; Blending: Boolean);
75 procedure e_DrawPoint(Size: Byte; X, Y: Integer; Red, Green, Blue: Byte);
76 procedure e_DrawLine(Width: Byte; X1, Y1, X2, Y2: Integer; Red, Green, Blue: Byte; Alpha: Byte = 0);
77 procedure e_DrawQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue: Byte; Alpha: Byte = 0);
78 procedure e_DrawFillQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue, Alpha: Byte;
79 Blending: TBlending = B_NONE);
80
81 function e_CreateTextureImg (var img: TImageData; var ID: DWORD): Boolean;
82 function e_CreateTexture(FileName: string; var ID: DWORD): Boolean;
83 function e_CreateTextureEx(FileName: string; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean;
84 function e_CreateTextureMem(pData: Pointer; dataSize: LongInt; var ID: DWORD): Boolean;
85 function e_CreateTextureMemEx(pData: Pointer; dataSize: LongInt; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean;
86 procedure e_GetTextureSize(ID: DWORD; Width, Height: PWord);
87 function e_GetTextureSize2(ID: DWORD): TRectWH;
88 procedure e_DeleteTexture(ID: DWORD);
89 procedure e_RemoveAllTextures();
90
91 // CharFont
92 function e_CharFont_Create(sp: ShortInt=0): DWORD;
93 procedure e_CharFont_AddChar(FontID: DWORD; Texture: Integer; c: Char; w: Byte);
94 procedure e_CharFont_Print(FontID: DWORD; X, Y: Integer; Text: string);
95 procedure e_CharFont_PrintEx(FontID: DWORD; X, Y: Integer; Text: string;
96 Color: TRGB; Scale: Single = 1.0);
97 procedure e_CharFont_PrintFmt(FontID: DWORD; X, Y: Integer; Text: string);
98 procedure e_CharFont_GetSize(FontID: DWORD; Text: string; var w, h: Word);
99 procedure e_CharFont_GetSizeFmt(FontID: DWORD; Text: string; var w, h: Word);
100 function e_CharFont_GetMaxWidth(FontID: DWORD): Word;
101 function e_CharFont_GetMaxHeight(FontID: DWORD): Word;
102 procedure e_CharFont_Remove(FontID: DWORD);
103 procedure e_CharFont_RemoveAll();
104
105 // TextureFont
106 procedure e_TextureFontBuild(Tex: DWORD; var FontID: DWORD; XCount, YCount: Word;
107 Space: ShortInt=0);
108 procedure e_TextureFontKill(FontID: DWORD);
109 procedure e_TextureFontPrint(X, Y: GLint; Text: string; FontID: DWORD);
110 procedure e_TextureFontPrintEx(X, Y: GLint; Text: string; FontID: DWORD; Red, Green,
111 Blue: Byte; Scale: Single; Shadow: Boolean = False);
112 procedure e_TextureFontPrintFmt(X, Y: GLint; Text: string; FontID: DWORD; Shadow: Boolean = False);
113 procedure e_TextureFontGetSize(ID: DWORD; var CharWidth, CharHeight: Byte);
114 procedure e_RemoveAllTextureFont();
115
116 function e_TextureFontCharWidth (ch: Char; FontID: DWORD): Integer;
117 procedure e_TextureFontPrintCharEx (X, Y: Integer; Ch: Char; FontID: DWORD; Shadow: Boolean = False);
118
119 procedure e_ReleaseEngine();
120 procedure e_BeginRender();
121 procedure e_Clear(Mask: TGLbitfield; Red, Green, Blue: Single); overload;
122 procedure e_Clear(); overload;
123 procedure e_EndRender();
124
125 function e_GetGamma(win: PSDL_Window): Byte;
126 procedure e_SetGamma(win: PSDL_Window;Gamma: Byte);
127
128 procedure e_MakeScreenshot(st: TStream; Width, Height: Word);
129
130 function _RGB(Red, Green, Blue: Byte): TRGB;
131 function _Point(X, Y: Integer): TPoint2i;
132 function _Rect(X, Y: Integer; Width, Height: Word): TRectWH;
133 function _TRect(L, T, R, B: LongInt): TRect;
134
135
136 var
137 e_Colors: TRGB;
138 e_NoGraphics: Boolean = False;
139 e_FastScreenshots: Boolean = true; // it's REALLY SLOW with `false`
140
141
142 implementation
143
144 uses
145 paszlib, crc, utils;
146
147
148 type
149 TTexture = record
150 //ID: DWORD;
151 tx: GLTexture;
152 Width: Word;
153 Height: Word;
154 Fmt: Word;
155 end;
156
157 TTextureFont = record
158 Texture: DWORD;
159 TextureID: DWORD;
160 Base: Uint32;
161 CharWidth: Byte;
162 CharHeight: Byte;
163 XC, YC, SPC: Word;
164 end;
165
166 TCharFont = record
167 Chars: array[0..255] of
168 record
169 TextureID: Integer;
170 Width: Byte;
171 end;
172 Space: ShortInt;
173 Height: ShortInt;
174 Live: Boolean;
175 end;
176
177 TSavedTexture = record
178 TexID: DWORD;
179 OldID: DWORD;
180 Pixels: Pointer;
181 end;
182
183 var
184 e_Textures: array of TTexture = nil;
185 e_TextureFonts: array of TTextureFont = nil;
186 e_CharFonts: array of TCharFont;
187 //e_SavedTextures: array of TSavedTexture;
188
189 //------------------------------------------------------------------
190 // Èíèöèàëèçèðóåò OpenGL
191 //------------------------------------------------------------------
192 procedure e_InitGL();
193 begin
194 if e_NoGraphics then
195 begin
196 e_DummyTextures := True;
197 Exit;
198 end;
199 e_Colors.R := 255;
200 e_Colors.G := 255;
201 e_Colors.B := 255;
202 glDisable(GL_DEPTH_TEST);
203 glEnable(GL_SCISSOR_TEST);
204 glClearColor(0, 0, 0, 0);
205 end;
206
207 procedure e_SetViewPort(X, Y, Width, Height: Word);
208 var
209 mat: Array [0..15] of GLDouble;
210
211 begin
212 if e_NoGraphics then Exit;
213 glLoadIdentity();
214 glScissor(X, Y, Width, Height);
215 glViewport(X, Y, Width, Height);
216 //gluOrtho2D(0, Width, Height, 0);
217
218 glMatrixMode(GL_PROJECTION);
219
220 mat[ 0] := 2.0 / Width;
221 mat[ 1] := 0.0;
222 mat[ 2] := 0.0;
223 mat[ 3] := 0.0;
224
225 mat[ 4] := 0.0;
226 mat[ 5] := -2.0 / Height;
227 mat[ 6] := 0.0;
228 mat[ 7] := 0.0;
229
230 mat[ 8] := 0.0;
231 mat[ 9] := 0.0;
232 mat[10] := 1.0;
233 mat[11] := 0.0;
234
235 mat[12] := -1.0;
236 mat[13] := 1.0;
237 mat[14] := 0.0;
238 mat[15] := 1.0;
239
240 glLoadMatrixd(@mat[0]);
241
242 glMatrixMode(GL_MODELVIEW);
243 glLoadIdentity();
244 end;
245
246 //------------------------------------------------------------------
247 // Èùåò ñâîáîäíûé ýëåìåíò â ìàññèâå òåêñòóð
248 //------------------------------------------------------------------
249 function FindTexture(): DWORD;
250 var
251 i: integer;
252 begin
253 if e_Textures <> nil then
254 for i := 0 to High(e_Textures) do
255 if e_Textures[i].Width = 0 then
256 begin
257 Result := i;
258 Exit;
259 end;
260
261 if e_Textures = nil then
262 begin
263 SetLength(e_Textures, 32);
264 Result := 0;
265 end
266 else
267 begin
268 Result := High(e_Textures) + 1;
269 SetLength(e_Textures, Length(e_Textures) + 32);
270 end;
271 end;
272
273 //------------------------------------------------------------------
274 // Ñîçäàåò òåêñòóðó
275 //------------------------------------------------------------------
276 function e_CreateTexture(FileName: String; var ID: DWORD): Boolean;
277 var
278 find_id: DWORD;
279 fmt: Word;
280 begin
281 Result := False;
282
283 e_WriteLog('Loading texture from '+FileName, MSG_NOTIFY);
284
285 find_id := FindTexture();
286
287 if not LoadTexture(FileName, e_Textures[find_id].tx, e_Textures[find_id].Width,
288 e_Textures[find_id].Height, @fmt) then Exit;
289
290 ID := find_id;
291 e_Textures[ID].Fmt := fmt;
292
293 Result := True;
294 end;
295
296 function e_CreateTextureEx(FileName: String; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean;
297 var
298 find_id: DWORD;
299 fmt: Word;
300 begin
301 Result := False;
302
303 find_id := FindTexture();
304
305 if not LoadTextureEx(FileName, e_Textures[find_id].tx, fX, fY, fWidth, fHeight, @fmt) then exit;
306
307 e_Textures[find_id].Width := fWidth;
308 e_Textures[find_id].Height := fHeight;
309 e_Textures[find_id].Fmt := fmt;
310
311 ID := find_id;
312
313 Result := True;
314 end;
315
316 function e_CreateTextureMem(pData: Pointer; dataSize: LongInt; var ID: DWORD): Boolean;
317 var
318 find_id: DWORD;
319 fmt: Word;
320 begin
321 Result := False;
322
323 find_id := FindTexture;
324
325 if not LoadTextureMem(pData, dataSize, e_Textures[find_id].tx, e_Textures[find_id].Width, e_Textures[find_id].Height, @fmt) then exit;
326
327 id := find_id;
328 e_Textures[id].Fmt := fmt;
329
330 Result := True;
331 end;
332
333 function e_CreateTextureMemEx(pData: Pointer; dataSize: LongInt; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean;
334 var
335 find_id: DWORD;
336 fmt: Word;
337 begin
338 Result := False;
339
340 find_id := FindTexture();
341
342 if not LoadTextureMemEx(pData, dataSize, e_Textures[find_id].tx, fX, fY, fWidth, fHeight, @fmt) then exit;
343
344 e_Textures[find_id].Width := fWidth;
345 e_Textures[find_id].Height := fHeight;
346 e_Textures[find_id].Fmt := fmt;
347
348 ID := find_id;
349
350 Result := True;
351 end;
352
353 function e_CreateTextureImg (var img: TImageData; var ID: DWORD): Boolean;
354 var
355 find_id: DWORD;
356 fmt, tw, th: Word;
357 begin
358 result := false;
359 find_id := FindTexture();
360 if not LoadTextureImg(img, e_Textures[find_id].tx, tw, th, @fmt) then exit;
361 //writeln(' tw=', tw, '; th=', th);
362 e_Textures[find_id].Width := tw;
363 e_Textures[find_id].Height := th;
364 e_Textures[find_id].Fmt := fmt;
365 ID := find_id;
366 result := True;
367 end;
368
369 procedure e_GetTextureSize(ID: DWORD; Width, Height: PWord);
370 begin
371 if Width <> nil then Width^ := e_Textures[ID].Width;
372 if Height <> nil then Height^ := e_Textures[ID].Height;
373 end;
374
375 function e_GetTextureSize2(ID: DWORD): TRectWH;
376 var
377 data: PChar;
378 x, y: Integer;
379 w, h: Word;
380 a: Boolean;
381 lastline: Integer;
382 begin
383 w := e_Textures[ID].Width;
384 h := e_Textures[ID].Height;
385
386 Result.Y := 0;
387 Result.X := 0;
388 Result.Width := w;
389 Result.Height := h;
390
391 if e_NoGraphics then Exit;
392
393 data := GetMemory(w*h*4);
394 glEnable(GL_TEXTURE_2D);
395 glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id);
396 glGetTexImage(GL_TEXTURE_2D, 0, GL_RGBA, GL_UNSIGNED_BYTE, data);
397
398 for y := h-1 downto 0 do
399 begin
400 lastline := y;
401 a := True;
402
403 for x := 1 to w-4 do
404 begin
405 a := Byte((data+y*w*4+x*4+3)^) <> 0;
406 if a then Break;
407 end;
408
409 if a then
410 begin
411 Result.Y := h-lastline;
412 Break;
413 end;
414 end;
415
416 for y := 0 to h-1 do
417 begin
418 lastline := y;
419 a := True;
420
421 for x := 1 to w-4 do
422 begin
423 a := Byte((data+y*w*4+x*4+3)^) <> 0;
424 if a then Break;
425 end;
426
427 if a then
428 begin
429 Result.Height := h-lastline-Result.Y;
430 Break;
431 end;
432 end;
433
434 for x := 0 to w-1 do
435 begin
436 lastline := x;
437 a := True;
438
439 for y := 1 to h-4 do
440 begin
441 a := Byte((data+y*w*4+x*4+3)^) <> 0;
442 if a then Break;
443 end;
444
445 if a then
446 begin
447 Result.X := lastline+1;
448 Break;
449 end;
450 end;
451
452 for x := w-1 downto 0 do
453 begin
454 lastline := x;
455 a := True;
456
457 for y := 1 to h-4 do
458 begin
459 a := Byte((data+y*w*4+x*4+3)^) <> 0;
460 if a then Break;
461 end;
462
463 if a then
464 begin
465 Result.Width := lastline-Result.X+1;
466 Break;
467 end;
468 end;
469
470 FreeMemory(data);
471 end;
472
473 procedure e_ResizeWindow(Width, Height: Integer);
474 begin
475 if Height = 0 then
476 Height := 1;
477 e_SetViewPort(0, 0, Width, Height);
478 end;
479
480 procedure e_Draw(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
481 Blending: Boolean; Mirror: TMirrorType = M_NONE);
482 var
483 u, v: Single;
484 begin
485 if e_NoGraphics then Exit;
486 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
487
488 if (Alpha > 0) or (AlphaChannel) or (Blending) then
489 glEnable(GL_BLEND)
490 else
491 glDisable(GL_BLEND);
492
493 if (AlphaChannel) or (Alpha > 0) then
494 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
495
496 if Alpha > 0 then
497 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255-Alpha);
498
499 if Blending then
500 glBlendFunc(GL_SRC_ALPHA, GL_ONE);
501
502 glEnable(GL_TEXTURE_2D);
503 glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id);
504 glBegin(GL_QUADS);
505
506 u := e_Textures[ID].tx.u;
507 v := e_Textures[ID].tx.v;
508
509 if Mirror = M_NONE then
510 begin
511 glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].Width, Y);
512 glTexCoord2f(0, 0); glVertex2i(X, Y);
513 glTexCoord2f(0, -v); glVertex2i(X, Y + e_Textures[id].Height);
514 glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].Width, Y + e_Textures[id].Height);
515 end
516 else
517 if Mirror = M_HORIZONTAL then
518 begin
519 glTexCoord2f(u, 0); glVertex2i(X, Y);
520 glTexCoord2f(0, 0); glVertex2i(X + e_Textures[id].Width, Y);
521 glTexCoord2f(0, -v); glVertex2i(X + e_Textures[id].Width, Y + e_Textures[id].Height);
522 glTexCoord2f(u, -v); glVertex2i(X, Y + e_Textures[id].Height);
523 end
524 else
525 if Mirror = M_VERTICAL then
526 begin
527 glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].Width, Y);
528 glTexCoord2f(0, -v); glVertex2i(X, Y);
529 glTexCoord2f(0, 0); glVertex2i(X, Y + e_Textures[id].Height);
530 glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].Width, Y + e_Textures[id].Height);
531 end;
532
533 glEnd();
534
535 glDisable(GL_BLEND);
536 end;
537
538 procedure e_DrawSize(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
539 Blending: Boolean; Width, Height: Word; Mirror: TMirrorType = M_NONE);
540 var
541 u, v: Single;
542 begin
543 if e_NoGraphics then Exit;
544 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
545
546 if (Alpha > 0) or (AlphaChannel) or (Blending) then
547 glEnable(GL_BLEND)
548 else
549 glDisable(GL_BLEND);
550
551 if (AlphaChannel) or (Alpha > 0) then
552 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
553
554 if Alpha > 0 then
555 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255-Alpha);
556
557 if Blending then
558 glBlendFunc(GL_SRC_ALPHA, GL_ONE);
559
560 glEnable(GL_TEXTURE_2D);
561 glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id);
562
563 u := e_Textures[ID].tx.u;
564 v := e_Textures[ID].tx.v;
565
566 glBegin(GL_QUADS);
567 glTexCoord2f(0, v); glVertex2i(X, Y);
568 glTexCoord2f(u, v); glVertex2i(X + Width, Y);
569 glTexCoord2f(u, 0); glVertex2i(X + Width, Y + Height);
570 glTexCoord2f(0, 0); glVertex2i(X, Y + Height);
571 glEnd();
572
573 glDisable(GL_BLEND);
574 end;
575
576 procedure e_DrawSizeMirror(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
577 Blending: Boolean; Width, Height: Word; Mirror: TMirrorType = M_NONE);
578 var
579 u, v: Single;
580 begin
581 if e_NoGraphics then Exit;
582 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
583
584 if (Alpha > 0) or (AlphaChannel) or (Blending) then
585 glEnable(GL_BLEND)
586 else
587 glDisable(GL_BLEND);
588
589 if (AlphaChannel) or (Alpha > 0) then
590 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
591
592 if Alpha > 0 then
593 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255-Alpha);
594
595 if Blending then
596 glBlendFunc(GL_SRC_ALPHA, GL_ONE);
597
598 glEnable(GL_TEXTURE_2D);
599 glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id);
600 glBegin(GL_QUADS);
601
602 u := e_Textures[ID].tx.u;
603 v := e_Textures[ID].tx.v;
604
605 if Mirror = M_NONE then
606 begin
607 glTexCoord2f(u, 0); glVertex2i(X + Width, Y);
608 glTexCoord2f(0, 0); glVertex2i(X, Y);
609 glTexCoord2f(0, -v); glVertex2i(X, Y + Height);
610 glTexCoord2f(u, -v); glVertex2i(X + Width, Y + Height);
611 end
612 else
613 if Mirror = M_HORIZONTAL then
614 begin
615 glTexCoord2f(u, 0); glVertex2i(X, Y);
616 glTexCoord2f(0, 0); glVertex2i(X + Width, Y);
617 glTexCoord2f(0, -v); glVertex2i(X + Width, Y + Height);
618 glTexCoord2f(u, -v); glVertex2i(X, Y + Height);
619 end
620 else
621 if Mirror = M_VERTICAL then
622 begin
623 glTexCoord2f(u, -v); glVertex2i(X + Width, Y);
624 glTexCoord2f(0, -v); glVertex2i(X, Y);
625 glTexCoord2f(0, 0); glVertex2i(X, Y + Height);
626 glTexCoord2f(u, 0); glVertex2i(X + Width, Y + Height);
627 end;
628
629 glEnd();
630
631 glDisable(GL_BLEND);
632 end;
633
634 procedure e_DrawFill(ID: DWORD; X, Y: Integer; XCount, YCount: Word; Alpha: Integer;
635 AlphaChannel: Boolean; Blending: Boolean);
636 var
637 X2, Y2, dx, w, h: Integer;
638 u, v: Single;
639 begin
640 if e_NoGraphics then Exit;
641 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
642
643 if (Alpha > 0) or (AlphaChannel) or (Blending) then
644 glEnable(GL_BLEND)
645 else
646 glDisable(GL_BLEND);
647
648 if (AlphaChannel) or (Alpha > 0) then
649 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
650
651 if Alpha > 0 then
652 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255-Alpha);
653
654 if Blending then
655 glBlendFunc(GL_SRC_ALPHA, GL_ONE);
656
657 if XCount = 0 then
658 XCount := 1;
659
660 if YCount = 0 then
661 YCount := 1;
662
663 glEnable(GL_TEXTURE_2D);
664 glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id);
665
666 X2 := X + e_Textures[ID].Width * XCount;
667 Y2 := Y + e_Textures[ID].Height * YCount;
668
669 //k8: this SHOULD work... i hope
670 if (e_Textures[ID].tx.width = e_Textures[ID].tx.glwidth) and (e_Textures[ID].tx.height = e_Textures[ID].tx.glheight) then
671 begin
672 glBegin(GL_QUADS);
673 glTexCoord2i(0, YCount); glVertex2i(X, Y);
674 glTexCoord2i(XCount, YCount); glVertex2i(X2, Y);
675 glTexCoord2i(XCount, 0); glVertex2i(X2, Y2);
676 glTexCoord2i(0, 0); glVertex2i(X, Y2);
677 glEnd();
678 end
679 else
680 begin
681 glBegin(GL_QUADS);
682 // hard day's night
683 u := e_Textures[ID].tx.u;
684 v := e_Textures[ID].tx.v;
685 w := e_Textures[ID].tx.width;
686 h := e_Textures[ID].tx.height;
687 while YCount > 0 do
688 begin
689 dx := XCount;
690 x2 := X;
691 while dx > 0 do
692 begin
693 glTexCoord2f(0, v); glVertex2i(X, Y);
694 glTexCoord2f(u, v); glVertex2i(X+w, Y);
695 glTexCoord2f(u, 0); glVertex2i(X+w, Y+h);
696 glTexCoord2f(0, 0); glVertex2i(X, Y+h);
697 Inc(X, w);
698 Dec(dx);
699 end;
700 X := x2;
701 Inc(Y, h);
702 Dec(YCount);
703 end;
704 glEnd();
705 end;
706
707 glDisable(GL_BLEND);
708 end;
709
710 procedure e_DrawAdv(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
711 Blending: Boolean; Angle: Single; RC: PPoint; Mirror: TMirrorType = M_NONE);
712 var
713 u, v: Single;
714 begin
715 if e_NoGraphics then Exit;
716 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
717
718 if (Alpha > 0) or (AlphaChannel) or (Blending) then
719 glEnable(GL_BLEND)
720 else
721 glDisable(GL_BLEND);
722
723 if (AlphaChannel) or (Alpha > 0) then
724 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
725
726 if Alpha > 0 then
727 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255-Alpha);
728
729 if Blending then
730 glBlendFunc(GL_SRC_ALPHA, GL_ONE);
731
732 if (Angle <> 0) and (RC <> nil) then
733 begin
734 glPushMatrix();
735 glTranslatef(X+RC.X, Y+RC.Y, 0);
736 glRotatef(Angle, 0, 0, 1);
737 glTranslatef(-(X+RC.X), -(Y+RC.Y), 0);
738 end;
739
740 glEnable(GL_TEXTURE_2D);
741 glBindTexture(GL_TEXTURE_2D, e_Textures[id].tx.id);
742 glBegin(GL_QUADS); //0-1 1-1
743 //00 10
744
745 u := e_Textures[ID].tx.u;
746 v := e_Textures[ID].tx.v;
747
748 if Mirror = M_NONE then
749 begin
750 glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].Width, Y);
751 glTexCoord2f(0, 0); glVertex2i(X, Y);
752 glTexCoord2f(0, -v); glVertex2i(X, Y + e_Textures[id].Height);
753 glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].Width, Y + e_Textures[id].Height);
754 end
755 else
756 if Mirror = M_HORIZONTAL then
757 begin
758 glTexCoord2f(u, 0); glVertex2i(X, Y);
759 glTexCoord2f(0, 0); glVertex2i(X + e_Textures[id].Width, Y);
760 glTexCoord2f(0, -v); glVertex2i(X + e_Textures[id].Width, Y + e_Textures[id].Height);
761 glTexCoord2f(u, -v); glVertex2i(X, Y + e_Textures[id].Height);
762 end
763 else
764 if Mirror = M_VERTICAL then
765 begin
766 glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].Width, Y);
767 glTexCoord2f(0, -v); glVertex2i(X, Y);
768 glTexCoord2f(0, 0); glVertex2i(X, Y + e_Textures[id].Height);
769 glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].Width, Y + e_Textures[id].Height);
770 end;
771
772 glEnd();
773
774 if Angle <> 0 then
775 glPopMatrix();
776
777 glDisable(GL_BLEND);
778 end;
779
780 procedure e_DrawPoint(Size: Byte; X, Y: Integer; Red, Green, Blue: Byte);
781 begin
782 if e_NoGraphics then Exit;
783 glDisable(GL_TEXTURE_2D);
784 glColor3ub(Red, Green, Blue);
785 glPointSize(Size);
786
787 if (Size = 2) or (Size = 4) then
788 X := X + 1;
789
790 glBegin(GL_POINTS);
791 glVertex2f(X+0.3, Y+1.0);
792 glEnd();
793
794 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
795 end;
796
797 procedure e_LineCorrection(var X1, Y1, X2, Y2: Integer);
798 begin
799 // Make lines only top-left/bottom-right and top-right/bottom-left
800 if Y2 < Y1 then
801 begin
802 X1 := X1 xor X2;
803 X2 := X1 xor X2;
804 X1 := X1 xor X2;
805
806 Y1 := Y1 xor Y2;
807 Y2 := Y1 xor Y2;
808 Y1 := Y1 xor Y2;
809 end;
810
811 // Pixel-perfect hack
812 if X1 < X2 then
813 Inc(X2)
814 else
815 Inc(X1);
816 Inc(Y2);
817 end;
818
819 procedure e_DrawQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue: Byte; Alpha: Byte = 0);
820 var
821 nX1, nY1, nX2, nY2: Integer;
822 begin
823 if e_NoGraphics then Exit;
824 // Only top-left/bottom-right quad
825 if X1 > X2 then
826 begin
827 X1 := X1 xor X2;
828 X2 := X1 xor X2;
829 X1 := X1 xor X2;
830 end;
831 if Y1 > Y2 then
832 begin
833 Y1 := Y1 xor Y2;
834 Y2 := Y1 xor Y2;
835 Y1 := Y1 xor Y2;
836 end;
837
838 if Alpha > 0 then
839 begin
840 glEnable(GL_BLEND);
841 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
842 end else
843 glDisable(GL_BLEND);
844
845 glDisable(GL_TEXTURE_2D);
846 glColor4ub(Red, Green, Blue, 255-Alpha);
847 glLineWidth(1);
848
849 glBegin(GL_LINES);
850 nX1 := X1; nY1 := Y1;
851 nX2 := X2; nY2 := Y1;
852 e_LineCorrection(nX1, nY1, nX2, nY2); // Pixel-perfect lines
853 glVertex2i(nX1, nY1);
854 glVertex2i(nX2, nY2);
855
856 nX1 := X2; nY1 := Y1;
857 nX2 := X2; nY2 := Y2;
858 e_LineCorrection(nX1, nY1, nX2, nY2);
859 glVertex2i(nX1, nY1);
860 glVertex2i(nX2, nY2);
861
862 nX1 := X2; nY1 := Y2;
863 nX2 := X1; nY2 := Y2;
864 e_LineCorrection(nX1, nY1, nX2, nY2);
865 glVertex2i(nX1, nY1);
866 glVertex2i(nX2, nY2);
867
868 nX1 := X1; nY1 := Y2;
869 nX2 := X1; nY2 := Y1;
870 e_LineCorrection(nX1, nY1, nX2, nY2);
871 glVertex2i(nX1, nY1);
872 glVertex2i(nX2, nY2);
873 glEnd();
874
875 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
876
877 glDisable(GL_BLEND);
878 end;
879
880 procedure e_DrawFillQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue, Alpha: Byte;
881 Blending: TBlending = B_NONE);
882 begin
883 if e_NoGraphics then Exit;
884 if (Alpha > 0) or (Blending <> B_NONE) then
885 glEnable(GL_BLEND)
886 else
887 glDisable(GL_BLEND);
888
889 if Blending = B_BLEND then
890 glBlendFunc(GL_SRC_ALPHA, GL_ONE)
891 else
892 if Blending = B_FILTER then
893 glBlendFunc(GL_DST_COLOR, GL_SRC_COLOR)
894 else
895 if Blending = B_INVERT then
896 glBlendFunc(GL_ONE_MINUS_DST_COLOR, GL_ZERO)
897 else
898 if Alpha > 0 then
899 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
900
901 glDisable(GL_TEXTURE_2D);
902 glColor4ub(Red, Green, Blue, 255-Alpha);
903
904 X2 := X2 + 1;
905 Y2 := Y2 + 1;
906
907 glBegin(GL_QUADS);
908 glVertex2i(X1, Y1);
909 glVertex2i(X2, Y1);
910 glVertex2i(X2, Y2);
911 glVertex2i(X1, Y2);
912 glEnd();
913
914 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
915
916 glDisable(GL_BLEND);
917 end;
918
919 procedure e_DrawLine(Width: Byte; X1, Y1, X2, Y2: Integer; Red, Green, Blue: Byte; Alpha: Byte = 0);
920 begin
921 if e_NoGraphics then Exit;
922 // Pixel-perfect lines
923 if Width = 1 then
924 e_LineCorrection(X1, Y1, X2, Y2);
925
926 if Alpha > 0 then
927 begin
928 glEnable(GL_BLEND);
929 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
930 end else
931 glDisable(GL_BLEND);
932
933 glDisable(GL_TEXTURE_2D);
934 glColor4ub(Red, Green, Blue, 255-Alpha);
935 glLineWidth(Width);
936
937 glBegin(GL_LINES);
938 glVertex2i(X1, Y1);
939 glVertex2i(X2, Y2);
940 glEnd();
941
942 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
943
944 glDisable(GL_BLEND);
945 end;
946
947 //------------------------------------------------------------------
948 // Óäàëÿåò òåêñòóðó èç ìàññèâà
949 //------------------------------------------------------------------
950 procedure e_DeleteTexture(ID: DWORD);
951 begin
952 if not e_NoGraphics then
953 glDeleteTextures(1, @e_Textures[ID].tx.id);
954 e_Textures[ID].tx.id := 0;
955 e_Textures[ID].Width := 0;
956 e_Textures[ID].Height := 0;
957 end;
958
959 //------------------------------------------------------------------
960 // Óäàëÿåò âñå òåêñòóðû
961 //------------------------------------------------------------------
962 procedure e_RemoveAllTextures();
963 var
964 i: integer;
965 begin
966 if e_Textures = nil then Exit;
967
968 for i := 0 to High(e_Textures) do
969 if e_Textures[i].Width <> 0 then e_DeleteTexture(i);
970 e_Textures := nil;
971 end;
972
973 //------------------------------------------------------------------
974 // Óäàëÿåò äâèæîê
975 //------------------------------------------------------------------
976 procedure e_ReleaseEngine();
977 begin
978 e_RemoveAllTextures;
979 e_RemoveAllTextureFont;
980 end;
981
982 procedure e_BeginRender();
983 begin
984 if e_NoGraphics then Exit;
985 glEnable(GL_ALPHA_TEST);
986 glAlphaFunc(GL_GREATER, 0.0);
987 end;
988
989 procedure e_Clear(Mask: TGLbitfield; Red, Green, Blue: Single); overload;
990 begin
991 if e_NoGraphics then Exit;
992 glClearColor(Red, Green, Blue, 0);
993 glClear(Mask);
994 end;
995
996 procedure e_Clear(); overload;
997 begin
998 if e_NoGraphics then Exit;
999 glClearColor(0, 0, 0, 0);
1000 glClear(GL_COLOR_BUFFER_BIT);
1001 end;
1002
1003 procedure e_EndRender();
1004 begin
1005 if e_NoGraphics then Exit;
1006 glPopMatrix();
1007 end;
1008
1009 function e_GetGamma(win: PSDL_Window): Byte;
1010 var
1011 ramp: array [0..256*3-1] of Word;
1012 rgb: array [0..2] of Double;
1013 sum: double;
1014 count: integer;
1015 min: integer;
1016 max: integer;
1017 A, B: double;
1018 i, j: integer;
1019 begin
1020 Result := 0;
1021 if e_NoGraphics then Exit;
1022 rgb[0] := 1.0;
1023 rgb[1] := 1.0;
1024 rgb[2] := 1.0;
1025
1026 SDL_GetWindowGammaRamp(win, @ramp[0], @ramp[256], @ramp[512]);
1027
1028 for i := 0 to 2 do
1029 begin
1030 sum := 0;
1031 count := 0;
1032 min := 256 * i;
1033 max := min + 256;
1034
1035 for j := min to max - 1 do
1036 if ramp[j] > 0 then
1037 begin
1038 B := (j mod 256)/256;
1039 A := ramp[j]/65536;
1040 sum := sum + ln(A)/ln(B);
1041 inc(count);
1042 end;
1043 rgb[i] := sum / count;
1044 end;
1045
1046 Result := 100 - Trunc(((rgb[0] + rgb[1] + rgb[2])/3 - 0.23) * 100/(2.7 - 0.23));
1047 end;
1048
1049 procedure e_SetGamma(win: PSDL_Window; Gamma: Byte);
1050 var
1051 ramp: array [0..256*3-1] of Word;
1052 i: integer;
1053 r: double;
1054 g: double;
1055 begin
1056 if e_NoGraphics then Exit;
1057 g := (100 - Gamma)*(2.7 - 0.23)/100 + 0.23;
1058
1059 for i := 0 to 255 do
1060 begin
1061 r := Exp(g * ln(i/256))*65536;
1062 if r < 0 then r := 0
1063 else if r > 65535 then r := 65535;
1064 ramp[i] := trunc(r);
1065 ramp[i + 256] := trunc(r);
1066 ramp[i + 512] := trunc(r);
1067 end;
1068
1069 SDL_SetWindowGammaRamp(win, @ramp[0], @ramp[256], @ramp[512]);
1070 end;
1071
1072 function e_CharFont_Create(sp: ShortInt=0): DWORD;
1073 var
1074 i, id: DWORD;
1075 begin
1076 e_WriteLog('Creating CharFont...', MSG_NOTIFY);
1077
1078 id := DWORD(-1);
1079
1080 if e_CharFonts <> nil then
1081 for i := 0 to High(e_CharFonts) do
1082 if not e_CharFonts[i].Live then
1083 begin
1084 id := i;
1085 Break;
1086 end;
1087
1088 if id = DWORD(-1) then
1089 begin
1090 SetLength(e_CharFonts, Length(e_CharFonts) + 1);
1091 id := High(e_CharFonts);
1092 end;
1093
1094 with e_CharFonts[id] do
1095 begin
1096 for i := 0 to High(Chars) do
1097 with Chars[i] do
1098 begin
1099 TextureID := -1;
1100 Width := 0;
1101 end;
1102
1103 Space := sp;
1104 Live := True;
1105 end;
1106
1107 Result := id;
1108 end;
1109
1110 procedure e_CharFont_AddChar(FontID: DWORD; Texture: Integer; c: Char; w: Byte);
1111 begin
1112 with e_CharFonts[FontID].Chars[Ord(c)] do
1113 begin
1114 TextureID := Texture;
1115 Width := w;
1116 end;
1117 end;
1118
1119 procedure e_CharFont_Print(FontID: DWORD; X, Y: Integer; Text: string);
1120 var
1121 a: Integer;
1122 begin
1123 if e_NoGraphics then Exit;
1124 if Text = '' then Exit;
1125 if e_CharFonts = nil then Exit;
1126 if Integer(FontID) > High(e_CharFonts) then Exit;
1127
1128 with e_CharFonts[FontID] do
1129 begin
1130 for a := 1 to Length(Text) do
1131 with Chars[Ord(Text[a])] do
1132 if TextureID <> -1 then
1133 begin
1134 e_Draw(TextureID, X, Y, 0, True, False);
1135 X := X+Width+IfThen(a = Length(Text), 0, Space);
1136 end;
1137 end;
1138 end;
1139
1140 procedure e_CharFont_PrintEx(FontID: DWORD; X, Y: Integer; Text: string;
1141 Color: TRGB; Scale: Single = 1.0);
1142 var
1143 a: Integer;
1144 c: TRGB;
1145 begin
1146 if e_NoGraphics then Exit;
1147 if Text = '' then Exit;
1148 if e_CharFonts = nil then Exit;
1149 if Integer(FontID) > High(e_CharFonts) then Exit;
1150
1151 with e_CharFonts[FontID] do
1152 begin
1153 for a := 1 to Length(Text) do
1154 with Chars[Ord(Text[a])] do
1155 if TextureID <> -1 then
1156 begin
1157 if Scale <> 1.0 then
1158 begin
1159 glPushMatrix;
1160 glScalef(Scale, Scale, 0);
1161 end;
1162
1163 c := e_Colors;
1164 e_Colors := Color;
1165 e_Draw(TextureID, X, Y, 0, True, False);
1166 e_Colors := c;
1167
1168 if Scale <> 1.0 then glPopMatrix;
1169
1170 X := X+Width+IfThen(a = Length(Text), 0, Space);
1171 end;
1172 end;
1173 end;
1174
1175 procedure e_CharFont_PrintFmt(FontID: DWORD; X, Y: Integer; Text: string);
1176 var
1177 a, TX, TY, len: Integer;
1178 tc, c: TRGB;
1179 w, h: Word;
1180 begin
1181 if e_NoGraphics then Exit;
1182 if Text = '' then Exit;
1183 if e_CharFonts = nil then Exit;
1184 if Integer(FontID) > High(e_CharFonts) then Exit;
1185
1186 c.R := 255;
1187 c.G := 255;
1188 c.B := 255;
1189
1190 TX := X;
1191 TY := Y;
1192 len := Length(Text);
1193
1194 e_CharFont_GetSize(FontID, 'A', w, h);
1195
1196 with e_CharFonts[FontID] do
1197 begin
1198 for a := 1 to len do
1199 begin
1200 case Text[a] of
1201 #10: // line feed
1202 begin
1203 TX := X;
1204 TY := TY + h;
1205 continue;
1206 end;
1207 #1: // black
1208 begin
1209 c.R := 0; c.G := 0; c.B := 0;
1210 continue;
1211 end;
1212 #2: // white
1213 begin
1214 c.R := 255; c.G := 255; c.B := 255;
1215 continue;
1216 end;
1217 #3: // darker
1218 begin
1219 c.R := c.R div 2; c.G := c.G div 2; c.B := c.B div 2;
1220 continue;
1221 end;
1222 #4: // lighter
1223 begin
1224 c.R := Min(c.R * 2, 255); c.G := Min(c.G * 2, 255); c.B := Min(c.B * 2, 255);
1225 continue;
1226 end;
1227 #18: // red
1228 begin
1229 c.R := 255; c.G := 0; c.B := 0;
1230 continue;
1231 end;
1232 #19: // green
1233 begin
1234 c.R := 0; c.G := 255; c.B := 0;
1235 continue;
1236 end;
1237 #20: // blue
1238 begin
1239 c.R := 0; c.G := 0; c.B := 255;
1240 continue;
1241 end;
1242 #21: // yellow
1243 begin
1244 c.R := 255; c.G := 255; c.B := 0;
1245 continue;
1246 end;
1247 end;
1248
1249 with Chars[Ord(Text[a])] do
1250 if TextureID <> -1 then
1251 begin
1252 tc := e_Colors;
1253 e_Colors := c;
1254 e_Draw(TextureID, TX, TY, 0, True, False);
1255 e_Colors := tc;
1256
1257 TX := TX+Width+IfThen(a = Length(Text), 0, Space);
1258 end;
1259 end;
1260 end;
1261 end;
1262
1263 procedure e_CharFont_GetSize(FontID: DWORD; Text: string; var w, h: Word);
1264 var
1265 a: Integer;
1266 h2: Word;
1267 begin
1268 w := 0;
1269 h := 0;
1270
1271 if Text = '' then Exit;
1272 if e_CharFonts = nil then Exit;
1273 if Integer(FontID) > High(e_CharFonts) then Exit;
1274
1275 with e_CharFonts[FontID] do
1276 begin
1277 for a := 1 to Length(Text) do
1278 with Chars[Ord(Text[a])] do
1279 if TextureID <> -1 then
1280 begin
1281 w := w+Width+IfThen(a = Length(Text), 0, Space);
1282 e_GetTextureSize(TextureID, nil, @h2);
1283 if h2 > h then h := h2;
1284 end;
1285 end;
1286 end;
1287
1288 procedure e_CharFont_GetSizeFmt(FontID: DWORD; Text: string; var w, h: Word);
1289 var
1290 a, lines, len: Integer;
1291 h2, w2: Word;
1292 begin
1293 w2 := 0;
1294 w := 0;
1295 h := 0;
1296
1297 if Text = '' then Exit;
1298 if e_CharFonts = nil then Exit;
1299 if Integer(FontID) > High(e_CharFonts) then Exit;
1300
1301 lines := 1;
1302 len := Length(Text);
1303
1304 with e_CharFonts[FontID] do
1305 begin
1306 for a := 1 to len do
1307 begin
1308 if Text[a] = #10 then
1309 begin
1310 Inc(lines);
1311 if w2 > w then
1312 begin
1313 w := w2;
1314 w2 := 0;
1315 end;
1316 continue;
1317 end
1318 else if Text[a] in [#1, #2, #3, #4, #18, #19, #20, #21] then
1319 continue;
1320
1321 with Chars[Ord(Text[a])] do
1322 if TextureID <> -1 then
1323 begin
1324 w2 := w2 + Width + IfThen(a = len, 0, Space);
1325 e_GetTextureSize(TextureID, nil, @h2);
1326 if h2 > h then h := h2;
1327 end;
1328 end;
1329 end;
1330
1331 if w2 > w then
1332 w := w2;
1333 h := h * lines;
1334 end;
1335
1336 function e_CharFont_GetMaxWidth(FontID: DWORD): Word;
1337 var
1338 a: Integer;
1339 begin
1340 Result := 0;
1341
1342 if e_CharFonts = nil then Exit;
1343 if Integer(FontID) > High(e_CharFonts) then Exit;
1344
1345 for a := 0 to High(e_CharFonts[FontID].Chars) do
1346 Result := Max(Result, e_CharFonts[FontID].Chars[a].Width);
1347 end;
1348
1349 function e_CharFont_GetMaxHeight(FontID: DWORD): Word;
1350 var
1351 a: Integer;
1352 h2: Word;
1353 begin
1354 Result := 0;
1355
1356 if e_CharFonts = nil then Exit;
1357 if Integer(FontID) > High(e_CharFonts) then Exit;
1358
1359 for a := 0 to High(e_CharFonts[FontID].Chars) do
1360 begin
1361 if e_CharFonts[FontID].Chars[a].TextureID <> -1 then
1362 e_GetTextureSize(e_CharFonts[FontID].Chars[a].TextureID, nil, @h2)
1363 else h2 := 0;
1364 if h2 > Result then Result := h2;
1365 end;
1366 end;
1367
1368 procedure e_CharFont_Remove(FontID: DWORD);
1369 var
1370 a: Integer;
1371 begin
1372 with e_CharFonts[FontID] do
1373 for a := 0 to High(Chars) do
1374 if Chars[a].TextureID <> -1 then e_DeleteTexture(Chars[a].TextureID);
1375
1376 e_CharFonts[FontID].Live := False;
1377 end;
1378
1379 procedure e_CharFont_RemoveAll();
1380 var
1381 a: Integer;
1382 begin
1383 if e_CharFonts = nil then Exit;
1384
1385 for a := 0 to High(e_CharFonts) do
1386 e_CharFont_Remove(a);
1387
1388 e_CharFonts := nil;
1389 end;
1390
1391 procedure e_TextureFontBuild(Tex: DWORD; var FontID: DWORD; XCount, YCount: Word;
1392 Space: ShortInt=0);
1393 var
1394 loop1 : GLuint;
1395 cx, cy : real;
1396 i, id: DWORD;
1397 begin
1398 if e_NoGraphics then Exit;
1399 e_WriteLog('Creating texture font...', MSG_NOTIFY);
1400
1401 id := DWORD(-1);
1402
1403 if e_TextureFonts <> nil then
1404 for i := 0 to High(e_TextureFonts) do
1405 if e_TextureFonts[i].Base = 0 then
1406 begin
1407 id := i;
1408 Break;
1409 end;
1410
1411 if id = DWORD(-1) then
1412 begin
1413 SetLength(e_TextureFonts, Length(e_TextureFonts) + 1);
1414 id := High(e_TextureFonts);
1415 end;
1416
1417 with e_TextureFonts[id] do
1418 begin
1419 Base := glGenLists(XCount*YCount);
1420 TextureID := e_Textures[Tex].tx.id;
1421 CharWidth := (e_Textures[Tex].Width div XCount)+Space;
1422 CharHeight := e_Textures[Tex].Height div YCount;
1423 XC := XCount;
1424 YC := YCount;
1425 Texture := Tex;
1426 SPC := Space;
1427 end;
1428
1429 glBindTexture(GL_TEXTURE_2D, e_Textures[Tex].tx.id);
1430 for loop1 := 0 to XCount*YCount-1 do
1431 begin
1432 cx := (loop1 mod XCount)/XCount;
1433 cy := (loop1 div YCount)/YCount;
1434
1435 glNewList(e_TextureFonts[id].Base+loop1, GL_COMPILE);
1436 glBegin(GL_QUADS);
1437 glTexCoord2f(cx, 1.0-cy-1/YCount);
1438 glVertex2d(0, e_Textures[Tex].Height div YCount);
1439
1440 glTexCoord2f(cx+1/XCount, 1.0-cy-1/YCount);
1441 glVertex2i(e_Textures[Tex].Width div XCount, e_Textures[Tex].Height div YCount);
1442
1443 glTexCoord2f(cx+1/XCount, 1.0-cy);
1444 glVertex2i(e_Textures[Tex].Width div XCount, 0);
1445
1446 glTexCoord2f(cx, 1.0-cy);
1447 glVertex2i(0, 0);
1448 glEnd();
1449 glTranslated((e_Textures[Tex].Width div XCount)+Space, 0, 0);
1450 glEndList();
1451 end;
1452
1453 FontID := id;
1454 end;
1455
1456 procedure e_TextureFontKill(FontID: DWORD);
1457 begin
1458 if e_NoGraphics then Exit;
1459 glDeleteLists(e_TextureFonts[FontID].Base, 256);
1460 e_TextureFonts[FontID].Base := 0;
1461 end;
1462
1463 procedure e_TextureFontPrint(X, Y: GLint; Text: string; FontID: DWORD);
1464 begin
1465 if e_NoGraphics then Exit;
1466 if Integer(FontID) > High(e_TextureFonts) then Exit;
1467 if Text = '' then Exit;
1468
1469 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
1470 glEnable(GL_BLEND);
1471
1472 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
1473
1474 glPushMatrix;
1475 glBindTexture(GL_TEXTURE_2D, e_TextureFonts[FontID].TextureID);
1476 glEnable(GL_TEXTURE_2D);
1477 glTranslated(x, y, 0);
1478 glListBase(DWORD(Integer(e_TextureFonts[FontID].Base)-32));
1479 glCallLists(Length(Text), GL_UNSIGNED_BYTE, PChar(Text));
1480 glDisable(GL_TEXTURE_2D);
1481 glPopMatrix;
1482
1483 glDisable(GL_BLEND);
1484 end;
1485
1486 // god forgive me for this, but i cannot figure out how to do it without lists
1487 procedure e_TextureFontPrintChar(X, Y: Integer; Ch: Char; FontID: DWORD; Shadow: Boolean = False);
1488 begin
1489 if e_NoGraphics then Exit;
1490 glPushMatrix;
1491
1492 if Shadow then
1493 begin
1494 glColor4ub(0, 0, 0, 128);
1495 glTranslated(X+1, Y+1, 0);
1496 glCallLists(1, GL_UNSIGNED_BYTE, @Ch);
1497 glPopMatrix;
1498 glPushMatrix;
1499 end;
1500
1501 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
1502 glTranslated(X, Y, 0);
1503 glCallLists(1, GL_UNSIGNED_BYTE, @Ch);
1504
1505 glPopMatrix;
1506 end;
1507
1508 procedure e_TextureFontPrintCharEx (X, Y: Integer; Ch: Char; FontID: DWORD; Shadow: Boolean = False);
1509 begin
1510 glBindTexture(GL_TEXTURE_2D, e_TextureFonts[FontID].TextureID);
1511 glEnable(GL_TEXTURE_2D);
1512 //glListBase(DWORD(Integer(e_TextureFonts[FontID].Base)-32));
1513
1514 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
1515 glEnable(GL_BLEND);
1516 e_TextureFontPrintChar(X, Y, Ch, FontID, Shadow);
1517 glDisable(GL_TEXTURE_2D);
1518 glDisable(GL_BLEND);
1519 end;
1520
1521 function e_TextureFontCharWidth (ch: Char; FontID: DWORD): Integer;
1522 begin
1523 result := e_TextureFonts[FontID].CharWidth;
1524 end;
1525
1526 procedure e_TextureFontPrintFmt(X, Y: Integer; Text: string; FontID: DWORD; Shadow: Boolean = False);
1527 var
1528 a, TX, TY, len: Integer;
1529 tc, c: TRGB;
1530 w: Word;
1531 begin
1532 if e_NoGraphics then Exit;
1533 if Text = '' then Exit;
1534 if e_TextureFonts = nil then Exit;
1535 if Integer(FontID) > High(e_TextureFonts) then Exit;
1536
1537 c.R := 255;
1538 c.G := 255;
1539 c.B := 255;
1540
1541 TX := X;
1542 TY := Y;
1543 len := Length(Text);
1544
1545 w := e_TextureFonts[FontID].CharWidth;
1546
1547 with e_TextureFonts[FontID] do
1548 begin
1549 glBindTexture(GL_TEXTURE_2D, e_TextureFonts[FontID].TextureID);
1550 glEnable(GL_TEXTURE_2D);
1551 glListBase(DWORD(Integer(e_TextureFonts[FontID].Base)-32));
1552
1553 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
1554 glEnable(GL_BLEND);
1555
1556 for a := 1 to len do
1557 begin
1558 case Text[a] of
1559 {#10: // line feed
1560 begin
1561 TX := X;
1562 TY := TY + h;
1563 continue;
1564 end;}
1565 #1: // black
1566 begin
1567 c.R := 0; c.G := 0; c.B := 0;
1568 continue;
1569 end;
1570 #2: // white
1571 begin
1572 c.R := 255; c.G := 255; c.B := 255;
1573 continue;
1574 end;
1575 #3: // darker
1576 begin
1577 c.R := c.R div 2; c.G := c.G div 2; c.B := c.B div 2;
1578 continue;
1579 end;
1580 #4: // lighter
1581 begin
1582 c.R := Min(c.R * 2, 255); c.G := Min(c.G * 2, 255); c.B := Min(c.B * 2, 255);
1583 continue;
1584 end;
1585 #18: // red
1586 begin
1587 c.R := 255; c.G := 0; c.B := 0;
1588 continue;
1589 end;
1590 #19: // green
1591 begin
1592 c.R := 0; c.G := 255; c.B := 0;
1593 continue;
1594 end;
1595 #20: // blue
1596 begin
1597 c.R := 0; c.G := 0; c.B := 255;
1598 continue;
1599 end;
1600 #21: // yellow
1601 begin
1602 c.R := 255; c.G := 255; c.B := 0;
1603 continue;
1604 end;
1605 end;
1606
1607 tc := e_Colors;
1608 e_Colors := c;
1609 e_TextureFontPrintChar(TX, TY, Text[a], FontID, Shadow);
1610 e_Colors := tc;
1611
1612 TX := TX+w;
1613 end;
1614 glDisable(GL_TEXTURE_2D);
1615 glDisable(GL_BLEND);
1616 end;
1617 end;
1618
1619 procedure e_TextureFontPrintEx(X, Y: GLint; Text: string; FontID: DWORD; Red, Green,
1620 Blue: Byte; Scale: Single; Shadow: Boolean = False);
1621 begin
1622 if e_NoGraphics then Exit;
1623 if Text = '' then Exit;
1624
1625 glPushMatrix;
1626 glBindTexture(GL_TEXTURE_2D, e_TextureFonts[FontID].TextureID);
1627 glEnable(GL_TEXTURE_2D);
1628 glListBase(DWORD(Integer(e_TextureFonts[FontID].Base)-32));
1629
1630 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
1631 glEnable(GL_BLEND);
1632
1633 if Shadow then
1634 begin
1635 glColor4ub(0, 0, 0, 128);
1636 glTranslated(x+1, y+1, 0);
1637 glScalef(Scale, Scale, 0);
1638 glCallLists(Length(Text), GL_UNSIGNED_BYTE, PChar(Text));
1639 glPopMatrix;
1640 glPushMatrix;
1641 end;
1642
1643 glColor4ub(Red, Green, Blue, 255);
1644 glTranslated(x, y, 0);
1645 glScalef(Scale, Scale, 0);
1646 glCallLists(Length(Text), GL_UNSIGNED_BYTE, PChar(Text));
1647
1648 glDisable(GL_TEXTURE_2D);
1649 glPopMatrix;
1650 glColor3ub(e_Colors.R, e_Colors.G, e_Colors.B);
1651 glDisable(GL_BLEND);
1652 end;
1653
1654 procedure e_TextureFontGetSize(ID: DWORD; var CharWidth, CharHeight: Byte);
1655 begin
1656 CharWidth := 16;
1657 CharHeight := 16;
1658 if e_NoGraphics then Exit;
1659 if Integer(ID) > High(e_TextureFonts) then
1660 Exit;
1661 CharWidth := e_TextureFonts[ID].CharWidth;
1662 CharHeight := e_TextureFonts[ID].CharHeight;
1663 end;
1664
1665 procedure e_RemoveAllTextureFont();
1666 var
1667 i: integer;
1668 begin
1669 if e_NoGraphics then Exit;
1670 if e_TextureFonts = nil then Exit;
1671
1672 for i := 0 to High(e_TextureFonts) do
1673 if e_TextureFonts[i].Base <> 0 then
1674 begin
1675 glDeleteLists(e_TextureFonts[i].Base, 256);
1676 e_TextureFonts[i].Base := 0;
1677 end;
1678
1679 e_TextureFonts := nil;
1680 end;
1681
1682 function _RGB(Red, Green, Blue: Byte): TRGB;
1683 begin
1684 Result.R := Red;
1685 Result.G := Green;
1686 Result.B := Blue;
1687 end;
1688
1689 function _Point(X, Y: Integer): TPoint2i;
1690 begin
1691 Result.X := X;
1692 Result.Y := Y;
1693 end;
1694
1695 function _Rect(X, Y: Integer; Width, Height: Word): TRectWH;
1696 begin
1697 Result.X := X;
1698 Result.Y := Y;
1699 Result.Width := Width;
1700 Result.Height := Height;
1701 end;
1702
1703 function _TRect(L, T, R, B: LongInt): TRect;
1704 begin
1705 Result.Top := T;
1706 Result.Left := L;
1707 Result.Right := R;
1708 Result.Bottom := B;
1709 end;
1710
1711
1712 procedure e_MakeScreenshot (st: TStream; Width, Height: Word);
1713 var
1714 pixels, obuf, scln, ps, pd: PByte;
1715 obufsize: Integer;
1716 dlen: Cardinal;
1717 i, x, y, res: Integer;
1718 sign: array [0..7] of Byte;
1719 hbuf: array [0..12] of Byte;
1720 crc: LongWord;
1721 img: TImageData;
1722 clr: TColor32Rec;
1723 begin
1724 if e_NoGraphics then Exit;
1725 obuf := nil;
1726
1727 // first, extract and pack graphics data
1728 if (Width mod 4) > 0 then Width := Width+4-(Width mod 4);
1729
1730 GetMem(pixels, Width*Height*3);
1731 try
1732 FillChar(pixels^, Width*Height*3, 0);
1733 glReadPixels(0, 0, Width, Height, GL_RGB, GL_UNSIGNED_BYTE, pixels);
1734 //e_WriteLog('PNG: pixels read', MSG_NOTIFY);
1735
1736 if e_FastScreenshots then
1737 begin
1738 // create scanlines
1739 GetMem(scln, (Width*3+1)*Height);
1740 try
1741 ps := pixels;
1742 pd := scln;
1743 Inc(ps, (Width*3)*(Height-1));
1744 for i := 0 to Height-1 do
1745 begin
1746 pd^ := 0; // filter
1747 Inc(pd);
1748 Move(ps^, pd^, Width*3);
1749 Dec(ps, Width*3);
1750 Inc(pd, Width*3);
1751 end;
1752 except
1753 FreeMem(scln);
1754 raise;
1755 end;
1756 FreeMem(pixels);
1757 pixels := scln;
1758
1759 // pack it
1760 obufsize := (Width*3+1)*Height*2;
1761 GetMem(obuf, obufsize);
1762 try
1763 while true do
1764 begin
1765 dlen := obufsize;
1766 res := compress2(Pointer(obuf), dlen, Pointer(pixels), (Width*3+1)*Height, 9);
1767 if res = Z_OK then break;
1768 if res <> Z_BUF_ERROR then raise Exception.Create('can''t pack data for PNG');
1769 obufsize := obufsize*2;
1770 FreeMem(obuf);
1771 obuf := nil;
1772 GetMem(obuf, obufsize);
1773 end;
1774 //e_WriteLog(Format('PNG: pixels compressed from %d to %d', [Integer(Width*Height*3), Integer(dlen)]), MSG_NOTIFY);
1775
1776 // now write PNG
1777
1778 // signature
1779 sign[0] := 137;
1780 sign[1] := 80;
1781 sign[2] := 78;
1782 sign[3] := 71;
1783 sign[4] := 13;
1784 sign[5] := 10;
1785 sign[6] := 26;
1786 sign[7] := 10;
1787 st.writeBuffer(sign, 8);
1788 //e_WriteLog('PNG: signature written', MSG_NOTIFY);
1789
1790 // header
1791 writeIntBE(st, LongWord(13));
1792 sign[0] := 73;
1793 sign[1] := 72;
1794 sign[2] := 68;
1795 sign[3] := 82;
1796 st.writeBuffer(sign, 4);
1797 crc := crc32(0, @sign, 4);
1798 hbuf[0] := 0;
1799 hbuf[1] := 0;
1800 hbuf[2] := (Width shr 8) and $ff;
1801 hbuf[3] := Width and $ff;
1802 hbuf[4] := 0;
1803 hbuf[5] := 0;
1804 hbuf[6] := (Height shr 8) and $ff;
1805 hbuf[7] := Height and $ff;
1806 hbuf[8] := 8; // bit depth
1807 hbuf[9] := 2; // RGB
1808 hbuf[10] := 0; // compression method
1809 hbuf[11] := 0; // filter method
1810 hbuf[12] := 0; // no interlace
1811 crc := crc32(crc, @hbuf, 13);
1812 st.writeBuffer(hbuf, 13);
1813 writeIntBE(st, crc);
1814 //e_WriteLog('PNG: header written', MSG_NOTIFY);
1815
1816 // image data
1817 writeIntBE(st, LongWord(dlen));
1818 sign[0] := 73;
1819 sign[1] := 68;
1820 sign[2] := 65;
1821 sign[3] := 84;
1822 st.writeBuffer(sign, 4);
1823 crc := crc32(0, @sign, 4);
1824 crc := crc32(crc, obuf, dlen);
1825 st.writeBuffer(obuf^, dlen);
1826 writeIntBE(st, crc);
1827 //e_WriteLog('PNG: image data written', MSG_NOTIFY);
1828
1829 // image data end
1830 writeIntBE(st, LongWord(0));
1831 sign[0] := 73;
1832 sign[1] := 69;
1833 sign[2] := 78;
1834 sign[3] := 68;
1835 st.writeBuffer(sign, 4);
1836 crc := crc32(0, @sign, 4);
1837 writeIntBE(st, crc);
1838 //e_WriteLog('PNG: end marker written', MSG_NOTIFY);
1839 finally
1840 if obuf <> nil then FreeMem(obuf);
1841 end;
1842 end
1843 else
1844 begin
1845 Imaging.SetOption(ImagingPNGCompressLevel, 9);
1846 Imaging.SetOption(ImagingPNGPreFilter, 6);
1847 InitImage(img);
1848 try
1849 NewImage(Width, Height, TImageFormat.ifR8G8B8, img);
1850 ps := pixels;
1851 //writeln(stderr, 'moving pixels...');
1852 for y := Height-1 downto 0 do
1853 begin
1854 for x := 0 to Width-1 do
1855 begin
1856 clr.r := ps^; Inc(ps);
1857 clr.g := ps^; Inc(ps);
1858 clr.b := ps^; Inc(ps);
1859 clr.a := 255;
1860 SetPixel32(img, x, y, clr);
1861 end;
1862 end;
1863 GlobalMetadata.ClearMetaItems();
1864 GlobalMetadata.ClearMetaItemsForSaving();
1865 //writeln(stderr, 'compressing image...');
1866 if not SaveImageToStream('png', st, img) then raise Exception.Create('screenshot writing error');
1867 //writeln(stderr, 'done!');
1868 finally
1869 FreeImage(img);
1870 end;
1871 end;
1872 finally
1873 FreeMem(pixels);
1874 end;
1875 end;
1876
1877
1878 end.
[MIRROR] a port of Doom 2D Forever to FPC/SDL
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024