DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / d2df-sdl.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
render: fix unused variable warnings
[d2df-sdl.git] / src / game / opengl / r_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 r_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, r_texture, g_base,
26 MAPDEF, ImagingTypes, Imaging, ImagingUtility;
27
28 type
29 PDFPoint = ^TDFPoint;
30
31 //------------------------------------------------------------------
32 // прототипы функций
33 //------------------------------------------------------------------
34 procedure e_InitGL();
35 procedure e_SetViewPort(X, Y, Width, Height: Word);
36 procedure e_ResizeWindow(Width, Height: Integer);
37 function e_ResizeFramebuffer(Width, Height: Integer): Boolean;
38 procedure e_BlitFramebuffer(WinWidth, WinHeight: Integer);
39 procedure e_SetRenderTarget(Framebuffer: Boolean);
40
41 procedure e_Draw(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
42 Blending: Boolean; Mirror: TMirrorType = TMirrorType.None);
43 procedure e_DrawAdv(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
44 Blending: Boolean; Angle: Single; RC: PDFPoint; Mirror: TMirrorType = TMirrorType.None);
45 procedure e_DrawSize(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
46 Blending: Boolean; Width, Height: Word; Mirror: TMirrorType = TMirrorType.None);
47 procedure e_DrawSizeMirror(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
48 Blending: Boolean; Width, Height: Word; Mirror: TMirrorType = TMirrorType.None);
49
50 procedure e_DrawFill(ID: DWORD; X, Y: Integer; XCount, YCount: Word; Alpha: Integer;
51 AlphaChannel: Boolean; Blending: Boolean; ambientBlendMode: Boolean=false);
52
53 procedure e_DrawFillX (id: DWORD; x, y, wdt, hgt: Integer; alpha: Integer; alphachannel: Boolean;
54 blending: Boolean; scale: Single; ambientBlendMode: Boolean=false);
55
56 procedure e_AmbientQuad (x, y, w, h: Integer; r, g, b, a: Byte);
57
58 procedure e_DrawPoint(Size: Byte; X, Y: Integer; Red, Green, Blue: Byte);
59 procedure e_DrawLine(Width: Byte; X1, Y1, X2, Y2: Integer; Red, Green, Blue: Byte; Alpha: Byte = 0);
60 procedure e_DrawQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue: Byte; Alpha: Byte = 0);
61 procedure e_DrawFillQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue, Alpha: Byte;
62 Blending: TBlending = TBlending.None);
63 procedure e_DarkenQuad (x0, y0, x1, y1: Integer; a: Integer);
64 procedure e_DarkenQuadWH (x, y, w, h: Integer; a: Integer);
65
66 function e_CreateTextureImg (var img: TImageData; var ID: DWORD): Boolean;
67 function e_CreateTexture(FileName: string; var ID: DWORD): Boolean;
68 function e_CreateTextureEx(FileName: string; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean;
69 function e_CreateTextureMem(pData: Pointer; dataSize: LongInt; var ID: DWORD; filter: Boolean = False): Boolean;
70 function e_CreateTextureMemEx(pData: Pointer; dataSize: LongInt; var ID: DWORD; fX, fY, fWidth, fHeight: Word; filter: Boolean = False): Boolean;
71 procedure e_GetTextureSize(ID: DWORD; Width, Height: PWord);
72 procedure e_DeleteTexture(ID: DWORD);
73 procedure e_RemoveAllTextures();
74
75 // CharFont
76 function e_CharFont_Create(sp: ShortInt=0): DWORD;
77 procedure e_CharFont_AddChar(FontID: DWORD; Texture: Integer; c: Char; w: Byte);
78 procedure e_CharFont_Print(FontID: DWORD; X, Y: Integer; Text: string);
79 procedure e_CharFont_PrintEx(FontID: DWORD; X, Y: Integer; Text: string;
80 Color: TRGB; Scale: Single = 1.0);
81 procedure e_CharFont_PrintFmt(FontID: DWORD; X, Y: Integer; Text: string);
82 procedure e_CharFont_GetSize(FontID: DWORD; Text: string; var w, h: Word);
83 procedure e_CharFont_GetSizeFmt(FontID: DWORD; Text: string; var w, h: Word);
84 function e_CharFont_GetMaxWidth(FontID: DWORD): Word;
85 function e_CharFont_GetMaxHeight(FontID: DWORD): Word;
86 procedure e_CharFont_Remove(FontID: DWORD);
87 procedure e_CharFont_RemoveAll();
88
89 // TextureFont
90 procedure e_TextureFontBuild(Tex: DWORD; var FontID: DWORD; XCount, YCount: Word;
91 Space: ShortInt=0);
92 procedure e_TextureFontKill(FontID: DWORD);
93 procedure e_TextureFontPrint(X, Y: GLint; Text: string; FontID: DWORD);
94 procedure e_TextureFontPrintEx(X, Y: GLint; Text: string; FontID: DWORD; Red, Green,
95 Blue: Byte; Scale: Single; Shadow: Boolean = False);
96 procedure e_TextureFontPrintFmt(X, Y: GLint; Text: string; FontID: DWORD;
97 Shadow: Boolean = False; Newlines: Boolean = False);
98 procedure e_TextureFontGetSize(ID: DWORD; out CharWidth, CharHeight: Byte);
99 procedure e_RemoveAllTextureFont();
100
101 function e_TextureFontCharWidth (ch: Char; FontID: DWORD): Integer;
102 procedure e_TextureFontPrintCharEx (X, Y: Integer; Ch: Char; FontID: DWORD; Shadow: Boolean = False);
103
104 procedure e_ReleaseEngine();
105 procedure e_BeginRender();
106 procedure e_Clear(Mask: TGLbitfield; Red, Green, Blue: Single); overload;
107 procedure e_Clear(Red, Green, Blue: Single); overload;
108 procedure e_Clear(); overload;
109 procedure e_EndRender();
110
111 {$IFDEF USE_SDL2}
112 function e_GetGamma(win: PSDL_Window): Byte;
113 procedure e_SetGamma(win: PSDL_Window;Gamma: Byte);
114 {$ENDIF}
115
116 procedure e_MakeScreenshot(st: TStream; Width, Height: Word);
117
118 //function e_getTextGLId (ID: DWORD): GLuint;
119
120 var
121 e_Colors: TRGB;
122
123 implementation
124
125 uses
126 paszlib, crc, utils, g_options;
127
128 type
129 TTexture = record
130 tx: GLTexture;
131 end;
132
133 TTextureFont = record
134 Texture: DWORD;
135 TextureID: DWORD;
136 Base: Uint32;
137 CharWidth: Byte;
138 CharHeight: Byte;
139 XC, YC: WORD;
140 SPC: ShortInt;
141 end;
142
143 TCharFont = record
144 Chars: array[0..255] of
145 record
146 TextureID: Integer;
147 Width: Byte;
148 end;
149 Space: ShortInt;
150 Height: ShortInt;
151 alive: Boolean;
152 end;
153
154 TSavedTexture = record
155 TexID: DWORD;
156 OldID: DWORD;
157 Pixels: Pointer;
158 end;
159
160 var
161 e_Textures: array of TTexture = nil;
162 e_TextureFonts: array of TTextureFont = nil;
163 e_CharFonts: array of TCharFont;
164 //e_SavedTextures: array of TSavedTexture;
165 e_FBO: GLuint = 0;
166 e_RBO: GLuint = 0;
167 e_RBOSupported: Boolean = True;
168 e_Frame: GLuint = 0;
169
170 //function e_getTextGLId (ID: DWORD): GLuint; begin result := e_Textures[ID].tx.id; end;
171
172 //------------------------------------------------------------------
173 // Инициализирует OpenGL
174 //------------------------------------------------------------------
175 procedure e_InitGL();
176 begin
177 if e_NoGraphics then
178 begin
179 e_DummyTextures := True;
180 Exit;
181 end;
182 e_Colors.R := 255;
183 e_Colors.G := 255;
184 e_Colors.B := 255;
185 glDisable(GL_DEPTH_TEST);
186 glEnable(GL_SCISSOR_TEST);
187 glClearColor(0, 0, 0, 0);
188 end;
189
190 procedure e_SetViewPort(X, Y, Width, Height: Word);
191 var
192 mat: Array [0..15] of GLDouble;
193
194 begin
195 if e_NoGraphics then Exit;
196 glLoadIdentity();
197 glScissor(X, Y, Width, Height);
198 glViewport(X, Y, Width, Height);
199 //gluOrtho2D(0, Width, Height, 0);
200
201 glMatrixMode(GL_PROJECTION);
202
203 mat[ 0] := 2.0 / Width;
204 mat[ 1] := 0.0;
205 mat[ 2] := 0.0;
206 mat[ 3] := 0.0;
207
208 mat[ 4] := 0.0;
209 mat[ 5] := -2.0 / Height;
210 mat[ 6] := 0.0;
211 mat[ 7] := 0.0;
212
213 mat[ 8] := 0.0;
214 mat[ 9] := 0.0;
215 mat[10] := 1.0;
216 mat[11] := 0.0;
217
218 mat[12] := -1.0;
219 mat[13] := 1.0;
220 mat[14] := 0.0;
221 mat[15] := 1.0;
222
223 glLoadMatrixd(@mat[0]);
224
225 glMatrixMode(GL_MODELVIEW);
226 glLoadIdentity();
227 end;
228
229 //------------------------------------------------------------------
230 // Ищет свободный элемент в массиве текстур
231 //------------------------------------------------------------------
232 function FindTexture(): DWORD;
233 var
234 i: integer;
235 begin
236 if e_Textures <> nil then
237 for i := 0 to High(e_Textures) do
238 if e_Textures[i].tx.Width = 0 then
239 begin
240 Result := i;
241 Exit;
242 end;
243
244 if e_Textures = nil then
245 begin
246 SetLength(e_Textures, 32);
247 Result := 0;
248 end
249 else
250 begin
251 Result := High(e_Textures) + 1;
252 SetLength(e_Textures, Length(e_Textures) + 32);
253 end;
254 end;
255
256 //------------------------------------------------------------------
257 // Создает текстуру
258 //------------------------------------------------------------------
259 function e_CreateTexture(FileName: String; var ID: DWORD): Boolean;
260 var
261 find_id: DWORD;
262 fmt: Word;
263 begin
264 Result := False;
265
266 e_WriteLog('Loading texture from '+FileName, TMsgType.Notify);
267
268 find_id := FindTexture();
269
270 if not LoadTexture(FileName, e_Textures[find_id].tx, e_Textures[find_id].tx.Width,
271 e_Textures[find_id].tx.Height, @fmt) then Exit;
272
273 ID := find_id;
274
275 Result := True;
276 end;
277
278 function e_CreateTextureEx(FileName: String; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean;
279 var
280 find_id: DWORD;
281 fmt: Word;
282 begin
283 Result := False;
284
285 find_id := FindTexture();
286
287 if not LoadTextureEx(FileName, e_Textures[find_id].tx, fX, fY, fWidth, fHeight, @fmt) then exit;
288
289 ID := find_id;
290
291 Result := True;
292 end;
293
294 function e_CreateTextureMem(pData: Pointer; dataSize: LongInt; var ID: DWORD; filter: Boolean = False): Boolean;
295 var
296 find_id: DWORD;
297 fmt: Word;
298 begin
299 Result := False;
300
301 find_id := FindTexture;
302
303 if not LoadTextureMem(pData, dataSize, e_Textures[find_id].tx, e_Textures[find_id].tx.Width, e_Textures[find_id].tx.Height, @fmt, filter) then exit;
304
305 id := find_id;
306
307 Result := True;
308 end;
309
310 function e_CreateTextureMemEx(pData: Pointer; dataSize: LongInt; var ID: DWORD; fX, fY, fWidth, fHeight: Word; filter: Boolean = False): Boolean;
311 var
312 find_id: DWORD;
313 fmt: Word;
314 begin
315 Result := False;
316
317 find_id := FindTexture();
318
319 if not LoadTextureMemEx(pData, dataSize, e_Textures[find_id].tx, fX, fY, fWidth, fHeight, @fmt, filter) then exit;
320
321 ID := find_id;
322
323 Result := True;
324 end;
325
326 function e_CreateTextureImg (var img: TImageData; var ID: DWORD): Boolean;
327 var
328 find_id: DWORD;
329 fmt, tw, th: Word;
330 begin
331 result := false;
332 find_id := FindTexture();
333 if not LoadTextureImg(img, e_Textures[find_id].tx, tw, th, @fmt) then exit;
334 ID := find_id;
335 result := True;
336 end;
337
338 procedure e_GetTextureSize(ID: DWORD; Width, Height: PWord);
339 begin
340 if Width <> nil then Width^ := e_Textures[ID].tx.Width;
341 if Height <> nil then Height^ := e_Textures[ID].tx.Height;
342 end;
343
344 procedure DestroyFramebuffer;
345 begin
346 glBindTexture(GL_TEXTURE_2D, 0);
347 glBindRenderbuffer(GL_RENDERBUFFER, 0);
348 glBindFramebuffer(GL_FRAMEBUFFER, 0);
349
350 if e_Frame > 0 then
351 begin
352 glDeleteTextures(1, @e_Frame);
353 e_Frame := 0;
354 end;
355
356 if e_RBO > 0 then
357 begin
358 glDeleteRenderbuffers(1, @e_RBO);
359 e_RBO := 0;
360 end;
361
362 if e_FBO > 0 then
363 begin
364 glDeleteFramebuffers(1, @e_FBO);
365 e_FBO := 0;
366 end;
367 end;
368
369 function e_ResizeFramebuffer(Width, Height: Integer): Boolean;
370 begin
371 Result := False;
372
373 if e_NoGraphics then Exit;
374
375 DestroyFramebuffer;
376
377 glGetError();
378
379 glGenFramebuffers(1, @e_FBO);
380
381 if glGetError() <> GL_NO_ERROR then
382 begin
383 e_LogWriteln('GL: glGenFramebuffers failed');
384 Exit;
385 end;
386
387 glGenTextures(1, @e_Frame);
388 glBindTexture(GL_TEXTURE_2D, e_Frame);
389 glTexImage2D(GL_TEXTURE_2D, 0, GL_RGB, Width, Height, 0, GL_RGB, GL_UNSIGNED_BYTE, nil);
390 glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
391 glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);
392
393 if glGetError() <> GL_NO_ERROR then
394 begin
395 e_LogWriteln('GL: can''t create FBO color buffer');
396 DestroyFramebuffer;
397 Exit;
398 end;
399
400 glBindFramebuffer(GL_FRAMEBUFFER, e_FBO);
401 glFramebufferTexture2D(GL_FRAMEBUFFER, GL_COLOR_ATTACHMENT0, GL_TEXTURE_2D, e_Frame, 0);
402 if glCheckFramebufferStatus(GL_FRAMEBUFFER) <> GL_FRAMEBUFFER_COMPLETE then
403 begin
404 e_LogWriteln('GL: can''t construct framebuffer with color attachment');
405 DestroyFramebuffer;
406 Exit;
407 end;
408
409 {$IFNDEF USE_GLES1}
410 if e_RBOSupported then
411 begin
412 glGenRenderbuffers(1, @e_RBO);
413 glBindRenderbuffer(GL_RENDERBUFFER, e_RBO);
414 glRenderbufferStorage(GL_RENDERBUFFER, GL_DEPTH24_STENCIL8, Width, Height);
415 glFramebufferRenderbuffer(GL_FRAMEBUFFER, GL_DEPTH_STENCIL_ATTACHMENT, GL_RENDERBUFFER, e_RBO);
416 if glCheckFramebufferStatus(GL_FRAMEBUFFER) <> GL_FRAMEBUFFER_COMPLETE then
417 begin
418 e_LogWriteln('GL: can''t construct framebuffer with depth+stencil attachment, trying without');
419 e_RBOSupported := False;
420 Result := e_ResizeFramebuffer(Width, Height);
421 Exit;
422 end;
423 end;
424 {$ENDIF}
425
426 Result := True;
427 end;
428
429 procedure e_ResizeWindow(Width, Height: Integer);
430 begin
431 if Height = 0 then
432 Height := 1;
433 e_SetViewPort(0, 0, Width, Height);
434 end;
435
436 procedure drawTxQuad (x0, y0, w, h, tw, th: Integer; u, v: single; Mirror: TMirrorType);
437 var
438 x1, y1, tmp: Integer;
439 begin
440 if (w < 1) or (h < 1) then exit;
441 x1 := x0+w;
442 y1 := y0+h;
443 if Mirror = TMirrorType.Horizontal then begin tmp := x1; x1 := x0; x0 := tmp; end
444 else if Mirror = TMirrorType.Vertical then begin tmp := y1; y1 := y0; y0 := tmp; end;
445 glTexCoord2f(0, v); glVertex2i(x0, y0);
446 glTexCoord2f(0, 0); glVertex2i(x0, y1);
447 glTexCoord2f(u, 0); glVertex2i(x1, y1);
448 glTexCoord2f(u, v); glVertex2i(x1, y0);
449 end;
450
451 procedure e_SetRenderTarget(Framebuffer: Boolean);
452 begin
453 if (e_FBO = 0) or e_NoGraphics then exit;
454 if Framebuffer then
455 glBindFramebuffer(GL_FRAMEBUFFER, e_FBO)
456 else
457 glBindFramebuffer(GL_FRAMEBUFFER, 0);
458 end;
459
460 procedure e_BlitFramebuffer(WinWidth, WinHeight: Integer);
461 begin
462 if (e_FBO = 0) or (e_Frame = 0) or e_NoGraphics then exit;
463
464 glDisable(GL_BLEND);
465 glEnable(GL_TEXTURE_2D);
466 glBindTexture(GL_TEXTURE_2D, e_Frame);
467 glColor4ub(255, 255, 255, 255);
468
469 glBegin(GL_QUADS);
470 glTexCoord2f(0, 1); glVertex2i( 0, 0);
471 glTexCoord2f(0, 0); glVertex2i( 0, WinHeight);
472 glTexCoord2f(1, 0); glVertex2i(WinWidth, WinHeight);
473 glTexCoord2f(1, 1); glVertex2i(WinWidth, 0);
474 glEnd();
475 end;
476
477 procedure e_Draw(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
478 Blending: Boolean; Mirror: TMirrorType = TMirrorType.None);
479 begin
480 if e_NoGraphics then Exit;
481 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
482
483 if (Alpha > 0) or (AlphaChannel) or (Blending) then
484 glEnable(GL_BLEND)
485 else
486 glDisable(GL_BLEND);
487
488 if (AlphaChannel) or (Alpha > 0) then
489 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
490
491 if Alpha > 0 then
492 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255-Alpha);
493
494 if Blending then
495 glBlendFunc(GL_SRC_ALPHA, GL_ONE);
496
497 glEnable(GL_TEXTURE_2D);
498 glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id);
499 glBegin(GL_QUADS);
500
501 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);
502
503 //u := e_Textures[ID].tx.u;
504 //v := e_Textures[ID].tx.v;
505
506 {
507 if Mirror = M_NONE then
508 begin
509 glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].tx.Width, Y);
510 glTexCoord2f(0, 0); glVertex2i(X, Y);
511 glTexCoord2f(0, -v); glVertex2i(X, Y + e_Textures[id].tx.Height);
512 glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].tx.Width, Y + e_Textures[id].tx.Height);
513 end
514 else
515 if Mirror = M_HORIZONTAL then
516 begin
517 glTexCoord2f(u, 0); glVertex2i(X, Y);
518 glTexCoord2f(0, 0); glVertex2i(X + e_Textures[id].tx.Width, Y);
519 glTexCoord2f(0, -v); glVertex2i(X + e_Textures[id].tx.Width, Y + e_Textures[id].tx.Height);
520 glTexCoord2f(u, -v); glVertex2i(X, Y + e_Textures[id].tx.Height);
521 end
522 else
523 if Mirror = M_VERTICAL then
524 begin
525 glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].tx.Width, Y);
526 glTexCoord2f(0, -v); glVertex2i(X, Y);
527 glTexCoord2f(0, 0); glVertex2i(X, Y + e_Textures[id].tx.Height);
528 glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].tx.Width, Y + e_Textures[id].tx.Height);
529 end;
530 }
531
532 glEnd();
533
534 glDisable(GL_BLEND);
535 end;
536
537 procedure e_DrawSize(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
538 Blending: Boolean; Width, Height: Word; Mirror: TMirrorType = TMirrorType.None);
539 var
540 u, v: Single;
541 begin
542 if e_NoGraphics then Exit;
543 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
544
545 if (Alpha > 0) or (AlphaChannel) or (Blending) then
546 glEnable(GL_BLEND)
547 else
548 glDisable(GL_BLEND);
549
550 if (AlphaChannel) or (Alpha > 0) then
551 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
552
553 if Alpha > 0 then
554 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255-Alpha);
555
556 if Blending then
557 glBlendFunc(GL_SRC_ALPHA, GL_ONE);
558
559 glEnable(GL_TEXTURE_2D);
560 glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id);
561
562 u := e_Textures[ID].tx.u;
563 v := e_Textures[ID].tx.v;
564
565 glBegin(GL_QUADS);
566 glTexCoord2f(0, v); glVertex2i(X, Y);
567 glTexCoord2f(u, v); glVertex2i(X + Width, Y);
568 glTexCoord2f(u, 0); glVertex2i(X + Width, Y + Height);
569 glTexCoord2f(0, 0); glVertex2i(X, Y + Height);
570 glEnd();
571
572 glDisable(GL_BLEND);
573 end;
574
575 procedure e_DrawSizeMirror(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
576 Blending: Boolean; Width, Height: Word; Mirror: TMirrorType = TMirrorType.None);
577 begin
578 if e_NoGraphics then Exit;
579 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
580
581 if (Alpha > 0) or (AlphaChannel) or (Blending) then
582 glEnable(GL_BLEND)
583 else
584 glDisable(GL_BLEND);
585
586 if (AlphaChannel) or (Alpha > 0) then
587 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
588
589 if Alpha > 0 then
590 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255-Alpha);
591
592 if Blending then
593 glBlendFunc(GL_SRC_ALPHA, GL_ONE);
594
595 glEnable(GL_TEXTURE_2D);
596 glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id);
597 glBegin(GL_QUADS);
598 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);
599 glEnd();
600
601 glDisable(GL_BLEND);
602 end;
603
604 procedure e_DrawFill(ID: DWORD; X, Y: Integer; XCount, YCount: Word; Alpha: Integer;
605 AlphaChannel: Boolean; Blending: Boolean; ambientBlendMode: Boolean=false);
606 var
607 X2, Y2, dx, w, h: Integer;
608 u, v: Single;
609 begin
610 if e_NoGraphics then Exit;
611 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
612 ambientBlendMode := false;
613
614 if (Alpha > 0) or AlphaChannel or Blending then
615 begin
616 glEnable(GL_BLEND);
617 end
618 else
619 begin
620 if not ambientBlendMode then glDisable(GL_BLEND);
621 end;
622 if AlphaChannel or (Alpha > 0) then glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
623 if (Alpha > 0) then glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255-Alpha);
624 if Blending then glBlendFunc(GL_SRC_ALPHA, GL_ONE);
625
626 if (XCount = 0) then XCount := 1;
627 if (YCount = 0) then YCount := 1;
628
629 glEnable(GL_TEXTURE_2D);
630 glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id);
631
632 X2 := X+e_Textures[ID].tx.width*XCount;
633 Y2 := Y+e_Textures[ID].tx.height*YCount;
634
635 //k8: this SHOULD work... i hope
636 if (e_Textures[ID].tx.width = e_Textures[ID].tx.glwidth) and (e_Textures[ID].tx.height = e_Textures[ID].tx.glheight) then
637 begin
638 glBegin(GL_QUADS);
639 glTexCoord2i(0, YCount); glVertex2i(X, Y);
640 glTexCoord2i(XCount, YCount); glVertex2i(X2, Y);
641 glTexCoord2i(XCount, 0); glVertex2i(X2, Y2);
642 glTexCoord2i(0, 0); glVertex2i(X, Y2);
643 glEnd();
644 end
645 else
646 begin
647 glBegin(GL_QUADS);
648 // hard day's night
649 u := e_Textures[ID].tx.u;
650 v := e_Textures[ID].tx.v;
651 w := e_Textures[ID].tx.width;
652 h := e_Textures[ID].tx.height;
653 while YCount > 0 do
654 begin
655 dx := XCount;
656 x2 := X;
657 while dx > 0 do
658 begin
659 glTexCoord2f(0, v); glVertex2i(X, Y);
660 glTexCoord2f(u, v); glVertex2i(X+w, Y);
661 glTexCoord2f(u, 0); glVertex2i(X+w, Y+h);
662 glTexCoord2f(0, 0); glVertex2i(X, Y+h);
663 Inc(X, w);
664 Dec(dx);
665 end;
666 X := x2;
667 Inc(Y, h);
668 Dec(YCount);
669 end;
670 glEnd();
671 end;
672
673 glDisable(GL_BLEND);
674 end;
675
676
677 //TODO: overflow checks
678 function intersectRect (var x0, y0, w0, h0: Integer; const x1, y1, w1, h1: Integer): Boolean;
679 var
680 ex0, ey0: Integer;
681 begin
682 result := false;
683 if (w0 < 1) or (h0 < 1) or (w1 < 1) or (h1 < 1) then exit;
684 // check for intersection
685 if (x0+w0 <= x1) or (y0+h0 <= y1) or (x1+w1 <= x0) or (y1+h1 <= y0) then exit;
686 if (x0 >= x1+w1) or (y0 >= y1+h1) or (x1 >= x0+h0) or (y1 >= y0+h0) then exit;
687 // ok, intersects
688 ex0 := x0+w0;
689 ey0 := y0+h0;
690 if (x0 < x1) then x0 := x1;
691 if (y0 < y1) then y0 := y1;
692 if (ex0 > x1+w1) then ex0 := x1+w1;
693 if (ey0 > y1+h1) then ey0 := y1+h1;
694 w0 := ex0-x0;
695 h0 := ey0-y0;
696 result := (w0 > 0) and (h0 > 0);
697 end;
698
699
700 procedure e_DrawFillX (id: DWORD; x, y, wdt, hgt: Integer; alpha: Integer; alphachannel: Boolean;
701 blending: Boolean; scale: Single; ambientBlendMode: Boolean=false);
702 var
703 x2, y2: Integer;
704 {
705 wassc: Boolean;
706 scxywh: array[0..3] of GLint;
707 vpxywh: array[0..3] of GLint;
708 }
709 w, h, dw, cw, ch, yofs: Integer;
710 u, v, cu, cv: Single;
711 onlyOneY: Boolean;
712
713 {
714 procedure setScissorGLInternal (x, y, w, h: Integer);
715 begin
716 //if not scallowed then exit;
717 x := trunc(x*scale);
718 y := trunc(y*scale);
719 w := trunc(w*scale);
720 h := trunc(h*scale);
721 y := vpxywh[3]-(y+h);
722 if not intersectRect(x, y, w, h, scxywh[0], scxywh[1], scxywh[2], scxywh[3]) then
723 begin
724 glScissor(0, 0, 0, 0);
725 end
726 else
727 begin
728 //writeln(' (', x, ',', y, ')-(', w, ',', h, ')');
729 glScissor(x, y, w, h);
730 end;
731 end;
732 }
733
734 begin
735 if e_NoGraphics then exit;
736 ambientBlendMode := false;
737
738 if (wdt < 1) or (hgt < 1) then exit;
739
740 if (wdt mod e_Textures[ID].tx.width = 0) and (hgt mod e_Textures[ID].tx.height = 0) then
741 begin
742 e_DrawFill(id, x, y, wdt div e_Textures[ID].tx.width, hgt div e_Textures[ID].tx.height, alpha, alphachannel, blending, ambientBlendMode);
743 exit;
744 end;
745
746 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
747
748 if (Alpha > 0) or AlphaChannel or Blending then
749 begin
750 glEnable(GL_BLEND);
751 end
752 else
753 begin
754 if not ambientBlendMode then glDisable(GL_BLEND);
755 end;
756 if AlphaChannel or (Alpha > 0) then glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
757 if (Alpha > 0) then glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255-Alpha);
758 if Blending then glBlendFunc(GL_SRC_ALPHA, GL_ONE);
759
760 glEnable(GL_TEXTURE_2D);
761 glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id);
762
763 x2 := x+wdt;
764 y2 := y+hgt;
765
766 //k8: this SHOULD work... i hope
767 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
768 begin
769 glBegin(GL_QUADS);
770 glTexCoord2f(0, hgt/e_Textures[ID].tx.height); glVertex2i(x, y);
771 glTexCoord2f(wdt/e_Textures[ID].tx.width, hgt/e_Textures[ID].tx.height); glVertex2i(x2, y);
772 glTexCoord2f(wdt/e_Textures[ID].tx.width, 0); glVertex2i(x2, y2);
773 glTexCoord2f(0, 0); glVertex2i(x, y2);
774 glEnd();
775 end
776 else
777 begin
778 // hard day's night; setup scissor
779 {
780 glGetIntegerv(GL_VIEWPORT, @vpxywh[0]);
781 wassc := (glIsEnabled(GL_SCISSOR_TEST) <> 0);
782 if wassc then glGetIntegerv(GL_SCISSOR_BOX, @scxywh[0]) else glGetIntegerv(GL_VIEWPORT, @scxywh[0]);
783 //writeln('(', scxywh[0], ',', scxywh[1], ')-(', scxywh[2], ',', scxywh[3], ')');
784 //glEnable(GL_SCISSOR_TEST);
785 setScissorGLInternal(x, y, wdt, hgt);
786 }
787 // draw quads
788 u := e_Textures[ID].tx.u;
789 v := e_Textures[ID].tx.v;
790 w := e_Textures[ID].tx.width;
791 h := e_Textures[ID].tx.height;
792 x2 := x;
793 if (hgt > h) then begin y += hgt-h; onlyOneY := false; end else onlyOneY := true;
794 glBegin(GL_QUADS);
795 while (hgt > 0) do
796 begin
797 if (hgt >= h) then begin ch := h; cv := v; yofs := 0; end else begin ch := hgt; cv := v/(h/hgt); yofs := h-hgt; end;
798 if onlyOneY then yofs := 0;
799 Dec(hgt, h);
800 dw := wdt;
801 x := x2;
802 while (dw > 0) do
803 begin
804 if (dw >= w) then begin cw := w; cu := u; end else begin cw := dw; cu := u/(w/dw); end;
805 Dec(dw, w);
806 glTexCoord2f(0, cv); glVertex2i(X, Y+yofs);
807 glTexCoord2f(cu, cv); glVertex2i(X+cw, Y+yofs);
808 glTexCoord2f(cu, 0); glVertex2i(X+cw, Y+ch+yofs);
809 glTexCoord2f(0, 0); glVertex2i(X, Y+ch+yofs);
810 Inc(X, w);
811 end;
812 Dec(Y, h);
813 end;
814 glEnd();
815 //if wassc then glEnable(GL_SCISSOR_TEST) else glDisable(GL_SCISSOR_TEST);
816 end;
817
818 glDisable(GL_BLEND);
819 end;
820
821
822 procedure e_AmbientQuad (x, y, w, h: Integer; r, g, b, a: Byte);
823 begin
824 if e_NoGraphics then exit;
825 if (w < 1) or (h < 1) then exit;
826 if (a <> 255) or ((r or g or b) <> 0) then
827 begin
828 glEnable(GL_BLEND);
829 glDisable(GL_TEXTURE_2D);
830 glColor4ub(r, g, b, a);
831 if ((r or g or b) <> 0) then
832 begin
833 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
834 glBegin(GL_QUADS);
835 glVertex2i(x, y);
836 glVertex2i(x+w, y);
837 glVertex2i(x+w, y+h);
838 glVertex2i(x, y+h);
839 glEnd();
840 end;
841 glBlendFunc(GL_ZERO, GL_SRC_ALPHA);
842 glBegin(GL_QUADS);
843 glVertex2i(x, y);
844 glVertex2i(x+w, y);
845 glVertex2i(x+w, y+h);
846 glVertex2i(x, y+h);
847 glEnd();
848 glDisable(GL_BLEND);
849 end;
850 end;
851
852
853 procedure e_DrawAdv(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean;
854 Blending: Boolean; Angle: Single; RC: PDFPoint; Mirror: TMirrorType = TMirrorType.None);
855 begin
856 if e_NoGraphics then Exit;
857
858 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
859
860 if (Alpha > 0) or (AlphaChannel) or (Blending) then
861 glEnable(GL_BLEND)
862 else
863 glDisable(GL_BLEND);
864
865 if (AlphaChannel) or (Alpha > 0) then
866 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
867
868 if Alpha > 0 then
869 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255-Alpha);
870
871 if Blending then
872 glBlendFunc(GL_SRC_ALPHA, GL_ONE);
873
874 if (Angle <> 0) and (RC <> nil) then
875 begin
876 glPushMatrix();
877 glTranslatef(X+RC.X, Y+RC.Y, 0);
878 glRotatef(Angle, 0, 0, 1);
879 glTranslatef(-(X+RC.X), -(Y+RC.Y), 0);
880 end;
881
882 glEnable(GL_TEXTURE_2D);
883 glBindTexture(GL_TEXTURE_2D, e_Textures[id].tx.id);
884 glBegin(GL_QUADS); //0-1 1-1
885 //00 10
886 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);
887 glEnd();
888
889 if Angle <> 0 then
890 glPopMatrix();
891
892 glDisable(GL_BLEND);
893 end;
894
895 procedure e_DrawPoint(Size: Byte; X, Y: Integer; Red, Green, Blue: Byte);
896 begin
897 if e_NoGraphics then Exit;
898 glDisable(GL_TEXTURE_2D);
899 glColor3ub(Red, Green, Blue);
900 glPointSize(Size);
901
902 if (Size = 2) or (Size = 4) then
903 X := X + 1;
904
905 glBegin(GL_POINTS);
906 glVertex2f(X+0.3, Y+1.0);
907 glEnd();
908
909 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
910 end;
911
912 procedure e_LineCorrection(var X1, Y1, X2, Y2: Integer);
913 begin
914 // Make lines only top-left/bottom-right and top-right/bottom-left
915 if Y2 < Y1 then
916 begin
917 X1 := X1 xor X2;
918 X2 := X1 xor X2;
919 X1 := X1 xor X2;
920
921 Y1 := Y1 xor Y2;
922 Y2 := Y1 xor Y2;
923 Y1 := Y1 xor Y2;
924 end;
925
926 // Pixel-perfect hack
927 if X1 < X2 then
928 Inc(X2)
929 else
930 Inc(X1);
931 Inc(Y2);
932 end;
933
934 procedure e_DrawQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue: Byte; Alpha: Byte = 0);
935 var
936 nX1, nY1, nX2, nY2: Integer;
937 begin
938 if e_NoGraphics then Exit;
939 // Only top-left/bottom-right quad
940 if X1 > X2 then
941 begin
942 X1 := X1 xor X2;
943 X2 := X1 xor X2;
944 X1 := X1 xor X2;
945 end;
946 if Y1 > Y2 then
947 begin
948 Y1 := Y1 xor Y2;
949 Y2 := Y1 xor Y2;
950 Y1 := Y1 xor Y2;
951 end;
952
953 if Alpha > 0 then
954 begin
955 glEnable(GL_BLEND);
956 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
957 end
958 else
959 glDisable(GL_BLEND);
960
961 glDisable(GL_TEXTURE_2D);
962 glColor4ub(Red, Green, Blue, 255-Alpha);
963 glLineWidth(1);
964 glBegin(GL_LINES);
965 nX1 := X1; nY1 := Y1;
966 nX2 := X2; nY2 := Y1;
967 e_LineCorrection(nX1, nY1, nX2, nY2); // Pixel-perfect lines
968 glVertex2i(nX1, nY1);
969 glVertex2i(nX2, nY2);
970
971 nX1 := X2; nY1 := Y1;
972 nX2 := X2; nY2 := Y2;
973 e_LineCorrection(nX1, nY1, nX2, nY2);
974 glVertex2i(nX1, nY1);
975 glVertex2i(nX2, nY2);
976
977 nX1 := X2; nY1 := Y2;
978 nX2 := X1; nY2 := Y2;
979 e_LineCorrection(nX1, nY1, nX2, nY2);
980 glVertex2i(nX1, nY1);
981 glVertex2i(nX2, nY2);
982
983 nX1 := X1; nY1 := Y2;
984 nX2 := X1; nY2 := Y1;
985 e_LineCorrection(nX1, nY1, nX2, nY2);
986 glVertex2i(nX1, nY1);
987 glVertex2i(nX2, nY2);
988 glEnd();
989 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
990 glDisable(GL_BLEND);
991 end;
992
993 procedure e_DrawFillQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue, Alpha: Byte;
994 Blending: TBlending = TBlending.None);
995 begin
996 if e_NoGraphics then Exit;
997 if (Alpha > 0) or (Blending <> TBlending.None) then
998 glEnable(GL_BLEND)
999 else
1000 glDisable(GL_BLEND);
1001
1002 case Blending of
1003 TBlending.None: if Alpha > 0 then glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
1004 TBlending.Blend: glBlendFunc(GL_SRC_ALPHA, GL_ONE);
1005 TBlending.Invert: glBlendFunc(GL_ONE_MINUS_DST_COLOR, GL_ZERO);
1006 TBlending.Filter: glBlendFunc(GL_ZERO, GL_SRC_COLOR);
1007 end;
1008
1009 glDisable(GL_TEXTURE_2D);
1010 glColor4ub(Red, Green, Blue, 255-Alpha);
1011
1012 X2 := X2 + 1;
1013 Y2 := Y2 + 1;
1014
1015 glBegin(GL_QUADS);
1016 glVertex2i(X1, Y1);
1017 glVertex2i(X2, Y1);
1018 glVertex2i(X2, Y2);
1019 glVertex2i(X1, Y2);
1020 glEnd();
1021
1022 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
1023 glDisable(GL_BLEND);
1024 end;
1025
1026
1027 // ////////////////////////////////////////////////////////////////////////// //
1028 procedure e_DarkenQuad (x0, y0, x1, y1: Integer; a: Integer);
1029 begin
1030 if (a < 0) then a := 0;
1031 if (a > 255) then a := 255;
1032 glEnable(GL_BLEND);
1033 glBlendFunc(GL_ZERO, GL_SRC_ALPHA);
1034 glDisable(GL_TEXTURE_2D);
1035 glColor4ub(0, 0, 0, Byte(255-a));
1036 glBegin(GL_QUADS);
1037 glVertex2i(x0, y0);
1038 glVertex2i(x1, y0);
1039 glVertex2i(x1, y1);
1040 glVertex2i(x0, y1);
1041 glEnd();
1042 //glRect(x, y, x+w, y+h);
1043 glColor4ub(1, 1, 1, 1);
1044 glDisable(GL_BLEND);
1045 //glBlendEquation(GL_FUNC_ADD);
1046 end;
1047
1048 procedure e_DarkenQuadWH (x, y, w, h: Integer; a: Integer);
1049 begin
1050 if (w > 0) and (h > 0) then e_DarkenQuad(x, y, x+w, y+h, a);
1051 end;
1052
1053
1054 procedure e_DrawLine(Width: Byte; X1, Y1, X2, Y2: Integer; Red, Green, Blue: Byte; Alpha: Byte = 0);
1055 begin
1056 if e_NoGraphics then Exit;
1057 // Pixel-perfect lines
1058 if Width = 1 then
1059 e_LineCorrection(X1, Y1, X2, Y2);
1060
1061 if Alpha > 0 then
1062 begin
1063 glEnable(GL_BLEND);
1064 glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
1065 end else
1066 glDisable(GL_BLEND);
1067
1068 glDisable(GL_TEXTURE_2D);
1069 glColor4ub(Red, Green, Blue, 255-Alpha);
1070 glLineWidth(Width);
1071 glBegin(GL_LINES);
1072 glVertex2i(X1, Y1);
1073 glVertex2i(X2, Y2);
1074 glEnd();
1075 glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255);
1076
1077 glDisable(GL_BLEND);
1078 end;
1079
1080 //------------------------------------------------------------------
1081 // Удаляет текстуру из массива
1082 //------------------------------------------------------------------
1083 procedure e_DeleteTexture(ID: DWORD);
1084 begin
1085 if not e_NoGraphics then
1086 glDeleteTextures(1, @e_Textures[ID].tx.id);
1087 e_Textures[ID].tx.id := 0;
1088 e_Textures[ID].tx.Width := 0;
1089 e_Textures[ID].tx.Height := 0;
1090 end;
1091
1092 //------------------------------------------------------------------
1093 // Удаляет все текстуры
1094 //------------------------------------------------------------------
1095 procedure e_RemoveAllTextures();
1096 var
1097 i: integer;
1098 begin
1099 if e_Textures = nil then Exit;
1100
1101 for i := 0 to High(e_Textures) do
1102 if e_Textures[i].tx.Width <> 0 then e_DeleteTexture(i);
1103 e_Textures := nil;
1104 end;
1105
1106 //------------------------------------------------------------------
1107 // Удаляет движок
1108 //------------------------------------------------------------------
1109 procedure e_ReleaseEngine();
1110 begin
1111 e_RemoveAllTextures;
1112 e_RemoveAllTextureFont;
1113 end;
1114
1115 procedure e_BeginRender();
1116 begin
1117 if e_NoGraphics then Exit;
1118 glEnable(GL_ALPHA_TEST);
1119 glAlphaFunc(GL_GREATER, 0.0);
1120 end;
1121
1122 procedure e_Clear(Mask: TGLbitfield; Red, Green, Blue: Single); overload;
1123 begin
1124 if e_NoGraphics then Exit;
1125 glClearColor(Red, Green, Blue, 0);
1126 glClear(Mask);
1127 end;
1128
1129 procedure e_Clear(Red, Green, Blue: Single); overload;
1130 begin
1131 if e_NoGraphics then Exit;
1132 glClearColor(Red, Green, Blue, 0);
1133 glClear(GL_COLOR_BUFFER_BIT);
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 procedure e_MakeScreenshot (st: TStream; Width, Height: Word);
1903 var
1904 pixels, obuf, scln, ps, pd: PByte;
1905 obufsize: Integer;
1906 dlen: Cardinal;
1907 i, x, y, res: Integer;
1908 sign: array [0..7] of Byte;
1909 hbuf: array [0..12] of Byte;
1910 crc: LongWord;
1911 img: TImageData;
1912 clr: TColor32Rec;
1913 begin
1914 if e_NoGraphics then Exit;
1915 obuf := nil;
1916
1917 // first, extract and pack graphics data
1918 if (Width mod 4) > 0 then Width := Width+4-(Width mod 4);
1919
1920 GetMem(pixels, Width*Height*3);
1921 try
1922 FillChar(pixels^, Width*Height*3, 0);
1923 glReadPixels(0, 0, Width, Height, GL_RGB, GL_UNSIGNED_BYTE, pixels);
1924 //e_WriteLog('PNG: pixels read', MSG_NOTIFY);
1925
1926 if e_FastScreenshots then
1927 begin
1928 // create scanlines
1929 GetMem(scln, (Width*3+1)*Height);
1930 try
1931 ps := pixels;
1932 pd := scln;
1933 Inc(ps, (Width*3)*(Height-1));
1934 for i := 0 to Height-1 do
1935 begin
1936 pd^ := 0; // filter
1937 Inc(pd);
1938 Move(ps^, pd^, Width*3);
1939 Dec(ps, Width*3);
1940 Inc(pd, Width*3);
1941 end;
1942 except
1943 FreeMem(scln);
1944 raise;
1945 end;
1946 FreeMem(pixels);
1947 pixels := scln;
1948
1949 // pack it
1950 obufsize := (Width*3+1)*Height*2;
1951 GetMem(obuf, obufsize);
1952 try
1953 while true do
1954 begin
1955 dlen := obufsize;
1956 res := compress2(Pointer(obuf), dlen, Pointer(pixels), (Width*3+1)*Height, 9);
1957 if res = Z_OK then break;
1958 if res <> Z_BUF_ERROR then raise Exception.Create('can''t pack data for PNG');
1959 obufsize := obufsize*2;
1960 FreeMem(obuf);
1961 obuf := nil;
1962 GetMem(obuf, obufsize);
1963 end;
1964 //e_WriteLog(Format('PNG: pixels compressed from %d to %d', [Integer(Width*Height*3), Integer(dlen)]), MSG_NOTIFY);
1965
1966 // now write PNG
1967
1968 // signature
1969 sign[0] := 137;
1970 sign[1] := 80;
1971 sign[2] := 78;
1972 sign[3] := 71;
1973 sign[4] := 13;
1974 sign[5] := 10;
1975 sign[6] := 26;
1976 sign[7] := 10;
1977 st.writeBuffer(sign, 8);
1978 //e_WriteLog('PNG: signature written', MSG_NOTIFY);
1979
1980 // header
1981 writeIntBE(st, LongWord(13));
1982 sign[0] := 73;
1983 sign[1] := 72;
1984 sign[2] := 68;
1985 sign[3] := 82;
1986 st.writeBuffer(sign, 4);
1987 crc := crc32(0, @sign[0], 4);
1988 hbuf[0] := 0;
1989 hbuf[1] := 0;
1990 hbuf[2] := (Width shr 8) and $ff;
1991 hbuf[3] := Width and $ff;
1992 hbuf[4] := 0;
1993 hbuf[5] := 0;
1994 hbuf[6] := (Height shr 8) and $ff;
1995 hbuf[7] := Height and $ff;
1996 hbuf[8] := 8; // bit depth
1997 hbuf[9] := 2; // RGB
1998 hbuf[10] := 0; // compression method
1999 hbuf[11] := 0; // filter method
2000 hbuf[12] := 0; // no interlace
2001 crc := crc32(crc, @hbuf[0], 13);
2002 st.writeBuffer(hbuf, 13);
2003 writeIntBE(st, crc);
2004 //e_WriteLog('PNG: header written', MSG_NOTIFY);
2005
2006 // image data
2007 writeIntBE(st, LongWord(dlen));
2008 sign[0] := 73;
2009 sign[1] := 68;
2010 sign[2] := 65;
2011 sign[3] := 84;
2012 st.writeBuffer(sign, 4);
2013 crc := crc32(0, @sign[0], 4);
2014 crc := crc32(crc, obuf, dlen);
2015 st.writeBuffer(obuf^, dlen);
2016 writeIntBE(st, crc);
2017 //e_WriteLog('PNG: image data written', MSG_NOTIFY);
2018
2019 // image data end
2020 writeIntBE(st, LongWord(0));
2021 sign[0] := 73;
2022 sign[1] := 69;
2023 sign[2] := 78;
2024 sign[3] := 68;
2025 st.writeBuffer(sign, 4);
2026 crc := crc32(0, @sign[0], 4);
2027 writeIntBE(st, crc);
2028 //e_WriteLog('PNG: end marker written', MSG_NOTIFY);
2029 finally
2030 if obuf <> nil then FreeMem(obuf);
2031 end;
2032 end
2033 else
2034 begin
2035 Imaging.SetOption(ImagingPNGCompressLevel, 9);
2036 Imaging.SetOption(ImagingPNGPreFilter, 6);
2037 InitImage(img);
2038 try
2039 NewImage(Width, Height, TImageFormat.ifR8G8B8, img);
2040 ps := pixels;
2041 //writeln(stderr, 'moving pixels...');
2042 for y := Height-1 downto 0 do
2043 begin
2044 for x := 0 to Width-1 do
2045 begin
2046 clr.r := ps^; Inc(ps);
2047 clr.g := ps^; Inc(ps);
2048 clr.b := ps^; Inc(ps);
2049 clr.a := 255;
2050 SetPixel32(img, x, y, clr);
2051 end;
2052 end;
2053 GlobalMetadata.ClearMetaItems();
2054 GlobalMetadata.ClearMetaItemsForSaving();
2055 //writeln(stderr, 'compressing image...');
2056 if not SaveImageToStream('png', st, img) then raise Exception.Create('screenshot writing error');
2057 //writeln(stderr, 'done!');
2058 finally
2059 FreeImage(img);
2060 end;
2061 end;
2062 finally
2063 FreeMem(pixels);
2064 end;
2065 end;
2066
2067
2068 end.
[MIRROR] a port of Doom 2D Forever to FPC/SDL
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024