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/>.
16 {$INCLUDE ../shared/a_modes.inc}
22 SysUtils
, Classes
, Math
, e_log
, e_texture
, 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
);
80 procedure e_DarkenQuad (x0
, y0
, x1
, y1
: Integer; a
: Integer);
81 procedure e_DarkenQuadWH (x
, y
, w
, h
: Integer; a
: Integer);
83 function e_CreateTextureImg (var img
: TImageData
; var ID
: DWORD
): Boolean;
84 function e_CreateTexture(FileName
: string; var ID
: DWORD
): Boolean;
85 function e_CreateTextureEx(FileName
: string; var ID
: DWORD
; fX
, fY
, fWidth
, fHeight
: Word): Boolean;
86 function e_CreateTextureMem(pData
: Pointer; dataSize
: LongInt; var ID
: DWORD
): Boolean;
87 function e_CreateTextureMemEx(pData
: Pointer; dataSize
: LongInt; var ID
: DWORD
; fX
, fY
, fWidth
, fHeight
: Word): Boolean;
88 procedure e_GetTextureSize(ID
: DWORD
; Width
, Height
: PWord);
89 function e_GetTextureSize2(ID
: DWORD
): TRectWH
;
90 procedure e_DeleteTexture(ID
: DWORD
);
91 procedure e_RemoveAllTextures();
94 function e_CharFont_Create(sp
: ShortInt=0): DWORD
;
95 procedure e_CharFont_AddChar(FontID
: DWORD
; Texture
: Integer; c
: Char; w
: Byte);
96 procedure e_CharFont_Print(FontID
: DWORD
; X
, Y
: Integer; Text: string);
97 procedure e_CharFont_PrintEx(FontID
: DWORD
; X
, Y
: Integer; Text: string;
98 Color
: TRGB
; Scale
: Single = 1.0);
99 procedure e_CharFont_PrintFmt(FontID
: DWORD
; X
, Y
: Integer; Text: string);
100 procedure e_CharFont_GetSize(FontID
: DWORD
; Text: string; var w
, h
: Word);
101 procedure e_CharFont_GetSizeFmt(FontID
: DWORD
; Text: string; var w
, h
: Word);
102 function e_CharFont_GetMaxWidth(FontID
: DWORD
): Word;
103 function e_CharFont_GetMaxHeight(FontID
: DWORD
): Word;
104 procedure e_CharFont_Remove(FontID
: DWORD
);
105 procedure e_CharFont_RemoveAll();
108 procedure e_TextureFontBuild(Tex
: DWORD
; var FontID
: DWORD
; XCount
, YCount
: Word;
110 procedure e_TextureFontKill(FontID
: DWORD
);
111 procedure e_TextureFontPrint(X
, Y
: GLint
; Text: string; FontID
: DWORD
);
112 procedure e_TextureFontPrintEx(X
, Y
: GLint
; Text: string; FontID
: DWORD
; Red
, Green
,
113 Blue
: Byte; Scale
: Single; Shadow
: Boolean = False);
114 procedure e_TextureFontPrintFmt(X
, Y
: GLint
; Text: string; FontID
: DWORD
; Shadow
: Boolean = False);
115 procedure e_TextureFontGetSize(ID
: DWORD
; out CharWidth
, CharHeight
: Byte);
116 procedure e_RemoveAllTextureFont();
118 function e_TextureFontCharWidth (ch
: Char; FontID
: DWORD
): Integer;
119 procedure e_TextureFontPrintCharEx (X
, Y
: Integer; Ch
: Char; FontID
: DWORD
; Shadow
: Boolean = False);
121 procedure e_ReleaseEngine();
122 procedure e_BeginRender();
123 procedure e_Clear(Mask
: TGLbitfield
; Red
, Green
, Blue
: Single); overload
;
124 procedure e_Clear(); overload
;
125 procedure e_EndRender();
127 function e_GetGamma(win
: PSDL_Window
): Byte;
128 procedure e_SetGamma(win
: PSDL_Window
;Gamma
: Byte);
130 procedure e_MakeScreenshot(st
: TStream
; Width
, Height
: Word);
132 function _RGB(Red
, Green
, Blue
: Byte): TRGB
;
133 function _Point(X
, Y
: Integer): TPoint2i
;
134 function _Rect(X
, Y
: Integer; Width
, Height
: Word): TRectWH
;
135 function _TRect(L
, T
, R
, B
: LongInt): TRect
;
137 //function e_getTextGLId (ID: DWORD): GLuint;
141 e_NoGraphics
: Boolean = False;
142 e_FastScreenshots
: Boolean = true; // it's REALLY SLOW with `false`
156 TTextureFont
= record
166 Chars
: array[0..255] of
176 TSavedTexture
= record
183 e_Textures
: array of TTexture
= nil;
184 e_TextureFonts
: array of TTextureFont
= nil;
185 e_CharFonts
: array of TCharFont
;
186 //e_SavedTextures: array of TSavedTexture;
188 //function e_getTextGLId (ID: DWORD): GLuint; begin result := e_Textures[ID].tx.id; end;
190 //------------------------------------------------------------------
191 // Èíèöèàëèçèðóåò OpenGL
192 //------------------------------------------------------------------
193 procedure e_InitGL();
197 e_DummyTextures
:= True;
203 glDisable(GL_DEPTH_TEST
);
204 glEnable(GL_SCISSOR_TEST
);
205 glClearColor(0, 0, 0, 0);
208 procedure e_SetViewPort(X
, Y
, Width
, Height
: Word);
210 mat
: Array [0..15] of GLDouble
;
213 if e_NoGraphics
then Exit
;
215 glScissor(X
, Y
, Width
, Height
);
216 glViewport(X
, Y
, Width
, Height
);
217 //gluOrtho2D(0, Width, Height, 0);
219 glMatrixMode(GL_PROJECTION
);
221 mat
[ 0] := 2.0 / Width
;
227 mat
[ 5] := -2.0 / Height
;
241 glLoadMatrixd(@mat
[0]);
243 glMatrixMode(GL_MODELVIEW
);
247 //------------------------------------------------------------------
248 // Èùåò ñâîáîäíûé ýëåìåíò â ìàññèâå òåêñòóð
249 //------------------------------------------------------------------
250 function FindTexture(): DWORD
;
254 if e_Textures
<> nil then
255 for i
:= 0 to High(e_Textures
) do
256 if e_Textures
[i
].tx
.Width
= 0 then
262 if e_Textures
= nil then
264 SetLength(e_Textures
, 32);
269 Result
:= High(e_Textures
) + 1;
270 SetLength(e_Textures
, Length(e_Textures
) + 32);
274 //------------------------------------------------------------------
276 //------------------------------------------------------------------
277 function e_CreateTexture(FileName
: String; var ID
: DWORD
): Boolean;
284 e_WriteLog('Loading texture from '+FileName
, MSG_NOTIFY
);
286 find_id
:= FindTexture();
288 if not LoadTexture(FileName
, e_Textures
[find_id
].tx
, e_Textures
[find_id
].tx
.Width
,
289 e_Textures
[find_id
].tx
.Height
, @fmt
) then Exit
;
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
;
312 function e_CreateTextureMem(pData
: Pointer; dataSize
: LongInt; var ID
: DWORD
): Boolean;
319 find_id
:= FindTexture
;
321 if not LoadTextureMem(pData
, dataSize
, e_Textures
[find_id
].tx
, e_Textures
[find_id
].tx
.Width
, e_Textures
[find_id
].tx
.Height
, @fmt
) then exit
;
328 function e_CreateTextureMemEx(pData
: Pointer; dataSize
: LongInt; var ID
: DWORD
; fX
, fY
, fWidth
, fHeight
: Word): Boolean;
335 find_id
:= FindTexture();
337 if not LoadTextureMemEx(pData
, dataSize
, e_Textures
[find_id
].tx
, fX
, fY
, fWidth
, fHeight
, @fmt
) then exit
;
344 function e_CreateTextureImg (var img
: TImageData
; var ID
: DWORD
): Boolean;
350 find_id
:= FindTexture();
351 if not LoadTextureImg(img
, e_Textures
[find_id
].tx
, tw
, th
, @fmt
) then exit
;
356 procedure e_GetTextureSize(ID
: DWORD
; Width
, Height
: PWord);
358 if Width
<> nil then Width
^ := e_Textures
[ID
].tx
.Width
;
359 if Height
<> nil then Height
^ := e_Textures
[ID
].tx
.Height
;
362 function e_GetTextureSize2(ID
: DWORD
): TRectWH
;
370 w
:= e_Textures
[ID
].tx
.Width
;
371 h
:= e_Textures
[ID
].tx
.Height
;
378 if e_NoGraphics
then Exit
;
380 data
:= GetMemory(w
*h
*4);
381 glEnable(GL_TEXTURE_2D
);
382 glBindTexture(GL_TEXTURE_2D
, e_Textures
[ID
].tx
.id
);
383 glGetTexImage(GL_TEXTURE_2D
, 0, GL_RGBA
, GL_UNSIGNED_BYTE
, data
);
385 for y
:= h
-1 downto 0 do
392 a
:= Byte((data
+y
*w
*4+x
*4+3)^) <> 0;
398 Result
.Y
:= h
-lastline
;
410 a
:= Byte((data
+y
*w
*4+x
*4+3)^) <> 0;
416 Result
.Height
:= h
-lastline
-Result
.Y
;
428 a
:= Byte((data
+y
*w
*4+x
*4+3)^) <> 0;
434 Result
.X
:= lastline
+1;
439 for x
:= w
-1 downto 0 do
446 a
:= Byte((data
+y
*w
*4+x
*4+3)^) <> 0;
452 Result
.Width
:= lastline
-Result
.X
+1;
460 procedure e_ResizeWindow(Width
, Height
: Integer);
464 e_SetViewPort(0, 0, Width
, Height
);
467 procedure drawTxQuad (x0
, y0
, w
, h
: Integer; u
, v
: single; Mirror
: TMirrorType
);
469 x1
, y1
, tmp
: Integer;
471 if (w
< 1) or (h
< 1) then exit
;
474 if Mirror
= M_HORIZONTAL
then begin tmp
:= x1
; x1
:= x0
; x0
:= tmp
; end
475 else if Mirror
= M_VERTICAL
then begin tmp
:= y1
; y1
:= y0
; y0
:= tmp
; end;
476 glTexCoord2f(0, v
); glVertex2i(x0
, y0
);
477 glTexCoord2f(0, 0); glVertex2i(x0
, y1
);
478 glTexCoord2f(u
, 0); glVertex2i(x1
, y1
);
479 glTexCoord2f(u
, v
); glVertex2i(x1
, y0
);
482 procedure e_Draw(ID
: DWORD
; X
, Y
: Integer; Alpha
: Byte; AlphaChannel
: Boolean;
483 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 drawTxQuad(X
, Y
, e_Textures
[id
].tx
.width
, e_Textures
[id
].tx
.height
, e_Textures
[ID
].tx
.u
, e_Textures
[ID
].tx
.v
, Mirror
);
508 //u := e_Textures[ID].tx.u;
509 //v := e_Textures[ID].tx.v;
512 if Mirror = M_NONE then
514 glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].tx.Width, Y);
515 glTexCoord2f(0, 0); glVertex2i(X, Y);
516 glTexCoord2f(0, -v); glVertex2i(X, Y + e_Textures[id].tx.Height);
517 glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].tx.Width, Y + e_Textures[id].tx.Height);
520 if Mirror = M_HORIZONTAL then
522 glTexCoord2f(u, 0); glVertex2i(X, Y);
523 glTexCoord2f(0, 0); glVertex2i(X + e_Textures[id].tx.Width, Y);
524 glTexCoord2f(0, -v); glVertex2i(X + e_Textures[id].tx.Width, Y + e_Textures[id].tx.Height);
525 glTexCoord2f(u, -v); glVertex2i(X, Y + e_Textures[id].tx.Height);
528 if Mirror = M_VERTICAL then
530 glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].tx.Width, Y);
531 glTexCoord2f(0, -v); glVertex2i(X, Y);
532 glTexCoord2f(0, 0); glVertex2i(X, Y + e_Textures[id].tx.Height);
533 glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].tx.Width, Y + e_Textures[id].tx.Height);
542 procedure e_DrawSize(ID
: DWORD
; X
, Y
: Integer; Alpha
: Byte; AlphaChannel
: Boolean;
543 Blending
: Boolean; Width
, Height
: Word; Mirror
: TMirrorType
= M_NONE
);
547 if e_NoGraphics
then Exit
;
548 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
550 if (Alpha
> 0) or (AlphaChannel
) or (Blending
) then
555 if (AlphaChannel
) or (Alpha
> 0) then
556 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
559 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255-Alpha
);
562 glBlendFunc(GL_SRC_ALPHA
, GL_ONE
);
564 glEnable(GL_TEXTURE_2D
);
565 glBindTexture(GL_TEXTURE_2D
, e_Textures
[ID
].tx
.id
);
567 u
:= e_Textures
[ID
].tx
.u
;
568 v
:= e_Textures
[ID
].tx
.v
;
571 glTexCoord2f(0, v
); glVertex2i(X
, Y
);
572 glTexCoord2f(u
, v
); glVertex2i(X
+ Width
, Y
);
573 glTexCoord2f(u
, 0); glVertex2i(X
+ Width
, Y
+ Height
);
574 glTexCoord2f(0, 0); glVertex2i(X
, Y
+ Height
);
580 procedure e_DrawSizeMirror(ID
: DWORD
; X
, Y
: Integer; Alpha
: Byte; AlphaChannel
: Boolean;
581 Blending
: Boolean; Width
, Height
: Word; Mirror
: TMirrorType
= M_NONE
);
583 if e_NoGraphics
then Exit
;
584 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
586 if (Alpha
> 0) or (AlphaChannel
) or (Blending
) then
591 if (AlphaChannel
) or (Alpha
> 0) then
592 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
595 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255-Alpha
);
598 glBlendFunc(GL_SRC_ALPHA
, GL_ONE
);
600 glEnable(GL_TEXTURE_2D
);
601 glBindTexture(GL_TEXTURE_2D
, e_Textures
[ID
].tx
.id
);
603 drawTxQuad(X
, Y
, Width
, Height
, e_Textures
[ID
].tx
.u
, e_Textures
[ID
].tx
.v
, Mirror
);
609 procedure e_DrawFill(ID
: DWORD
; X
, Y
: Integer; XCount
, YCount
: Word; Alpha
: Integer;
610 AlphaChannel
: Boolean; Blending
: Boolean);
612 X2
, Y2
, dx
, w
, h
: Integer;
615 if e_NoGraphics
then Exit
;
616 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
618 if (Alpha
> 0) or (AlphaChannel
) or (Blending
) then
623 if (AlphaChannel
) or (Alpha
> 0) then
624 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
627 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255-Alpha
);
630 glBlendFunc(GL_SRC_ALPHA
, GL_ONE
);
638 glEnable(GL_TEXTURE_2D
);
639 glBindTexture(GL_TEXTURE_2D
, e_Textures
[ID
].tx
.id
);
641 X2
:= X
+ e_Textures
[ID
].tx
.width
* XCount
;
642 Y2
:= Y
+ e_Textures
[ID
].tx
.height
* YCount
;
644 //k8: this SHOULD work... i hope
645 if (e_Textures
[ID
].tx
.width
= e_Textures
[ID
].tx
.glwidth
) and (e_Textures
[ID
].tx
.height
= e_Textures
[ID
].tx
.glheight
) then
648 glTexCoord2i(0, YCount
); glVertex2i(X
, Y
);
649 glTexCoord2i(XCount
, YCount
); glVertex2i(X2
, Y
);
650 glTexCoord2i(XCount
, 0); glVertex2i(X2
, Y2
);
651 glTexCoord2i(0, 0); glVertex2i(X
, Y2
);
658 u
:= e_Textures
[ID
].tx
.u
;
659 v
:= e_Textures
[ID
].tx
.v
;
660 w
:= e_Textures
[ID
].tx
.width
;
661 h
:= e_Textures
[ID
].tx
.height
;
668 glTexCoord2f(0, v
); glVertex2i(X
, Y
);
669 glTexCoord2f(u
, v
); glVertex2i(X
+w
, Y
);
670 glTexCoord2f(u
, 0); glVertex2i(X
+w
, Y
+h
);
671 glTexCoord2f(0, 0); glVertex2i(X
, Y
+h
);
685 procedure e_DrawAdv(ID
: DWORD
; X
, Y
: Integer; Alpha
: Byte; AlphaChannel
: Boolean;
686 Blending
: Boolean; Angle
: Single; RC
: PPoint
; Mirror
: TMirrorType
= M_NONE
);
688 if e_NoGraphics
then Exit
;
690 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
692 if (Alpha
> 0) or (AlphaChannel
) or (Blending
) then
697 if (AlphaChannel
) or (Alpha
> 0) then
698 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
701 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255-Alpha
);
704 glBlendFunc(GL_SRC_ALPHA
, GL_ONE
);
706 if (Angle
<> 0) and (RC
<> nil) then
709 glTranslatef(X
+RC
.X
, Y
+RC
.Y
, 0);
710 glRotatef(Angle
, 0, 0, 1);
711 glTranslatef(-(X
+RC
.X
), -(Y
+RC
.Y
), 0);
714 glEnable(GL_TEXTURE_2D
);
715 glBindTexture(GL_TEXTURE_2D
, e_Textures
[id
].tx
.id
);
716 glBegin(GL_QUADS
); //0-1 1-1
718 drawTxQuad(X
, Y
, e_Textures
[id
].tx
.width
, e_Textures
[id
].tx
.height
, e_Textures
[ID
].tx
.u
, e_Textures
[ID
].tx
.v
, Mirror
);
727 procedure e_DrawPoint(Size
: Byte; X
, Y
: Integer; Red
, Green
, Blue
: Byte);
729 if e_NoGraphics
then Exit
;
730 glDisable(GL_TEXTURE_2D
);
731 glColor3ub(Red
, Green
, Blue
);
734 if (Size
= 2) or (Size
= 4) then
738 glVertex2f(X
+0.3, Y
+1.0);
741 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
744 procedure e_LineCorrection(var X1
, Y1
, X2
, Y2
: Integer);
746 // Make lines only top-left/bottom-right and top-right/bottom-left
758 // Pixel-perfect hack
766 procedure e_DrawQuad(X1
, Y1
, X2
, Y2
: Integer; Red
, Green
, Blue
: Byte; Alpha
: Byte = 0);
768 nX1
, nY1
, nX2
, nY2
: Integer;
770 if e_NoGraphics
then Exit
;
771 // Only top-left/bottom-right quad
788 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
792 glDisable(GL_TEXTURE_2D
);
793 glColor4ub(Red
, Green
, Blue
, 255-Alpha
);
797 nX1
:= X1
; nY1
:= Y1
;
798 nX2
:= X2
; nY2
:= Y1
;
799 e_LineCorrection(nX1
, nY1
, nX2
, nY2
); // Pixel-perfect lines
800 glVertex2i(nX1
, nY1
);
801 glVertex2i(nX2
, nY2
);
803 nX1
:= X2
; nY1
:= Y1
;
804 nX2
:= X2
; nY2
:= Y2
;
805 e_LineCorrection(nX1
, nY1
, nX2
, nY2
);
806 glVertex2i(nX1
, nY1
);
807 glVertex2i(nX2
, nY2
);
809 nX1
:= X2
; nY1
:= Y2
;
810 nX2
:= X1
; nY2
:= Y2
;
811 e_LineCorrection(nX1
, nY1
, nX2
, nY2
);
812 glVertex2i(nX1
, nY1
);
813 glVertex2i(nX2
, nY2
);
815 nX1
:= X1
; nY1
:= Y2
;
816 nX2
:= X1
; nY2
:= Y1
;
817 e_LineCorrection(nX1
, nY1
, nX2
, nY2
);
818 glVertex2i(nX1
, nY1
);
819 glVertex2i(nX2
, nY2
);
822 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
827 procedure e_DrawFillQuad(X1
, Y1
, X2
, Y2
: Integer; Red
, Green
, Blue
, Alpha
: Byte;
828 Blending
: TBlending
= B_NONE
);
830 if e_NoGraphics
then Exit
;
831 if (Alpha
> 0) or (Blending
<> B_NONE
) then
836 if Blending
= B_BLEND
then
837 glBlendFunc(GL_SRC_ALPHA
, GL_ONE
)
839 if Blending
= B_FILTER
then
840 glBlendFunc(GL_DST_COLOR
, GL_SRC_COLOR
)
842 if Blending
= B_INVERT
then
843 glBlendFunc(GL_ONE_MINUS_DST_COLOR
, GL_ZERO
)
846 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
848 glDisable(GL_TEXTURE_2D
);
849 glColor4ub(Red
, Green
, Blue
, 255-Alpha
);
861 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
867 // ////////////////////////////////////////////////////////////////////////// //
868 procedure e_DarkenQuad (x0
, y0
, x1
, y1
: Integer; a
: Integer);
870 if (a
< 0) then a
:= 0;
871 if (a
> 255) then a
:= 255;
873 glBlendFunc(GL_ZERO
, GL_SRC_ALPHA
);
874 glDisable(GL_TEXTURE_2D
);
875 glColor4ub(0, 0, 0, Byte(255-a
));
882 //glRect(x, y, x+w, y+h);
883 glColor4ub(1, 1, 1, 1);
885 //glBlendEquation(GL_FUNC_ADD);
888 procedure e_DarkenQuadWH (x
, y
, w
, h
: Integer; a
: Integer);
890 if (w
> 0) and (h
> 0) then e_DarkenQuad(x
, y
, x
+w
, y
+h
, a
);
894 procedure e_DrawLine(Width
: Byte; X1
, Y1
, X2
, Y2
: Integer; Red
, Green
, Blue
: Byte; Alpha
: Byte = 0);
896 if e_NoGraphics
then Exit
;
897 // Pixel-perfect lines
899 e_LineCorrection(X1
, Y1
, X2
, Y2
);
904 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
908 glDisable(GL_TEXTURE_2D
);
909 glColor4ub(Red
, Green
, Blue
, 255-Alpha
);
917 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
922 //------------------------------------------------------------------
923 // Óäàëÿåò òåêñòóðó èç ìàññèâà
924 //------------------------------------------------------------------
925 procedure e_DeleteTexture(ID
: DWORD
);
927 if not e_NoGraphics
then
928 glDeleteTextures(1, @e_Textures
[ID
].tx
.id
);
929 e_Textures
[ID
].tx
.id
:= 0;
930 e_Textures
[ID
].tx
.Width
:= 0;
931 e_Textures
[ID
].tx
.Height
:= 0;
934 //------------------------------------------------------------------
935 // Óäàëÿåò âñå òåêñòóðû
936 //------------------------------------------------------------------
937 procedure e_RemoveAllTextures();
941 if e_Textures
= nil then Exit
;
943 for i
:= 0 to High(e_Textures
) do
944 if e_Textures
[i
].tx
.Width
<> 0 then e_DeleteTexture(i
);
948 //------------------------------------------------------------------
950 //------------------------------------------------------------------
951 procedure e_ReleaseEngine();
954 e_RemoveAllTextureFont
;
957 procedure e_BeginRender();
959 if e_NoGraphics
then Exit
;
960 glEnable(GL_ALPHA_TEST
);
961 glAlphaFunc(GL_GREATER
, 0.0);
964 procedure e_Clear(Mask
: TGLbitfield
; Red
, Green
, Blue
: Single); overload
;
966 if e_NoGraphics
then Exit
;
967 glClearColor(Red
, Green
, Blue
, 0);
971 procedure e_Clear(); overload
;
973 if e_NoGraphics
then Exit
;
974 glClearColor(0, 0, 0, 0);
975 glClear(GL_COLOR_BUFFER_BIT
);
978 procedure e_EndRender();
980 if e_NoGraphics
then Exit
;
984 function e_GetGamma(win
: PSDL_Window
): Byte;
986 ramp
: array [0..256*3-1] of Word;
987 rgb
: array [0..2] of Double;
996 if e_NoGraphics
then Exit
;
1001 SDL_GetWindowGammaRamp(win
, @ramp
[0], @ramp
[256], @ramp
[512]);
1010 for j
:= min
to max
- 1 do
1013 B
:= (j
mod 256)/256;
1015 sum
:= sum
+ ln(A
)/ln(B
);
1018 rgb
[i
] := sum
/ count
;
1021 Result
:= 100 - Trunc(((rgb
[0] + rgb
[1] + rgb
[2])/3 - 0.23) * 100/(2.7 - 0.23));
1024 procedure e_SetGamma(win
: PSDL_Window
; Gamma
: Byte);
1026 ramp
: array [0..256*3-1] of Word;
1031 if e_NoGraphics
then Exit
;
1032 g
:= (100 - Gamma
)*(2.7 - 0.23)/100 + 0.23;
1034 for i
:= 0 to 255 do
1036 r
:= Exp(g
* ln(i
/256))*65536;
1037 if r
< 0 then r
:= 0
1038 else if r
> 65535 then r
:= 65535;
1039 ramp
[i
] := trunc(r
);
1040 ramp
[i
+ 256] := trunc(r
);
1041 ramp
[i
+ 512] := trunc(r
);
1044 SDL_SetWindowGammaRamp(win
, @ramp
[0], @ramp
[256], @ramp
[512]);
1047 function e_CharFont_Create(sp
: ShortInt=0): DWORD
;
1051 e_WriteLog('Creating CharFont...', MSG_NOTIFY
);
1055 if e_CharFonts
<> nil then
1056 for i
:= 0 to High(e_CharFonts
) do
1057 if not e_CharFonts
[i
].Live
then
1063 if id
= DWORD(-1) then
1065 SetLength(e_CharFonts
, Length(e_CharFonts
) + 1);
1066 id
:= High(e_CharFonts
);
1069 with e_CharFonts
[id
] do
1071 for i
:= 0 to High(Chars
) do
1085 procedure e_CharFont_AddChar(FontID
: DWORD
; Texture
: Integer; c
: Char; w
: Byte);
1087 with e_CharFonts
[FontID
].Chars
[Ord(c
)] do
1089 TextureID
:= Texture
;
1094 procedure e_CharFont_Print(FontID
: DWORD
; X
, Y
: Integer; Text: string);
1098 if e_NoGraphics
then Exit
;
1099 if Text = '' then Exit
;
1100 if e_CharFonts
= nil then Exit
;
1101 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1103 with e_CharFonts
[FontID
] do
1105 for a
:= 1 to Length(Text) do
1106 with Chars
[Ord(Text[a
])] do
1107 if TextureID
<> -1 then
1109 e_Draw(TextureID
, X
, Y
, 0, True, False);
1110 X
:= X
+Width
+IfThen(a
= Length(Text), 0, Space
);
1115 procedure e_CharFont_PrintEx(FontID
: DWORD
; X
, Y
: Integer; Text: string;
1116 Color
: TRGB
; Scale
: Single = 1.0);
1121 if e_NoGraphics
then Exit
;
1122 if Text = '' then Exit
;
1123 if e_CharFonts
= nil then Exit
;
1124 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1126 with e_CharFonts
[FontID
] do
1128 for a
:= 1 to Length(Text) do
1129 with Chars
[Ord(Text[a
])] do
1130 if TextureID
<> -1 then
1132 if Scale
<> 1.0 then
1135 glScalef(Scale
, Scale
, 0);
1140 e_Draw(TextureID
, X
, Y
, 0, True, False);
1143 if Scale
<> 1.0 then glPopMatrix
;
1145 X
:= X
+Width
+IfThen(a
= Length(Text), 0, Space
);
1150 procedure e_CharFont_PrintFmt(FontID
: DWORD
; X
, Y
: Integer; Text: string);
1152 a
, TX
, TY
, len
: Integer;
1156 if e_NoGraphics
then Exit
;
1157 if Text = '' then Exit
;
1158 if e_CharFonts
= nil then Exit
;
1159 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1167 len
:= Length(Text);
1169 e_CharFont_GetSize(FontID
, 'A', w
, h
);
1171 with e_CharFonts
[FontID
] do
1173 for a
:= 1 to len
do
1184 c
.R
:= 0; c
.G
:= 0; c
.B
:= 0;
1189 c
.R
:= 255; c
.G
:= 255; c
.B
:= 255;
1194 c
.R
:= c
.R
div 2; c
.G
:= c
.G
div 2; c
.B
:= c
.B
div 2;
1199 c
.R
:= Min(c
.R
* 2, 255); c
.G
:= Min(c
.G
* 2, 255); c
.B
:= Min(c
.B
* 2, 255);
1204 c
.R
:= 255; c
.G
:= 0; c
.B
:= 0;
1209 c
.R
:= 0; c
.G
:= 255; c
.B
:= 0;
1214 c
.R
:= 0; c
.G
:= 0; c
.B
:= 255;
1219 c
.R
:= 255; c
.G
:= 255; c
.B
:= 0;
1224 with Chars
[Ord(Text[a
])] do
1225 if TextureID
<> -1 then
1229 e_Draw(TextureID
, TX
, TY
, 0, True, False);
1232 TX
:= TX
+Width
+IfThen(a
= Length(Text), 0, Space
);
1238 procedure e_CharFont_GetSize(FontID
: DWORD
; Text: string; var w
, h
: Word);
1246 if Text = '' then Exit
;
1247 if e_CharFonts
= nil then Exit
;
1248 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1250 with e_CharFonts
[FontID
] do
1252 for a
:= 1 to Length(Text) do
1253 with Chars
[Ord(Text[a
])] do
1254 if TextureID
<> -1 then
1256 w
:= w
+Width
+IfThen(a
= Length(Text), 0, Space
);
1257 e_GetTextureSize(TextureID
, nil, @h2
);
1258 if h2
> h
then h
:= h2
;
1263 procedure e_CharFont_GetSizeFmt(FontID
: DWORD
; Text: string; var w
, h
: Word);
1265 a
, lines
, len
: Integer;
1272 if Text = '' then Exit
;
1273 if e_CharFonts
= nil then Exit
;
1274 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1277 len
:= Length(Text);
1279 with e_CharFonts
[FontID
] do
1281 for a
:= 1 to len
do
1283 if Text[a
] = #10 then
1293 else if Text[a
] in [#1, #2, #3, #4, #18, #19, #20, #21] then
1296 with Chars
[Ord(Text[a
])] do
1297 if TextureID
<> -1 then
1299 w2
:= w2
+ Width
+ IfThen(a
= len
, 0, Space
);
1300 e_GetTextureSize(TextureID
, nil, @h2
);
1301 if h2
> h
then h
:= h2
;
1311 function e_CharFont_GetMaxWidth(FontID
: DWORD
): Word;
1317 if e_CharFonts
= nil then Exit
;
1318 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1320 for a
:= 0 to High(e_CharFonts
[FontID
].Chars
) do
1321 Result
:= Max(Result
, e_CharFonts
[FontID
].Chars
[a
].Width
);
1324 function e_CharFont_GetMaxHeight(FontID
: DWORD
): Word;
1331 if e_CharFonts
= nil then Exit
;
1332 if Integer(FontID
) > High(e_CharFonts
) then Exit
;
1334 for a
:= 0 to High(e_CharFonts
[FontID
].Chars
) do
1336 if e_CharFonts
[FontID
].Chars
[a
].TextureID
<> -1 then
1337 e_GetTextureSize(e_CharFonts
[FontID
].Chars
[a
].TextureID
, nil, @h2
)
1339 if h2
> Result
then Result
:= h2
;
1343 procedure e_CharFont_Remove(FontID
: DWORD
);
1347 with e_CharFonts
[FontID
] do
1348 for a
:= 0 to High(Chars
) do
1349 if Chars
[a
].TextureID
<> -1 then e_DeleteTexture(Chars
[a
].TextureID
);
1351 e_CharFonts
[FontID
].Live
:= False;
1354 procedure e_CharFont_RemoveAll();
1358 if e_CharFonts
= nil then Exit
;
1360 for a
:= 0 to High(e_CharFonts
) do
1361 e_CharFont_Remove(a
);
1366 procedure e_TextureFontBuild(Tex
: DWORD
; var FontID
: DWORD
; XCount
, YCount
: Word;
1373 if e_NoGraphics
then Exit
;
1374 e_WriteLog('Creating texture font...', MSG_NOTIFY
);
1378 if e_TextureFonts
<> nil then
1379 for i
:= 0 to High(e_TextureFonts
) do
1380 if e_TextureFonts
[i
].Base
= 0 then
1386 if id
= DWORD(-1) then
1388 SetLength(e_TextureFonts
, Length(e_TextureFonts
) + 1);
1389 id
:= High(e_TextureFonts
);
1392 with e_TextureFonts
[id
] do
1394 Base
:= glGenLists(XCount
*YCount
);
1395 TextureID
:= e_Textures
[Tex
].tx
.id
;
1396 CharWidth
:= (e_Textures
[Tex
].tx
.Width
div XCount
)+Space
;
1397 CharHeight
:= e_Textures
[Tex
].tx
.Height
div YCount
;
1404 glBindTexture(GL_TEXTURE_2D
, e_Textures
[Tex
].tx
.id
);
1405 for loop1
:= 0 to XCount
*YCount
-1 do
1407 cx
:= (loop1
mod XCount
)/XCount
;
1408 cy
:= (loop1
div YCount
)/YCount
;
1410 glNewList(e_TextureFonts
[id
].Base
+loop1
, GL_COMPILE
);
1412 glTexCoord2f(cx
, 1.0-cy
-1/YCount
);
1413 glVertex2i(0, e_Textures
[Tex
].tx
.Height
div YCount
);
1415 glTexCoord2f(cx
+1/XCount
, 1.0-cy
-1/YCount
);
1416 glVertex2i(e_Textures
[Tex
].tx
.Width
div XCount
, e_Textures
[Tex
].tx
.Height
div YCount
);
1418 glTexCoord2f(cx
+1/XCount
, 1.0-cy
);
1419 glVertex2i(e_Textures
[Tex
].tx
.Width
div XCount
, 0);
1421 glTexCoord2f(cx
, 1.0-cy
);
1424 glTranslated((e_Textures
[Tex
].tx
.Width
div XCount
)+Space
, 0, 0);
1431 procedure e_TextureFontKill(FontID
: DWORD
);
1433 if e_NoGraphics
then Exit
;
1434 glDeleteLists(e_TextureFonts
[FontID
].Base
, 256);
1435 e_TextureFonts
[FontID
].Base
:= 0;
1438 procedure e_TextureFontPrint(X
, Y
: GLint
; Text: string; FontID
: DWORD
);
1440 if e_NoGraphics
then Exit
;
1441 if Integer(FontID
) > High(e_TextureFonts
) then Exit
;
1442 if Text = '' then Exit
;
1444 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
1447 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
1450 glBindTexture(GL_TEXTURE_2D
, e_TextureFonts
[FontID
].TextureID
);
1451 glEnable(GL_TEXTURE_2D
);
1452 glTranslated(x
, y
, 0);
1453 glListBase(DWORD(Integer(e_TextureFonts
[FontID
].Base
)-32));
1454 glCallLists(Length(Text), GL_UNSIGNED_BYTE
, PChar(Text));
1455 glDisable(GL_TEXTURE_2D
);
1458 glDisable(GL_BLEND
);
1461 // god forgive me for this, but i cannot figure out how to do it without lists
1462 procedure e_TextureFontPrintChar(X
, Y
: Integer; Ch
: Char; FontID
: DWORD
; Shadow
: Boolean = False);
1464 if e_NoGraphics
then Exit
;
1469 glColor4ub(0, 0, 0, 128);
1470 glTranslated(X
+1, Y
+1, 0);
1471 glCallLists(1, GL_UNSIGNED_BYTE
, @Ch
);
1476 glColor4ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
, 255);
1477 glTranslated(X
, Y
, 0);
1478 glCallLists(1, GL_UNSIGNED_BYTE
, @Ch
);
1483 procedure e_TextureFontPrintCharEx (X
, Y
: Integer; Ch
: Char; FontID
: DWORD
; Shadow
: Boolean = False);
1485 glBindTexture(GL_TEXTURE_2D
, e_TextureFonts
[FontID
].TextureID
);
1486 glEnable(GL_TEXTURE_2D
);
1487 //glListBase(DWORD(Integer(e_TextureFonts[FontID].Base)-32));
1489 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
1491 e_TextureFontPrintChar(X
, Y
, Ch
, FontID
, Shadow
);
1492 glDisable(GL_TEXTURE_2D
);
1493 glDisable(GL_BLEND
);
1496 function e_TextureFontCharWidth (ch
: Char; FontID
: DWORD
): Integer;
1498 result
:= e_TextureFonts
[FontID
].CharWidth
;
1501 procedure e_TextureFontPrintFmt(X
, Y
: Integer; Text: string; FontID
: DWORD
; Shadow
: Boolean = False);
1503 a
, TX
, TY
, len
: Integer;
1507 if e_NoGraphics
then Exit
;
1508 if Text = '' then Exit
;
1509 if e_TextureFonts
= nil then Exit
;
1510 if Integer(FontID
) > High(e_TextureFonts
) then Exit
;
1518 len
:= Length(Text);
1520 w
:= e_TextureFonts
[FontID
].CharWidth
;
1522 with e_TextureFonts
[FontID
] do
1524 glBindTexture(GL_TEXTURE_2D
, e_TextureFonts
[FontID
].TextureID
);
1525 glEnable(GL_TEXTURE_2D
);
1526 glListBase(DWORD(Integer(e_TextureFonts
[FontID
].Base
)-32));
1528 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
1531 for a
:= 1 to len
do
1542 c
.R
:= 0; c
.G
:= 0; c
.B
:= 0;
1547 c
.R
:= 255; c
.G
:= 255; c
.B
:= 255;
1552 c
.R
:= c
.R
div 2; c
.G
:= c
.G
div 2; c
.B
:= c
.B
div 2;
1557 c
.R
:= Min(c
.R
* 2, 255); c
.G
:= Min(c
.G
* 2, 255); c
.B
:= Min(c
.B
* 2, 255);
1562 c
.R
:= 255; c
.G
:= 0; c
.B
:= 0;
1567 c
.R
:= 0; c
.G
:= 255; c
.B
:= 0;
1572 c
.R
:= 0; c
.G
:= 0; c
.B
:= 255;
1577 c
.R
:= 255; c
.G
:= 255; c
.B
:= 0;
1584 e_TextureFontPrintChar(TX
, TY
, Text[a
], FontID
, Shadow
);
1589 glDisable(GL_TEXTURE_2D
);
1590 glDisable(GL_BLEND
);
1594 procedure e_TextureFontPrintEx(X
, Y
: GLint
; Text: string; FontID
: DWORD
; Red
, Green
,
1595 Blue
: Byte; Scale
: Single; Shadow
: Boolean = False);
1597 if e_NoGraphics
then Exit
;
1598 if Text = '' then Exit
;
1601 glBindTexture(GL_TEXTURE_2D
, e_TextureFonts
[FontID
].TextureID
);
1602 glEnable(GL_TEXTURE_2D
);
1603 glListBase(DWORD(Integer(e_TextureFonts
[FontID
].Base
)-32));
1605 glBlendFunc(GL_SRC_ALPHA
, GL_ONE_MINUS_SRC_ALPHA
);
1610 glColor4ub(0, 0, 0, 128);
1611 glTranslated(x
+1, y
+1, 0);
1612 glScalef(Scale
, Scale
, 0);
1613 glCallLists(Length(Text), GL_UNSIGNED_BYTE
, PChar(Text));
1618 glColor4ub(Red
, Green
, Blue
, 255);
1619 glTranslated(x
, y
, 0);
1620 glScalef(Scale
, Scale
, 0);
1621 glCallLists(Length(Text), GL_UNSIGNED_BYTE
, PChar(Text));
1623 glDisable(GL_TEXTURE_2D
);
1625 glColor3ub(e_Colors
.R
, e_Colors
.G
, e_Colors
.B
);
1626 glDisable(GL_BLEND
);
1629 procedure e_TextureFontGetSize(ID
: DWORD
; out CharWidth
, CharHeight
: Byte);
1633 if e_NoGraphics
then Exit
;
1634 if Integer(ID
) > High(e_TextureFonts
) then
1636 CharWidth
:= e_TextureFonts
[ID
].CharWidth
;
1637 CharHeight
:= e_TextureFonts
[ID
].CharHeight
;
1640 procedure e_RemoveAllTextureFont();
1644 if e_NoGraphics
then Exit
;
1645 if e_TextureFonts
= nil then Exit
;
1647 for i
:= 0 to High(e_TextureFonts
) do
1648 if e_TextureFonts
[i
].Base
<> 0 then
1650 glDeleteLists(e_TextureFonts
[i
].Base
, 256);
1651 e_TextureFonts
[i
].Base
:= 0;
1654 e_TextureFonts
:= nil;
1657 function _RGB(Red
, Green
, Blue
: Byte): TRGB
;
1664 function _Point(X
, Y
: Integer): TPoint2i
;
1670 function _Rect(X
, Y
: Integer; Width
, Height
: Word): TRectWH
;
1674 Result
.Width
:= Width
;
1675 Result
.Height
:= Height
;
1678 function _TRect(L
, T
, R
, B
: LongInt): TRect
;
1687 procedure e_MakeScreenshot (st
: TStream
; Width
, Height
: Word);
1689 pixels
, obuf
, scln
, ps
, pd
: PByte;
1692 i
, x
, y
, res
: Integer;
1693 sign
: array [0..7] of Byte;
1694 hbuf
: array [0..12] of Byte;
1699 if e_NoGraphics
then Exit
;
1702 // first, extract and pack graphics data
1703 if (Width
mod 4) > 0 then Width
:= Width
+4-(Width
mod 4);
1705 GetMem(pixels
, Width
*Height
*3);
1707 FillChar(pixels
^, Width
*Height
*3, 0);
1708 glReadPixels(0, 0, Width
, Height
, GL_RGB
, GL_UNSIGNED_BYTE
, pixels
);
1709 //e_WriteLog('PNG: pixels read', MSG_NOTIFY);
1711 if e_FastScreenshots
then
1714 GetMem(scln
, (Width
*3+1)*Height
);
1718 Inc(ps
, (Width
*3)*(Height
-1));
1719 for i
:= 0 to Height
-1 do
1723 Move(ps
^, pd
^, Width
*3);
1735 obufsize
:= (Width
*3+1)*Height
*2;
1736 GetMem(obuf
, obufsize
);
1741 res
:= compress2(Pointer(obuf
), dlen
, Pointer(pixels
), (Width
*3+1)*Height
, 9);
1742 if res
= Z_OK
then break
;
1743 if res
<> Z_BUF_ERROR
then raise Exception
.Create('can''t pack data for PNG');
1744 obufsize
:= obufsize
*2;
1747 GetMem(obuf
, obufsize
);
1749 //e_WriteLog(Format('PNG: pixels compressed from %d to %d', [Integer(Width*Height*3), Integer(dlen)]), MSG_NOTIFY);
1762 st
.writeBuffer(sign
, 8);
1763 //e_WriteLog('PNG: signature written', MSG_NOTIFY);
1766 writeIntBE(st
, LongWord(13));
1771 st
.writeBuffer(sign
, 4);
1772 crc
:= crc32(0, @sign
[0], 4);
1775 hbuf
[2] := (Width
shr 8) and $ff;
1776 hbuf
[3] := Width
and $ff;
1779 hbuf
[6] := (Height
shr 8) and $ff;
1780 hbuf
[7] := Height
and $ff;
1781 hbuf
[8] := 8; // bit depth
1782 hbuf
[9] := 2; // RGB
1783 hbuf
[10] := 0; // compression method
1784 hbuf
[11] := 0; // filter method
1785 hbuf
[12] := 0; // no interlace
1786 crc
:= crc32(crc
, @hbuf
[0], 13);
1787 st
.writeBuffer(hbuf
, 13);
1788 writeIntBE(st
, crc
);
1789 //e_WriteLog('PNG: header written', MSG_NOTIFY);
1792 writeIntBE(st
, LongWord(dlen
));
1797 st
.writeBuffer(sign
, 4);
1798 crc
:= crc32(0, @sign
[0], 4);
1799 crc
:= crc32(crc
, obuf
, dlen
);
1800 st
.writeBuffer(obuf
^, dlen
);
1801 writeIntBE(st
, crc
);
1802 //e_WriteLog('PNG: image data written', MSG_NOTIFY);
1805 writeIntBE(st
, LongWord(0));
1810 st
.writeBuffer(sign
, 4);
1811 crc
:= crc32(0, @sign
[0], 4);
1812 writeIntBE(st
, crc
);
1813 //e_WriteLog('PNG: end marker written', MSG_NOTIFY);
1815 if obuf
<> nil then FreeMem(obuf
);
1820 Imaging
.SetOption(ImagingPNGCompressLevel
, 9);
1821 Imaging
.SetOption(ImagingPNGPreFilter
, 6);
1824 NewImage(Width
, Height
, TImageFormat
.ifR8G8B8
, img
);
1826 //writeln(stderr, 'moving pixels...');
1827 for y
:= Height
-1 downto 0 do
1829 for x
:= 0 to Width
-1 do
1831 clr
.r
:= ps
^; Inc(ps
);
1832 clr
.g
:= ps
^; Inc(ps
);
1833 clr
.b
:= ps
^; Inc(ps
);
1835 SetPixel32(img
, x
, y
, clr
);
1838 GlobalMetadata
.ClearMetaItems();
1839 GlobalMetadata
.ClearMetaItemsForSaving();
1840 //writeln(stderr, 'compressing image...');
1841 if not SaveImageToStream('png', st
, img
) then raise Exception
.Create('screenshot writing error');
1842 //writeln(stderr, 'done!');