src/engine/e_graphics.pas

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