DEADSOFTWARE

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


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