DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / d2df-sdl.git / blob


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