X-Git-Url: http://deadsoftware.ru/gitweb?a=blobdiff_plain;f=src%2Fengine%2Fe_graphics.pas;h=39b6e4330ef71754142a013ee8807501c97805ff;hb=7292fe409145dfcbb2776e34bb64d56e32985b9d;hp=898c208e4bb7e2cc2d75f0481d91cd8851c51c29;hpb=ac201b02f10ef558087d50f6b03b4519ab567558;p=d2df-sdl.git diff --git a/src/engine/e_graphics.pas b/src/engine/e_graphics.pas index 898c208..39b6e43 100644 --- a/src/engine/e_graphics.pas +++ b/src/engine/e_graphics.pas @@ -1,10 +1,25 @@ -{$MODE DELPHI} +(* Copyright (C) DooM 2D:Forever Developers + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) +{$INCLUDE e_amodes.inc} unit e_graphics; interface uses - SysUtils, Math, e_log, e_textures, SDL2, GL, GLExt, MAPDEF; + SysUtils, Classes, Math, e_log, e_textures, SDL2, GL, GLExt, MAPDEF, ImagingTypes, Imaging, ImagingUtility; type TMirrorType=(M_NONE, M_HORIZONTAL, M_VERTICAL); @@ -63,10 +78,11 @@ procedure e_DrawQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue: Byte; Alpha: Byt procedure e_DrawFillQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue, Alpha: Byte; Blending: TBlending = B_NONE); +function e_CreateTextureImg (var img: TImageData; var ID: DWORD): Boolean; function e_CreateTexture(FileName: string; var ID: DWORD): Boolean; function e_CreateTextureEx(FileName: string; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean; -function e_CreateTextureMem(pData: Pointer; var ID: DWORD): Boolean; -function e_CreateTextureMemEx(pData: Pointer; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean; +function e_CreateTextureMem(pData: Pointer; dataSize: LongInt; var ID: DWORD): Boolean; +function e_CreateTextureMemEx(pData: Pointer; dataSize: LongInt; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean; procedure e_GetTextureSize(ID: DWORD; Width, Height: PWord); function e_GetTextureSize2(ID: DWORD): TRectWH; procedure e_DeleteTexture(ID: DWORD); @@ -97,6 +113,9 @@ procedure e_TextureFontPrintFmt(X, Y: GLint; Text: string; FontID: DWORD; Shadow procedure e_TextureFontGetSize(ID: DWORD; var CharWidth, CharHeight: Byte); procedure e_RemoveAllTextureFont(); +function e_TextureFontCharWidth (ch: Char; FontID: DWORD): Integer; +procedure e_TextureFontPrintCharEx (X, Y: Integer; Ch: Char; FontID: DWORD; Shadow: Boolean = False); + procedure e_ReleaseEngine(); procedure e_BeginRender(); procedure e_Clear(Mask: TGLbitfield; Red, Green, Blue: Single); overload; @@ -106,73 +125,30 @@ procedure e_EndRender(); function e_GetGamma(win: PSDL_Window): Byte; procedure e_SetGamma(win: PSDL_Window;Gamma: Byte); -procedure e_MakeScreenshot(FileName: string; Width, Height: Word); +procedure e_MakeScreenshot(st: TStream; Width, Height: Word); function _RGB(Red, Green, Blue: Byte): TRGB; function _Point(X, Y: Integer): TPoint2i; function _Rect(X, Y: Integer; Width, Height: Word): TRectWH; function _TRect(L, T, R, B: LongInt): TRect; +//function e_getTextGLId (ID: DWORD): GLuint; var e_Colors: TRGB; e_NoGraphics: Boolean = False; + e_FastScreenshots: Boolean = true; // it's REALLY SLOW with `false` + implementation -type - LONG = LongInt; - BITMAPINFOHEADER = record - biSize : DWORD; - biWidth : LONG; - biHeight : LONG; - biPlanes : WORD; - biBitCount : WORD; - biCompression : DWORD; - biSizeImage : DWORD; - biXPelsPerMeter : LONG; - biYPelsPerMeter : LONG; - biClrUsed : DWORD; - biClrImportant : DWORD; - end; - LPBITMAPINFOHEADER = ^BITMAPINFOHEADER; - TBITMAPINFOHEADER = BITMAPINFOHEADER; - PBITMAPINFOHEADER = ^BITMAPINFOHEADER; - - RGBQUAD = record - rgbBlue : BYTE; - rgbGreen : BYTE; - rgbRed : BYTE; - rgbReserved : BYTE; - end; - tagRGBQUAD = RGBQUAD; - TRGBQUAD = RGBQUAD; - PRGBQUAD = ^RGBQUAD; +uses + paszlib, crc, utils; - BITMAPINFO = record - bmiHeader : BITMAPINFOHEADER; - bmiColors : array[0..0] of RGBQUAD; - end; - LPBITMAPINFO = ^BITMAPINFO; - PBITMAPINFO = ^BITMAPINFO; - TBITMAPINFO = BITMAPINFO; - - BITMAPFILEHEADER = packed record - bfType : Word; - bfSize : DWord; - bfReserved1 : Word; - bfReserved2 : Word; - bfOffBits : DWord; - end; - tagBITMAPFILEHEADER = BITMAPFILEHEADER; type TTexture = record - //ID: DWORD; tx: GLTexture; - Width: Word; - Height: Word; - Fmt: Word; end; TTextureFont = record @@ -207,6 +183,8 @@ var e_CharFonts: array of TCharFont; //e_SavedTextures: array of TSavedTexture; +//function e_getTextGLId (ID: DWORD): GLuint; begin result := e_Textures[ID].tx.id; end; + //------------------------------------------------------------------ // Èíèöèàëèçèðóåò OpenGL //------------------------------------------------------------------ @@ -273,7 +251,7 @@ var begin if e_Textures <> nil then for i := 0 to High(e_Textures) do - if e_Textures[i].Width = 0 then + if e_Textures[i].tx.Width = 0 then begin Result := i; Exit; @@ -305,11 +283,10 @@ begin find_id := FindTexture(); - if not LoadTexture(FileName, e_Textures[find_id].tx, e_Textures[find_id].Width, - e_Textures[find_id].Height, @fmt) then Exit; + if not LoadTexture(FileName, e_Textures[find_id].tx, e_Textures[find_id].tx.Width, + e_Textures[find_id].tx.Height, @fmt) then Exit; ID := find_id; - e_Textures[ID].Fmt := fmt; Result := True; end; @@ -325,16 +302,12 @@ begin if not LoadTextureEx(FileName, e_Textures[find_id].tx, fX, fY, fWidth, fHeight, @fmt) then exit; - e_Textures[find_id].Width := fWidth; - e_Textures[find_id].Height := fHeight; - e_Textures[find_id].Fmt := fmt; - ID := find_id; Result := True; end; -function e_CreateTextureMem(pData: Pointer; var ID: DWORD): Boolean; +function e_CreateTextureMem(pData: Pointer; dataSize: LongInt; var ID: DWORD): Boolean; var find_id: DWORD; fmt: Word; @@ -343,16 +316,14 @@ begin find_id := FindTexture; - if not LoadTextureMem(pData, e_Textures[find_id].tx, e_Textures[find_id].Width, - e_Textures[find_id].Height, @fmt) then exit; + 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; id := find_id; - e_Textures[id].Fmt := fmt; Result := True; end; -function e_CreateTextureMemEx(pData: Pointer; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean; +function e_CreateTextureMemEx(pData: Pointer; dataSize: LongInt; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean; var find_id: DWORD; fmt: Word; @@ -361,21 +332,29 @@ begin find_id := FindTexture(); - if not LoadTextureMemEx(pData, e_Textures[find_id].tx, fX, fY, fWidth, fHeight, @fmt) then exit; - - e_Textures[find_id].Width := fWidth; - e_Textures[find_id].Height := fHeight; - e_Textures[find_id].Fmt := fmt; + if not LoadTextureMemEx(pData, dataSize, e_Textures[find_id].tx, fX, fY, fWidth, fHeight, @fmt) then exit; ID := find_id; Result := True; end; +function e_CreateTextureImg (var img: TImageData; var ID: DWORD): Boolean; +var + find_id: DWORD; + fmt, tw, th: Word; +begin + result := false; + find_id := FindTexture(); + if not LoadTextureImg(img, e_Textures[find_id].tx, tw, th, @fmt) then exit; + ID := find_id; + result := True; +end; + procedure e_GetTextureSize(ID: DWORD; Width, Height: PWord); begin - if Width <> nil then Width^ := e_Textures[ID].Width; - if Height <> nil then Height^ := e_Textures[ID].Height; + if Width <> nil then Width^ := e_Textures[ID].tx.Width; + if Height <> nil then Height^ := e_Textures[ID].tx.Height; end; function e_GetTextureSize2(ID: DWORD): TRectWH; @@ -386,8 +365,8 @@ var a: Boolean; lastline: Integer; begin - w := e_Textures[ID].Width; - h := e_Textures[ID].Height; + w := e_Textures[ID].tx.Width; + h := e_Textures[ID].tx.Height; Result.Y := 0; Result.X := 0; @@ -483,10 +462,23 @@ begin e_SetViewPort(0, 0, Width, Height); end; +procedure drawTxQuad (x0, y0, w, h: Integer; u, v: single; Mirror: TMirrorType); +var + x1, y1, tmp: Integer; +begin + if (w < 1) or (h < 1) then exit; + x1 := x0+w; + y1 := y0+h; + if Mirror = M_HORIZONTAL then begin tmp := x1; x1 := x0; x0 := tmp; end + else if Mirror = M_VERTICAL then begin tmp := y1; y1 := y0; y0 := tmp; end; + glTexCoord2f(0, v); glVertex2i(x0, y0); + glTexCoord2f(0, 0); glVertex2i(x0, y1); + glTexCoord2f(u, 0); glVertex2i(x1, y1); + glTexCoord2f(u, v); glVertex2i(x1, y0); +end; + procedure e_Draw(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean; Blending: Boolean; Mirror: TMirrorType = M_NONE); -var - u, v: Single; begin if e_NoGraphics then Exit; glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255); @@ -509,32 +501,36 @@ begin glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id); glBegin(GL_QUADS); - u := e_Textures[ID].tx.u; - v := e_Textures[ID].tx.v; + drawTxQuad(X, Y, e_Textures[id].tx.width, e_Textures[id].tx.height, e_Textures[ID].tx.u, e_Textures[ID].tx.v, Mirror); + //u := e_Textures[ID].tx.u; + //v := e_Textures[ID].tx.v; + + { if Mirror = M_NONE then begin - glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].Width, Y); + glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].tx.Width, Y); glTexCoord2f(0, 0); glVertex2i(X, Y); - glTexCoord2f(0, -v); glVertex2i(X, Y + e_Textures[id].Height); - glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].Width, Y + e_Textures[id].Height); + glTexCoord2f(0, -v); glVertex2i(X, Y + e_Textures[id].tx.Height); + glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].tx.Width, Y + e_Textures[id].tx.Height); end else if Mirror = M_HORIZONTAL then begin glTexCoord2f(u, 0); glVertex2i(X, Y); - glTexCoord2f(0, 0); glVertex2i(X + e_Textures[id].Width, Y); - glTexCoord2f(0, -v); glVertex2i(X + e_Textures[id].Width, Y + e_Textures[id].Height); - glTexCoord2f(u, -v); glVertex2i(X, Y + e_Textures[id].Height); + glTexCoord2f(0, 0); glVertex2i(X + e_Textures[id].tx.Width, Y); + glTexCoord2f(0, -v); glVertex2i(X + e_Textures[id].tx.Width, Y + e_Textures[id].tx.Height); + glTexCoord2f(u, -v); glVertex2i(X, Y + e_Textures[id].tx.Height); end else if Mirror = M_VERTICAL then begin - glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].Width, Y); + glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].tx.Width, Y); glTexCoord2f(0, -v); glVertex2i(X, Y); - glTexCoord2f(0, 0); glVertex2i(X, Y + e_Textures[id].Height); - glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].Width, Y + e_Textures[id].Height); + glTexCoord2f(0, 0); glVertex2i(X, Y + e_Textures[id].tx.Height); + glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].tx.Width, Y + e_Textures[id].tx.Height); end; + } glEnd(); @@ -581,8 +577,6 @@ end; procedure e_DrawSizeMirror(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean; Blending: Boolean; Width, Height: Word; Mirror: TMirrorType = M_NONE); -var - u, v: Single; begin if e_NoGraphics then Exit; glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255); @@ -604,34 +598,7 @@ begin glEnable(GL_TEXTURE_2D); glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id); glBegin(GL_QUADS); - - u := e_Textures[ID].tx.u; - v := e_Textures[ID].tx.v; - - if Mirror = M_NONE then - begin - glTexCoord2f(u, 0); glVertex2i(X + Width, Y); - glTexCoord2f(0, 0); glVertex2i(X, Y); - glTexCoord2f(0, -v); glVertex2i(X, Y + Height); - glTexCoord2f(u, -v); glVertex2i(X + Width, Y + Height); - end - else - if Mirror = M_HORIZONTAL then - begin - glTexCoord2f(u, 0); glVertex2i(X, Y); - glTexCoord2f(0, 0); glVertex2i(X + Width, Y); - glTexCoord2f(0, -v); glVertex2i(X + Width, Y + Height); - glTexCoord2f(u, -v); glVertex2i(X, Y + Height); - end - else - if Mirror = M_VERTICAL then - begin - glTexCoord2f(u, -v); glVertex2i(X + Width, Y); - glTexCoord2f(0, -v); glVertex2i(X, Y); - glTexCoord2f(0, 0); glVertex2i(X, Y + Height); - glTexCoord2f(u, 0); glVertex2i(X + Width, Y + Height); - end; - + drawTxQuad(X, Y, Width, Height, e_Textures[ID].tx.u, e_Textures[ID].tx.v, Mirror); glEnd(); glDisable(GL_BLEND); @@ -669,8 +636,8 @@ begin glEnable(GL_TEXTURE_2D); glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id); - X2 := X + e_Textures[ID].Width * XCount; - Y2 := Y + e_Textures[ID].Height * YCount; + X2 := X + e_Textures[ID].tx.width * XCount; + Y2 := Y + e_Textures[ID].tx.height * YCount; //k8: this SHOULD work... i hope if (e_Textures[ID].tx.width = e_Textures[ID].tx.glwidth) and (e_Textures[ID].tx.height = e_Textures[ID].tx.glheight) then @@ -715,10 +682,9 @@ end; procedure e_DrawAdv(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean; Blending: Boolean; Angle: Single; RC: PPoint; Mirror: TMirrorType = M_NONE); -var - u, v: Single; begin if e_NoGraphics then Exit; + glColor4ub(e_Colors.R, e_Colors.G, e_Colors.B, 255); if (Alpha > 0) or (AlphaChannel) or (Blending) then @@ -747,34 +713,7 @@ begin glBindTexture(GL_TEXTURE_2D, e_Textures[id].tx.id); glBegin(GL_QUADS); //0-1 1-1 //00 10 - - u := e_Textures[ID].tx.u; - v := e_Textures[ID].tx.v; - - if Mirror = M_NONE then - begin - glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].Width, Y); - glTexCoord2f(0, 0); glVertex2i(X, Y); - glTexCoord2f(0, -v); glVertex2i(X, Y + e_Textures[id].Height); - glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].Width, Y + e_Textures[id].Height); - end - else - if Mirror = M_HORIZONTAL then - begin - glTexCoord2f(u, 0); glVertex2i(X, Y); - glTexCoord2f(0, 0); glVertex2i(X + e_Textures[id].Width, Y); - glTexCoord2f(0, -v); glVertex2i(X + e_Textures[id].Width, Y + e_Textures[id].Height); - glTexCoord2f(u, -v); glVertex2i(X, Y + e_Textures[id].Height); - end - else - if Mirror = M_VERTICAL then - begin - glTexCoord2f(u, -v); glVertex2i(X + e_Textures[id].Width, Y); - glTexCoord2f(0, -v); glVertex2i(X, Y); - glTexCoord2f(0, 0); glVertex2i(X, Y + e_Textures[id].Height); - glTexCoord2f(u, 0); glVertex2i(X + e_Textures[id].Width, Y + e_Textures[id].Height); - end; - + drawTxQuad(X, Y, e_Textures[id].tx.width, e_Textures[id].tx.height, e_Textures[ID].tx.u, e_Textures[ID].tx.v, Mirror); glEnd(); if Angle <> 0 then @@ -958,8 +897,8 @@ begin if not e_NoGraphics then glDeleteTextures(1, @e_Textures[ID].tx.id); e_Textures[ID].tx.id := 0; - e_Textures[ID].Width := 0; - e_Textures[ID].Height := 0; + e_Textures[ID].tx.Width := 0; + e_Textures[ID].tx.Height := 0; end; //------------------------------------------------------------------ @@ -972,7 +911,7 @@ begin if e_Textures = nil then Exit; for i := 0 to High(e_Textures) do - if e_Textures[i].Width <> 0 then e_DeleteTexture(i); + if e_Textures[i].tx.Width <> 0 then e_DeleteTexture(i); e_Textures := nil; end; @@ -1012,73 +951,6 @@ begin glPopMatrix(); end; -procedure e_MakeScreenshot(FileName: String; Width, Height: Word); -type - aRGB = Array [0..1] of TRGB; - PaRGB = ^aRGB; - TByteArray = Array [0..1] of Byte; - PByteArray = ^TByteArray; -var - FILEHEADER: BITMAPFILEHEADER; - INFOHEADER: BITMAPINFOHEADER; - pixels: PByteArray; - tmp: Byte; - i: Integer; - F: File of Byte; -begin - if e_NoGraphics then Exit; - - if (Width mod 4) > 0 then - Width := Width + 4 - (Width mod 4); - - GetMem(pixels, Width*Height*3); - glReadPixels(0, 0, Width, Height, GL_RGB, GL_UNSIGNED_BYTE, pixels); - - for i := 0 to Width * Height - 1 do - with PaRGB(pixels)[i] do - begin - tmp := R; - R := B; - B := tmp; - end; - - with FILEHEADER do - begin - bfType := $4D42; // "BM" - bfSize := Width*Height*3 + SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER); - bfReserved1 := 0; - bfReserved2 := 0; - bfOffBits := SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER); - end; - - with INFOHEADER do - begin - biSize := SizeOf(BITMAPINFOHEADER); - biWidth := Width; - biHeight := Height; - biPlanes := 1; - biBitCount := 24; - biCompression := 0; - biSizeImage := Width*Height*3; - biXPelsPerMeter := 0; - biYPelsPerMeter := 0; - biClrUsed := 0; - biClrImportant := 0; - end; - - //writeln('shot: ', FileName); - AssignFile(F, FileName); - Rewrite(F); - - BlockWrite(F, FILEHEADER, SizeOf(FILEHEADER)); - BlockWrite(F, INFOHEADER, SizeOf(INFOHEADER)); - BlockWrite(F, pixels[0], Width*Height*3); - - CloseFile(F); - - FreeMem(pixels); -end; - function e_GetGamma(win: PSDL_Window): Byte; var ramp: array [0..256*3-1] of Word; @@ -1491,8 +1363,8 @@ begin begin Base := glGenLists(XCount*YCount); TextureID := e_Textures[Tex].tx.id; - CharWidth := (e_Textures[Tex].Width div XCount)+Space; - CharHeight := e_Textures[Tex].Height div YCount; + CharWidth := (e_Textures[Tex].tx.Width div XCount)+Space; + CharHeight := e_Textures[Tex].tx.Height div YCount; XC := XCount; YC := YCount; Texture := Tex; @@ -1508,18 +1380,18 @@ begin glNewList(e_TextureFonts[id].Base+loop1, GL_COMPILE); glBegin(GL_QUADS); glTexCoord2f(cx, 1.0-cy-1/YCount); - glVertex2d(0, e_Textures[Tex].Height div YCount); + glVertex2i(0, e_Textures[Tex].tx.Height div YCount); glTexCoord2f(cx+1/XCount, 1.0-cy-1/YCount); - glVertex2i(e_Textures[Tex].Width div XCount, e_Textures[Tex].Height div YCount); + glVertex2i(e_Textures[Tex].tx.Width div XCount, e_Textures[Tex].tx.Height div YCount); glTexCoord2f(cx+1/XCount, 1.0-cy); - glVertex2i(e_Textures[Tex].Width div XCount, 0); + glVertex2i(e_Textures[Tex].tx.Width div XCount, 0); glTexCoord2f(cx, 1.0-cy); glVertex2i(0, 0); glEnd(); - glTranslated((e_Textures[Tex].Width div XCount)+Space, 0, 0); + glTranslated((e_Textures[Tex].tx.Width div XCount)+Space, 0, 0); glEndList(); end; @@ -1578,6 +1450,24 @@ begin glPopMatrix; end; +procedure e_TextureFontPrintCharEx (X, Y: Integer; Ch: Char; FontID: DWORD; Shadow: Boolean = False); +begin + glBindTexture(GL_TEXTURE_2D, e_TextureFonts[FontID].TextureID); + glEnable(GL_TEXTURE_2D); + //glListBase(DWORD(Integer(e_TextureFonts[FontID].Base)-32)); + + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + glEnable(GL_BLEND); + e_TextureFontPrintChar(X, Y, Ch, FontID, Shadow); + glDisable(GL_TEXTURE_2D); + glDisable(GL_BLEND); +end; + +function e_TextureFontCharWidth (ch: Char; FontID: DWORD): Integer; +begin + result := e_TextureFonts[FontID].CharWidth; +end; + procedure e_TextureFontPrintFmt(X, Y: Integer; Text: string; FontID: DWORD; Shadow: Boolean = False); var a, TX, TY, len: Integer; @@ -1763,4 +1653,171 @@ begin Result.Bottom := B; end; + +procedure e_MakeScreenshot (st: TStream; Width, Height: Word); +var + pixels, obuf, scln, ps, pd: PByte; + obufsize: Integer; + dlen: Cardinal; + i, x, y, res: Integer; + sign: array [0..7] of Byte; + hbuf: array [0..12] of Byte; + crc: LongWord; + img: TImageData; + clr: TColor32Rec; +begin + if e_NoGraphics then Exit; + obuf := nil; + + // first, extract and pack graphics data + if (Width mod 4) > 0 then Width := Width+4-(Width mod 4); + + GetMem(pixels, Width*Height*3); + try + FillChar(pixels^, Width*Height*3, 0); + glReadPixels(0, 0, Width, Height, GL_RGB, GL_UNSIGNED_BYTE, pixels); + //e_WriteLog('PNG: pixels read', MSG_NOTIFY); + + if e_FastScreenshots then + begin + // create scanlines + GetMem(scln, (Width*3+1)*Height); + try + ps := pixels; + pd := scln; + Inc(ps, (Width*3)*(Height-1)); + for i := 0 to Height-1 do + begin + pd^ := 0; // filter + Inc(pd); + Move(ps^, pd^, Width*3); + Dec(ps, Width*3); + Inc(pd, Width*3); + end; + except + FreeMem(scln); + raise; + end; + FreeMem(pixels); + pixels := scln; + + // pack it + obufsize := (Width*3+1)*Height*2; + GetMem(obuf, obufsize); + try + while true do + begin + dlen := obufsize; + res := compress2(Pointer(obuf), dlen, Pointer(pixels), (Width*3+1)*Height, 9); + if res = Z_OK then break; + if res <> Z_BUF_ERROR then raise Exception.Create('can''t pack data for PNG'); + obufsize := obufsize*2; + FreeMem(obuf); + obuf := nil; + GetMem(obuf, obufsize); + end; + //e_WriteLog(Format('PNG: pixels compressed from %d to %d', [Integer(Width*Height*3), Integer(dlen)]), MSG_NOTIFY); + + // now write PNG + + // signature + sign[0] := 137; + sign[1] := 80; + sign[2] := 78; + sign[3] := 71; + sign[4] := 13; + sign[5] := 10; + sign[6] := 26; + sign[7] := 10; + st.writeBuffer(sign, 8); + //e_WriteLog('PNG: signature written', MSG_NOTIFY); + + // header + writeIntBE(st, LongWord(13)); + sign[0] := 73; + sign[1] := 72; + sign[2] := 68; + sign[3] := 82; + st.writeBuffer(sign, 4); + crc := crc32(0, @sign, 4); + hbuf[0] := 0; + hbuf[1] := 0; + hbuf[2] := (Width shr 8) and $ff; + hbuf[3] := Width and $ff; + hbuf[4] := 0; + hbuf[5] := 0; + hbuf[6] := (Height shr 8) and $ff; + hbuf[7] := Height and $ff; + hbuf[8] := 8; // bit depth + hbuf[9] := 2; // RGB + hbuf[10] := 0; // compression method + hbuf[11] := 0; // filter method + hbuf[12] := 0; // no interlace + crc := crc32(crc, @hbuf, 13); + st.writeBuffer(hbuf, 13); + writeIntBE(st, crc); + //e_WriteLog('PNG: header written', MSG_NOTIFY); + + // image data + writeIntBE(st, LongWord(dlen)); + sign[0] := 73; + sign[1] := 68; + sign[2] := 65; + sign[3] := 84; + st.writeBuffer(sign, 4); + crc := crc32(0, @sign, 4); + crc := crc32(crc, obuf, dlen); + st.writeBuffer(obuf^, dlen); + writeIntBE(st, crc); + //e_WriteLog('PNG: image data written', MSG_NOTIFY); + + // image data end + writeIntBE(st, LongWord(0)); + sign[0] := 73; + sign[1] := 69; + sign[2] := 78; + sign[3] := 68; + st.writeBuffer(sign, 4); + crc := crc32(0, @sign, 4); + writeIntBE(st, crc); + //e_WriteLog('PNG: end marker written', MSG_NOTIFY); + finally + if obuf <> nil then FreeMem(obuf); + end; + end + else + begin + Imaging.SetOption(ImagingPNGCompressLevel, 9); + Imaging.SetOption(ImagingPNGPreFilter, 6); + InitImage(img); + try + NewImage(Width, Height, TImageFormat.ifR8G8B8, img); + ps := pixels; + //writeln(stderr, 'moving pixels...'); + for y := Height-1 downto 0 do + begin + for x := 0 to Width-1 do + begin + clr.r := ps^; Inc(ps); + clr.g := ps^; Inc(ps); + clr.b := ps^; Inc(ps); + clr.a := 255; + SetPixel32(img, x, y, clr); + end; + end; + GlobalMetadata.ClearMetaItems(); + GlobalMetadata.ClearMetaItemsForSaving(); + //writeln(stderr, 'compressing image...'); + if not SaveImageToStream('png', st, img) then raise Exception.Create('screenshot writing error'); + //writeln(stderr, 'done!'); + finally + FreeImage(img); + end; + end; + finally + FreeMem(pixels); + end; +end; + + end.