DEADSOFTWARE

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


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