DEADSOFTWARE

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