1 (* Copyright (C) DooM 2D:Forever Developers
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.
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.
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/>.
22 SysUtils
, Classes
, Math
, e_log
, e_textures
, SDL2
, GL
, GLExt
, MAPDEF
, ImagingTypes
, Imaging
, ImagingUtility
;
25 TMirrorType
=(M_NONE
, M_HORIZONTAL
, M_VERTICAL
);
26 TBlending
=(B_NONE
, B_BLEND
, B_FILTER
, B_INVERT
);
32 TPoint
= MAPDEF
.TPoint
; // TODO: create an utiltypes.pas or something
33 // for other types like rect as well
40 Left
, Top
, Right
, Bottom
: Integer;
58 //------------------------------------------------------------------
60 //------------------------------------------------------------------
62 procedure e_SetViewPort(X
, Y
, Width
, Height
: Word);
63 procedure e_ResizeWindow(Width
, Height
: Integer);
65 procedure e_Draw(ID
: DWORD
; X
, Y
: Integer; Alpha
: Byte; AlphaChannel
: Boolean;
66 Blending
: Boolean; Mirror
: TMirrorType
= M_NONE
);
67 procedure e_DrawAdv(ID
: DWORD
; X
, Y
: Integer; Alpha
: Byte; AlphaChannel
: Boolean;
68 Blending
: Boolean; Angle
: Single; RC
: PPoint
; Mirror
: TMirrorType
= M_NONE
);
69 procedure e_DrawSize(ID
: DWORD
; X
, Y
: Integer; Alpha
: Byte; AlphaChannel
: Boolean;
70 Blending
: Boolean; Width
, Height
: Word; Mirror
: TMirrorType
= M_NONE
);
71 procedure e_DrawSizeMirror(ID
: DWORD
; X
, Y
: Integer; Alpha
: Byte; AlphaChannel
: Boolean;
72 Blending
: Boolean; Width
, Height
: Word; Mirror
: TMirrorType
= M_NONE
);
73 procedure e_DrawFill(ID
: DWORD
; X
, Y
: Integer; XCount
, YCount
: Word; Alpha
: Integer;
74 AlphaChannel
: Boolean; Blending
: Boolean);
75 procedure e_DrawPoint(Size
: Byte; X
, Y
: Integer; Red
, Green
, Blue
: Byte);
76 procedure e_DrawLine(Width
: Byte; X1
, Y1
, X2
, Y2
: Integer; Red
, Green
, Blue
: Byte; Alpha
: Byte = 0);
77 procedure e_DrawQuad(X1
, Y1
, X2
, Y2
: Integer; Red
, Green
, Blue
: Byte; Alpha
: Byte = 0);
78 procedure e_DrawFillQuad(X1
, Y1
, X2
, Y2
: Integer; Red
, Green
, Blue
, Alpha
: Byte;
79 Blending
: TBlending
= B_NONE
);
81 function e_CreateTextureImg (var img
: TImageData
; var ID
: DWORD
): Boolean;
82 function e_CreateTexture(FileName
: string; var ID
: DWORD
): Boolean;
83 function e_CreateTextureEx(FileName
: string; var ID
: DWORD
; fX
, fY
, fWidth
, fHeight
: Word): Boolean;
84 function e_CreateTextureMem(pData
: Pointer; dataSize
: LongInt; var ID
: DWORD
): Boolean;
85 function e_CreateTextureMemEx(pData
: Pointer; dataSize
: LongInt; var ID
: DWORD
; fX
, fY
, fWidth
, fHeight
: Word): Boolean;
86 procedure e_GetTextureSize(ID
: DWORD
; Width
, Height
: PWord);
87 function e_GetTextureSize2(ID
: DWORD
): TRectWH
;
88 procedure e_DeleteTexture(ID
: DWORD
);
89 procedure e_RemoveAllTextures();
92 function e_CharFont_Create(sp
: ShortInt=0): DWORD
;
93 procedure e_CharFont_AddChar(FontID
: DWORD
; Texture
: Integer; c
: Char; w
: Byte);
94 procedure e_CharFont_Print(FontID
: DWORD
; X
, Y
: Integer; Text: string);
95 procedure e_CharFont_PrintEx(FontID
: DWORD
; X
, Y
: Integer; Text: string;
96 Color
: TRGB
; Scale
: Single = 1.0);
97 procedure e_CharFont_PrintFmt(FontID
: DWORD
; X
, Y
: Integer; Text: string);
98 procedure e_CharFont_GetSize(FontID
: DWORD
; Text: string; var w
, h
: Word);
99 procedure e_CharFont_GetSizeFmt(FontID
: DWORD
; Text: string; var w
, h
: Word);
100 function e_CharFont_GetMaxWidth(FontID
: DWORD
): Word;
101 function e_CharFont_GetMaxHeight(FontID
: DWORD
): Word;
102 procedure e_CharFont_Remove(FontID
: DWORD
);
103 procedure e_CharFont_RemoveAll();
106 procedure e_TextureFontBuild(Tex
: DWORD
; var FontID
: DWORD
; XCount
, YCount
: Word;
108 procedure e_TextureFontKill(FontID
: DWORD
);
109 procedure e_TextureFontPrint(X
, Y
: GLint
; Text: string; FontID
: DWORD
);
110 procedure e_TextureFontPrintEx(X
, Y
: GLint
; Text: string; FontID
: DWORD
; Red
, Green
,
111 Blue
: Byte; Scale
: Single; Shadow
: Boolean = False);
112 procedure e_TextureFontPrintFmt(X
, Y
: GLint
; Text: string; FontID
: DWORD
; Shadow
: Boolean = False);
113 procedure e_TextureFontGetSize(ID
: DWORD
; var CharWidth
, CharHeight
: Byte);
114 procedure e_RemoveAllTextureFont();
116 function e_TextureFontCharWidth (ch
: Char; FontID
: DWORD
): Integer;
117 procedure e_TextureFontPrintCharEx (X
, Y
: Integer; Ch
: Char; FontID
: DWORD
; Shadow
: Boolean = False);
119 procedure e_ReleaseEngine();
120 procedure e_BeginRender();
121 procedure e_Clear(Mask
: TGLbitfield
; Red
, Green
, Blue
: Single); overload
;
122 procedure e_Clear(); overload
;
123 procedure e_EndRender();
125 function e_GetGamma(win
: PSDL_Window
): Byte;
126 procedure e_SetGamma(win
: PSDL_Window
;Gamma
: Byte);
128 procedure e_MakeScreenshot(st
: TStream
; Width
, Height
: Word);
130 function _RGB(Red
, Green
, Blue
: Byte): TRGB
;
131 function _Point(X
, Y
: Integer): TPoint2i
;
132 function _Rect(X
, Y
: Integer; Width
, Height
: Word): TRectWH
;
133 function _TRect(L
, T
, R
, B
: LongInt): TRect
;
138 e_NoGraphics
: Boolean = False;
139 e_FastScreenshots
: Boolean = true; // it's REALLY SLOW with `false`
157 TTextureFont
= record
167 Chars
: array[0..255] of
177 TSavedTexture
= record
184 e_Textures
: array of TTexture
= nil;
185 e_TextureFonts
: array of TTextureFont
= nil;
186 e_CharFonts
: array of TCharFont
;
187 //e_SavedTextures: array of TSavedTexture;
189 //------------------------------------------------------------------
190 // Èíèöèàëèçèðóåò OpenGL
191 //------------------------------------------------------------------
192 procedure e_InitGL();
196 e_DummyTextures
:= True;
202 glDisable(GL_DEPTH_TEST
);
203 glEnable(GL_SCISSOR_TEST
);
204 glClearColor(0, 0, 0, 0);
207 procedure e_SetViewPort(X
, Y
, Width
, Height
: Word);
209 mat
: Array [0..15] of GLDouble
;
212 if e_NoGraphics
then Exit
;
214 glScissor(X
, Y
, Width
, Height
);
215 glViewport(X
, Y
, Width
, Height
);
216 //gluOrtho2D(0, Width, Height, 0);
218 glMatrixMode(GL_PROJECTION
);
220 mat
[ 0] := 2.0 / Width
;
226 mat
[ 5] := -2.0 / Height
;
240 glLoadMatrixd(@mat
[0]);
242 glMatrixMode(GL_MODELVIEW
);
246 //------------------------------------------------------------------
247 // Èùåò ñâîáîäíûé ýëåìåíò â ìàññèâå òåêñòóð
248 //------------------------------------------------------------------
249 function FindTexture(): DWORD
;
253 if e_Textures
<> nil then
254 for i
:= 0 to High(e_Textures
) do
255 if e_Textures
[i
].Width
= 0 then
261 if e_Textures
= nil then
263 SetLength(e_Textures
, 32);
268 Result
:= High(e_Textures
) + 1;
269 SetLength(e_Textures
, Length(e_Textures
) + 32);
273 //------------------------------------------------------------------
275 //------------------------------------------------------------------
276 function e_CreateTexture(FileName
: String; var ID
: DWORD
): Boolean;
283 e_WriteLog('Loading texture from '+FileName
, MSG_NOTIFY
);
285 find_id
:= FindTexture();
287 if not LoadTexture(FileName
, e_Textures
[find_id
].tx
, e_Textures
[find_id
].Width
,
288 e_Textures
[find_id
].Height
, @fmt
) then Exit
;
291 e_Textures
[ID
].Fmt
:= fmt
;
296 function e_CreateTextureEx(FileName
: String; var ID
: DWORD
; fX
, fY
, fWidth
, fHeight
: Word): Boolean;
303 find_id
:= FindTexture();
305 if not LoadTextureEx(FileName
, e_Textures
[find_id
].tx
, fX
, fY
, fWidth
, fHeight
, @fmt
) then exit
;
307 e_Textures
[find_id
].Width
:= fWidth
;
308 e_Textures
[find_id
].Height
:= fHeight
;
309 e_Textures
[find_id
].Fmt
:= fmt
;
316 function e_CreateTextureMem(pData
: Pointer; dataSize
: LongInt; var ID
: DWORD
): Boolean;
323 find_id
:= FindTexture
;
325 if not LoadTextureMem(pData
, dataSize
, e_Textures
[find_id
].tx
, e_Textures
[find_id
].Width
, e_Textures
[find_id
].Height
, @fmt
) then exit
;
328 e_Textures
[id
].Fmt
:= fmt
;
333 function e_CreateTextureMemEx(pData
: Pointer; dataSize
: LongInt; var ID
: DWORD
; fX
, fY
, fWidth
, fHeight
: Word): Boolean;
340 find_id
:= FindTexture();
342 if not LoadTextureMemEx(pData
, dataSize
, e_Textures
[find_id
].tx
, fX
, fY
, fWidth
, fHeight
, @fmt
) then exit
;
344 e_Textures
[find_id
].Width
:= fWidth
;
345 e_Textures
[find_id
].Height
:= fHeight
;
346 e_Textures
[find_id
].Fmt
:= fmt
;
353 function e_CreateTextureImg (var img
: TImageData
; var ID
: DWORD
): Boolean;
359 find_id
:= FindTexture();
360 if not LoadTextureImg(img
, e_Textures
[find_id
].tx
, tw
, th
, @fmt
) then exit
;
361 //writeln(' tw=', tw, '; th=', th);
362 e_Textures
[find_id
].Width
:= tw
;
363 e_Textures
[find_id
].Height
:= th
;
364 e_Textures
[find_id
].Fmt
:= fmt
;
369 procedure e_GetTextureSize(ID
: DWORD
; Width
, Height
: PWord);
371 if Width
<> nil then Width
^ := e_Textures
[ID
].Width
;
372 if Height
<> nil then Height
^ := e_Textures
[ID
].Height
;
375 function e_GetTextureSize2(ID
: DWORD
): TRectWH
;
383 w
:= e_Textures
[ID
].Width
;
384 h
:= e_Textures
[ID
].Height
;
391 if e_NoGraphics
then Exit
;
393 data
:= GetMemory(w
*h
*4);
394 glEnable(GL_TEXTURE_2D
);
395 glBindTexture(GL_TEXTURE_2D
, e_Textures
[ID
].tx
.id
);
396 glGetTexImage(GL_TEXTURE_2D
, 0, GL_RGBA
, GL_UNSIGNED_BYTE
, data
);
398 for y
:= h
-1 downto 0 do
405 a
:= Byte((data
+y
*w
*4+x
*4+3)^) <> 0;
411 Result
.Y
:= h
-lastline
;
423 a
:= Byte((data
+y
*w
*4+x
*4+3)^) <> 0;
429 Result
.Height
:= h
-lastline
-Result
.Y
;
441 a
:= Byte((data
+y
*w
*4+x
*4+3)^) <> 0;
447 Result
.X
:= lastline
+1;
452 for x
:= w
-1 downto 0 do
459 a
:= Byte((data
+y
*w
*4+x
*4+3)^) <> 0;
465 Result
.Width
:= lastline
-Result
.X
+1;
473 procedure e_ResizeWindow(Width
, Height
: Integer);
477 e_SetViewPort(0, 0, Width
, Height
);
480 procedure e_Draw(ID
: DWORD
; X
, Y
: Integer; Alpha
: Byte; AlphaChannel
: Boolean;
481 Blending
: Boolean; Mirror
: TMirrorType
= M_NONE
);
485 if e_NoGraphics
then Exit
;
486 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
488 if (Alpha
> 0) or (AlphaChannel
) or (Blending
) then
493 if (AlphaChannel
) or (Alpha
> 0) then
494 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
497 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255-Alpha
);
500 glBlendFunc(GL_SRC_ALPHA
, GL_ONE
);
502 glEnable(GL_TEXTURE_2D
);
503 glBindTexture(GL_TEXTURE_2D
, e_Textures
[ID
].tx
.id
);
506 u
:= e_Textures
[ID
].tx
.u
;
507 v
:= e_Textures
[ID
].tx
.v
;
509 if Mirror
= M_NONE
then
511 glTexCoord2f(u
, 0); glVertex2i(X
+ e_Textures
[id
].Width
, Y
);
512 glTexCoord2f(0, 0); glVertex2i(X
, Y
);
513 glTexCoord2f(0, -v
); glVertex2i(X
, Y
+ e_Textures
[id
].Height
);
514 glTexCoord2f(u
, -v
); glVertex2i(X
+ e_Textures
[id
].Width
, Y
+ e_Textures
[id
].Height
);
517 if Mirror
= M_HORIZONTAL
then
519 glTexCoord2f(u
, 0); glVertex2i(X
, Y
);
520 glTexCoord2f(0, 0); glVertex2i(X
+ e_Textures
[id
].Width
, Y
);
521 glTexCoord2f(0, -v
); glVertex2i(X
+ e_Textures
[id
].Width
, Y
+ e_Textures
[id
].Height
);
522 glTexCoord2f(u
, -v
); glVertex2i(X
, Y
+ e_Textures
[id
].Height
);
525 if Mirror
= M_VERTICAL
then
527 glTexCoord2f(u
, -v
); glVertex2i(X
+ e_Textures
[id
].Width
, Y
);
528 glTexCoord2f(0, -v
); glVertex2i(X
, Y
);
529 glTexCoord2f(0, 0); glVertex2i(X
, Y
+ e_Textures
[id
].Height
);
530 glTexCoord2f(u
, 0); glVertex2i(X
+ e_Textures
[id
].Width
, Y
+ e_Textures
[id
].Height
);
538 procedure e_DrawSize(ID
: DWORD
; X
, Y
: Integer; Alpha
: Byte; AlphaChannel
: Boolean;
539 Blending
: Boolean; Width
, Height
: Word; Mirror
: TMirrorType
= M_NONE
);
543 if e_NoGraphics
then Exit
;
544 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
546 if (Alpha
> 0) or (AlphaChannel
) or (Blending
) then
551 if (AlphaChannel
) or (Alpha
> 0) then
552 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
555 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255-Alpha
);
558 glBlendFunc(GL_SRC_ALPHA
, GL_ONE
);
560 glEnable(GL_TEXTURE_2D
);
561 glBindTexture(GL_TEXTURE_2D
, e_Textures
[ID
].tx
.id
);
563 u
:= e_Textures
[ID
].tx
.u
;
564 v
:= e_Textures
[ID
].tx
.v
;
567 glTexCoord2f(0, v
); glVertex2i(X
, Y
);
568 glTexCoord2f(u
, v
); glVertex2i(X
+ Width
, Y
);
569 glTexCoord2f(u
, 0); glVertex2i(X
+ Width
, Y
+ Height
);
570 glTexCoord2f(0, 0); glVertex2i(X
, Y
+ Height
);
576 procedure e_DrawSizeMirror(ID
: DWORD
; X
, Y
: Integer; Alpha
: Byte; AlphaChannel
: Boolean;
577 Blending
: Boolean; Width
, Height
: Word; Mirror
: TMirrorType
= M_NONE
);
581 if e_NoGraphics
then Exit
;
582 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
584 if (Alpha
> 0) or (AlphaChannel
) or (Blending
) then
589 if (AlphaChannel
) or (Alpha
> 0) then
590 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
593 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255-Alpha
);
596 glBlendFunc(GL_SRC_ALPHA
, GL_ONE
);
598 glEnable(GL_TEXTURE_2D
);
599 glBindTexture(GL_TEXTURE_2D
, e_Textures
[ID
].tx
.id
);
602 u
:= e_Textures
[ID
].tx
.u
;
603 v
:= e_Textures
[ID
].tx
.v
;
605 if Mirror
= M_NONE
then
607 glTexCoord2f(u
, 0); glVertex2i(X
+ Width
, Y
);
608 glTexCoord2f(0, 0); glVertex2i(X
, Y
);
609 glTexCoord2f(0, -v
); glVertex2i(X
, Y
+ Height
);
610 glTexCoord2f(u
, -v
); glVertex2i(X
+ Width
, Y
+ Height
);
613 if Mirror
= M_HORIZONTAL
then
615 glTexCoord2f(u
, 0); glVertex2i(X
, Y
);
616 glTexCoord2f(0, 0); glVertex2i(X
+ Width
, Y
);
617 glTexCoord2f(0, -v
); glVertex2i(X
+ Width
, Y
+ Height
);
618 glTexCoord2f(u
, -v
); glVertex2i(X
, Y
+ Height
);
621 if Mirror
= M_VERTICAL
then
623 glTexCoord2f(u
, -v
); glVertex2i(X
+ Width
, Y
);
624 glTexCoord2f(0, -v
); glVertex2i(X
, Y
);
625 glTexCoord2f(0, 0); glVertex2i(X
, Y
+ Height
);
626 glTexCoord2f(u
, 0); glVertex2i(X
+ Width
, Y
+ Height
);
634 procedure e_DrawFill(ID
: DWORD
; X
, Y
: Integer; XCount
, YCount
: Word; Alpha
: Integer;
635 AlphaChannel
: Boolean; Blending
: Boolean);
637 X2
, Y2
, dx
, w
, h
: Integer;
640 if e_NoGraphics
then Exit
;
641 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
643 if (Alpha
> 0) or (AlphaChannel
) or (Blending
) then
648 if (AlphaChannel
) or (Alpha
> 0) then
649 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
652 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255-Alpha
);
655 glBlendFunc(GL_SRC_ALPHA
, GL_ONE
);
663 glEnable(GL_TEXTURE_2D
);
664 glBindTexture(GL_TEXTURE_2D
, e_Textures
[ID
].tx
.id
);
666 X2
:= X
+ e_Textures
[ID
].Width
* XCount
;
667 Y2
:= Y
+ e_Textures
[ID
].Height
* YCount
;
669 //k8: this SHOULD work... i hope
670 if (e_Textures
[ID
].tx
.width
= e_Textures
[ID
].tx
.glwidth
) and (e_Textures
[ID
].tx
.height
= e_Textures
[ID
].tx
.glheight
) then
673 glTexCoord2i(0, YCount
); glVertex2i(X
, Y
);
674 glTexCoord2i(XCount
, YCount
); glVertex2i(X2
, Y
);
675 glTexCoord2i(XCount
, 0); glVertex2i(X2
, Y2
);
676 glTexCoord2i(0, 0); glVertex2i(X
, Y2
);
683 u
:= e_Textures
[ID
].tx
.u
;
684 v
:= e_Textures
[ID
].tx
.v
;
685 w
:= e_Textures
[ID
].tx
.width
;
686 h
:= e_Textures
[ID
].tx
.height
;
693 glTexCoord2f(0, v
); glVertex2i(X
, Y
);
694 glTexCoord2f(u
, v
); glVertex2i(X
+w
, Y
);
695 glTexCoord2f(u
, 0); glVertex2i(X
+w
, Y
+h
);
696 glTexCoord2f(0, 0); glVertex2i(X
, Y
+h
);
710 procedure e_DrawAdv(ID
: DWORD
; X
, Y
: Integer; Alpha
: Byte; AlphaChannel
: Boolean;
711 Blending
: Boolean; Angle
: Single; RC
: PPoint
; Mirror
: TMirrorType
= M_NONE
);
715 if e_NoGraphics
then Exit
;
716 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
718 if (Alpha
> 0) or (AlphaChannel
) or (Blending
) then
723 if (AlphaChannel
) or (Alpha
> 0) then
724 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
727 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255-Alpha
);
730 glBlendFunc(GL_SRC_ALPHA
, GL_ONE
);
732 if (Angle
<> 0) and (RC
<> nil) then
735 glTranslatef(X
+RC
.X
, Y
+RC
.Y
, 0);
736 glRotatef(Angle
, 0, 0, 1);
737 glTranslatef(-(X
+RC
.X
), -(Y
+RC
.Y
), 0);
740 glEnable(GL_TEXTURE_2D
);
741 glBindTexture(GL_TEXTURE_2D
, e_Textures
[id
].tx
.id
);
742 glBegin(GL_QUADS
); //0-1 1-1
745 u
:= e_Textures
[ID
].tx
.u
;
746 v
:= e_Textures
[ID
].tx
.v
;
748 if Mirror
= M_NONE
then
750 glTexCoord2f(u
, 0); glVertex2i(X
+ e_Textures
[id
].Width
, Y
);
751 glTexCoord2f(0, 0); glVertex2i(X
, Y
);
752 glTexCoord2f(0, -v
); glVertex2i(X
, Y
+ e_Textures
[id
].Height
);
753 glTexCoord2f(u
, -v
); glVertex2i(X
+ e_Textures
[id
].Width
, Y
+ e_Textures
[id
].Height
);
756 if Mirror
= M_HORIZONTAL
then
758 glTexCoord2f(u
, 0); glVertex2i(X
, Y
);
759 glTexCoord2f(0, 0); glVertex2i(X
+ e_Textures
[id
].Width
, Y
);
760 glTexCoord2f(0, -v
); glVertex2i(X
+ e_Textures
[id
].Width
, Y
+ e_Textures
[id
].Height
);
761 glTexCoord2f(u
, -v
); glVertex2i(X
, Y
+ e_Textures
[id
].Height
);
764 if Mirror
= M_VERTICAL
then
766 glTexCoord2f(u
, -v
); glVertex2i(X
+ e_Textures
[id
].Width
, Y
);
767 glTexCoord2f(0, -v
); glVertex2i(X
, Y
);
768 glTexCoord2f(0, 0); glVertex2i(X
, Y
+ e_Textures
[id
].Height
);
769 glTexCoord2f(u
, 0); glVertex2i(X
+ e_Textures
[id
].Width
, Y
+ e_Textures
[id
].Height
);
780 procedure e_DrawPoint(Size
: Byte; X
, Y
: Integer; Red
, Green
, Blue
: Byte);
782 if e_NoGraphics
then Exit
;
783 glDisable(GL_TEXTURE_2D
);
784 glColor3ub(Red
, Green
, Blue
);
787 if (Size
= 2) or (Size
= 4) then
791 glVertex2f(X
+0.3, Y
+1.0);
794 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
797 procedure e_LineCorrection(var X1
, Y1
, X2
, Y2
: Integer);
799 // Make lines only top-left/bottom-right and top-right/bottom-left
811 // Pixel-perfect hack
819 procedure e_DrawQuad(X1
, Y1
, X2
, Y2
: Integer; Red
, Green
, Blue
: Byte; Alpha
: Byte = 0);
821 nX1
, nY1
, nX2
, nY2
: Integer;
823 if e_NoGraphics
then Exit
;
824 // Only top-left/bottom-right quad
841 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
845 glDisable(GL_TEXTURE_2D
);
846 glColor4ub(Red
, Green
, Blue
, 255-Alpha
);
850 nX1
:= X1
; nY1
:= Y1
;
851 nX2
:= X2
; nY2
:= Y1
;
852 e_LineCorrection(nX1
, nY1
, nX2
, nY2
); // Pixel-perfect lines
853 glVertex2i(nX1
, nY1
);
854 glVertex2i(nX2
, nY2
);
856 nX1
:= X2
; nY1
:= Y1
;
857 nX2
:= X2
; nY2
:= Y2
;
858 e_LineCorrection(nX1
, nY1
, nX2
, nY2
);
859 glVertex2i(nX1
, nY1
);
860 glVertex2i(nX2
, nY2
);
862 nX1
:= X2
; nY1
:= Y2
;
863 nX2
:= X1
; nY2
:= Y2
;
864 e_LineCorrection(nX1
, nY1
, nX2
, nY2
);
865 glVertex2i(nX1
, nY1
);
866 glVertex2i(nX2
, nY2
);
868 nX1
:= X1
; nY1
:= Y2
;
869 nX2
:= X1
; nY2
:= Y1
;
870 e_LineCorrection(nX1
, nY1
, nX2
, nY2
);
871 glVertex2i(nX1
, nY1
);
872 glVertex2i(nX2
, nY2
);
875 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
880 procedure e_DrawFillQuad(X1
, Y1
, X2
, Y2
: Integer; Red
, Green
, Blue
, Alpha
: Byte;
881 Blending
: TBlending
= B_NONE
);
883 if e_NoGraphics
then Exit
;
884 if (Alpha
> 0) or (Blending
<> B_NONE
) then
889 if Blending
= B_BLEND
then
890 glBlendFunc(GL_SRC_ALPHA
, GL_ONE
)
892 if Blending
= B_FILTER
then
893 glBlendFunc(GL_DST_COLOR
, GL_SRC_COLOR
)
895 if Blending
= B_INVERT
then
896 glBlendFunc(GL_ONE_MINUS_DST_COLOR
, GL_ZERO
)
899 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
901 glDisable(GL_TEXTURE_2D
);
902 glColor4ub(Red
, Green
, Blue
, 255-Alpha
);
914 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
919 procedure e_DrawLine(Width
: Byte; X1
, Y1
, X2
, Y2
: Integer; Red
, Green
, Blue
: Byte; Alpha
: Byte = 0);
921 if e_NoGraphics
then Exit
;
922 // Pixel-perfect lines
924 e_LineCorrection(X1
, Y1
, X2
, Y2
);
929 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
933 glDisable(GL_TEXTURE_2D
);
934 glColor4ub(Red
, Green
, Blue
, 255-Alpha
);
942 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
947 //------------------------------------------------------------------
948 // Óäàëÿåò òåêñòóðó èç ìàññèâà
949 //------------------------------------------------------------------
950 procedure e_DeleteTexture(ID
: DWORD
);
952 if not e_NoGraphics
then
953 glDeleteTextures(1, @e_Textures
[ID
].tx
.id
);
954 e_Textures
[ID
].tx
.id
:= 0;
955 e_Textures
[ID
].Width
:= 0;
956 e_Textures
[ID
].Height
:= 0;
959 //------------------------------------------------------------------
960 // Óäàëÿåò âñå òåêñòóðû
961 //------------------------------------------------------------------
962 procedure e_RemoveAllTextures();
966 if e_Textures
= nil then Exit
;
968 for i
:= 0 to High(e_Textures
) do
969 if e_Textures
[i
].Width
<> 0 then e_DeleteTexture(i
);
973 //------------------------------------------------------------------
975 //------------------------------------------------------------------
976 procedure e_ReleaseEngine();
979 e_RemoveAllTextureFont
;
982 procedure e_BeginRender();
984 if e_NoGraphics
then Exit
;
985 glEnable(GL_ALPHA_TEST
);
986 glAlphaFunc(GL_GREATER
, 0.0);
989 procedure e_Clear(Mask
: TGLbitfield
; Red
, Green
, Blue
: Single); overload
;
991 if e_NoGraphics
then Exit
;
992 glClearColor(Red
, Green
, Blue
, 0);
996 procedure e_Clear(); overload
;
998 if e_NoGraphics
then Exit
;
999 glClearColor(0, 0, 0, 0);
1000 glClear(GL_COLOR_BUFFER_BIT
);
1003 procedure e_EndRender();
1005 if e_NoGraphics
then Exit
;
1009 function e_GetGamma(win
: PSDL_Window
): Byte;
1011 ramp
: array [0..256*3-1] of Word;
1012 rgb
: array [0..2] of Double;
1021 if e_NoGraphics
then Exit
;
1026 SDL_GetWindowGammaRamp(win
, @ramp
[0], @ramp
[256], @ramp
[512]);
1035 for j
:= min
to max
- 1 do
1038 B
:= (j
mod 256)/256;
1040 sum
:= sum
+ ln(A
)/ln(B
);
1043 rgb
[i
] := sum
/ count
;
1046 Result
:= 100 - Trunc(((rgb
[0] + rgb
[1] + rgb
[2])/3 - 0.23) * 100/(2.7 - 0.23));
1049 procedure e_SetGamma(win
: PSDL_Window
; Gamma
: Byte);
1051 ramp
: array [0..256*3-1] of Word;
1056 if e_NoGraphics
then Exit
;
1057 g
:= (100 - Gamma
)*(2.7 - 0.23)/100 + 0.23;
1059 for i
:= 0 to 255 do
1061 r
:= Exp(g
* ln(i
/256))*65536;
1062 if r
< 0 then r
:= 0
1063 else if r
> 65535 then r
:= 65535;
1064 ramp
[i
] := trunc(r
);
1065 ramp
[i
+ 256] := trunc(r
);
1066 ramp
[i
+ 512] := trunc(r
);
1069 SDL_SetWindowGammaRamp(win
, @ramp
[0], @ramp
[256], @ramp
[512]);
1072 function e_CharFont_Create(sp
: ShortInt=0): DWORD
;
1076 e_WriteLog('Creating CharFont...', MSG_NOTIFY
);
1080 if e_CharFonts
<> nil then
1081 for i
:= 0 to High(e_CharFonts
) do
1082 if not e_CharFonts
[i
].Live
then
1088 if id
= DWORD(-1) then
1090 SetLength(e_CharFonts
, Length(e_CharFonts
) + 1);
1091 id
:= High(e_CharFonts
);
1094 with e_CharFonts
[id
] do
1096 for i
:= 0 to High(Chars
) do
1110 procedure e_CharFont_AddChar(FontID
: DWORD
; Texture
: Integer; c
: Char; w
: Byte);
1112 with e_CharFonts
[FontID
].Chars
[Ord(c
)] do
1114 TextureID
:= Texture
;
1119 procedure e_CharFont_Print(FontID
: DWORD
; X
, Y
: Integer; Text: string);
1123 if e_NoGraphics
then Exit
;
1124 if Text = '' then Exit
;
1125 if e_CharFonts
= nil then Exit
;
1126 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1128 with e_CharFonts
[FontID
] do
1130 for a
:= 1 to Length(Text) do
1131 with Chars
[Ord(Text[a
])] do
1132 if TextureID
<> -1 then
1134 e_Draw(TextureID
, X
, Y
, 0, True, False);
1135 X
:= X
+Width
+IfThen(a
= Length(Text), 0, Space
);
1140 procedure e_CharFont_PrintEx(FontID
: DWORD
; X
, Y
: Integer; Text: string;
1141 Color
: TRGB
; Scale
: Single = 1.0);
1146 if e_NoGraphics
then Exit
;
1147 if Text = '' then Exit
;
1148 if e_CharFonts
= nil then Exit
;
1149 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1151 with e_CharFonts
[FontID
] do
1153 for a
:= 1 to Length(Text) do
1154 with Chars
[Ord(Text[a
])] do
1155 if TextureID
<> -1 then
1157 if Scale
<> 1.0 then
1160 glScalef(Scale
, Scale
, 0);
1165 e_Draw(TextureID
, X
, Y
, 0, True, False);
1168 if Scale
<> 1.0 then glPopMatrix
;
1170 X
:= X
+Width
+IfThen(a
= Length(Text), 0, Space
);
1175 procedure e_CharFont_PrintFmt(FontID
: DWORD
; X
, Y
: Integer; Text: string);
1177 a
, TX
, TY
, len
: Integer;
1181 if e_NoGraphics
then Exit
;
1182 if Text = '' then Exit
;
1183 if e_CharFonts
= nil then Exit
;
1184 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1192 len
:= Length(Text);
1194 e_CharFont_GetSize(FontID
, 'A', w
, h
);
1196 with e_CharFonts
[FontID
] do
1198 for a
:= 1 to len
do
1209 c
.R
:= 0; c
.G
:= 0; c
.B
:= 0;
1214 c
.R
:= 255; c
.G
:= 255; c
.B
:= 255;
1219 c
.R
:= c
.R
div 2; c
.G
:= c
.G
div 2; c
.B
:= c
.B
div 2;
1224 c
.R
:= Min(c
.R
* 2, 255); c
.G
:= Min(c
.G
* 2, 255); c
.B
:= Min(c
.B
* 2, 255);
1229 c
.R
:= 255; c
.G
:= 0; c
.B
:= 0;
1234 c
.R
:= 0; c
.G
:= 255; c
.B
:= 0;
1239 c
.R
:= 0; c
.G
:= 0; c
.B
:= 255;
1244 c
.R
:= 255; c
.G
:= 255; c
.B
:= 0;
1249 with Chars
[Ord(Text[a
])] do
1250 if TextureID
<> -1 then
1254 e_Draw(TextureID
, TX
, TY
, 0, True, False);
1257 TX
:= TX
+Width
+IfThen(a
= Length(Text), 0, Space
);
1263 procedure e_CharFont_GetSize(FontID
: DWORD
; Text: string; var w
, h
: Word);
1271 if Text = '' then Exit
;
1272 if e_CharFonts
= nil then Exit
;
1273 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1275 with e_CharFonts
[FontID
] do
1277 for a
:= 1 to Length(Text) do
1278 with Chars
[Ord(Text[a
])] do
1279 if TextureID
<> -1 then
1281 w
:= w
+Width
+IfThen(a
= Length(Text), 0, Space
);
1282 e_GetTextureSize(TextureID
, nil, @h2
);
1283 if h2
> h
then h
:= h2
;
1288 procedure e_CharFont_GetSizeFmt(FontID
: DWORD
; Text: string; var w
, h
: Word);
1290 a
, lines
, len
: Integer;
1297 if Text = '' then Exit
;
1298 if e_CharFonts
= nil then Exit
;
1299 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1302 len
:= Length(Text);
1304 with e_CharFonts
[FontID
] do
1306 for a
:= 1 to len
do
1308 if Text[a
] = #10 then
1318 else if Text[a
] in [#1, #2, #3, #4, #18, #19, #20, #21] then
1321 with Chars
[Ord(Text[a
])] do
1322 if TextureID
<> -1 then
1324 w2
:= w2
+ Width
+ IfThen(a
= len
, 0, Space
);
1325 e_GetTextureSize(TextureID
, nil, @h2
);
1326 if h2
> h
then h
:= h2
;
1336 function e_CharFont_GetMaxWidth(FontID
: DWORD
): Word;
1342 if e_CharFonts
= nil then Exit
;
1343 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1345 for a
:= 0 to High(e_CharFonts
[FontID
].Chars
) do
1346 Result
:= Max(Result
, e_CharFonts
[FontID
].Chars
[a
].Width
);
1349 function e_CharFont_GetMaxHeight(FontID
: DWORD
): Word;
1356 if e_CharFonts
= nil then Exit
;
1357 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1359 for a
:= 0 to High(e_CharFonts
[FontID
].Chars
) do
1361 if e_CharFonts
[FontID
].Chars
[a
].TextureID
<> -1 then
1362 e_GetTextureSize(e_CharFonts
[FontID
].Chars
[a
].TextureID
, nil, @h2
)
1364 if h2
> Result
then Result
:= h2
;
1368 procedure e_CharFont_Remove(FontID
: DWORD
);
1372 with e_CharFonts
[FontID
] do
1373 for a
:= 0 to High(Chars
) do
1374 if Chars
[a
].TextureID
<> -1 then e_DeleteTexture(Chars
[a
].TextureID
);
1376 e_CharFonts
[FontID
].Live
:= False;
1379 procedure e_CharFont_RemoveAll();
1383 if e_CharFonts
= nil then Exit
;
1385 for a
:= 0 to High(e_CharFonts
) do
1386 e_CharFont_Remove(a
);
1391 procedure e_TextureFontBuild(Tex
: DWORD
; var FontID
: DWORD
; XCount
, YCount
: Word;
1398 if e_NoGraphics
then Exit
;
1399 e_WriteLog('Creating texture font...', MSG_NOTIFY
);
1403 if e_TextureFonts
<> nil then
1404 for i
:= 0 to High(e_TextureFonts
) do
1405 if e_TextureFonts
[i
].Base
= 0 then
1411 if id
= DWORD(-1) then
1413 SetLength(e_TextureFonts
, Length(e_TextureFonts
) + 1);
1414 id
:= High(e_TextureFonts
);
1417 with e_TextureFonts
[id
] do
1419 Base
:= glGenLists(XCount
*YCount
);
1420 TextureID
:= e_Textures
[Tex
].tx
.id
;
1421 CharWidth
:= (e_Textures
[Tex
].Width
div XCount
)+Space
;
1422 CharHeight
:= e_Textures
[Tex
].Height
div YCount
;
1429 glBindTexture(GL_TEXTURE_2D
, e_Textures
[Tex
].tx
.id
);
1430 for loop1
:= 0 to XCount
*YCount
-1 do
1432 cx
:= (loop1
mod XCount
)/XCount
;
1433 cy
:= (loop1
div YCount
)/YCount
;
1435 glNewList(e_TextureFonts
[id
].Base
+loop1
, GL_COMPILE
);
1437 glTexCoord2f(cx
, 1.0-cy
-1/YCount
);
1438 glVertex2d(0, e_Textures
[Tex
].Height
div YCount
);
1440 glTexCoord2f(cx
+1/XCount
, 1.0-cy
-1/YCount
);
1441 glVertex2i(e_Textures
[Tex
].Width
div XCount
, e_Textures
[Tex
].Height
div YCount
);
1443 glTexCoord2f(cx
+1/XCount
, 1.0-cy
);
1444 glVertex2i(e_Textures
[Tex
].Width
div XCount
, 0);
1446 glTexCoord2f(cx
, 1.0-cy
);
1449 glTranslated((e_Textures
[Tex
].Width
div XCount
)+Space
, 0, 0);
1456 procedure e_TextureFontKill(FontID
: DWORD
);
1458 if e_NoGraphics
then Exit
;
1459 glDeleteLists(e_TextureFonts
[FontID
].Base
, 256);
1460 e_TextureFonts
[FontID
].Base
:= 0;
1463 procedure e_TextureFontPrint(X
, Y
: GLint
; Text: string; FontID
: DWORD
);
1465 if e_NoGraphics
then Exit
;
1466 if Integer(FontID
) > High(e_TextureFonts
) then Exit
;
1467 if Text = '' then Exit
;
1469 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
1472 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
1475 glBindTexture(GL_TEXTURE_2D
, e_TextureFonts
[FontID
].TextureID
);
1476 glEnable(GL_TEXTURE_2D
);
1477 glTranslated(x
, y
, 0);
1478 glListBase(DWORD(Integer(e_TextureFonts
[FontID
].Base
)-32));
1479 glCallLists(Length(Text), GL_UNSIGNED_BYTE
, PChar(Text));
1480 glDisable(GL_TEXTURE_2D
);
1483 glDisable(GL_BLEND
);
1486 // god forgive me for this, but i cannot figure out how to do it without lists
1487 procedure e_TextureFontPrintChar(X
, Y
: Integer; Ch
: Char; FontID
: DWORD
; Shadow
: Boolean = False);
1489 if e_NoGraphics
then Exit
;
1494 glColor4ub(0, 0, 0, 128);
1495 glTranslated(X
+1, Y
+1, 0);
1496 glCallLists(1, GL_UNSIGNED_BYTE
, @Ch
);
1501 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
1502 glTranslated(X
, Y
, 0);
1503 glCallLists(1, GL_UNSIGNED_BYTE
, @Ch
);
1508 procedure e_TextureFontPrintCharEx (X
, Y
: Integer; Ch
: Char; FontID
: DWORD
; Shadow
: Boolean = False);
1510 glBindTexture(GL_TEXTURE_2D
, e_TextureFonts
[FontID
].TextureID
);
1511 glEnable(GL_TEXTURE_2D
);
1512 //glListBase(DWORD(Integer(e_TextureFonts[FontID].Base)-32));
1514 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
1516 e_TextureFontPrintChar(X
, Y
, Ch
, FontID
, Shadow
);
1517 glDisable(GL_TEXTURE_2D
);
1518 glDisable(GL_BLEND
);
1521 function e_TextureFontCharWidth (ch
: Char; FontID
: DWORD
): Integer;
1523 result
:= e_TextureFonts
[FontID
].CharWidth
;
1526 procedure e_TextureFontPrintFmt(X
, Y
: Integer; Text: string; FontID
: DWORD
; Shadow
: Boolean = False);
1528 a
, TX
, TY
, len
: Integer;
1532 if e_NoGraphics
then Exit
;
1533 if Text = '' then Exit
;
1534 if e_TextureFonts
= nil then Exit
;
1535 if Integer(FontID
) > High(e_TextureFonts
) then Exit
;
1543 len
:= Length(Text);
1545 w
:= e_TextureFonts
[FontID
].CharWidth
;
1547 with e_TextureFonts
[FontID
] do
1549 glBindTexture(GL_TEXTURE_2D
, e_TextureFonts
[FontID
].TextureID
);
1550 glEnable(GL_TEXTURE_2D
);
1551 glListBase(DWORD(Integer(e_TextureFonts
[FontID
].Base
)-32));
1553 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
1556 for a
:= 1 to len
do
1567 c
.R
:= 0; c
.G
:= 0; c
.B
:= 0;
1572 c
.R
:= 255; c
.G
:= 255; c
.B
:= 255;
1577 c
.R
:= c
.R
div 2; c
.G
:= c
.G
div 2; c
.B
:= c
.B
div 2;
1582 c
.R
:= Min(c
.R
* 2, 255); c
.G
:= Min(c
.G
* 2, 255); c
.B
:= Min(c
.B
* 2, 255);
1587 c
.R
:= 255; c
.G
:= 0; c
.B
:= 0;
1592 c
.R
:= 0; c
.G
:= 255; c
.B
:= 0;
1597 c
.R
:= 0; c
.G
:= 0; c
.B
:= 255;
1602 c
.R
:= 255; c
.G
:= 255; c
.B
:= 0;
1609 e_TextureFontPrintChar(TX
, TY
, Text[a
], FontID
, Shadow
);
1614 glDisable(GL_TEXTURE_2D
);
1615 glDisable(GL_BLEND
);
1619 procedure e_TextureFontPrintEx(X
, Y
: GLint
; Text: string; FontID
: DWORD
; Red
, Green
,
1620 Blue
: Byte; Scale
: Single; Shadow
: Boolean = False);
1622 if e_NoGraphics
then Exit
;
1623 if Text = '' then Exit
;
1626 glBindTexture(GL_TEXTURE_2D
, e_TextureFonts
[FontID
].TextureID
);
1627 glEnable(GL_TEXTURE_2D
);
1628 glListBase(DWORD(Integer(e_TextureFonts
[FontID
].Base
)-32));
1630 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
1635 glColor4ub(0, 0, 0, 128);
1636 glTranslated(x
+1, y
+1, 0);
1637 glScalef(Scale
, Scale
, 0);
1638 glCallLists(Length(Text), GL_UNSIGNED_BYTE
, PChar(Text));
1643 glColor4ub(Red
, Green
, Blue
, 255);
1644 glTranslated(x
, y
, 0);
1645 glScalef(Scale
, Scale
, 0);
1646 glCallLists(Length(Text), GL_UNSIGNED_BYTE
, PChar(Text));
1648 glDisable(GL_TEXTURE_2D
);
1650 glColor3ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
);
1651 glDisable(GL_BLEND
);
1654 procedure e_TextureFontGetSize(ID
: DWORD
; var CharWidth
, CharHeight
: Byte);
1658 if e_NoGraphics
then Exit
;
1659 if Integer(ID
) > High(e_TextureFonts
) then
1661 CharWidth
:= e_TextureFonts
[ID
].CharWidth
;
1662 CharHeight
:= e_TextureFonts
[ID
].CharHeight
;
1665 procedure e_RemoveAllTextureFont();
1669 if e_NoGraphics
then Exit
;
1670 if e_TextureFonts
= nil then Exit
;
1672 for i
:= 0 to High(e_TextureFonts
) do
1673 if e_TextureFonts
[i
].Base
<> 0 then
1675 glDeleteLists(e_TextureFonts
[i
].Base
, 256);
1676 e_TextureFonts
[i
].Base
:= 0;
1679 e_TextureFonts
:= nil;
1682 function _RGB(Red
, Green
, Blue
: Byte): TRGB
;
1689 function _Point(X
, Y
: Integer): TPoint2i
;
1695 function _Rect(X
, Y
: Integer; Width
, Height
: Word): TRectWH
;
1699 Result
.Width
:= Width
;
1700 Result
.Height
:= Height
;
1703 function _TRect(L
, T
, R
, B
: LongInt): TRect
;
1712 procedure e_MakeScreenshot (st
: TStream
; Width
, Height
: Word);
1714 pixels
, obuf
, scln
, ps
, pd
: PByte;
1717 i
, x
, y
, res
: Integer;
1718 sign
: array [0..7] of Byte;
1719 hbuf
: array [0..12] of Byte;
1724 if e_NoGraphics
then Exit
;
1727 // first, extract and pack graphics data
1728 if (Width
mod 4) > 0 then Width
:= Width
+4-(Width
mod 4);
1730 GetMem(pixels
, Width
*Height
*3);
1732 FillChar(pixels
^, Width
*Height
*3, 0);
1733 glReadPixels(0, 0, Width
, Height
, GL_RGB
, GL_UNSIGNED_BYTE
, pixels
);
1734 //e_WriteLog('PNG: pixels read', MSG_NOTIFY);
1736 if e_FastScreenshots
then
1739 GetMem(scln
, (Width
*3+1)*Height
);
1743 Inc(ps
, (Width
*3)*(Height
-1));
1744 for i
:= 0 to Height
-1 do
1748 Move(ps
^, pd
^, Width
*3);
1760 obufsize
:= (Width
*3+1)*Height
*2;
1761 GetMem(obuf
, obufsize
);
1766 res
:= compress2(Pointer(obuf
), dlen
, Pointer(pixels
), (Width
*3+1)*Height
, 9);
1767 if res
= Z_OK
then break
;
1768 if res
<> Z_BUF_ERROR
then raise Exception
.Create('can''t pack data for PNG');
1769 obufsize
:= obufsize
*2;
1772 GetMem(obuf
, obufsize
);
1774 //e_WriteLog(Format('PNG: pixels compressed from %d to %d', [Integer(Width*Height*3), Integer(dlen)]), MSG_NOTIFY);
1787 st
.writeBuffer(sign
, 8);
1788 //e_WriteLog('PNG: signature written', MSG_NOTIFY);
1791 writeIntBE(st
, LongWord(13));
1796 st
.writeBuffer(sign
, 4);
1797 crc
:= crc32(0, @sign
, 4);
1800 hbuf
[2] := (Width
shr 8) and $ff;
1801 hbuf
[3] := Width
and $ff;
1804 hbuf
[6] := (Height
shr 8) and $ff;
1805 hbuf
[7] := Height
and $ff;
1806 hbuf
[8] := 8; // bit depth
1807 hbuf
[9] := 2; // RGB
1808 hbuf
[10] := 0; // compression method
1809 hbuf
[11] := 0; // filter method
1810 hbuf
[12] := 0; // no interlace
1811 crc
:= crc32(crc
, @hbuf
, 13);
1812 st
.writeBuffer(hbuf
, 13);
1813 writeIntBE(st
, crc
);
1814 //e_WriteLog('PNG: header written', MSG_NOTIFY);
1817 writeIntBE(st
, LongWord(dlen
));
1822 st
.writeBuffer(sign
, 4);
1823 crc
:= crc32(0, @sign
, 4);
1824 crc
:= crc32(crc
, obuf
, dlen
);
1825 st
.writeBuffer(obuf
^, dlen
);
1826 writeIntBE(st
, crc
);
1827 //e_WriteLog('PNG: image data written', MSG_NOTIFY);
1830 writeIntBE(st
, LongWord(0));
1835 st
.writeBuffer(sign
, 4);
1836 crc
:= crc32(0, @sign
, 4);
1837 writeIntBE(st
, crc
);
1838 //e_WriteLog('PNG: end marker written', MSG_NOTIFY);
1840 if obuf
<> nil then FreeMem(obuf
);
1845 Imaging
.SetOption(ImagingPNGCompressLevel
, 9);
1846 Imaging
.SetOption(ImagingPNGPreFilter
, 6);
1849 NewImage(Width
, Height
, TImageFormat
.ifR8G8B8
, img
);
1851 //writeln(stderr, 'moving pixels...');
1852 for y
:= Height
-1 downto 0 do
1854 for x
:= 0 to Width
-1 do
1856 clr
.r
:= ps
^; Inc(ps
);
1857 clr
.g
:= ps
^; Inc(ps
);
1858 clr
.b
:= ps
^; Inc(ps
);
1860 SetPixel32(img
, x
, y
, clr
);
1863 GlobalMetadata
.ClearMetaItems();
1864 GlobalMetadata
.ClearMetaItemsForSaving();
1865 //writeln(stderr, 'compressing image...');
1866 if not SaveImageToStream('png', st
, img
) then raise Exception
.Create('screenshot writing error');
1867 //writeln(stderr, 'done!');