DEADSOFTWARE

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