DEADSOFTWARE

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