X-Git-Url: http://deadsoftware.ru/gitweb?a=blobdiff_plain;f=src%2Fengine%2Fe_graphics.pas;h=ef4e6f0b9b69634c3442b2e0bc0bda20c3da377c;hb=a2e634cf318657af3a04f3c0a5caba4c158ac965;hp=b10ae2257b509e9e17ff6662dc6d45386ca36367;hpb=4539facbedd44a516d4a1a169143b93205897663;p=d2df-sdl.git diff --git a/src/engine/e_graphics.pas b/src/engine/e_graphics.pas index b10ae22..ef4e6f0 100644 --- a/src/engine/e_graphics.pas +++ b/src/engine/e_graphics.pas @@ -1,9 +1,10 @@ +{$MODE DELPHI} 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); @@ -62,10 +63,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); @@ -96,19 +98,19 @@ 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; procedure e_Clear(); overload; procedure e_EndRender(); -procedure e_SaveGLContext(); -procedure e_RestoreGLContext(); - 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; @@ -118,9 +120,16 @@ function _TRect(L, T, R, B: LongInt): TRect; var e_Colors: TRGB; + e_NoGraphics: Boolean = False; + e_FastScreenshots: Boolean = true; // it's REALLY SLOW with `false` + implementation +uses + paszlib, crc, utils; + + type TTexture = record //ID: DWORD; @@ -160,18 +169,23 @@ var e_Textures: array of TTexture = nil; e_TextureFonts: array of TTextureFont = nil; e_CharFonts: array of TCharFont; - e_SavedTextures: array of TSavedTexture; + //e_SavedTextures: array of TSavedTexture; //------------------------------------------------------------------ // Èíèöèàëèçèðóåò OpenGL //------------------------------------------------------------------ procedure e_InitGL(); begin - glDisable(GL_DEPTH_TEST); - glEnable(GL_SCISSOR_TEST); + if e_NoGraphics then + begin + e_DummyTextures := True; + Exit; + end; e_Colors.R := 255; e_Colors.G := 255; e_Colors.B := 255; + glDisable(GL_DEPTH_TEST); + glEnable(GL_SCISSOR_TEST); glClearColor(0, 0, 0, 0); end; @@ -180,6 +194,7 @@ var mat: Array [0..15] of GLDouble; begin + if e_NoGraphics then Exit; glLoadIdentity(); glScissor(X, Y, Width, Height); glViewport(X, Y, Width, Height); @@ -283,7 +298,7 @@ begin 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; @@ -292,8 +307,7 @@ 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].Width, e_Textures[find_id].Height, @fmt) then exit; id := find_id; e_Textures[id].Fmt := fmt; @@ -301,7 +315,7 @@ begin 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; @@ -310,7 +324,7 @@ begin find_id := FindTexture(); - if not LoadTextureMemEx(pData, e_Textures[find_id].tx, fX, fY, fWidth, fHeight, @fmt) then exit; + if not LoadTextureMemEx(pData, dataSize, e_Textures[find_id].tx, fX, fY, fWidth, fHeight, @fmt) then exit; e_Textures[find_id].Width := fWidth; e_Textures[find_id].Height := fHeight; @@ -321,6 +335,22 @@ begin 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; + //writeln(' tw=', tw, '; th=', th); + e_Textures[find_id].Width := tw; + e_Textures[find_id].Height := th; + e_Textures[find_id].Fmt := fmt; + ID := find_id; + result := True; +end; + procedure e_GetTextureSize(ID: DWORD; Width, Height: PWord); begin if Width <> nil then Width^ := e_Textures[ID].Width; @@ -337,16 +367,19 @@ var begin w := e_Textures[ID].Width; h := e_Textures[ID].Height; - data := GetMemory(w*h*4); - glEnable(GL_TEXTURE_2D); - glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id); - glGetTexImage(GL_TEXTURE_2D, 0, GL_RGBA, GL_UNSIGNED_BYTE, data); Result.Y := 0; Result.X := 0; Result.Width := w; Result.Height := h; + if e_NoGraphics then Exit; + + data := GetMemory(w*h*4); + glEnable(GL_TEXTURE_2D); + glBindTexture(GL_TEXTURE_2D, e_Textures[ID].tx.id); + glGetTexImage(GL_TEXTURE_2D, 0, GL_RGBA, GL_UNSIGNED_BYTE, data); + for y := h-1 downto 0 do begin lastline := y; @@ -434,6 +467,7 @@ procedure e_Draw(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean; 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 @@ -491,6 +525,7 @@ procedure e_DrawSize(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolea 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 @@ -528,6 +563,7 @@ procedure e_DrawSizeMirror(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: 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 @@ -583,9 +619,10 @@ end; procedure e_DrawFill(ID: DWORD; X, Y: Integer; XCount, YCount: Word; Alpha: Integer; AlphaChannel: Boolean; Blending: Boolean); var - X2, Y2, dx, dy, w, h: Integer; + X2, Y2, dx, w, h: Integer; 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 @@ -660,6 +697,7 @@ procedure e_DrawAdv(ID: DWORD; X, Y: Integer; Alpha: Byte; AlphaChannel: Boolean 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 @@ -726,6 +764,7 @@ end; procedure e_DrawPoint(Size: Byte; X, Y: Integer; Red, Green, Blue: Byte); begin + if e_NoGraphics then Exit; glDisable(GL_TEXTURE_2D); glColor3ub(Red, Green, Blue); glPointSize(Size); @@ -766,6 +805,7 @@ procedure e_DrawQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue: Byte; Alpha: Byt var nX1, nY1, nX2, nY2: Integer; begin + if e_NoGraphics then Exit; // Only top-left/bottom-right quad if X1 > X2 then begin @@ -825,6 +865,7 @@ end; procedure e_DrawFillQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue, Alpha: Byte; Blending: TBlending = B_NONE); begin + if e_NoGraphics then Exit; if (Alpha > 0) or (Blending <> B_NONE) then glEnable(GL_BLEND) else @@ -862,6 +903,7 @@ end; procedure e_DrawLine(Width: Byte; X1, Y1, X2, Y2: Integer; Red, Green, Blue: Byte; Alpha: Byte = 0); begin + if e_NoGraphics then Exit; // Pixel-perfect lines if Width = 1 then e_LineCorrection(X1, Y1, X2, Y2); @@ -892,7 +934,8 @@ end; //------------------------------------------------------------------ procedure e_DeleteTexture(ID: DWORD); begin - glDeleteTextures(1, @e_Textures[ID].tx.id); + 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; @@ -923,97 +966,31 @@ end; procedure e_BeginRender(); begin + if e_NoGraphics then Exit; glEnable(GL_ALPHA_TEST); glAlphaFunc(GL_GREATER, 0.0); end; procedure e_Clear(Mask: TGLbitfield; Red, Green, Blue: Single); overload; begin - glClearColor(Red, Green, Blue, 0); - glClear(Mask); + if e_NoGraphics then Exit; + glClearColor(Red, Green, Blue, 0); + glClear(Mask); end; procedure e_Clear(); overload; begin - glClearColor(0, 0, 0, 0); - glClear(GL_COLOR_BUFFER_BIT); + if e_NoGraphics then Exit; + glClearColor(0, 0, 0, 0); + glClear(GL_COLOR_BUFFER_BIT); end; procedure e_EndRender(); begin + if e_NoGraphics then Exit; glPopMatrix(); end; -procedure e_MakeScreenshot(FileName: String; Width, Height: Word); -begin -end; - -{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 (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; - - 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; @@ -1025,6 +1002,8 @@ var A, B: double; i, j: integer; begin + Result := 0; + if e_NoGraphics then Exit; rgb[0] := 1.0; rgb[1] := 1.0; rgb[2] := 1.0; @@ -1059,6 +1038,7 @@ var r: double; g: double; begin + if e_NoGraphics then Exit; g := (100 - Gamma)*(2.7 - 0.23)/100 + 0.23; for i := 0 to 255 do @@ -1125,6 +1105,7 @@ procedure e_CharFont_Print(FontID: DWORD; X, Y: Integer; Text: string); var a: Integer; begin + if e_NoGraphics then Exit; if Text = '' then Exit; if e_CharFonts = nil then Exit; if Integer(FontID) > High(e_CharFonts) then Exit; @@ -1147,6 +1128,7 @@ var a: Integer; c: TRGB; begin + if e_NoGraphics then Exit; if Text = '' then Exit; if e_CharFonts = nil then Exit; if Integer(FontID) > High(e_CharFonts) then Exit; @@ -1181,6 +1163,7 @@ var tc, c: TRGB; w, h: Word; begin + if e_NoGraphics then Exit; if Text = '' then Exit; if e_CharFonts = nil then Exit; if Integer(FontID) > High(e_CharFonts) then Exit; @@ -1397,6 +1380,7 @@ var cx, cy : real; i, id: DWORD; begin + if e_NoGraphics then Exit; e_WriteLog('Creating texture font...', MSG_NOTIFY); id := DWORD(-1); @@ -1454,56 +1438,16 @@ begin FontID := id; end; -procedure e_TextureFontBuildInPlace(id: DWORD); -var - loop1 : GLuint; - cx, cy : real; - XCount, YCount, Space: Integer; - {i,} Tex: DWORD; -begin - with e_TextureFonts[id] do - begin - Base := glGenLists(XC*YC); - TextureID := e_Textures[Texture].tx.id; - XCount := XC; - YCount := YC; - Space := SPC; - Tex := Texture; - end; - - glBindTexture(GL_TEXTURE_2D, e_Textures[Tex].tx.id); - for loop1 := 0 to XCount*YCount-1 do - begin - cx := (loop1 mod XCount)/XCount; - cy := (loop1 div YCount)/YCount; - - 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); - - glTexCoord2f(cx+1/XCount, 1.0-cy-1/YCount); - glVertex2i(e_Textures[Tex].Width div XCount, e_Textures[Tex].Height div YCount); - - glTexCoord2f(cx+1/XCount, 1.0-cy); - glVertex2i(e_Textures[Tex].Width div XCount, 0); - - glTexCoord2f(cx, 1.0-cy); - glVertex2i(0, 0); - glEnd(); - glTranslated((e_Textures[Tex].Width div XCount)+Space, 0, 0); - glEndList(); - end; -end; - procedure e_TextureFontKill(FontID: DWORD); begin + if e_NoGraphics then Exit; glDeleteLists(e_TextureFonts[FontID].Base, 256); e_TextureFonts[FontID].Base := 0; end; procedure e_TextureFontPrint(X, Y: GLint; Text: string; FontID: DWORD); begin + if e_NoGraphics then Exit; if Integer(FontID) > High(e_TextureFonts) then Exit; if Text = '' then Exit; @@ -1527,6 +1471,7 @@ end; // god forgive me for this, but i cannot figure out how to do it without lists procedure e_TextureFontPrintChar(X, Y: Integer; Ch: Char; FontID: DWORD; Shadow: Boolean = False); begin + if e_NoGraphics then Exit; glPushMatrix; if Shadow then @@ -1545,12 +1490,31 @@ 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; tc, c: TRGB; w: Word; begin + if e_NoGraphics then Exit; if Text = '' then Exit; if e_TextureFonts = nil then Exit; if Integer(FontID) > High(e_TextureFonts) then Exit; @@ -1640,6 +1604,7 @@ end; procedure e_TextureFontPrintEx(X, Y: GLint; Text: string; FontID: DWORD; Red, Green, Blue: Byte; Scale: Single; Shadow: Boolean = False); begin + if e_NoGraphics then Exit; if Text = '' then Exit; glPushMatrix; @@ -1673,6 +1638,9 @@ end; procedure e_TextureFontGetSize(ID: DWORD; var CharWidth, CharHeight: Byte); begin + CharWidth := 16; + CharHeight := 16; + if e_NoGraphics then Exit; if Integer(ID) > High(e_TextureFonts) then Exit; CharWidth := e_TextureFonts[ID].CharWidth; @@ -1683,6 +1651,7 @@ procedure e_RemoveAllTextureFont(); var i: integer; begin + if e_NoGraphics then Exit; if e_TextureFonts = nil then Exit; for i := 0 to High(e_TextureFonts) do @@ -1695,94 +1664,6 @@ begin e_TextureFonts := nil; end; -procedure e_SaveGLContext(); -var - PxLen: Cardinal; - i: Integer; -begin - e_WriteLog('Backing up GL context:', MSG_NOTIFY); - - glPushAttrib(GL_ALL_ATTRIB_BITS); - glPushClientAttrib(GL_CLIENT_ALL_ATTRIB_BITS); - - if e_Textures <> nil then - begin - e_WriteLog(' Backing up textures...', MSG_NOTIFY); - SetLength(e_SavedTextures, Length(e_Textures)); - for i := Low(e_Textures) to High(e_Textures) do - begin - e_SavedTextures[i].Pixels := nil; - if e_Textures[i].Width > 0 then - begin - with e_SavedTextures[i] do - begin - PxLen := 3; - if e_Textures[i].Fmt = GL_RGBA then Inc(PxLen); - Pixels := GetMem(PxLen * e_Textures[i].Width * e_Textures[i].Height); - glBindTexture(GL_TEXTURE_2D, e_Textures[i].tx.id); - glGetTexImage(GL_TEXTURE_2D, 0, e_Textures[i].Fmt, GL_UNSIGNED_BYTE, Pixels); - glBindTexture(GL_TEXTURE_2D, 0); - OldID := e_Textures[i].tx.id; - TexId := i; - end; - end; - end; - end; - - if e_TextureFonts <> nil then - begin - e_WriteLog(' Releasing texturefonts...', MSG_NOTIFY); - for i := 0 to High(e_TextureFonts) do - if e_TextureFonts[i].Base <> 0 then - begin - glDeleteLists(e_TextureFonts[i].Base, 256); - e_TextureFonts[i].Base := 0; - end; - end; -end; - -procedure e_RestoreGLContext(); -var - GLID: GLuint; - i: Integer; -begin - e_WriteLog('Restoring GL context:', MSG_NOTIFY); - - glPopClientAttrib(); - glPopAttrib(); - - if e_SavedTextures <> nil then - begin - e_WriteLog(' Regenerating textures...', MSG_NOTIFY); - for i := Low(e_SavedTextures) to High(e_SavedTextures) do - begin - if e_SavedTextures[i].Pixels <> nil then - with e_SavedTextures[i] do - begin - CreateTexture(e_Textures[TexID].tx, e_Textures[TexID].Width, e_Textures[TexID].Height, e_Textures[TexID].Fmt, Pixels); - //GLID := CreateTexture(e_Textures[TexID].Width, e_Textures[TexID].Height, e_Textures[TexID].Fmt, Pixels); - //e_Textures[TexID].tx := GLID; - FreeMem(Pixels); - end; - end; - end; - - if e_TextureFonts <> nil then - begin - e_WriteLog(' Regenerating texturefonts...', MSG_NOTIFY); - for i := Low(e_TextureFonts) to High(e_TextureFonts) do - with e_TextureFonts[i] do - begin - TextureID := e_Textures[Texture].tx.id; - Base := 0; - e_TextureFontBuildInPlace(i); - end; - end; - - SetLength(e_SavedTextures, 0); -end; - - function _RGB(Red, Green, Blue: Byte): TRGB; begin Result.R := Red; @@ -1812,4 +1693,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 := 0; + 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.