home *** CD-ROM | disk | FTP | other *** search
/ Chip 2005 November / CDVD1105.ISO / Software / Freeware / programare / graphics32 / GR32.pas < prev    next >
Pascal/Delphi Source File  |  2005-02-26  |  134KB  |  5,041 lines
  1. unit GR32;
  2.  
  3. (* ***** BEGIN LICENSE BLOCK *****
  4.  * Version: MPL 1.1
  5.  *
  6.  * The contents of this file are subject to the Mozilla Public License Version
  7.  * 1.1 (the "License"); you may not use this file except in compliance with
  8.  * the License. You may obtain a copy of the License at
  9.  * http://www.mozilla.org/MPL/
  10.  *
  11.  * Software distributed under the License is distributed on an "AS IS" basis,
  12.  * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  13.  * for the specific language governing rights and limitations under the
  14.  * License.
  15.  *
  16.  * The Original Code is Graphics32
  17.  *
  18.  * The Initial Developer of the Original Code is
  19.  * Alex A. Denisov
  20.  *
  21.  * Portions created by the Initial Developer are Copyright (C) 2000-2004
  22.  * the Initial Developer. All Rights Reserved.
  23.  *
  24.  * Contributor(s):
  25.  *   Michael Hansen <dyster_tid@hotmail.com>
  26.  *   Andre Beckedorf <Andre@metaException.de>
  27.  *   Mattias Andersson <mattias@centaurix.com>
  28.  *   J. Tulach <tulach@position.cz>
  29.  *
  30.  * ***** END LICENSE BLOCK ***** *)
  31.  
  32. interface
  33.  
  34. {$I GR32.inc}
  35.  
  36. uses
  37. {$IFDEF CLX}
  38.   Qt, Types,
  39.   {$IFDEF LINUX}Libc,{$ENDIF}
  40.   {$IFDEF MSWINDOWS}Windows,{$ENDIF}
  41.   QControls, QGraphics, QConsts,
  42. {$ELSE}
  43.   Windows, Messages, Controls, Graphics,
  44. {$ENDIF}
  45.   Classes, SysUtils;
  46.  
  47. { Version Control }
  48.  
  49. const
  50.   Graphics32Version = '1.7.1';
  51.  
  52. { 32-bit Color }
  53.  
  54. type
  55.   PColor32 = ^TColor32;
  56.   TColor32 = type Cardinal;
  57.  
  58.   PColor32Array = ^TColor32Array;
  59.   TColor32Array = array [0..0] of TColor32;
  60.   TArrayOfColor32 = array of TColor32;
  61.  
  62.   PPalette32 = ^TPalette32;
  63.   TPalette32 = array [Byte] of TColor32;
  64.  
  65. const
  66.   // Some predefined color constants
  67.   clBlack32               = TColor32($FF000000);
  68.   clDimGray32             = TColor32($FF3F3F3F);
  69.   clGray32                = TColor32($FF7F7F7F);
  70.   clLightGray32           = TColor32($FFBFBFBF);
  71.   clWhite32               = TColor32($FFFFFFFF);
  72.   clMaroon32              = TColor32($FF7F0000);
  73.   clGreen32               = TColor32($FF007F00);
  74.   clOlive32               = TColor32($FF7F7F00);
  75.   clNavy32                = TColor32($FF00007F);
  76.   clPurple32              = TColor32($FF7F007F);
  77.   clTeal32                = TColor32($FF007F7F);
  78.   clRed32                 = TColor32($FFFF0000);
  79.   clLime32                = TColor32($FF00FF00);
  80.   clYellow32              = TColor32($FFFFFF00);
  81.   clBlue32                = TColor32($FF0000FF);
  82.   clFuchsia32             = TColor32($FFFF00FF);
  83.   clAqua32                = TColor32($FF00FFFF);
  84.  
  85.   // Some semi-transparent color constants
  86.   clTrWhite32             = TColor32($7FFFFFFF);
  87.   clTrBlack32             = TColor32($7F000000);
  88.   clTrRed32               = TColor32($7FFF0000);
  89.   clTrGreen32             = TColor32($7F00FF00);
  90.   clTrBlue32              = TColor32($7F0000FF);
  91.  
  92. // Color construction and conversion functions
  93. function Color32(WinColor: TColor): TColor32; overload;
  94. function Color32(R, G, B: Byte; A: Byte = $FF): TColor32; overload;
  95. function Color32(Index: Byte; var Palette: TPalette32): TColor32; overload;
  96. function Gray32(Intensity: Byte; Alpha: Byte = $FF): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
  97. function WinColor(Color32: TColor32): TColor;
  98. function ArrayOfColor32(Colors: array of TColor32): TArrayOfColor32;
  99.  
  100. // Color component access
  101. procedure Color32ToRGB(Color32: TColor32; var R, G, B: Byte);
  102. procedure Color32ToRGBA(Color32: TColor32; var R, G, B, A: Byte);
  103. function RedComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF}
  104. function GreenComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF}
  105. function BlueComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF}
  106. function AlphaComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF}
  107. function Intensity(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF}
  108. function SetAlpha(Color32: TColor32; NewAlpha: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
  109.  
  110. // Color space conversion
  111. function HSLtoRGB(H, S, L: Single): TColor32;
  112. procedure RGBtoHSL(RGB: TColor32; out H, S, L : Single);
  113.  
  114. {$IFNDEF CLX}
  115. // Palette conversion functions
  116. function WinPalette(const P: TPalette32): HPALETTE;
  117. {$ENDIF}
  118.  
  119. { A fixed-point type }
  120.  
  121. type
  122.   // this type has data bits arrangement compatible with Windows.TFixed
  123.   TFixed = type Integer;
  124.   PFixed = ^TFixed;
  125.  
  126.   // a little bit of fixed point math
  127.   function Fixed(S: Single): TFixed; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  128.   function Fixed(I: Integer): TFixed; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  129.   function FixedFloor(A: TFixed): Integer;
  130.   function FixedCeil(A: TFixed): Integer;
  131.   function FixedMul(A, B: TFixed): TFixed;
  132.   function FixedDiv(A, B: TFixed): TFixed;
  133.   function FixedRound(A: TFixed): Integer;
  134.  
  135. { Fixedmath related constants }
  136.  
  137. const
  138.   FixedOne = $10000;
  139.   FixedPI  = Round( PI * FixedOne );
  140.   FixedToFloat = 1/FixedOne;
  141.  
  142. { Points }
  143.  
  144. type
  145. {$IFNDEF BCB}
  146.   TPoint = {$IFDEF CLX}Types{$ELSE}Windows{$ENDIF}.TPoint;
  147. {$ENDIF}
  148.   PPoint = ^TPoint;
  149.   TFloatPoint = record
  150.     X, Y: Single;
  151.   end;
  152.   PFloatPoint = ^TFloatPoint;
  153.   TFixedPoint = record
  154.     X, Y: TFixed;
  155.   end;
  156.   PFixedPoint = ^TFixedPoint;
  157.   TArrayOfPoint = array of TPoint;
  158.   TArrayOfArrayOfPoint = array of TArrayOfPoint;
  159.   TArrayOfFloatPoint = array of TFloatPoint;
  160.   TArrayOfArrayOfFloatPoint = array of TArrayOfFloatPoint;
  161.   TArrayOfFixedPoint = array of TFixedPoint;
  162.   TArrayOfArrayOfFixedPoint = array of TArrayOfFixedPoint;
  163.  
  164. // construction and conversion of point types
  165. function Point(X, Y: Integer): TPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  166. function Point(const FP: TFloatPoint): TPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  167. function Point(const FXP: TFixedPoint): TPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  168. function FloatPoint(X, Y: Single): TFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  169. function FloatPoint(const P: TPoint): TFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  170. function FloatPoint(const FXP: TFixedPoint): TFloatPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  171. function FixedPoint(X, Y: Integer): TFixedPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  172. function FixedPoint(X, Y: Single): TFixedPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  173. function FixedPoint(const P: TPoint): TFixedPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  174. function FixedPoint(const FP: TFloatPoint): TFixedPoint; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  175.  
  176. { Rectangles }
  177.  
  178. type
  179.   TFloatRect = packed record
  180.     case Integer of
  181.       0: (Left, Top, Right, Bottom: Single);
  182.       1: (TopLeft, BottomRight: TFloatPoint);
  183.   end;
  184.   TFixedRect = packed record
  185.     case Integer of
  186.       0: (Left, Top, Right, Bottom: TFixed);
  187.       1: (TopLeft, BottomRight: TFixedPoint);
  188.   end;
  189.   TRectRounding = (rrClosest, rrOutside, rrInside);
  190.  
  191. // Rectangle construction/conversion functions
  192. function MakeRect(const L, T, R, B: Integer): TRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  193. function MakeRect(const FR: TFloatRect; Rounding: TRectRounding = rrClosest): TRect; overload;
  194. function MakeRect(const FXR: TFixedRect; Rounding: TRectRounding = rrClosest): TRect; overload;
  195. function FixedRect(const L, T, R, B: TFixed): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  196. function FixedRect(const ARect: TRect): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  197. function FixedRect(const FR: TFloatRect): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  198. function FloatRect(const L, T, R, B: Single): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  199. function FloatRect(const ARect: TRect): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  200. function FloatRect(const FXR: TFixedRect): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  201.  
  202. // Some basic operations over rectangles
  203. function IntersectRect(out Dst: TRect; const R1, R2: TRect): Boolean;
  204. function IntersectRectF(out Dst: TFloatRect; const FR1, FR2: TFloatRect): Boolean;
  205. function EqualRect(const R1, R2: TRect): Boolean; {$IFDEF USEINLINING} inline; {$ENDIF}
  206. procedure InflateRect(var R: TRect; Dx, Dy: Integer); overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  207. procedure InflateRectF(var FR: TFloatRect; Dx, Dy: Single); {$IFDEF USEINLINING} inline; {$ENDIF}
  208. procedure OffsetRect(var R: TRect; Dx, Dy: Integer); overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  209. procedure OffsetRectF(var FR: TFloatRect; Dx, Dy: Single); overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  210. function IsRectEmpty(const R: TRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  211. function IsRectEmptyF(const FR: TFloatRect): Boolean; overload; {$IFDEF USEINLINING} inline; {$ENDIF}
  212. function PtInRect(const R: TRect; const P: TPoint): Boolean; {$IFDEF USEINLINING} inline; {$ENDIF}
  213.  
  214.  
  215. { Other dynamic arrays }
  216. type
  217.   TArrayOfByte = array of Byte;
  218.   TArrayOfInteger = array of Integer;
  219.   TArrayOfArrayOfInteger = array of TArrayOfInteger;
  220.   TArrayOfSingle = array of Single;
  221.  
  222. {$IFDEF CLX}
  223.   HBITMAP = QImageH;
  224.   HDC = QPainterH;
  225.   HFont = QFontH;
  226. {$ENDIF}
  227.  
  228. { TBitmap32 draw mode }
  229. type
  230.   TDrawMode = (dmOpaque, dmBlend, dmCustom);
  231.   TCombineMode = (cmBlend, cmMerge);
  232.  
  233. { Stretch filters }
  234.   TStretchFilter = (sfNearest, sfDraft, sfLinear, sfCosine, sfSpline,
  235.     sfLanczos, sfMitchell);
  236.  
  237. { Gamma bias for line/pixel antialiasing }
  238.  
  239. var
  240.   GAMMA_TABLE: array [Byte] of Byte;
  241.   Interpolator: function(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32;
  242.  
  243. procedure SetGamma(Gamma: Single = 0.7);
  244.  
  245. {$IFDEF CLX}
  246. { TextOut Flags for WinAPI compatibility }
  247. const
  248.   DT_LEFT = Integer(AlignmentFlags_AlignLeft);
  249.   DT_RIGHT = Integer(AlignmentFlags_AlignRight);
  250.   DT_TOP = Integer(AlignmentFlags_AlignTop);
  251.   DT_BOTTOM = Integer(AlignmentFlags_AlignBottom);
  252.   DT_CENTER = Integer(AlignmentFlags_AlignHCenter);
  253.   DT_VCENTER = Integer(AlignmentFlags_AlignVCenter);
  254.   DT_EXPANDTABS = Integer(AlignmentFlags_ExpandTabs);
  255.   DT_NOCLIP = Integer(AlignmentFlags_DontClip);
  256.   DT_WORDBREAK = Integer(AlignmentFlags_WordBreak);
  257.   DT_SINGLELINE = Integer(AlignmentFlags_SingleLine);
  258. { missing since there is no QT equivalent:
  259.   DT_CALCRECT (makes no sense with TBitmap32.TextOut[2])
  260.   DT_EDITCONTOL
  261.   DT_END_ELLIPSIS and DT_PATH_ELLIPSIS
  262.   DT_EXTERNALLEADING
  263.   DT_MODIFYSTRING
  264.   DT_NOPREFIX
  265.   DT_RTLREADING
  266.   DT_TABSTOP
  267. }
  268. {$ENDIF}
  269.  
  270. type
  271.   { TThreadPersistent }
  272.   { TThreadPersistent is an ancestor for TBitmap32 object. In addition to
  273.     TPersistent methods, it provides thread-safe locking and change notification }
  274.   TThreadPersistent = class(TPersistent)
  275.   private
  276.     FLock: TRTLCriticalSection;
  277.     FLockCount: Integer;
  278.     FUpdateCount: Integer;
  279.     FOnChange: TNotifyEvent;
  280.   protected
  281.     property LockCount: Integer read FLockCount;
  282.     property UpdateCount: Integer read FUpdateCount;
  283.   public
  284.     constructor Create; virtual;
  285.     destructor Destroy; override;
  286.     procedure Changed; virtual;
  287.     procedure BeginUpdate;
  288.     procedure EndUpdate;
  289.     procedure Lock;
  290.     procedure Unlock;
  291.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  292.   end;
  293.  
  294.   { TCustomMap }
  295.   { An ancestor for bitmaps and similar 2D distributions wich have width and
  296.     height properties }
  297.   TCustomMap = class(TThreadPersistent)
  298.   private
  299.     FHeight: Integer;
  300.     FWidth: Integer;
  301.     FOnResize: TNotifyEvent;
  302.     procedure SetHeight(NewHeight: Integer);
  303.     procedure SetWidth(NewWidth: Integer);
  304.   protected
  305.     procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); virtual;
  306.   public
  307.     procedure Delete; virtual;
  308.     function  Empty: Boolean; virtual;
  309.     procedure Resized; virtual;
  310.     function SetSizeFrom(Source: TPersistent): Boolean;
  311.     function SetSize(NewWidth, NewHeight: Integer): Boolean; virtual;
  312.     property Height: Integer read FHeight write SetHeight;
  313.     property Width: Integer read FWidth write SetWidth;
  314.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  315.   end;
  316.  
  317.   { TBitmap32 }
  318.   { This is the core of Graphics32 unit. The TBitmap32 class is responsible
  319.     for storage of a bitmap, as well as for drawing in it.
  320.     The OnCombine event is fired only when DrawMode is set to dmCustom and two
  321.     bitmaps are blended together. Unlike most normal events, it does not contain
  322.     "Sender" parameter and is not called through some virtual method. This
  323.     (a little bit non-standard) approach allows for faster operation. }
  324.  
  325.   TPixelCombineEvent = procedure(F: TColor32; var B: TColor32; M: TColor32) of object;
  326.  
  327.   TBitmap32 = class(TCustomMap)
  328.   private
  329.     FBits: PColor32Array;
  330.     FCanvas: TCanvas;
  331.     FClipRect: TRect;
  332.     FFixedClipRect: TFixedRect;
  333.     F256ClipRect: TRect;
  334.     FClipping: Boolean;
  335.     FDrawMode: TDrawMode;
  336.     FFont: TFont;
  337.     FHandle: HBITMAP;
  338.     FHDC: HDC;
  339. {$IFDEF CLX}
  340.     FPixmap: QPixmapH;
  341.     FPainterCount: Integer;
  342.     FPixmapActive: Boolean;
  343.     FPixmapChanged: Boolean;
  344. {$ELSE}
  345.     FBitmapInfo: TBitmapInfo;
  346. {$ENDIF}
  347.     FMasterAlpha: Cardinal;
  348.     FOuterColor: TColor32;
  349.     FPenColor: TColor32;
  350.     FStippleCounter: Single;
  351.     FStipplePattern: TArrayOfColor32;
  352.     FStippleStep: Single;
  353.     FStretchFilter: TStretchFilter;
  354.     FOnHandleChanged: TNotifyEvent;
  355.     FOnPixelCombine: TPixelCombineEvent;
  356.     FCombineMode: TCombineMode;
  357.     procedure FontChanged(Sender: TObject);
  358.     procedure CanvasChanged(Sender: TObject);
  359.     function  GetCanvas: TCanvas;
  360.     function  GetPixel(X, Y: Integer): TColor32;
  361.     function  GetPixelS(X, Y: Integer): TColor32;
  362.     function  GetPixelF(X, Y: Single): TColor32;
  363.     function  GetPixelFS(X, Y: Single): TColor32;
  364.     function  GetPixelX(X, Y: TFixed): TColor32;
  365.     function  GetPixelXS(X, Y: TFixed): TColor32;
  366.     function  GetPixelPtr(X, Y: Integer): PColor32;
  367.     function  GetScanLine(Y: Integer): PColor32Array;
  368. {$IFDEF CLX}
  369.     function  GetBits: PColor32Array;
  370.     function  GetPixmap: QPixmapH;
  371.     function  GetPainter: QPainterH;
  372. {$ENDIF}
  373.     procedure SetCombineMode(const Value: TCombineMode);
  374.     procedure SetDrawMode(Value: TDrawMode);
  375.     procedure SetFont(Value: TFont);
  376.     procedure SetMasterAlpha(Value: Cardinal);
  377.     procedure SetPixel(X, Y: Integer; Value: TColor32);
  378.     procedure SetPixelS(X, Y: Integer; Value: TColor32);
  379.     procedure SetStretchFilter(Value: TStretchFilter);
  380.     procedure TextScaleDown(const B, B2: TBitmap32; const N: Integer;
  381.       const Color: TColor32); {$IFDEF USEINLINING} inline; {$ENDIF}
  382.     procedure TextBlueToAlpha(const B: TBitmap32; const Color: TColor32); {$IFDEF USEINLINING} inline; {$ENDIF}
  383.     procedure UpdateClipRects;
  384.     procedure SetClipRect(const Value: TRect);
  385.   protected
  386.     FontHandle: HFont;
  387.     RasterX, RasterY: Integer;
  388.     RasterXF, RasterYF: TFixed;
  389.     procedure AssignTo(Dst: TPersistent); override;
  390.     procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override;
  391.     procedure HandleChanged; virtual;
  392.     function  Equal(B: TBitmap32): Boolean;
  393.     procedure SET_T256(X, Y: Integer; C: TColor32);
  394.     procedure SET_TS256(X, Y: Integer; C: TColor32);
  395.     function  GET_T256(X, Y: Integer): TColor32;
  396.     function  GET_TS256(X, Y: Integer): TColor32;
  397.     procedure ReadData(Stream: TStream); virtual;
  398.     procedure WriteData(Stream: TStream); virtual;
  399.     procedure DefineProperties(Filer: TFiler); override;
  400.     function  GetPixelB(X, Y: Integer): TColor32;
  401.     procedure SetPixelF(X, Y: Single; Value: TColor32);
  402.     procedure SetPixelX(X, Y: TFixed; Value: TColor32);
  403.     procedure SetPixelFS(X, Y: Single; Value: TColor32);
  404.     procedure SetPixelXS(X, Y: TFixed; Value: TColor32);
  405.  
  406. {$IFDEF CLX}
  407.     procedure PixmapNeeded;
  408.     procedure ImageNeeded;
  409.     procedure CheckPixmap;
  410.     procedure StartPainter;
  411.     procedure StopPainter;
  412. {$ENDIF}
  413.   public
  414.     constructor Create; override;
  415.     destructor Destroy; override;
  416.  
  417.     procedure Assign(Source: TPersistent); override;
  418.     function  BoundsRect: TRect;
  419.     function  Empty: Boolean; override;
  420.     procedure Clear; overload;
  421.     procedure Clear(FillColor: TColor32); overload;
  422.     procedure Delete; override;
  423.  
  424.     procedure LoadFromStream(Stream: TStream);
  425.     procedure SaveToStream(Stream: TStream);
  426.     procedure LoadFromFile(const FileName: string);
  427.     procedure SaveToFile(const FileName: string);
  428.     procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
  429.     procedure LoadFromResourceName(Instance: THandle; const ResName: string);
  430.  
  431.     procedure ResetAlpha; overload;
  432.     procedure ResetAlpha(const AlphaValue: Byte); overload;
  433.  
  434.     procedure Draw(DstX, DstY: Integer; Src: TBitmap32); overload;
  435.     procedure Draw(DstX, DstY: Integer; const SrcRect: TRect; Src: TBitmap32); overload;
  436.     procedure Draw(const DstRect, SrcRect: TRect; Src: TBitmap32); overload;
  437. {$IFDEF CLX}
  438.     procedure Draw(const DstRect, SrcRect: TRect; SrcPixmap: QPixmapH); overload;
  439. {$ELSE}
  440.   {$IFDEF BCB}
  441.     procedure Draw(const DstRect, SrcRect: TRect; hSrc: Cardinal); overload;
  442.   {$ELSE}
  443.     procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); overload;
  444.   {$ENDIF}
  445. {$ENDIF}
  446.  
  447.     procedure SetPixelT(X, Y: Integer; Value: TColor32); overload;
  448.     procedure SetPixelT(var Ptr: PColor32; Value: TColor32); overload;
  449.     procedure SetPixelTS(X, Y: Integer; Value: TColor32);
  450.  
  451.     procedure DrawTo(Dst: TBitmap32); overload;
  452.     procedure DrawTo(Dst: TBitmap32; DstX, DstY: Integer; const SrcRect: TRect); overload;
  453.     procedure DrawTo(Dst: TBitmap32; DstX, DstY: Integer); overload;
  454.     procedure DrawTo(Dst: TBitmap32; const DstRect: TRect); overload;
  455.     procedure DrawTo(Dst: TBitmap32; const DstRect, SrcRect: TRect); overload;
  456. {$IFDEF BCB}
  457.     procedure DrawTo(hDst: Cardinal; DstX, DstY: Integer); overload;
  458.     procedure DrawTo(hDst: Cardinal; const DstRect, SrcRect: TRect); overload;
  459.     procedure TileTo(hDst: Cardinal; const DstRect, SrcRect: TRect);
  460. {$ELSE}
  461.     procedure DrawTo(hDst: HDC; DstX, DstY: Integer); overload;
  462.     procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload;
  463.     procedure TileTo(hDst: HDC; const DstRect, SrcRect: TRect);
  464. {$ENDIF}
  465.  
  466.     procedure SetStipple(NewStipple: TArrayOfColor32); overload;
  467.     procedure SetStipple(NewStipple: array of TColor32); overload;
  468.     procedure AdvanceStippleCounter(LengthPixels: Single);
  469.     function  GetStippleColor: TColor32;
  470.  
  471.     procedure HorzLine(X1, Y, X2: Integer; Value: TColor32);
  472.     procedure HorzLineS(X1, Y, X2: Integer; Value: TColor32);
  473.     procedure HorzLineT(X1, Y, X2: Integer; Value: TColor32);
  474.     procedure HorzLineTS(X1, Y, X2: Integer; Value: TColor32);
  475.     procedure HorzLineTSP(X1, Y, X2: Integer);
  476.  
  477.     procedure VertLine(X, Y1, Y2: Integer; Value: TColor32);
  478.     procedure VertLineS(X, Y1, Y2: Integer; Value: TColor32);
  479.     procedure VertLineT(X, Y1, Y2: Integer; Value: TColor32);
  480.     procedure VertLineTS(X, Y1, Y2: Integer; Value: TColor32);
  481.     procedure VertLineTSP(X, Y1, Y2: Integer);
  482.  
  483.     procedure Line(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
  484.     procedure LineS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
  485.     procedure LineT(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
  486.     procedure LineTS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
  487.     procedure LineA(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
  488.     procedure LineAS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
  489.     procedure LineX(X1, Y1, X2, Y2: TFixed; Value: TColor32; L: Boolean = False); overload;
  490.     procedure LineF(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean = False); overload;
  491.     procedure LineXS(X1, Y1, X2, Y2: TFixed; Value: TColor32; L: Boolean = False); overload;
  492.     procedure LineFS(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean = False); overload;
  493.     procedure LineXP(X1, Y1, X2, Y2: TFixed; L: Boolean = False); overload;
  494.     procedure LineFP(X1, Y1, X2, Y2: Single; L: Boolean = False); overload;
  495.     procedure LineXSP(X1, Y1, X2, Y2: TFixed; L: Boolean = False); overload;
  496.     procedure LineFSP(X1, Y1, X2, Y2: Single; L: Boolean = False); overload;
  497.  
  498.     property  PenColor: TColor32 read FPenColor write FPenColor;
  499.     procedure MoveTo(X, Y: Integer);
  500.     procedure LineToS(X, Y: Integer);
  501.     procedure LineToTS(X, Y: Integer);
  502.     procedure LineToAS(X, Y: Integer);
  503.     procedure MoveToX(X, Y: TFixed);
  504.     procedure MoveToF(X, Y: Single);
  505.     procedure LineToXS(X, Y: TFixed);
  506.     procedure LineToFS(X, Y: Single);
  507.     procedure LineToXSP(X, Y: TFixed);
  508.     procedure LineToFSP(X, Y: Single);
  509.  
  510.     procedure FillRect(X1, Y1, X2, Y2: Integer; Value: TColor32);
  511.     procedure FillRectS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload;
  512.     procedure FillRectT(X1, Y1, X2, Y2: Integer; Value: TColor32);
  513.     procedure FillRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload;
  514.     procedure FillRectS(const ARect: TRect; Value: TColor32); overload;
  515.     procedure FillRectTS(const ARect: TRect; Value: TColor32); overload;
  516.  
  517.     procedure FrameRectS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload;
  518.     procedure FrameRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload;
  519.     procedure FrameRectTSP(X1, Y1, X2, Y2: Integer);
  520.     procedure FrameRectS(const ARect: TRect; Value: TColor32); overload;
  521.     procedure FrameRectTS(const ARect: TRect; Value: TColor32); overload;
  522.  
  523.     procedure RaiseRectTS(X1, Y1, X2, Y2: Integer; Contrast: Integer); overload;
  524.     procedure RaiseRectTS(const ARect: TRect; Contrast: Integer); overload;
  525.  
  526.     procedure UpdateFont;
  527. {$IFDEF CLX}
  528.     procedure Textout(X, Y: Integer; const Text: Widestring); overload;
  529.     procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); overload;
  530.     procedure Textout(DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload;
  531.     function  TextExtent(const Text: Widestring): TSize;
  532.     function  TextHeight(const Text: Widestring): Integer;
  533.     function  TextWidth(const Text: Widestring): Integer;
  534.     procedure RenderText(X, Y: Integer; const Text: Widestring; AALevel: Integer; Color: TColor32);
  535. {$ELSE}
  536.     procedure Textout(X, Y: Integer; const Text: String); overload;
  537.     procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: String); overload;
  538.     procedure Textout(DstRect: TRect; const Flags: Cardinal; const Text: String); overload;
  539.     function  TextExtent(const Text: String): TSize;
  540.     function  TextHeight(const Text: String): Integer;
  541.     function  TextWidth(const Text: String): Integer;
  542.     procedure RenderText(X, Y: Integer; const Text: String; AALevel: Integer; Color: TColor32);
  543. {$ENDIF}
  544.     procedure TextoutW(X, Y: Integer; const Text: Widestring); overload;
  545.     procedure TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); overload;
  546.     procedure TextoutW(DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload;
  547.     function  TextExtentW(const Text: Widestring): TSize;
  548.     function  TextHeightW(const Text: Widestring): Integer;
  549.     function  TextWidthW(const Text: Widestring): Integer;
  550.     procedure RenderTextW(X, Y: Integer; const Text: Widestring; AALevel: Integer; Color: TColor32);
  551.  
  552.     procedure Roll(Dx, Dy: Integer; FillBack: Boolean; FillColor: TColor32);
  553.     procedure FlipHorz(Dst: TBitmap32 = nil);
  554.     procedure FlipVert(Dst: TBitmap32 = nil);
  555.     procedure Rotate90(Dst: TBitmap32 = nil);
  556.     procedure Rotate180(Dst: TBitmap32 = nil);
  557.     procedure Rotate270(Dst: TBitmap32 = nil);
  558.  
  559.     procedure ResetClipRect;
  560.  
  561.     property Canvas: TCanvas read GetCanvas;
  562.     function CanvasAllocated: Boolean;
  563.     procedure DeleteCanvas;
  564.  
  565.     property  Pixel[X, Y: Integer]: TColor32 read GetPixel write SetPixel; default;
  566.     property  PixelS[X, Y: Integer]: TColor32 read GetPixelS write SetPixelS;
  567.     property  PixelX[X, Y: TFixed]: TColor32 read GetPixelX write SetPixelX;
  568.     property  PixelXS[X, Y: TFixed]: TColor32 read GetPixelXS write SetPixelXS;
  569.     property  PixelF[X, Y: Single]: TColor32 read GetPixelF write SetPixelF;
  570.     property  PixelFS[X, Y: Single]: TColor32 read GetPixelFS write SetPixelFS;
  571. {$IFDEF CLX}
  572.     property Pixmap: QPixmapH read GetPixmap;
  573.     property Bits: PColor32Array read GetBits;
  574.     property Handle: QPainterH read GetPainter;
  575.     property PixmapChanged: Boolean read FPixmapChanged write FPixmapChanged;
  576. {$ELSE}
  577.     property BitmapHandle: HBITMAP read FHandle;
  578.     property BitmapInfo: TBitmapInfo read FBitmapInfo;
  579.     property Bits: PColor32Array read FBits;
  580.     property Handle: HDC read FHDC;
  581. {$ENDIF}
  582.     property ClipRect: TRect read FClipRect write SetClipRect;
  583.     property Clipping: Boolean read FClipping;
  584.  
  585.     property Font: TFont read FFont write SetFont;
  586.     property PixelPtr[X, Y: Integer]: PColor32 read GetPixelPtr;
  587.     property ScanLine[Y: Integer]: PColor32Array read GetScanLine;
  588.     property StippleCounter: Single read FStippleCounter write FStippleCounter;
  589.     property StippleStep: Single read FStippleStep write FStippleStep;
  590.   published
  591.     property DrawMode: TDrawMode read FDrawMode write SetDrawMode default dmOpaque;
  592.     property CombineMode: TCombineMode read FCombineMode write SetCombineMode default cmBlend;
  593.     property MasterAlpha: Cardinal read FMasterAlpha write SetMasterAlpha default $FF;
  594.     property OuterColor: TColor32 read FOuterColor write FOuterColor default 0;
  595.     property StretchFilter: TStretchFilter read FStretchFilter write SetStretchFilter default sfNearest;
  596.     property OnChange;
  597.     property OnHandleChanged: TNotifyEvent read FOnHandleChanged write FOnHandleChanged;
  598.     property OnPixelCombine: TPixelCombineEvent read FOnPixelCombine write FOnPixelCombine;
  599.     property OnResize;
  600.   end;
  601.  
  602. {$IFDEF CLX}
  603.   TBitmap32Canvas = class(TCanvas)
  604.   private
  605.     FBitmap: TBitmap32;
  606.   protected
  607.     procedure BeginPainting; override;
  608.     procedure CreateHandle; override;
  609.   public
  610.     constructor Create(Bitmap: TBitmap32);
  611.   end;
  612. {$ENDIF}
  613.  
  614. implementation
  615.  
  616. uses
  617.   GR32_Blend, GR32_Transforms, GR32_LowLevel, GR32_Filters, Math, TypInfo,
  618.   GR32_System,
  619. {$IFDEF CLX}
  620.   QClipbrd,
  621. {$ELSE}
  622.   Clipbrd,
  623. {$ENDIF}
  624.   GR32_DrawingEx;
  625.  
  626. var
  627.   CounterLock: TRTLCriticalSection;
  628.  
  629. {$IFDEF CLX}
  630.   StockFont: TFont;
  631. {$ELSE}
  632.   StockFont: HFONT;
  633. {$ENDIF}
  634.   StockBitmap: TBitmap;
  635.  
  636. type
  637.   TGraphicAccess = class(TGraphic);
  638.  
  639. const
  640.   ZERO_RECT: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0);
  641.  
  642.  
  643. {$IFDEF CLX}
  644. function StretchPixmap(DestPainter: QPainterH; DestX, DestY, DestWidth, DestHeight,
  645.   SrcX, SrcY, SrcWidth, SrcHeight: Integer; SrcPixmap: QPixmapH): Integer;
  646. var
  647.   NewMatrix: QWMatrixH;
  648. begin
  649.   QPainter_saveWorldMatrix(DestPainter);
  650.   try
  651.     NewMatrix:= QWMatrix_create(DestWidth / SrcWidth, 0, 0, DestHeight / SrcHeight, DestX, DestY);
  652.     try
  653.       QPainter_setWorldMatrix(DestPainter, NewMatrix, True);
  654.       QPainter_drawPixmap(DestPainter, 0, 0, SrcPixmap, SrcX, SrcY, SrcWidth, SrcHeight);
  655.     finally
  656.       QWMatrix_destroy(NewMatrix);
  657.     end;
  658.   finally
  659.     QPainter_restoreWorldMatrix(DestPainter);
  660.   end;
  661.   Result := 0;
  662. end;
  663. {$ENDIF}
  664.  
  665. { Color construction and conversion functions }
  666.  
  667. function Color32(WinColor: TColor): TColor32; overload;
  668. {$IFDEF WIN_COLOR_FIX}
  669. var
  670.   I: Longword;
  671. {$ENDIF}
  672. begin
  673. {$IFDEF CLX}
  674.   WinColor := ColorToRGB(WinColor);
  675. {$ELSE}
  676.   if WinColor < 0 then WinColor := GetSysColor(WinColor and $000000FF);
  677. {$ENDIF}
  678.   
  679. {$IFDEF WIN_COLOR_FIX}
  680.   Result := $FF000000;
  681.   I := (WinColor and $00FF0000) shr 16;
  682.   if I <> 0 then Result := Result or TColor32(Integer(I) - 1);
  683.   I := WinColor and $0000FF00;
  684.   if I <> 0 then Result := Result or TColor32(Integer(I) - $00000100);
  685.   I := WinColor and $000000FF;
  686.   if I <> 0 then Result := Result or TColor32(Integer(I) - 1) shl 16;
  687. {$ELSE}
  688.   asm
  689.         MOV    EAX,WinColor
  690.         BSWAP  EAX
  691.         MOV    AL,$FF
  692.         ROR    EAX,8
  693.         MOV    Result,EAX
  694.   end;
  695. {$ENDIF}
  696. end;
  697.  
  698. function Color32(R, G, B: Byte; A: Byte = $FF): TColor32; overload;
  699. asm
  700.         MOV  AH,A
  701.         SHL  EAX,16
  702.         MOV  AH,DL
  703.         MOV  AL,CL
  704. end;
  705.  
  706. function Color32(Index: Byte; var Palette: TPalette32): TColor32; overload;
  707. begin
  708.   Result := Palette[Index];
  709. end;
  710.  
  711. function Gray32(Intensity: Byte; Alpha: Byte = $FF): TColor32;
  712. begin
  713.   Result := TColor32(Alpha) shl 24 + TColor32(Intensity) shl 16 +
  714.     TColor32(Intensity) shl 8 + TColor32(Intensity);
  715. end;
  716.  
  717. function WinColor(Color32: TColor32): TColor;
  718. asm
  719.   // the alpha channel byte is set to zero!
  720.         ROL    EAX,8  // ABGR  ->  BGRA
  721.         XOR    AL,AL  // BGRA  ->  BGR0
  722.         BSWAP  EAX    // BGR0  ->  0RGB
  723. end;
  724.  
  725. function ArrayOfColor32(Colors: array of TColor32): TArrayOfColor32;
  726. var
  727.   L: Integer;
  728. begin
  729.   // build a dynamic color array from specified colors
  730.   L := High(Colors) + 1;
  731.   SetLength(Result, L);
  732.   MoveLongword(Colors[0], Result[0], L);
  733. end;
  734.  
  735. procedure Color32ToRGB(Color32: TColor32; var R, G, B: Byte);
  736. begin
  737.   R := (Color32 and $00FF0000) shr 16;
  738.   G := (Color32 and $0000FF00) shr 8;
  739.   B := Color32 and $000000FF;
  740. end;
  741.  
  742. procedure Color32ToRGBA(Color32: TColor32; var R, G, B, A: Byte);
  743. begin
  744.   A := Color32 shr 24;
  745.   R := (Color32 and $00FF0000) shr 16;
  746.   G := (Color32 and $0000FF00) shr 8;
  747.   B := Color32 and $000000FF;
  748. end; 
  749.  
  750. function RedComponent(Color32: TColor32): Integer;
  751. begin
  752.   Result := (Color32 and $00FF0000) shr 16;
  753. end;
  754.  
  755. function GreenComponent(Color32: TColor32): Integer;
  756. begin
  757.   Result := (Color32 and $0000FF00) shr 8;
  758. end;
  759.  
  760. function BlueComponent(Color32: TColor32): Integer;
  761. begin
  762.   Result := Color32 and $000000FF;
  763. end;
  764.  
  765. function AlphaComponent(Color32: TColor32): Integer;
  766. begin
  767.   Result := Color32 shr 24;
  768. end;
  769.  
  770. function Intensity(Color32: TColor32): Integer;
  771. begin
  772. // (R * 61 + G * 174 + B * 21) / 256
  773.   Result := (
  774.     (Color32 and $00FF0000) shr 16 * 61 +
  775.     (Color32 and $0000FF00) shr 8 * 174 +
  776.     (Color32 and $000000FF) * 21
  777.     ) shr 8;
  778. end;
  779.  
  780. function SetAlpha(Color32: TColor32; NewAlpha: Integer): TColor32;
  781. begin
  782.   if NewAlpha < 0 then NewAlpha := 0
  783.   else if NewAlpha > 255 then NewAlpha := 255;
  784.   Result := (Color32 and $00FFFFFF) or (TColor32(NewAlpha) shl 24);
  785. end;
  786.  
  787. { Color space conversions }
  788.  
  789. function HSLtoRGB(H, S, L: Single): TColor32;
  790. const
  791.   OneOverThree = 1 / 3;
  792. var
  793.   M1, M2: Single;
  794.   R, G, B: Byte;
  795.  
  796.   function HueToColor(Hue: Single): Byte;
  797.   var
  798.     V: Double;
  799.   begin
  800.     Hue := Hue - Floor(Hue);
  801.     if 6 * Hue < 1 then V := M1 + (M2 - M1) * Hue * 6
  802.     else if 2 * Hue < 1 then V := M2
  803.     else if 3 * Hue < 2 then V := M1 + (M2 - M1) * (2 / 3 - Hue) * 6
  804.     else V := M1;
  805.     Result := Round(255 * V);
  806.   end;
  807.  
  808. begin
  809.   if S = 0 then
  810.   begin
  811.     R := Round(255 * L);
  812.     G := R;
  813.     B := R;
  814.   end
  815.   else
  816.   begin
  817.     if L <= 0.5 then M2 := L * (1 + S)
  818.     else M2 := L + S - L * S;
  819.     M1 := 2 * L - M2;
  820.     R := HueToColor(H + OneOverThree);
  821.     G := HueToColor(H);
  822.     B := HueToColor(H - OneOverThree)
  823.   end;
  824.   Result := Color32(R, G, B, 255);
  825. end;
  826.  
  827. procedure RGBtoHSL(RGB: TColor32; out H, S, L : Single);
  828. var
  829.   R, G, B, D, Cmax, Cmin: Single;
  830. begin
  831.   R := RedComponent(RGB) / 255;
  832.   G := GreenComponent(RGB) / 255;
  833.   B := BlueComponent(RGB) / 255;
  834.   Cmax := Max(R, Max(G, B));
  835.   Cmin := Min(R, Min(G, B));
  836.   L := (Cmax + Cmin) / 2;
  837.  
  838.   if Cmax = Cmin then
  839.   begin
  840.     H := 0;
  841.     S := 0
  842.   end
  843.   else
  844.   begin
  845.     D := Cmax - Cmin;
  846.     if L < 0.5 then S := D / (Cmax + Cmin)
  847.     else S := D / (2 - Cmax - Cmin);
  848.     if R = Cmax then H := (G - B) / D
  849.     else
  850.       if G = Cmax then H  := 2 + (B - R) / D
  851.       else H := 4 + (R - G) / D;
  852.     H := H / 6;
  853.     if H < 0 then H := H + 1
  854.   end;
  855. end;
  856.  
  857. { Palette conversion }
  858.  
  859. {$IFNDEF CLX}
  860. function WinPalette(const P: TPalette32): HPALETTE;
  861. var
  862.   L: TMaxLogPalette;
  863.   L0: LOGPALETTE absolute L;
  864.   I: Cardinal;
  865.   Cl: TColor32;
  866. begin
  867.   L.palVersion := $300;
  868.   L.palNumEntries := 256;
  869.   for I := 0 to 255 do
  870.   begin
  871.     Cl := P[I];
  872.     with L.palPalEntry[I] do
  873.     begin
  874.       peFlags := 0;
  875.       peRed := RedComponent(Cl);
  876.       peGreen := GreenComponent(Cl);
  877.       peBlue := BlueComponent(Cl);
  878.     end;
  879.   end;
  880.   Result := CreatePalette(l0);
  881. end;
  882. {$ENDIF}
  883.  
  884. { Fixed-point math }
  885.  
  886. function Fixed(S: Single): TFixed;
  887. begin
  888.   Result := Round(S * 65536);
  889. end;
  890.  
  891. function Fixed(I: Integer): TFixed;
  892. begin
  893.   Result := I * $10000{I shl 16};
  894. end;
  895.  
  896. function FixedFloor(A: TFixed): Integer;
  897. asm
  898.         SAR     EAX, 16;
  899. end;
  900.  
  901. function FixedCeil(A: TFixed): Integer;
  902. asm
  903.         ADD     EAX, $0000FFFF
  904.         SAR     EAX, 16;
  905. end;
  906.  
  907. function FixedRound(A: TFixed): Integer;
  908. asm
  909.         ADD     EAX, $00007FFF
  910.         SAR     EAX, 16
  911. end;
  912.  
  913. function FixedMul(A, B: TFixed): TFixed;
  914. asm
  915.         IMUL    EDX
  916.         SHRD    EAX, EDX, 16
  917. end;
  918.  
  919. function FixedDiv(A, B: TFixed): TFixed;
  920. asm
  921.         MOV     ECX, B
  922.         CDQ
  923.         SHLD    EDX, EAX, 16
  924.         SHL     EAX, 16
  925.         IDIV    ECX
  926. end;
  927.  
  928. { Points }
  929.  
  930. function Point(X, Y: Integer): TPoint;
  931. begin
  932.   Result.X := X;
  933.   Result.Y := Y;
  934. end;
  935.  
  936. function Point(const FP: TFloatPoint): TPoint;
  937. begin
  938.   Result.X := Round(FP.X);
  939.   Result.Y := Round(FP.Y);
  940. end;
  941.  
  942. function Point(const FXP: TFixedPoint): TPoint;
  943. begin
  944.   Result.X := FixedRound(FXP.X);
  945.   Result.Y := FixedRound(FXP.Y);
  946. end;
  947.  
  948. function FloatPoint(X, Y: Single): TFloatPoint;
  949. begin
  950.   Result.X := X;
  951.   Result.Y := Y;
  952. end;
  953.  
  954. function FloatPoint(const P: TPoint): TFloatPoint;
  955. begin
  956.   Result.X := P.X;
  957.   Result.Y := P.Y;
  958. end;
  959.  
  960. function FloatPoint(const FXP: TFixedPoint): TFloatPoint;
  961. const
  962.   F = 1 / 65536;
  963. begin
  964.   with FXP do
  965.   begin
  966.     Result.X := X * F;
  967.     Result.Y := Y * F;
  968.   end;
  969. end;
  970.  
  971. function FixedPoint(X, Y: Integer): TFixedPoint; overload;
  972. begin
  973.   Result.X := X shl 16;
  974.   Result.Y := Y shl 16;
  975. end;
  976.  
  977. function FixedPoint(X, Y: Single): TFixedPoint; overload;
  978. begin
  979.   Result.X := Round(X * 65536);
  980.   Result.Y := Round(Y * 65536);
  981. end;
  982.  
  983. function FixedPoint(const P: TPoint): TFixedPoint; overload;
  984. begin
  985.   Result.X := P.X shl 16;
  986.   Result.Y := P.Y shl 16;
  987. end;
  988.  
  989. function FixedPoint(const FP: TFloatPoint): TFixedPoint; overload;
  990. begin
  991.   Result.X := Round(FP.X * 65536);
  992.   Result.Y := Round(FP.Y * 65536);
  993. end;
  994.  
  995.  
  996. { Rectangles }
  997.  
  998. function MakeRect(const L, T, R, B: Integer): TRect;
  999. begin
  1000.   with Result do
  1001.   begin
  1002.     Left := L;
  1003.     Top := T;
  1004.     Right := R;
  1005.     Bottom := B;
  1006.   end;
  1007. end;
  1008.  
  1009. function MakeRect(const FR: TFloatRect; Rounding: TRectRounding): TRect;
  1010. begin
  1011.   with FR do
  1012.     case Rounding of
  1013.       rrClosest:
  1014.         begin
  1015.           Result.Left := Round(Left);
  1016.           Result.Top := Round(Top);
  1017.           Result.Right := Round(Right);
  1018.           Result.Bottom := Round(Bottom);
  1019.         end;
  1020.  
  1021.       rrInside:
  1022.         begin
  1023.           Result.Left := Ceil(Left);
  1024.           Result.Top := Ceil(Top);
  1025.           Result.Right := Ceil(Right);
  1026.           Result.Bottom := Ceil(Bottom);
  1027.           if Result.Right < Result.Left then Result.Right := Result.Left;
  1028.           if Result.Bottom < Result.Top then Result.Bottom := Result.Top;
  1029.         end;
  1030.  
  1031.       rrOutside:
  1032.         begin
  1033.           Result.Left := Floor(Left);
  1034.           Result.Top := Floor(Top);
  1035.           Result.Right := Ceil(Right);
  1036.           Result.Bottom := Ceil(Bottom);
  1037.         end;
  1038.     end;
  1039. end;
  1040.  
  1041. function MakeRect(const FXR: TFixedRect; Rounding: TRectRounding): TRect;
  1042. begin
  1043.   with FXR do
  1044.     case Rounding of
  1045.       rrClosest:
  1046.         begin
  1047.           Result.Left := FixedRound(Left);
  1048.           Result.Top := FixedRound(Top);
  1049.           Result.Right := FixedRound(Right);
  1050.           Result.Bottom := FixedRound(Bottom);
  1051.         end;
  1052.  
  1053.       rrInside:
  1054.         begin
  1055.           Result.Left := FixedCeil(Left);
  1056.           Result.Top := FixedCeil(Top);
  1057.           Result.Right := FixedFloor(Right);
  1058.           Result.Bottom := FixedFloor(Bottom);
  1059.           if Result.Right < Result.Left then Result.Right := Result.Left;
  1060.           if Result.Bottom < Result.Top then Result.Bottom := Result.Top;
  1061.         end;
  1062.  
  1063.       rrOutside:
  1064.         begin
  1065.           Result.Left := FixedFloor(Left);
  1066.           Result.Top := FixedFloor(Top);
  1067.           Result.Right := FixedCeil(Right);
  1068.           Result.Bottom := FixedCeil(Bottom);
  1069.         end;
  1070.     end;
  1071. end;
  1072.  
  1073. function FixedRect(const L, T, R, B: TFixed): TFixedRect;
  1074. begin
  1075.   with Result do
  1076.   begin
  1077.     Left := L;
  1078.     Top := T;
  1079.     Right := R;
  1080.     Bottom := B;
  1081.   end;
  1082. end;
  1083.  
  1084. function FixedRect(const ARect: TRect): TFixedRect;
  1085. begin
  1086.   with Result do
  1087.   begin
  1088.     Left := ARect.Left shl 16;
  1089.     Top := ARect.Top shl 16;
  1090.     Right := ARect.Right shl 16;
  1091.     Bottom := ARect.Bottom shl 16;
  1092.   end;
  1093. end;
  1094.  
  1095. function FixedRect(const FR: TFloatRect): TFixedRect;
  1096. begin
  1097.   with Result do
  1098.   begin
  1099.     Left := Round(FR.Left * 65536);
  1100.     Top := Round(FR.Top * 65536);
  1101.     Right := Round(FR.Right * 65536);
  1102.     Bottom := Round(FR.Bottom * 65536);
  1103.   end;
  1104. end;
  1105.  
  1106. function FloatRect(const L, T, R, B: Single): TFloatRect;
  1107. begin
  1108.   with Result do
  1109.   begin
  1110.     Left := L;
  1111.     Top := T;
  1112.     Right := R;
  1113.     Bottom := B;
  1114.   end;
  1115. end;
  1116.  
  1117. function FloatRect(const ARect: TRect): TFloatRect;
  1118. begin
  1119.   with Result do
  1120.   begin
  1121.     Left := ARect.Left;
  1122.     Top := ARect.Top;
  1123.     Right := ARect.Right;
  1124.     Bottom := ARect.Bottom;
  1125.   end;
  1126. end;
  1127.  
  1128. function FloatRect(const FXR: TFixedRect): TFloatRect;
  1129. begin
  1130.   with Result do
  1131.   begin
  1132.     Left := FXR.Left * FixedToFloat;
  1133.     Top := FXR.Top * FixedToFloat;
  1134.     Right := FXR.Right * FixedToFloat;
  1135.     Bottom := FXR.Bottom * FixedToFloat;
  1136.   end;
  1137. end;
  1138.  
  1139. function IntersectRect(out Dst: TRect; const R1, R2: TRect): Boolean;
  1140. begin
  1141.   if R1.Left >= R2.Left then Dst.Left := R1.Left else Dst.Left := R2.Left;
  1142.   if R1.Right <= R2.Right then Dst.Right := R1.Right else Dst.Right := R2.Right;
  1143.   if R1.Top >= R2.Top then Dst.Top := R1.Top else Dst.Top := R2.Top;
  1144.   if R1.Bottom <= R2.Bottom then Dst.Bottom := R1.Bottom else Dst.Bottom := R2.Bottom;
  1145.   Result := (Dst.Right >= Dst.Left) and (Dst.Bottom >= Dst.Top);
  1146.   if not Result then Dst := ZERO_RECT;
  1147. end;
  1148.  
  1149. function IntersectRectF(out Dst: TFloatRect; const FR1, FR2: TFloatRect): Boolean;
  1150. begin
  1151.   Dst.Left   := Max(FR1.Left,   FR2.Left);
  1152.   Dst.Right  := Min(FR1.Right,  FR2.Right);
  1153.   Dst.Top    := Max(FR1.Top,    FR2.Top);
  1154.   Dst.Bottom := Min(FR1.Bottom, FR2.Bottom);
  1155.   Result := (Dst.Right >= Dst.Left) and (Dst.Bottom >= Dst.Top);
  1156.   if not Result then FillLongword(Dst, 4, 0);
  1157. end;
  1158.  
  1159. function EqualRect(const R1, R2: TRect): Boolean;
  1160. begin
  1161.   Result := CompareMem(@R1, @R2, SizeOf(TRect));
  1162. end;
  1163.  
  1164. procedure InflateRect(var R: TRect; Dx, Dy: Integer);
  1165. begin
  1166.   Dec(R.Left, Dx); Dec(R.Top, Dy);
  1167.   Inc(R.Right, Dx); Inc(R.Bottom, Dy);
  1168. end;
  1169.  
  1170. procedure InflateRectF(var FR: TFloatRect; Dx, Dy: Single);
  1171. begin
  1172.   with FR do
  1173.   begin
  1174.     Left := Left - Dx; Top := Top - Dy;
  1175.     Right := Right + Dx; Bottom := Bottom + Dy;
  1176.   end;
  1177. end;
  1178.  
  1179. procedure OffsetRect(var R: TRect; Dx, Dy: Integer);
  1180. begin
  1181.   Inc(R.Left, Dx); Inc(R.Top, Dy);
  1182.   Inc(R.Right, Dx); Inc(R.Bottom, Dy);
  1183. end;
  1184.  
  1185. procedure OffsetRectF(var FR: TFloatRect; Dx, Dy: Single);
  1186. begin
  1187.   with FR do
  1188.   begin
  1189.     Left := Left + Dx; Top := Top + Dy;
  1190.     Right := Right + Dx; Bottom := Bottom + Dy;
  1191.   end;
  1192. end;
  1193.  
  1194. function IsRectEmpty(const R: TRect): Boolean;
  1195. begin
  1196.   Result := (R.Right <= R.Left) or (R.Bottom <= R.Top);
  1197. end;
  1198.  
  1199. function IsRectEmptyF(const FR: TFloatRect): Boolean;
  1200. begin
  1201.   Result := (FR.Right <= FR.Left) or (FR.Bottom <= FR.Top);
  1202. end;
  1203.  
  1204. function PtInRect(const R: TRect; const P: TPoint): Boolean;
  1205. begin
  1206.   Result := (P.X >= R.Left) and (P.X < R.Right) and
  1207.     (P.Y >= R.Top) and (P.Y < R.Bottom);
  1208. end;
  1209.  
  1210. { Gamma / Pixel Shape Correction table }
  1211.  
  1212. procedure SetGamma(Gamma: Single);
  1213. var
  1214.   i: Integer;
  1215. begin
  1216.   for i := 0 to 255 do
  1217.     GAMMA_TABLE[i] := Round(255 * Power(i / 255, Gamma));
  1218. end;
  1219.  
  1220.  
  1221.  
  1222. { TThreadPersistent }
  1223.  
  1224. constructor TThreadPersistent.Create;
  1225. begin
  1226.   InitializeCriticalSection(FLock);
  1227. end;
  1228.  
  1229. destructor TThreadPersistent.Destroy;
  1230. begin
  1231.   DeleteCriticalSection(FLock);
  1232.   inherited;
  1233. end;
  1234.  
  1235. procedure TThreadPersistent.BeginUpdate;
  1236. begin
  1237.   Inc(FUpdateCount);
  1238. end;
  1239.  
  1240. procedure TThreadPersistent.Changed;
  1241. begin
  1242.   if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self);
  1243. end;
  1244.  
  1245. procedure TThreadPersistent.EndUpdate;
  1246. begin
  1247.   Assert(FUpdateCount > 0, 'Unpaired TThreadPersistent.EndUpdate');
  1248.   Dec(FUpdateCount);
  1249. end;
  1250.  
  1251. procedure TThreadPersistent.Lock;
  1252. begin
  1253.   EnterCriticalSection(CounterLock);
  1254.   Inc(FLockCount);
  1255.   LeaveCriticalSection(CounterLock);
  1256.   EnterCriticalSection(FLock);
  1257. end;
  1258.  
  1259. procedure TThreadPersistent.Unlock;
  1260. begin
  1261.   LeaveCriticalSection(FLock);
  1262.   EnterCriticalSection(CounterLock);
  1263.   Dec(FLockCount);
  1264.   LeaveCriticalSection(CounterLock);
  1265. end;
  1266.  
  1267.  
  1268. { TCustomMap }
  1269.  
  1270. procedure TCustomMap.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer);
  1271. begin
  1272.   Width := NewWidth;
  1273.   Height := NewHeight;
  1274. end;
  1275.  
  1276. procedure TCustomMap.Delete;
  1277. begin
  1278.   SetSize(0, 0);
  1279. end;
  1280.  
  1281. function TCustomMap.Empty: Boolean;
  1282. begin
  1283.   Result := (Width = 0) or (Height = 0);
  1284. end;
  1285.  
  1286. procedure TCustomMap.Resized;
  1287. begin
  1288.   if Assigned(FOnResize) then FOnResize(Self);
  1289. end;
  1290.  
  1291. procedure TCustomMap.SetHeight(NewHeight: Integer);
  1292. begin
  1293.   SetSize(Width, NewHeight);
  1294. end;
  1295.  
  1296. function TCustomMap.SetSize(NewWidth, NewHeight: Integer): Boolean;
  1297. begin
  1298.   if NewWidth < 0 then NewWidth := 0;
  1299.   if NewHeight < 0 then NewHeight := 0;
  1300.   Result := (NewWidth <> FWidth) or (NewHeight <> FHeight);
  1301.   if Result then
  1302.   begin
  1303.     ChangeSize(FWidth, FHeight, NewWidth, NewHeight);
  1304.     Changed;
  1305.     Resized;
  1306.   end;
  1307. end;
  1308.  
  1309. function TCustomMap.SetSizeFrom(Source: TPersistent): Boolean;
  1310. begin
  1311.   if Source is TCustomMap then
  1312.     Result := SetSize(TCustomMap(Source).Width, TCustomMap(Source).Height)
  1313.   else if Source is TGraphic then
  1314.     Result := SetSize(TGraphic(Source).Width, TGraphic(Source).Height)
  1315.   else if Source is TControl then
  1316.     Result := SetSize(TControl(Source).Width, TControl(Source).Height)
  1317.   else if Source = nil then
  1318.     Result := SetSize(0, 0)
  1319.   else
  1320.     raise Exception.Create('Can''t set size from ''' + Source.ClassName + '''');
  1321. end;
  1322.  
  1323. procedure TCustomMap.SetWidth(NewWidth: Integer);
  1324. begin
  1325.   SetSize(NewWidth, Height);
  1326. end;
  1327.  
  1328.  
  1329. { TBitmap32 }
  1330.  
  1331. constructor TBitmap32.Create;
  1332. begin
  1333.   inherited;
  1334. {$IFNDEF CLX}
  1335.   FillChar(FBitmapInfo, SizeOf(TBitmapInfo), 0);
  1336.   with FBitmapInfo.bmiHeader do
  1337.   begin
  1338.     biSize := SizeOf(TBitmapInfoHeader);
  1339.     biPlanes := 1;
  1340.     biBitCount := 32;
  1341.     biCompression := BI_RGB;
  1342.   end;
  1343. {$ENDIF}
  1344.   FOuterColor := $00000000;  // by default as full transparency black
  1345.   FFont := TFont.Create;
  1346.   FFont.OnChange := FontChanged;
  1347. {$IFNDEF CLX}
  1348.   FFont.OwnerCriticalSection := @FLock;
  1349. {$ENDIF}
  1350.   FMasterAlpha := $FF;
  1351.   FPenColor := clWhite32;
  1352.   FStippleStep := 1;
  1353.  
  1354.   CombineMode := cmBlend;
  1355. end;
  1356.  
  1357. destructor TBitmap32.Destroy;
  1358. begin
  1359.   BeginUpdate;
  1360.   Lock;
  1361.   try
  1362.     DeleteCanvas;
  1363.     SetSize(0, 0);
  1364.     FFont.Free;
  1365.   finally
  1366.     Unlock;
  1367.   end;
  1368.   inherited;
  1369. end;
  1370.  
  1371. procedure TBitmap32.HandleChanged;
  1372. begin
  1373.   if FCanvas <> nil then FCanvas.Handle := Self.Handle;
  1374.   if Assigned(FOnHandleChanged) then FOnHandleChanged(Self);
  1375. end;
  1376.  
  1377. procedure TBitmap32.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer);
  1378. begin
  1379.   try
  1380.     FontChanged(Self);
  1381.     DeleteCanvas; // Patch by Thomas Bauer.....
  1382.  
  1383. {$IFDEF CLX}
  1384.     if Assigned(FHDC) then QPainter_destroy(FHDC);
  1385.     FHDC := nil;
  1386.     if Assigned(FHandle) then QImage_destroy(FHandle);
  1387.     FHandle := nil;
  1388. {$ELSE}
  1389.     if FHDC <> 0 then DeleteDC(FHDC);
  1390.     FHDC := 0;
  1391.     if FHandle <> 0 then DeleteObject(FHandle);
  1392.     FHandle := 0;
  1393. {$ENDIF}
  1394.  
  1395.     FBits := nil;
  1396.     Width := 0;
  1397.     Height := 0;
  1398.     if (NewWidth > 0) and (NewHeight > 0) then
  1399.     begin
  1400. {$IFDEF CLX}
  1401.       FHandle := QImage_create(NewWidth, NewHeight, 32, 1, QImageEndian_IgnoreEndian);
  1402.       if FHandle <> nil then
  1403.       begin
  1404.         FBits := Pointer(QImage_bits(FHandle));
  1405.         // clear it since QT doesn't initialize the image data:
  1406.         FillLongword(FBits[0], NewWidth * NewHeight, clBlack32);
  1407.       end;
  1408. {$ELSE}
  1409.       with FBitmapInfo.bmiHeader do
  1410.       begin
  1411.         biWidth := NewWidth;
  1412.         biHeight := -NewHeight;
  1413.       end;
  1414.       FHandle := CreateDIBSection(0, FBitmapInfo, DIB_RGB_COLORS, Pointer(FBits), 0, 0);
  1415. {$ENDIF}
  1416.  
  1417.       if FBits = nil then raise Exception.Create('Can''t allocate the DIB handle');
  1418.  
  1419. {$IFDEF CLX}
  1420.       FHDC := QPainter_create;
  1421.       if FHDC = nil then
  1422.       begin
  1423.         QImage_destroy(FHandle);
  1424.         FBits := nil;
  1425.         raise Exception.Create('Can''t create compatible DC');
  1426.       end;
  1427.  
  1428.       FPixmap := QPixmap_create;
  1429.       FPixmapActive := False;
  1430. {$ELSE}
  1431.       FHDC := CreateCompatibleDC(0);
  1432.       if FHDC = 0 then
  1433.       begin
  1434.         DeleteObject(FHandle);
  1435.         FHandle := 0;
  1436.         FBits := nil;
  1437.         raise Exception.Create('Can''t create compatible DC');
  1438.       end;
  1439.  
  1440.       if SelectObject(FHDC, FHandle) = 0 then
  1441.       begin
  1442.         DeleteDC(FHDC);
  1443.         DeleteObject(FHandle);
  1444.         FHDC := 0;
  1445.         FHandle := 0;
  1446.         FBits := nil;
  1447.         raise Exception.Create('Can''t select an object into DC');
  1448.       end;
  1449. {$ENDIF}
  1450.     end;
  1451.  
  1452.     Width := NewWidth;
  1453.     Height := NewHeight;
  1454.  
  1455.     ResetClipRect;
  1456.   finally
  1457.     HandleChanged;
  1458.   end;
  1459. end;
  1460.  
  1461. function TBitmap32.Empty: Boolean;
  1462. begin
  1463. {$IFDEF CLX}
  1464.   Result := not(Assigned(FHandle) or Assigned(FPixmap)) or inherited Empty;
  1465. {$ELSE}
  1466.   Result := (FHandle = 0) or inherited Empty;
  1467. {$ENDIF}
  1468. end;
  1469.  
  1470. procedure TBitmap32.Clear;
  1471. begin
  1472.   Clear(clBlack32);
  1473. end;
  1474.  
  1475. procedure TBitmap32.Clear(FillColor: TColor32);
  1476. begin
  1477.   if Empty then Exit;
  1478.   FillLongword(Bits[0], Width * Height, FillColor);
  1479.   Changed;
  1480. end;
  1481.  
  1482. procedure TBitmap32.Delete;
  1483. begin
  1484.   SetSize(0, 0);
  1485. end;
  1486.  
  1487. procedure TBitmap32.Assign(Source: TPersistent);
  1488. var
  1489.   Canvas: TCanvas;
  1490.   Picture: TPicture;
  1491.   TempBitmap: TBitmap32;
  1492.   I: integer;
  1493.   DstP, SrcP: PColor32;
  1494.   DstColor: TColor32;
  1495.  
  1496.   procedure AssignFromBitmap(SrcBmp: TBitmap);
  1497.   var
  1498.     TransparentColor: TColor32;
  1499.     I: integer;
  1500.   begin
  1501.     SetSize(SrcBmp.Width, SrcBmp.Height);
  1502.     if Empty then Exit;
  1503. {$IFDEF CLX}
  1504.     if not QPainter_isActive(Handle) then
  1505.       if not QPainter_begin(Handle, Pixmap) then
  1506.         raise EInvalidGraphicOperation.CreateRes(@SInvalidCanvasState);
  1507.     QPainter_drawPixmap(Handle, 0, 0, SrcBmp.Handle, 0, 0, Width, Height);
  1508.     QPainter_end(Handle);
  1509.     PixmapChanged := True;
  1510. {$ELSE}
  1511.     BitBlt(Handle, 0, 0, Width, Height, SrcBmp.Canvas.Handle, 0, 0, SRCCOPY);
  1512. {$ENDIF}
  1513.     if SrcBmp.PixelFormat <> pf32bit then ResetAlpha;
  1514.     if SrcBmp.Transparent then
  1515.     begin
  1516.       TransparentColor := Color32(SrcBmp.TransparentColor) and $00FFFFFF;
  1517.       DstP := @Bits[0];
  1518.       for I := 0 to Width * Height - 1 do
  1519.       begin
  1520.         DstColor := DstP^ and $00FFFFFF;
  1521.         if DstColor = TransparentColor then
  1522.           DstP^ := DstColor;
  1523.         inc(DstP);
  1524.       end;
  1525.     end;
  1526.   end;
  1527.  
  1528. begin
  1529.   BeginUpdate;
  1530.   try
  1531.     if Source = nil then
  1532.     begin
  1533.       SetSize(0, 0);
  1534.       Exit;
  1535.     end
  1536.     else if Source is TBitmap32 then
  1537.     begin
  1538.       SetSize(TBitmap32(Source).Width, TBitmap32(Source).Height);
  1539.       if Empty then Exit;
  1540. {$IFDEF CLX}
  1541.       Move(TBitmap32(Source).Bits[0], Bits[0], Width * Height * 4);
  1542. {$ELSE}
  1543.       BitBlt(Handle, 0, 0, Width, Height, TBitmap32(Source).Handle, 0, 0, SRCCOPY);
  1544.       //Move(TBitmap32(Source).Bits[0], Bits[0], Width * Height * 4);
  1545.       // Move is up to 2x faster with FastMove by the FastCode Project
  1546. {$ENDIF}
  1547.       FDrawMode := TBitmap32(Source).FDrawMode;
  1548.       FMasterAlpha := TBitmap32(Source).FMasterAlpha;
  1549.       FOuterColor := TBitmap32(Source).FOuterColor;
  1550.       FStretchFilter := TBitmap32(Source).FStretchFilter;
  1551.       Exit;
  1552.     end
  1553.     else if Source is TBitmap then
  1554.     begin
  1555.       AssignFromBitmap(TBitmap(Source));
  1556.       Exit;
  1557.     end
  1558.     else if Source is TGraphic then
  1559.     begin
  1560.       SetSize(TGraphic(Source).Width, TGraphic(Source).Height);
  1561.       if Empty then Exit;
  1562.       Canvas := TCanvas.Create;
  1563.       try
  1564.         Canvas.Handle := Self.Handle;
  1565.         TGraphicAccess(Source).Draw(Canvas, MakeRect(0, 0, Width, Height));
  1566.         ResetAlpha;
  1567.       finally
  1568.         Canvas.Free;
  1569.       end;
  1570.     end
  1571.     else if Source is TPicture then
  1572.     begin
  1573.       with TPicture(Source) do
  1574.       begin
  1575.         if TPicture(Source).Graphic is TBitmap then
  1576.           AssignFromBitmap(TBitmap(TPicture(Source).Graphic))
  1577.         else if (TPicture(Source).Graphic is TIcon) {$IFNDEF CLX}or
  1578.                 (TPicture(Source).Graphic is TMetaFile) {$ENDIF} then
  1579.         begin
  1580.           // icons, metafiles etc...
  1581.           SetSize(TPicture(Source).Graphic.Width, TPicture(Source).Graphic.Height);
  1582.           if Empty then Exit;
  1583.  
  1584.           TempBitmap := TBitmap32.Create;
  1585.           Canvas := TCanvas.Create;
  1586.           try
  1587.             Self.Clear(clWhite32);  // mask on white;
  1588.             Canvas.Handle := Self.Handle;
  1589.             TGraphicAccess(Graphic).Draw(Canvas, MakeRect(0, 0, Width, Height));
  1590.  
  1591.             TempBitmap.SetSize(TPicture(Source).Graphic.Width, TPicture(Source).Graphic.Height);
  1592.             TempBitmap.Clear(clRed32); // mask on red;
  1593.             Canvas.Handle := TempBitmap.Handle;
  1594.             TGraphicAccess(Graphic).Draw(Canvas, MakeRect(0, 0, Width, Height));
  1595.  
  1596.             DstP := @Bits[0];
  1597.             SrcP := @TempBitmap.Bits[0];
  1598.             for I := 0 to Width * Height - 1 do
  1599.             begin
  1600.               DstColor := DstP^ and $00FFFFFF;
  1601.               // this checks for transparency by comparing the pixel-color of the
  1602.               // temporary bitmap (red masked) with the pixel of our
  1603.               // bitmap (white masked). If they match, make that pixel opaque
  1604.               if DstColor = (SrcP^ and $00FFFFFF) then
  1605.                 DstP^ := DstColor or $FF000000
  1606.               else
  1607.               // if the colors don't match (that is the case if there is a
  1608.               // match "is clRed32 = clBlue32 ?"), just make that pixel
  1609.               // transparent:
  1610.                 DstP^ := DstColor;
  1611.  
  1612.                inc(SrcP); inc(DstP);
  1613.             end;
  1614.           finally
  1615.             TempBitmap.Free;
  1616.             Canvas.Free;
  1617.           end;
  1618.         end
  1619.         else
  1620.         begin
  1621.           // anything else...
  1622.           SetSize(TPicture(Source).Graphic.Width, TPicture(Source).Graphic.Height);
  1623.           if Empty then Exit;
  1624.           Canvas := TCanvas.Create;
  1625.           try
  1626.             Canvas.Handle := Self.Handle;
  1627.             TGraphicAccess(Graphic).Draw(Canvas, MakeRect(0, 0, Width, Height));
  1628.             ResetAlpha;
  1629.           finally
  1630.             Canvas.Free;
  1631.           end;
  1632.         end;
  1633.       end;
  1634.       Exit;
  1635.     end
  1636.     else if Source is TClipboard then
  1637.     begin
  1638.       Picture := TPicture.Create;
  1639.       try
  1640.         Picture.Assign(TClipboard(Source));
  1641.         SetSize(Picture.Width, Picture.Height);
  1642.         if Empty then Exit;
  1643.         Canvas := TCanvas.Create;
  1644.         try
  1645.           Canvas.Handle := Self.Handle;
  1646.           TGraphicAccess(Picture.Graphic).Draw(Canvas, MakeRect(0, 0, Width, Height));
  1647.           ResetAlpha;
  1648.         finally
  1649.           Canvas.Free;
  1650.         end;
  1651.       finally
  1652.         Picture.Free;
  1653.       end;
  1654.       Exit;
  1655.     end
  1656.     else
  1657.       inherited; // default handler
  1658.   finally;
  1659.     EndUpdate;
  1660.     Changed;
  1661.   end;
  1662. end;
  1663.  
  1664. procedure TBitmap32.AssignTo(Dst: TPersistent);
  1665. var
  1666.   Bmp: TBitmap;
  1667.  
  1668.   procedure CopyToBitmap(Bmp: TBitmap);
  1669.   begin
  1670. {$IFNDEF CLX}
  1671.     Bmp.HandleType := bmDIB;
  1672. {$ENDIF}
  1673.     Bmp.PixelFormat := pf32Bit;
  1674.     Bmp.Width := Width;
  1675.     Bmp.Height := Height;
  1676.     DrawTo(Bmp.Canvas.Handle, 0, 0);
  1677.   end;
  1678.  
  1679. begin
  1680.   if Dst is TPicture then CopyToBitmap(TPicture(Dst).Bitmap)
  1681.   else if Dst is TBitmap then CopyToBitmap(TBitmap(Dst))
  1682.   else if Dst is TClipboard then
  1683.   begin
  1684.     Bmp := TBitmap.Create;
  1685.     try
  1686.       CopyToBitmap(Bmp);
  1687.       TClipboard(Dst).Assign(Bmp);
  1688.     finally
  1689.       Bmp.Free;
  1690.     end;
  1691.   end
  1692.   else inherited;
  1693. end;
  1694.  
  1695. function TBitmap32.GetCanvas: TCanvas;
  1696. begin
  1697.   if FCanvas = nil then
  1698.   begin
  1699. {$IFDEF CLX}
  1700.     FCanvas := TBitmap32Canvas.Create(Self);
  1701. {$ELSE}
  1702.     FCanvas := TCanvas.Create;
  1703. {$ENDIF}
  1704.     FCanvas.Handle := Handle;
  1705.     FCanvas.OnChange := CanvasChanged;
  1706.   end;
  1707.   Result := FCanvas;
  1708. end;
  1709.  
  1710. procedure TBitmap32.CanvasChanged(Sender: TObject);
  1711. begin
  1712.   Changed;
  1713. end;
  1714.  
  1715. function TBitmap32.CanvasAllocated: Boolean;
  1716. begin
  1717.   Result := FCanvas <> nil;
  1718. end;
  1719.  
  1720. procedure TBitmap32.DeleteCanvas;
  1721. begin
  1722.   if FCanvas <> nil then
  1723.   begin
  1724. {$IFDEF CLX}
  1725.     FCanvas.Handle := nil;
  1726. {$ELSE}
  1727.     FCanvas.Handle := 0;
  1728. {$ENDIF}
  1729.     FCanvas.Free;
  1730.     FCanvas := nil;
  1731.   end;
  1732. end;
  1733.  
  1734. procedure TBitmap32.SetPixel(X, Y: Integer; Value: TColor32);
  1735. begin
  1736.   Bits[X + Y * Width] := Value;
  1737. end;
  1738.  
  1739. procedure TBitmap32.SetPixelS(X, Y: Integer; Value: TColor32);
  1740. begin
  1741.   if (X >= FClipRect.Left) and (X < FClipRect.Right) and
  1742.      (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then
  1743.     Bits[X + Y * Width] := Value;
  1744. end;
  1745.  
  1746. function TBitmap32.GetScanLine(Y: Integer): PColor32Array;
  1747. begin
  1748.   Result := @Bits[Y * FWidth];
  1749. end;
  1750.  
  1751. function TBitmap32.GetPixel(X, Y: Integer): TColor32;
  1752. begin
  1753.   Result := Bits[X + Y * Width];
  1754. end;
  1755.  
  1756. function TBitmap32.GetPixelS(X, Y: Integer): TColor32;
  1757. begin
  1758.   if (X >= FClipRect.Left) and (X < FClipRect.Right) and
  1759.      (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then
  1760.     Result := Bits[X + Y * Width]
  1761.   else
  1762.     Result := OuterColor;
  1763. end;
  1764.  
  1765. function TBitmap32.GetPixelPtr(X, Y: Integer): PColor32;
  1766. begin
  1767.   Result := @Bits[X + Y * Width];
  1768. end;
  1769.  
  1770. procedure TBitmap32.Draw(DstX, DstY: Integer; Src: TBitmap32);
  1771. begin
  1772.   if Assigned(Src) then Src.DrawTo(Self, DstX, DstY);
  1773. end;
  1774.  
  1775. procedure TBitmap32.Draw(DstX, DstY: Integer; const SrcRect: TRect; Src: TBitmap32);
  1776. begin
  1777.   if Assigned(Src) then Src.DrawTo(Self, DstX, DstY, SrcRect);
  1778. end;
  1779.  
  1780. procedure TBitmap32.Draw(const DstRect, SrcRect: TRect; Src: TBitmap32);
  1781. begin
  1782.   if Assigned(Src) then Src.DrawTo(Self, DstRect, SrcRect);
  1783. end;
  1784.  
  1785. {$IFDEF CLX}
  1786. procedure TBitmap32.Draw(const DstRect, SrcRect: TRect; SrcPixmap: QPixmapH);
  1787. var
  1788.   NewMatrix: QWMatrixH;
  1789.   SrcHeight, SrcWidth: Integer;
  1790. begin
  1791.   if Empty then Exit;
  1792.   StartPainter;
  1793.   QPainter_saveWorldMatrix(Handle);
  1794.   try
  1795.     SrcWidth := SrcRect.Right - SrcRect.Left;
  1796.     SrcHeight := SrcRect.Bottom - SrcRect.Top;
  1797.     // use world transformation to translate and scale.
  1798.     NewMatrix:= QWMatrix_create((DstRect.Right - DstRect.Left) / SrcWidth ,
  1799.       0, 0, (DstRect.Bottom - DstRect.Top) / SrcHeight, DstRect.Left, DstRect.Top);
  1800.     try
  1801.       QPainter_setWorldMatrix(Handle, NewMatrix, True);
  1802.       QPainter_drawPixmap(Handle, 0, 0, SrcPixmap,
  1803.         SrcRect.Left, SrcRect.Top, SrcWidth, SrcHeight);
  1804.     finally
  1805.       QWMatrix_destroy(NewMatrix);
  1806.     end;
  1807.   finally
  1808.     QPainter_restoreWorldMatrix(Handle);
  1809.     StopPainter;
  1810.   end;
  1811.   Changed;
  1812. end;
  1813.  
  1814. {$ELSE}
  1815.  
  1816. procedure TBitmap32.Draw(const DstRect, SrcRect: TRect; hSrc: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF});
  1817. begin
  1818.   if Empty then Exit;
  1819.   StretchBlt(Handle, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
  1820.     DstRect.Bottom - DstRect.Top, hSrc, SrcRect.Left, SrcRect.Top,
  1821.     SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, SRCCOPY);
  1822.   Changed;
  1823. end;
  1824. {$ENDIF}
  1825.  
  1826. procedure TBitmap32.DrawTo(Dst: TBitmap32);
  1827. begin
  1828.   if Empty or Dst.Empty then Exit;
  1829.   BlockTransfer(Dst, 0, 0, Dst.ClipRect, Self, BoundsRect, DrawMode, FOnPixelCombine);
  1830.   Dst.Changed;
  1831. end;
  1832.  
  1833. procedure TBitmap32.DrawTo(Dst: TBitmap32; DstX, DstY: Integer);
  1834. begin
  1835.   if Empty or Dst.Empty then Exit;
  1836.   BlockTransfer(Dst, DstX, DstY, Dst.ClipRect, Self, BoundsRect, DrawMode, FOnPixelCombine);
  1837.   Dst.Changed;
  1838. end;
  1839.  
  1840. procedure TBitmap32.DrawTo(Dst: TBitmap32; DstX, DstY: Integer; const SrcRect: TRect);
  1841. begin
  1842.   if Empty or Dst.Empty then Exit;
  1843.   BlockTransfer(Dst, DstX, DstY, Dst.ClipRect, Self, SrcRect, DrawMode, FOnPixelCombine);
  1844.   Dst.Changed;
  1845. end;
  1846.  
  1847. procedure TBitmap32.DrawTo(Dst: TBitmap32; const DstRect: TRect);
  1848. begin
  1849.   if Empty or Dst.Empty then Exit;
  1850.   StretchTransfer(Dst, DstRect, Dst.ClipRect, Self, BoundsRect, StretchFilter, DrawMode, FOnPixelCombine);
  1851.   Dst.Changed;
  1852. end;
  1853.  
  1854. procedure TBitmap32.DrawTo(Dst: TBitmap32; const DstRect, SrcRect: TRect);
  1855. begin
  1856.   if Empty or Dst.Empty then Exit;
  1857.   StretchTransfer(Dst, DstRect, Dst.ClipRect, Self, SrcRect, StretchFilter, DrawMode, FOnPixelCombine);
  1858.   Dst.Changed;
  1859. end;
  1860.  
  1861. procedure TBitmap32.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; DstX, DstY: Integer);
  1862. begin
  1863.   if Empty then Exit;
  1864. {$IFDEF CLX}
  1865.   StretchPixmap(
  1866.     hDst, DstX, DstY, Width, Height,
  1867.     0, 0, Width, Height, GetPixmap);
  1868. {$ELSE}
  1869.   StretchDIBits(
  1870.     hDst, DstX, DstY, Width, Height,
  1871.     0, 0, Width, Height, Bits, FBitmapInfo, DIB_RGB_COLORS, SRCCOPY);
  1872. {$ENDIF}
  1873. end;
  1874.  
  1875. procedure TBitmap32.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect);
  1876. begin
  1877.   if Empty then Exit;
  1878. {$IFDEF CLX}
  1879.   StretchPixmap(
  1880.     hDst,
  1881.     DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top,
  1882.     SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left,
  1883.     SrcRect.Bottom - SrcRect.Top, GetPixmap);
  1884. {$ELSE}
  1885.   StretchDIBits(
  1886.     hDst,
  1887.     DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top,
  1888.     SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left,
  1889.     SrcRect.Bottom - SrcRect.Top, Bits, FBitmapInfo, DIB_RGB_COLORS, SRCCOPY);
  1890. {$ENDIF}
  1891. end;
  1892.  
  1893. procedure TBitmap32.TileTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect);
  1894. const
  1895.   MaxTileSize = 1024;
  1896. var
  1897.   DstW, DstH: Integer;
  1898.   TilesX, TilesY: Integer;
  1899.   Buffer: TBitmap32;
  1900.   I, J: Integer;
  1901.   ClipRect, R: TRect;
  1902.   X, Y: Integer;
  1903. begin
  1904.   DstW := DstRect.Right - DstRect.Left;
  1905.   DstH := DstRect.Bottom - DstRect.Top;
  1906.   TilesX := (DstW + MaxTileSize - 1) div MaxTileSize;
  1907.   TilesY := (DstH + MaxTileSize - 1) div MaxTileSize;
  1908.   Buffer := TBitmap32.Create;
  1909.   try
  1910.     for J := 0 to TilesY - 1 do
  1911.     begin
  1912.       for I := 0 to TilesX - 1 do
  1913.       begin
  1914.         ClipRect.Left := I * MaxTileSize;
  1915.         ClipRect.Top := J * MaxTileSize;
  1916.         ClipRect.Right := (I + 1) * MaxTileSize;
  1917.         ClipRect.Bottom := (J + 1) * MaxTileSize;
  1918.         if ClipRect.Right > DstW then ClipRect.Right := DstW;
  1919.         if ClipRect.Bottom > DstH then ClipRect.Bottom := DstH;
  1920.         X := ClipRect.Left;
  1921.         Y := ClipRect.Top;
  1922.         OffsetRect(ClipRect, -X, -Y);
  1923.         R := DstRect;
  1924.         OffsetRect(R, -X - DstRect.Left, -Y - DstRect.Top);
  1925.         Buffer.SetSize(ClipRect.Right, ClipRect.Bottom);
  1926.         StretchTransfer(Buffer, R, ClipRect, Self, SrcRect, StretchFilter, DrawMode, FOnPixelCombine);
  1927.  
  1928. {$IFDEF CLX}
  1929.         StretchPixmap(
  1930.           hDst, X + DstRect.Left, Y + DstRect.Top, ClipRect.Right, ClipRect.Bottom,
  1931.           0, 0, Buffer.Width, Buffer.Height, GetPixmap);
  1932. {$ELSE}
  1933.         StretchDIBits(
  1934.           hDst, X + DstRect.Left, Y + DstRect.Top, ClipRect.Right, ClipRect.Bottom,
  1935.           0, 0, Buffer.Width, Buffer.Height,
  1936.           Buffer.Bits, Buffer.FBitmapInfo, DIB_RGB_COLORS, SRCCOPY);
  1937. {$ENDIF}
  1938.       end;
  1939.     end;
  1940.   finally
  1941.     Buffer.Free;
  1942.   end;
  1943. end;
  1944.  
  1945. procedure TBitmap32.ResetAlpha;
  1946. begin
  1947.   ResetAlpha($FF);
  1948. end;
  1949.  
  1950. procedure TBitmap32.ResetAlpha(const AlphaValue: Byte);
  1951. var
  1952.   I: Integer;
  1953.   P: PByte;
  1954.   NH, NL: Integer;
  1955. begin
  1956.   P := Pointer(FBits);
  1957.   Inc(P, 3); // shift the pointer to 'alpha' component of the first pixel
  1958.  
  1959.   { Enroll the loop 4 times }
  1960.   I := Width * Height;
  1961.   NH := I shr 2;
  1962.   NL := I and $3;
  1963.   for I := 0 to NH - 1 do
  1964.   begin
  1965.     P^ := AlphaValue; Inc(P, 4);
  1966.     P^ := AlphaValue; Inc(P, 4);
  1967.     P^ := AlphaValue; Inc(P, 4);
  1968.     P^ := AlphaValue; Inc(P, 4);
  1969.   end;
  1970.   for I := 0 to NL - 1 do
  1971.   begin
  1972.     P^ := AlphaValue; Inc(P, 4);
  1973.   end;
  1974.   Changed;
  1975. end;
  1976.  
  1977. function TBitmap32.GetPixelB(X, Y: Integer): TColor32;
  1978. begin
  1979.   // WARNING: this function should never be used on empty bitmaps !!!
  1980.   if X < 0 then X := 0
  1981.   else if X >= Width then X := Width - 1;
  1982.   if Y < 0 then Y := 0
  1983.   else if Y >= Height then Y := Height - 1;
  1984.   Result := Bits[X + Y * Width];
  1985. end;
  1986.  
  1987. procedure TBitmap32.SetPixelT(X, Y: Integer; Value: TColor32);
  1988. begin
  1989.   BLEND_MEM[FCombineMode](Value, Bits[X + Y * Width]);
  1990.   if MMX_ACTIVE then
  1991.   asm
  1992.     db $0F,$77               /// EMMS
  1993.   end;
  1994. end;
  1995.  
  1996. procedure TBitmap32.SetPixelT(var Ptr: PColor32; Value: TColor32);
  1997. begin
  1998.   BLEND_MEM[FCombineMode](Value, Ptr^);
  1999.   Inc(Ptr);
  2000.   if MMX_ACTIVE then
  2001.   asm
  2002.     db $0F,$77               /// EMMS
  2003.   end;
  2004. end;
  2005.  
  2006. procedure TBitmap32.SetPixelTS(X, Y: Integer; Value: TColor32);
  2007. begin
  2008.   if (X >= FClipRect.Left) and (X < FClipRect.Right) and
  2009.      (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then
  2010.   begin
  2011.     BLEND_MEM[FCombineMode](Value, Bits[X + Y * Width]);
  2012.     if MMX_ACTIVE then
  2013.     asm
  2014.       db $0F,$77               /// EMMS
  2015.     end;
  2016.   end;
  2017. end;
  2018.  
  2019. procedure TBitmap32.SET_T256(X, Y: Integer; C: TColor32);
  2020. var
  2021.   flrx, flry, celx, cely: Longword;
  2022.   P: PColor32;
  2023.   A: TColor32;
  2024.   CombineMem: TCombineMem;
  2025. begin
  2026.   { Warning: EMMS should be called after using this method }
  2027.   A := C shr 24;  // opacity
  2028.  
  2029.   flrx := X and $FF;
  2030.   flry := Y and $FF;
  2031.  
  2032.   asm
  2033.     SAR X, 8
  2034.     SAR Y, 8
  2035.   end;
  2036.  
  2037.   celx := A * GAMMA_TABLE[flrx xor 255];
  2038.   cely := GAMMA_TABLE[flry xor 255];
  2039.   P := @FBits[X + Y * FWidth];
  2040.   flrx := A * GAMMA_TABLE[flrx];
  2041.   flry := GAMMA_TABLE[flry];
  2042.  
  2043.   CombineMem := COMBINE_MEM[FCombineMode];
  2044.   CombineMem(C, P^, celx * cely shr 16); Inc(P);
  2045.   CombineMem(C, P^, flrx * cely shr 16); Inc(P, FWidth);
  2046.   CombineMem(C, P^, flrx * flry shr 16); Dec(P);
  2047.   CombineMem(C, P^, celx * flry shr 16);
  2048. end;
  2049.  
  2050. procedure TBitmap32.SET_TS256(X, Y: Integer; C: TColor32);
  2051. var
  2052.   flrx, flry, celx, cely: Longword;
  2053.   P: PColor32;
  2054.   A: TColor32;
  2055.   CombineMem: TCombineMem;
  2056. begin
  2057.   { Warning: EMMS should be called after using this method }
  2058.  
  2059.   // we're checking against Left - 1 and Top - 1 due to antialiased values...
  2060.   if (X < F256ClipRect.Left - 256) or (X >= F256ClipRect.Right) or
  2061.      (Y < F256ClipRect.Top - 256) or (Y >= F256ClipRect.Bottom) then Exit;
  2062.  
  2063.   flrx := X and $FF;
  2064.   flry := Y and $FF;
  2065.  
  2066.   asm
  2067.     SAR X, 8
  2068.     SAR Y, 8
  2069.   end;
  2070.  
  2071.   A := C shr 24;  // opacity
  2072.  
  2073.   celx := A * GAMMA_TABLE[flrx xor 255];
  2074.   cely := GAMMA_TABLE[flry xor 255];
  2075.   P := @FBits[X + Y * FWidth];
  2076.   flrx := A * GAMMA_TABLE[flrx];
  2077.   flry := GAMMA_TABLE[flry];
  2078.  
  2079.   CombineMem := COMBINE_MEM[FCombineMode];
  2080.  
  2081.   if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
  2082.      (X < FClipRect.Right - 1) and (Y < FClipRect.Bottom - 1) then
  2083.   begin
  2084.     CombineMem(C, P^, celx * cely shr 16); Inc(P);
  2085.     CombineMem(C, P^, flrx * cely shr 16); Inc(P, FWidth);
  2086.     CombineMem(C, P^, flrx * flry shr 16); Dec(P);
  2087.     CombineMem(C, P^, celx * flry shr 16);
  2088.   end
  2089.   else // "pixel" lies on the edge of the bitmap
  2090.   with FClipRect do
  2091.   begin
  2092.     if (X >= Left) and (Y >= Top) then CombineMem(C, P^, celx * cely shr 16); Inc(P);
  2093.     if (X < Right - 1) and (Y >= Top) then CombineMem(C, P^, flrx * cely shr 16); Inc(P, FWidth);
  2094.     if (X < Right - 1) and (Y < Bottom - 1) then CombineMem(C, P^, flrx * flry shr 16); Dec(P);
  2095.     if (X >= Left) and (Y < Bottom - 1) then CombineMem(C, P^, celx * flry shr 16);
  2096.   end;
  2097. end;
  2098.  
  2099. procedure TBitmap32.SetPixelF(X, Y: Single; Value: TColor32);
  2100. begin
  2101.   SET_T256(Round(X * 256), Round(Y * 256), Value);
  2102.   EMMS;
  2103. end;
  2104.  
  2105. procedure TBitmap32.SetPixelX(X, Y: TFixed; Value: TColor32);
  2106. begin
  2107.   asm
  2108.         ADD X, $7F
  2109.         ADD Y, $7F
  2110.         SAR X, 8
  2111.         SAR Y, 8
  2112.   end;
  2113.   SET_T256(X, Y, Value);
  2114.   EMMS;
  2115. end;
  2116.  
  2117. procedure TBitmap32.SetPixelFS(X, Y: Single; Value: TColor32);
  2118. begin
  2119.   SET_TS256(Round(X * 256), Round(Y * 256), Value);
  2120.   EMMS;
  2121. end;
  2122.  
  2123. procedure TBitmap32.SetPixelXS(X, Y: TFixed; Value: TColor32);
  2124. begin
  2125.   asm
  2126.         ADD X, $7F
  2127.         ADD Y, $7F
  2128.         SAR X, 8
  2129.         SAR Y, 8
  2130.   end;
  2131.   SET_TS256(X, Y, Value);
  2132.   EMMS;
  2133. end;
  2134.  
  2135. function TBitmap32.GET_T256(X, Y: Integer): TColor32;
  2136. // When using this, remember that it interpolates towards next x and y!
  2137. var
  2138.   Pos: Integer;
  2139. begin
  2140.   Pos := (X shr 8) + (Y shr 8) * FWidth;
  2141.   Result := Interpolator(GAMMA_TABLE[X and $FF xor 255],
  2142.                          GAMMA_TABLE[Y and $FF xor 255],
  2143.                          @FBits[Pos], @FBits[Pos + FWidth]);
  2144. end;
  2145.  
  2146. function TBitmap32.GET_TS256(X, Y: Integer): TColor32;
  2147. begin
  2148.   if (X > 0) and (Y > 0) and (X < (FWidth - 1) shl 8) and (Y < (FHeight - 1) shl 8) then
  2149.     Result := GET_T256(X,Y)
  2150.   else
  2151.     Result := FOuterColor;
  2152. end;
  2153.  
  2154. function TBitmap32.GetPixelF(X, Y: Single): TColor32;
  2155. begin
  2156.   Result := GET_T256(Round(X * 256), Round(Y * 256));
  2157.   EMMS;
  2158. end;
  2159.  
  2160. function TBitmap32.GetPixelFS(X, Y: Single): TColor32;
  2161. begin
  2162.   Result := GET_TS256(Round(X * 256), Round(Y * 256));
  2163.   EMMS;
  2164. end;
  2165.  
  2166. function TBitmap32.GetPixelX(X, Y: TFixed): TColor32;
  2167. begin
  2168.   asm
  2169.         ADD X, $7F
  2170.         ADD Y, $7F
  2171.         SAR X, 8
  2172.         SAR Y, 8
  2173.   end;
  2174.   Result := GET_T256(X, Y);
  2175.   EMMS;
  2176. end;
  2177.  
  2178. function TBitmap32.GetPixelXS(X, Y: TFixed): TColor32;
  2179. begin
  2180.   asm
  2181.         ADD X, $7F
  2182.         ADD Y, $7F
  2183.         SAR X, 8
  2184.         SAR Y, 8
  2185.   end;
  2186.   Result := GET_TS256(X, Y);
  2187.   EMMS;
  2188. end;
  2189.  
  2190. procedure TBitmap32.SetStipple(NewStipple: TArrayOfColor32);
  2191. begin
  2192.   FStippleCounter := 0;
  2193.   FStipplePattern := Copy(NewStipple, 0, Length(NewStipple));
  2194. end;
  2195.  
  2196. procedure TBitmap32.SetStipple(NewStipple: array of TColor32);
  2197. var
  2198.   L: Integer;
  2199. begin
  2200.   FStippleCounter := 0;
  2201.   L := High(NewStipple) + 1;
  2202.   SetLength(FStipplePattern, L);
  2203.   Move(NewStipple[0], FStipplePattern[0], L shl 2);
  2204. end;
  2205.  
  2206. procedure TBitmap32.AdvanceStippleCounter(LengthPixels: Single);
  2207. var
  2208.   L: Integer;
  2209.   Delta: Single;
  2210. begin
  2211.   L := Length(FStipplePattern);
  2212.   Delta := LengthPixels * FStippleStep;
  2213.   if (L = 0) or (Delta = 0) then Exit;
  2214.   FStippleCounter := FStippleCounter + Delta;
  2215.   FStippleCounter := FStippleCounter - Floor(FStippleCounter / L) * L;
  2216. end;
  2217.  
  2218. function TBitmap32.GetStippleColor: TColor32;
  2219. var
  2220.   L: Integer;
  2221.   NextIndex, PrevIndex: Integer;
  2222.   PrevWeight: Integer;
  2223. begin
  2224.   L := Length(FStipplePattern);
  2225.   if L = 0 then
  2226.   begin
  2227.     // no pattern defined, just return something and exit
  2228.     Result := clBlack32;
  2229.     Exit;
  2230.   end;
  2231.   while FStippleCounter >= L do FStippleCounter := FStippleCounter - L;
  2232.   while FStippleCounter < 0 do FStippleCounter := FStippleCounter + L;
  2233.   PrevIndex := Round(FStippleCounter - 0.5);
  2234.   PrevWeight := 255 - Round(255 * (FStippleCounter - PrevIndex));
  2235.   if PrevIndex < 0 then FStippleCounter := L - 1;
  2236.   NextIndex := PrevIndex + 1;
  2237.   if NextIndex >= L then NextIndex := 0;
  2238.   if PrevWeight = 255 then Result := FStipplePattern[PrevIndex]
  2239.   else
  2240.   begin
  2241.     Result := COMBINE_REG[FCombineMode](
  2242.       FStipplePattern[PrevIndex],
  2243.       FStipplePattern[NextIndex],
  2244.       PrevWeight);
  2245.     EMMS;
  2246.   end;
  2247.   FStippleCounter := FStippleCounter + FStippleStep;
  2248. end;
  2249.  
  2250. procedure TBitmap32.HorzLine(X1, Y, X2: Integer; Value: TColor32);
  2251. begin
  2252.   FillLongword(Bits[X1 + Y * Width], X2 - X1 + 1, Value);
  2253. end;
  2254.  
  2255. procedure TBitmap32.HorzLineS(X1, Y, X2: Integer; Value: TColor32);
  2256. begin
  2257.   if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) and
  2258.      TestClip(X1, X2, FClipRect.Left, FClipRect.Right) then
  2259.     HorzLine(X1, Y, X2, Value);
  2260. end;
  2261.  
  2262. procedure TBitmap32.HorzLineT(X1, Y, X2: Integer; Value: TColor32);
  2263. var
  2264.   i: Integer;
  2265.   P: PColor32;
  2266.   BlendMem: TBlendMem;
  2267. begin
  2268.   if X2 < X1 then Exit;
  2269.   P := PixelPtr[X1, Y];
  2270.   BlendMem := BLEND_MEM[FCombineMode];
  2271.   for i := X1 to X2 do
  2272.   begin
  2273.     BlendMem(Value, P^);
  2274.     Inc(P);
  2275.   end;
  2276.   EMMS;
  2277. end;
  2278.  
  2279. procedure TBitmap32.HorzLineTS(X1, Y, X2: Integer; Value: TColor32);
  2280. begin
  2281.   if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) and
  2282.      TestClip(X1, X2, FClipRect.Left, FClipRect.Right) then
  2283.     HorzLineT(X1, Y, X2, Value);
  2284. end;
  2285.  
  2286. procedure TBitmap32.HorzLineTSP(X1, Y, X2: Integer);
  2287. var
  2288.   I, N: Integer;
  2289. begin
  2290.   if Empty then Exit;
  2291.   if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then
  2292.   begin
  2293.     if ((X1 < FClipRect.Left) and (X2 < FClipRect.Left)) or
  2294.        ((X1 >= FClipRect.Right) and (X2 >= FClipRect.Right)) then
  2295.     begin
  2296.       AdvanceStippleCounter(Abs(X2 - X1) + 1);
  2297.       Exit;
  2298.     end;
  2299.     if X1 < FClipRect.Left then
  2300.     begin
  2301.       AdvanceStippleCounter(FClipRect.Left - X1);
  2302.       X1 := FClipRect.Left;
  2303.     end
  2304.     else if X1 >= FClipRect.Right then
  2305.     begin
  2306.       AdvanceStippleCounter(X1 - (FClipRect.Right - 1));
  2307.       X1 := FClipRect.Right - 1;
  2308.     end;
  2309.     N := 0;
  2310.     if X2 < FClipRect.Left then
  2311.     begin
  2312.       N := FClipRect.Left - X2;
  2313.       X2 := FClipRect.Left;
  2314.     end
  2315.     else if X2 >= FClipRect.Right then
  2316.     begin
  2317.       N := X2 - (FClipRect.Right - 1);
  2318.       X2 := FClipRect.Right - 1;
  2319.     end;
  2320.  
  2321.     if X2 >= X1 then
  2322.       for I := X1 to X2 do SetPixelT(I, Y, GetStippleColor)
  2323.     else
  2324.       for I := X1 downto X2 do SetPixelT(I, Y, GetStippleColor);
  2325.  
  2326.     if N > 0 then AdvanceStippleCounter(N);
  2327.   end
  2328.   else
  2329.     AdvanceStippleCounter(Abs(X2 - X1) + 1);
  2330. end;
  2331.  
  2332. procedure TBitmap32.VertLine(X, Y1, Y2: Integer; Value: TColor32);
  2333. var
  2334.   I, NH, NL: Integer;
  2335.   P: PColor32;
  2336. begin
  2337.   if Y2 < Y1 then Exit;
  2338.   P := PixelPtr[X, Y1];
  2339.   I := Y2 - Y1 + 1;
  2340.   NH := I shr 2;
  2341.   NL := I and $03;
  2342.   for I := 0 to NH - 1 do
  2343.   begin
  2344.     P^ := Value; Inc(P, Width);
  2345.     P^ := Value; Inc(P, Width);
  2346.     P^ := Value; Inc(P, Width);
  2347.     P^ := Value; Inc(P, Width);
  2348.   end;
  2349.   for I := 0 to NL - 1 do
  2350.   begin
  2351.     P^ := Value; Inc(P, Width);
  2352.   end;
  2353. end;
  2354.  
  2355. procedure TBitmap32.VertLineS(X, Y1, Y2: Integer; Value: TColor32);
  2356. begin
  2357.   if (X >= FClipRect.Left) and (X < FClipRect.Right) and
  2358.      TestClip(Y1, Y2, FClipRect.Top, FClipRect.Bottom) then
  2359.     VertLine(X, Y1, Y2, Value);
  2360. end;
  2361.  
  2362. procedure TBitmap32.VertLineT(X, Y1, Y2: Integer; Value: TColor32);
  2363. var
  2364.   i: Integer;
  2365.   P: PColor32;
  2366.   BlendMem: TBlendMem;
  2367. begin
  2368.   P := PixelPtr[X, Y1];
  2369.   BlendMem := BLEND_MEM[FCombineMode];
  2370.   for i := Y1 to Y2 do
  2371.   begin
  2372.     BlendMem(Value, P^);
  2373.     Inc(P, Width);
  2374.   end;
  2375.   EMMS;
  2376. end;
  2377.  
  2378. procedure TBitmap32.VertLineTS(X, Y1, Y2: Integer; Value: TColor32);
  2379. begin
  2380.   if (X >= FClipRect.Left) and (X < FClipRect.Right) and
  2381.      TestClip(Y1, Y2, FClipRect.Top, FClipRect.Bottom) then
  2382.     VertLineT(X, Y1, Y2, Value);
  2383. end;
  2384.  
  2385. procedure TBitmap32.VertLineTSP(X, Y1, Y2: Integer);
  2386. var
  2387.   I, N: Integer;
  2388. begin
  2389.   if Empty then Exit;
  2390.   if (X >= FClipRect.Left) and (X < FClipRect.Right) then
  2391.   begin
  2392.     if ((Y1 < FClipRect.Top) and (Y2 < FClipRect.Top)) or
  2393.        ((Y1 >= FClipRect.Bottom) and (Y2 >= FClipRect.Bottom)) then
  2394.     begin
  2395.       AdvanceStippleCounter(Abs(Y2 - Y1) + 1);
  2396.       Exit;
  2397.     end;
  2398.     if Y1 < FClipRect.Top then
  2399.     begin
  2400.       AdvanceStippleCounter(FClipRect.Top - Y1);
  2401.       Y1 := FClipRect.Top;
  2402.     end
  2403.     else if Y1 >= FClipRect.Bottom then
  2404.     begin
  2405.       AdvanceStippleCounter(Y1 - (FClipRect.Bottom - 1));
  2406.       Y1 := FClipRect.Bottom - 1;
  2407.     end;
  2408.     N := 0;
  2409.     if Y2 < FClipRect.Top then
  2410.     begin
  2411.       N := FClipRect.Top - Y2;
  2412.       Y2 := FClipRect.Top;
  2413.     end
  2414.     else if Y2 >= FClipRect.Bottom then
  2415.     begin
  2416.       N := Y2 - (FClipRect.Bottom - 1);
  2417.       Y2 := FClipRect.Bottom - 1;
  2418.     end;
  2419.  
  2420.     if Y2 >= Y1 then
  2421.       for I := Y1 to Y2 do SetPixelT(X, I, GetStippleColor)
  2422.     else
  2423.       for I := Y1 downto Y2 do SetPixelT(X, I, GetStippleColor);
  2424.  
  2425.     if N > 0 then AdvanceStippleCounter(N);
  2426.   end
  2427.   else
  2428.     AdvanceStippleCounter(Abs(Y2 - Y1) + 1);
  2429. end;
  2430.  
  2431. procedure TBitmap32.Line(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
  2432. var
  2433.   Dy, Dx, Sy, Sx, I, Delta: Integer;
  2434.   P: PColor32;
  2435. begin
  2436.   try
  2437.     Dx := X2 - X1;
  2438.     Dy := Y2 - Y1;
  2439.  
  2440.     if Dx > 0 then Sx := 1
  2441.     else if Dx < 0 then
  2442.     begin
  2443.       Dx := -Dx;
  2444.       Sx := -1;
  2445.     end
  2446.     else // Dx = 0
  2447.     begin
  2448.       if Dy > 0 then VertLine(X1, Y1, Y2 - 1, Value)
  2449.       else if Dy < 0 then VertLine(X1, Y2 + 1, Y1, Value);
  2450.       if L then Pixel[X2, Y2] := Value;
  2451.       Exit;
  2452.     end;
  2453.  
  2454.     if Dy > 0 then Sy := 1
  2455.     else if Dy < 0 then
  2456.     begin
  2457.       Dy := -Dy;
  2458.       Sy := -1;
  2459.     end
  2460.     else // Dy = 0
  2461.     begin
  2462.       if X2 > X1 then HorzLine(X1, Y1, X2 - 1, Value)
  2463.       else HorzLine(X2 + 1, Y1, X1, Value);
  2464.       if L then Pixel[X2, Y2] := Value;
  2465.       Exit;
  2466.     end;
  2467.  
  2468.     P := PixelPtr[X1, Y1];
  2469.     Sy := Sy * Width;
  2470.  
  2471.     if Dx > Dy then
  2472.     begin
  2473.       Delta := Dx shr 1;
  2474.       for I := 0 to Dx - 1 do
  2475.       begin
  2476.         P^ := Value;
  2477.         Inc(P, Sx);
  2478.         Inc(Delta, Dy);
  2479.         if Delta > Dx then
  2480.         begin
  2481.           Inc(P, Sy);
  2482.           Dec(Delta, Dx);
  2483.         end;
  2484.       end;
  2485.     end
  2486.     else // Dx < Dy
  2487.     begin
  2488.       Delta := Dy shr 1;
  2489.       for I := 0 to Dy - 1 do
  2490.       begin
  2491.         P^ := Value;
  2492.         Inc(P, Sy);
  2493.         Inc(Delta, Dx);
  2494.         if Delta > Dy then
  2495.         begin
  2496.           Inc(P, Sx);
  2497.           Dec(Delta, Dy);
  2498.         end;
  2499.       end;
  2500.     end;
  2501.     if L then P^ := Value;
  2502.   finally
  2503.     Changed;
  2504.   end;
  2505. end;
  2506.  
  2507. procedure TBitmap32.LineS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
  2508. var
  2509.   Cx1, Cx2, Cy1, Cy2, PI, Sx, Sy, Dx, Dy, xd, yd, Dx2, Dy2, rem, term, tmp, e: Integer;
  2510.   Swapped, CheckVert: Boolean;
  2511.   P: PColor32;
  2512. begin
  2513.   Dx := X2 - X1; Dy := Y2 - Y1;
  2514.  
  2515.   // check for trivial cases...
  2516.   If Dx = 0 then // vertical line?
  2517.   begin
  2518.     if Dy > 0 then VertLineS(X1, Y1, Y2 - 1, Value)
  2519.     else if Dy < 0 then VertLineS(X1, Y2 + 1, Y1, Value);
  2520.     if L then PixelS[X2, Y2] := Value;
  2521.     Changed;
  2522.     Exit;
  2523.   end
  2524.   else if Dy = 0 then // horizontal line?
  2525.   begin
  2526.     if Dx > 0 then HorzLineS(X1, Y1, X2 - 1, Value)
  2527.     else if Dx < 0 then HorzLineS(X2 + 1, Y1, X1, Value);
  2528.     if L then PixelS[X2, Y2] := Value;
  2529.     Changed;
  2530.     Exit;
  2531.   end;
  2532.  
  2533.   Cx1 := FClipRect.Left; Cx2 := FClipRect.Right - 1;
  2534.   Cy1 := FClipRect.Top;  Cy2 := FClipRect.Bottom - 1;
  2535.  
  2536.   If Dx > 0 then
  2537.   begin
  2538.     If (X1 > Cx2) or (X2 < Cx1) then Exit; // segment not visible
  2539.     Sx := 1;
  2540.   end
  2541.   else if Dx < 0 then
  2542.   begin
  2543.     If (X2 > Cx2) or (X1 < Cx1) then Exit; // segment not visible
  2544.     Sx := -1;
  2545.     X1 := -X1;   X2 := -X2;   Dx := -Dx;
  2546.     Cx1 := -Cx1; Cx2 := -Cx2;
  2547.     Swap(Cx1, Cx2);
  2548.   end;
  2549.  
  2550.   If Dy > 0 then
  2551.   begin
  2552.     If (Y1 > Cy2) or (Y2 < Cy1) then Exit; // segment not visible
  2553.     Sy := 1;
  2554.   end
  2555.   else if Dy < 0 then
  2556.   begin
  2557.     If (Y2 > Cy2) or (Y1 < Cy1) then Exit; // segment not visible
  2558.     Sy := -1;
  2559.     Y1 := -Y1;   Y2 := -Y2;   Dy := -Dy;
  2560.     Cy1 := -Cy1; Cy2 := -Cy2;
  2561.     Swap(Cy1, Cy2);
  2562.   end;
  2563.  
  2564.   If not L then
  2565.   begin
  2566.     If Dx > Dy then
  2567.     begin
  2568.       If Dx > 0 then
  2569.       begin
  2570.         Dec(Dx);
  2571.         Dec(X2)
  2572.       end
  2573.       else
  2574.       begin
  2575.         Inc(Dy);
  2576.         Inc(X2);
  2577.       end;
  2578.     end
  2579.     else
  2580.     begin
  2581.       If Dy > 0 then
  2582.       begin
  2583.         Dec(Dy);
  2584.         Dec(Y2);
  2585.       end
  2586.       else
  2587.       begin
  2588.         Inc(Dy);
  2589.         Inc(Y2);
  2590.       end;
  2591.     end;
  2592.   end;
  2593.  
  2594.   if (Dx = 0) or (Dy = 0) then Exit;
  2595.  
  2596.   if Dx < Dy then
  2597.   begin
  2598.     Swapped := True;
  2599.     Swap(X1, Y1); Swap(X2, Y2); Swap(Dx, Dy);
  2600.     Swap(Cx1, Cy1); Swap(Cx2, Cy2); Swap(Sx, Sy);
  2601.   end
  2602.   else
  2603.     Swapped := False;
  2604.  
  2605.   // Bresenham's set up:
  2606.   Dx2 := Dx shl 1; Dy2 := Dy shl 1;
  2607.   xd := X1; yd := Y1; e := Dy2 - Dx; term := X2;
  2608.   CheckVert := True;
  2609.   
  2610.   // clipping rect horizontal entry
  2611.   if Y1 < Cy1 then
  2612.   begin
  2613.     tmp := Dx2 * (Cy1 - Y1) - Dx;
  2614.     Inc(xd, tmp div Dy2);
  2615.     rem := tmp mod Dy2;
  2616.     if xd > Cx2 then Exit;
  2617.     if xd + 1 >= Cx1 then
  2618.     begin
  2619.       yd := Cy1;
  2620.       Dec(e, rem + Dx);
  2621.       if rem > 0 then
  2622.       begin
  2623.         Inc(xd);
  2624.         Inc(e, Dy2);
  2625.       end;
  2626.       CheckVert := False; // to avoid ugly labels we set this to omit the next check
  2627.     end;
  2628.   end;
  2629.  
  2630.   // clipping rect vertical entry
  2631.   if CheckVert and (X1 < Cx1) then
  2632.   begin
  2633.     tmp := Dy2 * (Cx1 - X1);
  2634.     Inc(yd, tmp div Dx2);
  2635.     rem := tmp mod Dx2;
  2636.     if (yd > Cy2) or (yd = Cy2) and (rem >= Dx) then Exit;
  2637.     xd := Cx1;
  2638.     Inc(e, rem);
  2639.     if (rem >= Dx) then
  2640.     begin
  2641.       Inc(yd);
  2642.       Dec(e, Dx2);
  2643.     end;
  2644.   end;
  2645.  
  2646.   // is the segment exiting the clipping rect?
  2647.   if Y2 > Cy2 then
  2648.   begin
  2649.     tmp := Dx2 * (Cy2 - Y1) + Dx;
  2650.     term := X1 + tmp div Dy2;
  2651.     rem := tmp mod Dy2;
  2652.     if rem = 0 then Dec(term);
  2653.   end;
  2654.  
  2655.   if term > Cx2 then
  2656.     term := Cx2;
  2657.  
  2658.   Inc(term);
  2659.  
  2660.   if Sy = -1 then
  2661.     yd := -yd;
  2662.  
  2663.   if Sx = -1 then
  2664.   begin
  2665.     xd := -xd;
  2666.     term := -term;
  2667.   end;
  2668.  
  2669.   Dec(Dx2, Dy2);
  2670.  
  2671.   If Swapped then
  2672.   begin
  2673.     PI := Sx * Width;
  2674.     P := @Bits[yd + xd * Width];
  2675.   end
  2676.   else
  2677.   begin
  2678.     PI := Sx;
  2679.     Sy := Sy * Width;
  2680.     P := @Bits[xd + yd * Width];
  2681.   end;
  2682.  
  2683.   while xd <> term do
  2684.   begin
  2685.     Inc(xd, Sx);
  2686.  
  2687.     P^ := Value;
  2688.     Inc(P, PI);
  2689.     if e >= 0 then
  2690.     begin
  2691.       Inc(P, Sy);
  2692.       Dec(e, Dx2);
  2693.     end
  2694.     else
  2695.       Inc(e, Dy2);
  2696.   end;
  2697.  
  2698.   Changed;
  2699. end;
  2700.  
  2701. procedure TBitmap32.LineT(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
  2702. var
  2703.   Dy, Dx, Sy, Sx, I, Delta: Integer;
  2704.   P: PColor32;
  2705.   BlendMem: TBlendMem;
  2706. begin
  2707.   try
  2708.     Dx := X2 - X1;
  2709.     Dy := Y2 - Y1;
  2710.  
  2711.     if Dx > 0 then Sx := 1
  2712.     else if Dx < 0 then
  2713.     begin
  2714.       Dx := -Dx;
  2715.       Sx := -1;
  2716.     end
  2717.     else // Dx = 0
  2718.     begin
  2719.       if Dy > 0 then VertLineT(X1, Y1, Y2 - 1, Value)
  2720.       else if Dy < 0 then VertLineT(X1, Y2 + 1, Y1, Value);
  2721.       if L then SetPixelT(X2, Y2, Value);
  2722.       Exit;
  2723.     end;
  2724.  
  2725.     if Dy > 0 then Sy := 1
  2726.     else if Dy < 0 then
  2727.     begin
  2728.       Dy := -Dy;
  2729.       Sy := -1;
  2730.     end
  2731.     else // Dy = 0
  2732.     begin
  2733.       if X2 > X1 then HorzLineT(X1, Y1, X2 - 1, Value)
  2734.       else HorzLineT(X2 + 1, Y1, X1, Value);
  2735.       if L then SetPixelT(X2, Y2, Value);
  2736.       Exit;
  2737.     end;
  2738.  
  2739.     P := PixelPtr[X1, Y1];
  2740.     Sy := Sy * Width;
  2741.  
  2742.     try
  2743.       BlendMem := BLEND_MEM[FCombineMode];
  2744.       if Dx > Dy then
  2745.       begin
  2746.         Delta := Dx shr 1;
  2747.         for I := 0 to Dx - 1 do
  2748.         begin
  2749.           BlendMem(Value, P^);
  2750.           Inc(P, Sx);
  2751.           Inc(Delta, Dy);
  2752.           if Delta > Dx then
  2753.           begin
  2754.             Inc(P, Sy);
  2755.             Dec(Delta, Dx);
  2756.           end;
  2757.         end;
  2758.       end
  2759.       else // Dx < Dy
  2760.       begin
  2761.         Delta := Dy shr 1;
  2762.         for I := 0 to Dy - 1 do
  2763.         begin
  2764.           BlendMem(Value, P^);
  2765.           Inc(P, Sy);
  2766.           Inc(Delta, Dx);
  2767.           if Delta > Dy then
  2768.           begin
  2769.             Inc(P, Sx);
  2770.             Dec(Delta, Dy);
  2771.           end;
  2772.         end;
  2773.       end;
  2774.       if L then BlendMem(Value, P^);
  2775.     finally
  2776.       EMMS;
  2777.     end;
  2778.   finally
  2779.     Changed;
  2780.   end;
  2781. end;
  2782.  
  2783. procedure TBitmap32.LineTS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
  2784. var
  2785.   Cx1, Cx2, Cy1, Cy2, PI, Sx, Sy, Dx, Dy, xd, yd, Dx2, Dy2, rem, term, tmp, e: Integer;
  2786.   Swapped, CheckVert: Boolean;
  2787.   P: PColor32;
  2788.   BlendMem: TBlendMem;
  2789. begin
  2790.   Dx := X2 - X1; Dy := Y2 - Y1;
  2791.  
  2792.   // check for trivial cases...
  2793.   If Dx = 0 then // vertical line?
  2794.   begin
  2795.     if Dy > 0 then VertLineTS(X1, Y1, Y2 - 1, Value)
  2796.     else if Dy < 0 then VertLineTS(X1, Y2 + 1, Y1, Value);
  2797.     if L then SetPixelTS(X2, Y2, Value);
  2798.     Changed;
  2799.     Exit;
  2800.   end
  2801.   else if Dy = 0 then // horizontal line?
  2802.   begin
  2803.     if Dx > 0 then HorzLineTS(X1, Y1, X2 - 1, Value)
  2804.     else if Dx < 0 then HorzLineTS(X2 + 1, Y1, X1, Value);
  2805.     if L then SetPixelTS(X2, Y2, Value);
  2806.     Changed;
  2807.     Exit;
  2808.   end;
  2809.  
  2810.   Cx1 := FClipRect.Left; Cx2 := FClipRect.Right - 1;
  2811.   Cy1 := FClipRect.Top;  Cy2 := FClipRect.Bottom - 1;
  2812.  
  2813.   If Dx > 0 then
  2814.   begin
  2815.     If (X1 > Cx2) or (X2 < Cx1) then Exit; // segment not visible
  2816.     Sx := 1;
  2817.   end
  2818.   else if Dx < 0 then
  2819.   begin
  2820.     If (X2 > Cx2) or (X1 < Cx1) then Exit; // segment not visible
  2821.     Sx := -1;
  2822.     X1 := -X1;   X2 := -X2;   Dx := -Dx;
  2823.     Cx1 := -Cx1; Cx2 := -Cx2;
  2824.     Swap(Cx1, Cx2);
  2825.   end;
  2826.  
  2827.   If Dy > 0 then
  2828.   begin
  2829.     If (Y1 > Cy2) or (Y2 < Cy1) then Exit; // segment not visible
  2830.     Sy := 1;
  2831.   end
  2832.   else if Dy < 0 then
  2833.   begin
  2834.     If (Y2 > Cy2) or (Y1 < Cy1) then Exit; // segment not visible
  2835.     Sy := -1;
  2836.     Y1 := -Y1;   Y2 := -Y2;   Dy := -Dy;
  2837.     Cy1 := -Cy1; Cy2 := -Cy2;
  2838.     Swap(Cy1, Cy2);
  2839.   end;
  2840.  
  2841.   If not L then
  2842.   begin
  2843.     If Dx > Dy then
  2844.     begin
  2845.       If Dx > 0 then
  2846.       begin
  2847.         Dec(Dx);
  2848.         Dec(X2)
  2849.       end
  2850.       else
  2851.       begin
  2852.         Inc(Dy);
  2853.         Inc(X2);
  2854.       end;
  2855.     end
  2856.     else
  2857.     begin
  2858.       If Dy > 0 then
  2859.       begin
  2860.         Dec(Dy);
  2861.         Dec(Y2);
  2862.       end
  2863.       else
  2864.       begin
  2865.         Inc(Dy);
  2866.         Inc(Y2);
  2867.       end;
  2868.     end;
  2869.   end;
  2870.  
  2871.   if (Dx = 0) or (Dy = 0) then Exit;
  2872.  
  2873.   if Dx < Dy then
  2874.   begin
  2875.     Swapped := True;
  2876.     Swap(X1, Y1); Swap(X2, Y2); Swap(Dx, Dy);
  2877.     Swap(Cx1, Cy1); Swap(Cx2, Cy2); Swap(Sx, Sy);
  2878.   end
  2879.   else
  2880.     Swapped := False;
  2881.  
  2882.   // Bresenham's set up:
  2883.   Dx2 := Dx shl 1; Dy2 := Dy shl 1;
  2884.   xd := X1; yd := Y1; e := Dy2 - Dx; term := X2;
  2885.   CheckVert := True;
  2886.   
  2887.   // clipping rect horizontal entry
  2888.   if Y1 < Cy1 then
  2889.   begin
  2890.     tmp := Dx2 * (Cy1 - Y1) - Dx;
  2891.     Inc(xd, tmp div Dy2);
  2892.     rem := tmp mod Dy2;
  2893.     if xd > Cx2 then Exit;
  2894.     if xd + 1 >= Cx1 then
  2895.     begin
  2896.       yd := Cy1;
  2897.       Dec(e, rem + Dx);
  2898.       if rem > 0 then
  2899.       begin
  2900.         Inc(xd);
  2901.         Inc(e, Dy2);
  2902.       end;
  2903.       CheckVert := False; // to avoid ugly labels we set this to omit the next check
  2904.     end;
  2905.   end;
  2906.  
  2907.   // clipping rect vertical entry
  2908.   if CheckVert and (X1 < Cx1) then
  2909.   begin
  2910.     tmp := Dy2 * (Cx1 - X1);
  2911.     Inc(yd, tmp div Dx2);
  2912.     rem := tmp mod Dx2;
  2913.     if (yd > Cy2) or (yd = Cy2) and (rem >= Dx) then Exit;
  2914.     xd := Cx1;
  2915.     Inc(e, rem);
  2916.     if (rem >= Dx) then
  2917.     begin
  2918.       Inc(yd);
  2919.       Dec(e, Dx2);
  2920.     end;
  2921.   end;
  2922.  
  2923.   // is the segment exiting the clipping rect?
  2924.   if Y2 > Cy2 then
  2925.   begin
  2926.     tmp := Dx2 * (Cy2 - Y1) + Dx;
  2927.     term := X1 + tmp div Dy2;
  2928.     rem := tmp mod Dy2;
  2929.     if rem = 0 then Dec(term);
  2930.   end;
  2931.  
  2932.   if term > Cx2 then
  2933.     term := Cx2;
  2934.  
  2935.   Inc(term);
  2936.  
  2937.   if Sy = -1 then
  2938.     yd := -yd;
  2939.  
  2940.   if Sx = -1 then
  2941.   begin
  2942.     xd := -xd;
  2943.     term := -term;
  2944.   end;
  2945.  
  2946.   Dec(Dx2, Dy2);
  2947.  
  2948.   If Swapped then
  2949.   begin
  2950.     PI := Sx * Width;
  2951.     P := @Bits[yd + xd * Width];
  2952.   end
  2953.   else
  2954.   begin
  2955.     PI := Sx;
  2956.     Sy := Sy * Width;
  2957.     P := @Bits[xd + yd * Width];
  2958.   end;
  2959.  
  2960.   try
  2961.     BlendMem := BLEND_MEM[FCombineMode];
  2962.     while xd <> term do
  2963.     begin
  2964.       Inc(xd, Sx);
  2965.  
  2966.       BlendMem(Value, P^);
  2967.       Inc(P, PI);
  2968.       if e >= 0 then
  2969.       begin
  2970.         Inc(P, Sy);
  2971.         Dec(e, Dx2);
  2972.       end
  2973.       else
  2974.         Inc(e, Dy2);
  2975.     end;
  2976.   finally
  2977.     EMMS;
  2978.     Changed;
  2979.   end;
  2980. end;
  2981.  
  2982. procedure TBitmap32.LineX(X1, Y1, X2, Y2: TFixed; Value: TColor32; L: Boolean);
  2983. var
  2984.   n, i: Integer;
  2985.   nx, ny, hyp: Integer;
  2986.   A: TColor32;
  2987.   h: Single;
  2988. begin
  2989.   try
  2990.     nx := X2 - X1; ny := Y2 - Y1;
  2991.     Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127);
  2992.     hyp := Round(Hypot(nx, ny));
  2993.     if L then Inc(hyp, 65536);
  2994.     if hyp < 256 then Exit;
  2995.     n := hyp shr 16;
  2996.     if n > 0 then
  2997.     begin
  2998.       h := 65536 / hyp;
  2999.       nx := Round(nx * h); ny := Round(ny * h);
  3000.       for i := 0 to n - 1 do
  3001.       begin
  3002.         SET_T256(X1 shr 8, Y1 shr 8, Value);
  3003.         Inc(X1, nx);
  3004.         Inc(Y1, ny);
  3005.       end;
  3006.     end;
  3007.     A := Value shr 24;
  3008.     hyp := hyp - n shl 16;
  3009.     A := A * Cardinal(hyp) shl 8 and $FF000000;
  3010.     SET_T256((X1 + X2 - nx) shr 9, (Y1 + Y2 - ny) shr 9, Value and $00FFFFFF + A);
  3011.   finally
  3012.     EMMS;
  3013.     Changed;
  3014.   end;
  3015. end;
  3016.  
  3017. procedure TBitmap32.LineF(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean);
  3018. begin
  3019.   LineX(Fixed(X1), Fixed(Y1), Fixed(X2), Fixed(Y2), Value, L);
  3020. end;
  3021.  
  3022. procedure TBitmap32.LineXS(X1, Y1, X2, Y2: TFixed; Value: TColor32; L: Boolean);
  3023. var
  3024.   n, i: Integer;
  3025.   ex, ey, nx, ny, hyp: Integer;
  3026.   A: TColor32;
  3027.   h: Single;
  3028. begin
  3029.   ex := X2; ey := Y2;
  3030.  
  3031.   // Check for visibility and clip the coordinates
  3032.   if not ClipLine(Integer(X1), Integer(Y1), Integer(X2), Integer(Y2),
  3033.     FFixedClipRect.Left - $10000, FFixedClipRect.Top - $10000,
  3034.     FFixedClipRect.Right, FFixedClipRect.Bottom) then Exit;
  3035.  
  3036.   { TODO : Handle L on clipping here... }
  3037.  
  3038.   if (ex <> X2) or (ey <> Y2) then L := True;
  3039.  
  3040.   // Check if it lies entirely in the bitmap area. Even after clipping
  3041.   // some pixels may lie outside the bitmap due to antialiasing
  3042.   if (X1 > FFixedClipRect.Left) and (X1 < FFixedClipRect.Right - $20000) and
  3043.      (Y1 > FFixedClipRect.Top) and (Y1 < FFixedClipRect.Bottom - $20000) and
  3044.      (X2 > FFixedClipRect.Left) and (X2 < FFixedClipRect.Right - $20000) and
  3045.      (Y2 > FFixedClipRect.Top) and (Y2 < FFixedClipRect.Bottom - $20000) then
  3046.   begin
  3047.     LineX(X1, Y1, X2, Y2, Value);
  3048.     Exit;
  3049.   end;
  3050.  
  3051.   // If we are still here, it means that the line touches one or several bitmap
  3052.   // boundaries. Use the safe version of antialiased pixel routine
  3053.   try
  3054.     nx := X2 - X1; ny := Y2 - Y1;
  3055.     Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127);
  3056.     hyp := Round(Hypot(nx, ny));
  3057.     if L then Inc(Hyp, 65536);
  3058.     if hyp < 256 then Exit;
  3059.     n := hyp shr 16;
  3060.     if n > 0 then
  3061.     begin
  3062.       h := 65536 / hyp;
  3063.       nx := Round(nx * h); ny := Round(ny * h);
  3064.       for i := 0 to n - 1 do
  3065.       begin
  3066.         SET_TS256(SAR_8(X1), SAR_8(Y1), Value);
  3067.         X1 := X1 + nx;
  3068.         Y1 := Y1 + ny;
  3069.       end;
  3070.     end;
  3071.     A := Value shr 24;
  3072.     hyp := hyp - n shl 16;
  3073.     A := A * Longword(hyp) shl 8 and $FF000000;
  3074.     SET_TS256(SAR_9(X1 + X2 - nx), SAR_9(Y1 + Y2 - ny), Value and $00FFFFFF + A);
  3075.   finally
  3076.     EMMS;
  3077.     Changed;
  3078.   end;
  3079. end;
  3080.  
  3081. procedure TBitmap32.LineFS(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean);
  3082. begin
  3083.   LineXS(Fixed(X1), Fixed(Y1), Fixed(X2), Fixed(Y2), Value, L);
  3084. end;
  3085.  
  3086. procedure TBitmap32.LineXP(X1, Y1, X2, Y2: TFixed; L: Boolean);
  3087. var
  3088.   n, i: Integer;
  3089.   nx, ny, hyp: Integer;
  3090.   A, C: TColor32;
  3091. begin
  3092.   try
  3093.     nx := X2 - X1; ny := Y2 - Y1;
  3094.     Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127);
  3095.     hyp := Round(Hypot(nx, ny));
  3096.     if L then Inc(hyp, 65536);
  3097.     if hyp < 256 then Exit;
  3098.     n := hyp shr 16;
  3099.     if n > 0 then
  3100.     begin
  3101.       nx := Round(nx / hyp * 65536);
  3102.       ny := Round(ny / hyp * 65536);
  3103.       for i := 0 to n - 1 do
  3104.       begin
  3105.         C := GetStippleColor;
  3106.         SET_T256(X1 shr 8, Y1 shr 8, C);
  3107.         EMMS;
  3108.         X1 := X1 + nx;
  3109.         Y1 := Y1 + ny;
  3110.       end;
  3111.     end;
  3112.     C := GetStippleColor;
  3113.     A := C shr 24;
  3114.     hyp := hyp - n shl 16;
  3115.     A := A * Longword(hyp) shl 8 and $FF000000;
  3116.     SET_T256((X1 + X2 - nx) shr 9, (Y1 + Y2 - ny) shr 9, C and $00FFFFFF + A);
  3117.     EMMS;
  3118.   finally
  3119.     Changed;
  3120.   end;
  3121. end;
  3122.  
  3123. procedure TBitmap32.LineFP(X1, Y1, X2, Y2: Single; L: Boolean);
  3124. begin
  3125.   LineXP(Fixed(X1), Fixed(Y1), Fixed(X2), Fixed(Y2), L);
  3126. end;
  3127.  
  3128. procedure TBitmap32.LineXSP(X1, Y1, X2, Y2: TFixed; L: Boolean);
  3129. const
  3130.   StippleInc: array [Boolean] of Single = (0, 1);
  3131. var
  3132.   n, i: Integer;
  3133.   sx, sy, ex, ey, nx, ny, hyp: Integer;
  3134.   A, C: TColor32;
  3135. begin
  3136.   sx := X1; sy := Y1; ex := X2; ey := Y2;
  3137.  
  3138.   // Check for visibility and clip the coordinates
  3139.   if not ClipLine(Integer(X1), Integer(Y1), Integer(X2), Integer(Y2),
  3140.     FFixedClipRect.Left - $10000, FFixedClipRect.Top - $10000,
  3141.     FFixedClipRect.Right, FFixedClipRect.Bottom) then
  3142.   begin
  3143.     AdvanceStippleCounter(Hypot((X2 - X1) / 65536, (Y2 - Y1) / 65536) - StippleInc[L]);
  3144.     Exit;
  3145.   end;
  3146.  
  3147.   if (ex <> X2) or (ey <> Y2) then L := True;
  3148.   
  3149.   // Check if it lies entirely in the bitmap area. Even after clipping
  3150.   // some pixels may lie outside the bitmap due to antialiasing
  3151.   if (X1 > FFixedClipRect.Left) and (X1 < FFixedClipRect.Right - $20000) and
  3152.      (Y1 > FFixedClipRect.Top) and (Y1 < FFixedClipRect.Bottom - $20000) and
  3153.      (X2 > FFixedClipRect.Left) and (X2 < FFixedClipRect.Right - $20000) and
  3154.      (Y2 > FFixedClipRect.Top) and (Y2 < FFixedClipRect.Bottom - $20000) then
  3155.   begin
  3156.     LineXP(X1, Y1, X2, Y2);
  3157.     Exit;
  3158.   end;
  3159.  
  3160.   if (sx <> X1) or (sy <> Y1) then
  3161.     AdvanceStippleCounter(Hypot((X1 - sx) / 65536, (Y1 - sy) / 65536));
  3162.  
  3163.   // If we are still here, it means that the line touches one or several bitmap
  3164.   // boundaries. Use the safe version of antialiased pixel routine
  3165.   try
  3166.     nx := X2 - X1; ny := Y2 - Y1;
  3167.     Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127);
  3168.     hyp := Round(Hypot(nx, ny));
  3169.     if L then Inc(hyp, 65536);
  3170.     if hyp < 256 then Exit;
  3171.     n := hyp shr 16;
  3172.     if n > 0 then
  3173.     begin
  3174.       nx := Round(nx / hyp * 65536); ny := Round(ny / hyp * 65536);
  3175.       for i := 0 to n - 1 do
  3176.       begin
  3177.         C := GetStippleColor;
  3178.         SET_TS256(SAR_8(X1), SAR_8(Y1), C);
  3179.         EMMS;
  3180.         X1 := X1 + nx;
  3181.         Y1 := Y1 + ny;
  3182.       end;
  3183.     end;
  3184.     C := GetStippleColor;
  3185.     A := C shr 24;
  3186.     hyp := hyp - n shl 16;
  3187.     A := A * Longword(hyp) shl 8 and $FF000000;
  3188.     SET_TS256(SAR_9(X1 + X2 - nx), SAR_9(Y1 + Y2 - ny), C and $00FFFFFF + A);
  3189.     EMMS;
  3190.  
  3191.   if (ex <> X2) or (ey <> Y2) then
  3192.     AdvanceStippleCounter(Hypot((X2 - ex) / 65536, (Y2 - ey) / 65536) - StippleInc[L]);
  3193.  
  3194.   finally
  3195.     Changed;
  3196.   end;
  3197. end;
  3198.  
  3199. procedure TBitmap32.LineFSP(X1, Y1, X2, Y2: Single; L: Boolean);
  3200. begin
  3201.   LineXSP(Fixed(X1), Fixed(Y1), Fixed(X2), Fixed(Y2), L);
  3202. end;
  3203.  
  3204. procedure TBitmap32.LineA(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
  3205. var
  3206.   Dx, Dy, Sx, Sy, D: Integer;
  3207.   EC, EA: Word;
  3208.   CI: Byte;
  3209.   P: PColor32;
  3210.   BlendMemEx: TBlendMemEx;
  3211. begin
  3212.   if (X1 = X2) or (Y1 = Y2) then
  3213.   begin
  3214.     LineT(X1, Y1, X2, Y2, Value, L);
  3215.     Exit;
  3216.   end;
  3217.  
  3218.   Dx := X2 - X1;
  3219.   Dy := Y2 - Y1;
  3220.  
  3221.   if Dx > 0 then Sx := 1
  3222.   else
  3223.   begin
  3224.     Sx := -1;
  3225.     Dx := -Dx;
  3226.   end;
  3227.  
  3228.   if Dy > 0 then Sy := 1
  3229.   else
  3230.   begin
  3231.     Sy := -1;
  3232.     Dy := -Dy;
  3233.   end;
  3234.  
  3235.   try
  3236.     EC := 0;
  3237.     BLEND_MEM[FCombineMode](Value, Bits[X1 + Y1 * Width]);
  3238.     BlendMemEx := BLEND_MEM_EX[FCombineMode];
  3239.  
  3240.     if Dy > Dx then
  3241.     begin
  3242.       EA := Dx shl 16 div Dy;
  3243.       if not L then Dec(Dy);
  3244.       while Dy > 0 do
  3245.       begin
  3246.         Dec(Dy);
  3247.         D := EC;
  3248.         Inc(EC, EA);
  3249.         if EC <= D then Inc(X1, Sx);
  3250.         Inc(Y1, Sy);
  3251.         CI := EC shr 8;
  3252.         P := @Bits[X1 + Y1 * Width];
  3253.         BlendMemEx(Value, P^, GAMMA_TABLE[CI xor 255]);
  3254.         Inc(P, Sx);
  3255.         BlendMemEx(Value, P^, GAMMA_TABLE[CI]);
  3256.       end;
  3257.     end
  3258.     else // DY <= DX
  3259.     begin
  3260.       EA := Dy shl 16 div Dx;
  3261.       if not L then Dec(Dx);
  3262.       while Dx > 0 do
  3263.       begin
  3264.         Dec(Dx);
  3265.         D := EC;
  3266.         Inc(EC, EA);
  3267.         if EC <= D then Inc(Y1, Sy);
  3268.         Inc(X1, Sx);
  3269.         CI := EC shr 8;
  3270.         P := @Bits[X1 + Y1 * Width];
  3271.         BlendMemEx(Value, P^, GAMMA_TABLE[CI xor 255]);
  3272.         if Sy = 1 then Inc(P, Width) else Dec(P, Width);
  3273.         BlendMemEx(Value, P^, GAMMA_TABLE[CI]);
  3274.       end;
  3275.     end;
  3276.   finally
  3277.     EMMS;
  3278.     Changed;
  3279.   end;
  3280. end;
  3281.  
  3282. procedure TBitmap32.LineAS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
  3283. var
  3284.   Cx1, Cx2, Cy1, Cy2, PI, Sx, Sy, Dx, Dy, xd, yd, rem, term, tmp: Integer;
  3285.   CheckVert, CornerAA: Boolean;
  3286.   D1, D2: PInteger;
  3287.   EC, EA, ED, D: Word;
  3288.   CI: Byte;
  3289.   P: PColor32;
  3290.   BlendMemEx: TBlendMemEx;
  3291. begin
  3292.   If (FClipRect.Right - FClipRect.Left = 0) or
  3293.      (FClipRect.Bottom - FClipRect.Top = 0) then Exit;
  3294.  
  3295.   Dx := X2 - X1; Dy := Y2 - Y1;
  3296.  
  3297.   // check for trivial cases...
  3298.   If Dx = 0 then // vertical line?
  3299.   begin
  3300.     if Dy > 0 then VertLineTS(X1, Y1, Y2 - 1, Value)
  3301.     else if Dy < 0 then VertLineTS(X1, Y2 + 1, Y1, Value);
  3302.     if L then SetPixelTS(X2, Y2, Value);
  3303.     Changed;
  3304.     Exit;
  3305.   end
  3306.   else if Dy = 0 then // horizontal line?
  3307.   begin
  3308.     if Dx > 0 then HorzLineTS(X1, Y1, X2 - 1, Value)
  3309.     else if Dx < 0 then HorzLineTS(X2 + 1, Y1, X1, Value);
  3310.     if L then SetPixelTS(X2, Y2, Value);
  3311.     Changed;
  3312.     Exit;
  3313.   end;
  3314.  
  3315.   Cx1 := FClipRect.Left; Cx2 := FClipRect.Right - 1;
  3316.   Cy1 := FClipRect.Top;  Cy2 := FClipRect.Bottom - 1;
  3317.  
  3318.   If Dx > 0 then
  3319.   begin
  3320.     If (X1 > Cx2) or (X2 < Cx1) then Exit; // segment not visible
  3321.     Sx := 1;
  3322.   end
  3323.   else if Dx < 0 then
  3324.   begin
  3325.     If (X2 > Cx2) or (X1 < Cx1) then Exit; // segment not visible
  3326.     Sx := -1;
  3327.     X1 := -X1;   X2 := -X2;   Dx := -Dx;
  3328.     Cx1 := -Cx1; Cx2 := -Cx2;
  3329.     Swap(Cx1, Cx2);
  3330.   end;
  3331.  
  3332.   If Dy > 0 then
  3333.   begin
  3334.     If (Y1 > Cy2) or (Y2 < Cy1) then Exit; // segment not visible
  3335.     Sy := 1;
  3336.   end
  3337.   else if Dy < 0 then
  3338.   begin
  3339.     If (Y2 > Cy2) or (Y1 < Cy1) then Exit; // segment not visible
  3340.     Sy := -1;
  3341.     Y1 := -Y1;   Y2 := -Y2;   Dy := -Dy;
  3342.     Cy1 := -Cy1; Cy2 := -Cy2;
  3343.     Swap(Cy1, Cy2);
  3344.   end;
  3345.  
  3346.   If not L then
  3347.   begin
  3348.     If Dx > Dy then
  3349.     begin
  3350.       If Dx > 0 then
  3351.       begin
  3352.         Dec(Dx);
  3353.         Dec(X2)
  3354.       end
  3355.       else
  3356.       begin
  3357.         Inc(Dy);
  3358.         Inc(X2);
  3359.       end;
  3360.     end
  3361.     else
  3362.     begin
  3363.       If Dy > 0 then
  3364.       begin
  3365.         Dec(Dy);
  3366.         Dec(Y2);
  3367.       end
  3368.       else
  3369.       begin
  3370.         Inc(Dy);
  3371.         Inc(Y2);
  3372.       end;
  3373.     end;
  3374.   end;
  3375.  
  3376.   if (Dx = 0) or (Dy = 0) then Exit;
  3377.  
  3378.   // Note: can't move this up due to the swap above...
  3379.   if Dx = Dy then // diagonal line?
  3380.   begin
  3381.     LineTS(Sx * X1, Sy * Y1, Sx * X2, Sy * Y2, Value, L);
  3382.     Exit;
  3383.   end;
  3384.  
  3385.   if Dx < Dy then
  3386.   begin
  3387.     Swap(X1, Y1); Swap(X2, Y2); Swap(Dx, Dy);
  3388.     Swap(Cx1, Cy1); Swap(Cx2, Cy2); Swap(Sx, Sy);
  3389.     D1 := @yd; D2 := @xd;
  3390.     PI := Sy;
  3391.   end
  3392.   else
  3393.   begin
  3394.     D1 := @xd; D2 := @yd;
  3395.     PI := Sy * Width;
  3396.   end;
  3397.  
  3398.   rem := 0;
  3399.   EA := Dy shl 16 div Dx;
  3400.   EC := 0;
  3401.   xd := X1; yd := Y1;
  3402.   CheckVert := True;
  3403.   CornerAA := False;
  3404.   BlendMemEx := BLEND_MEM_EX[FCombineMode];
  3405.  
  3406.   // clipping rect horizontal entry
  3407.   if Y1 < Cy1 then
  3408.   begin
  3409.     tmp := (Cy1 - Y1) * 65536;
  3410.     rem := tmp - 65536; // rem := (Cy1 - Y1 - 1) * 65536;
  3411.     if tmp mod EA > 0 then
  3412.       tmp := tmp div EA + 1
  3413.     else
  3414.       tmp := tmp div EA;
  3415.  
  3416.     xd := Min(xd + tmp, X2 + 1);
  3417.     EC := tmp * EA;
  3418.  
  3419.     if rem mod EA > 0 then
  3420.       rem := rem div EA + 1
  3421.     else
  3422.       rem := rem div EA;
  3423.  
  3424.     tmp := tmp - rem;
  3425.  
  3426.     // check whether the line is partly visible
  3427.     if xd > Cx2 then
  3428.       // do we need to draw an antialiased part on the corner of the clip rect?
  3429.       If xd <= Cx2 + tmp then
  3430.         CornerAA := True
  3431.       else
  3432.         Exit;
  3433.  
  3434.     if (xd {+ 1} >= Cx1) or CornerAA then
  3435.     begin
  3436.       yd := Cy1;
  3437.       rem := xd; // save old xd
  3438.  
  3439.       ED := EC - EA;
  3440.       term := SwapConstrain(xd - tmp, Cx1, Cx2);
  3441.  
  3442.       If CornerAA then
  3443.       begin
  3444.         Dec(ED, (xd - Cx2 - 1) * EA);
  3445.         xd := Cx2 + 1;
  3446.       end;
  3447.  
  3448.       // do we need to negate the vars?
  3449.       if Sy = -1 then yd := -yd;
  3450.       if Sx = -1 then
  3451.       begin
  3452.         xd := -xd;
  3453.         term := -term;
  3454.       end;
  3455.  
  3456.       // draw special case horizontal line entry (draw only last half of entering segment)
  3457.       try
  3458.         while xd <> term do
  3459.         begin
  3460.           Inc(xd, -Sx);
  3461.           BlendMemEx(Value, Bits[D1^ + D2^ * Width], GAMMA_TABLE[ED shr 8]);
  3462.           Dec(ED, EA);
  3463.         end;
  3464.       finally
  3465.         EMMS;
  3466.       end;
  3467.  
  3468.       If CornerAA then
  3469.       begin
  3470.         // we only needed to draw the visible antialiased part of the line,
  3471.         // everything else is outside of our cliprect, so exit now since
  3472.         // there is nothing more to paint...
  3473.         Changed;
  3474.         Exit;
  3475.       end;
  3476.  
  3477.       if Sy = -1 then yd := -yd;  // negate back
  3478.       xd := rem;  // restore old xd
  3479.       CheckVert := False; // to avoid ugly labels we set this to omit the next check
  3480.     end;
  3481.   end;
  3482.  
  3483.   // clipping rect vertical entry
  3484.   if CheckVert and (X1 < Cx1) then
  3485.   begin
  3486.     tmp := (Cx1 - X1) * EA;
  3487.     Inc(yd, tmp div 65536);
  3488.     EC := tmp;
  3489.     xd := Cx1;
  3490.     if (yd > Cy2) then
  3491.       Exit
  3492.     else if (yd = Cy2) then
  3493.       CornerAA := True;
  3494.   end;
  3495.  
  3496.   term := X2;
  3497.   CheckVert := False;
  3498.  
  3499.   // horizontal exit?
  3500.   if Y2 > Cy2 then
  3501.   begin
  3502.     tmp := (Cy2 - Y1) * 65536;
  3503.     term := X1 + tmp div EA;
  3504.     if not(tmp mod EA > 0) then
  3505.       Dec(Term);
  3506.  
  3507.     if term < Cx2 then
  3508.     begin
  3509.       rem := tmp + 65536; // rem := (Cy2 - Y1 + 1) * 65536;
  3510.       if rem mod EA > 0 then
  3511.         rem := X1 + rem div EA + 1
  3512.       else
  3513.         rem := X1 + rem div EA;
  3514.  
  3515.       if rem > Cx2 then rem := Cx2;
  3516.       CheckVert := True;
  3517.     end;
  3518.   end;
  3519.  
  3520.   if term > Cx2 then term := Cx2;
  3521.   Inc(term);
  3522.   if Sy = -1 then yd := -yd;
  3523.   if Sx = -1 then
  3524.   begin
  3525.     xd := -xd;
  3526.     term := -term;
  3527.     rem := -rem;
  3528.   end;
  3529.  
  3530.   // draw line
  3531.   if not CornerAA then
  3532.   try
  3533.     while xd <> term do
  3534.     begin
  3535.       CI := EC shr 8;
  3536.       P := @Bits[D1^ + D2^ * Width];
  3537.       BlendMemEx(Value, P^, GAMMA_TABLE[CI xor 255]);
  3538.       Inc(P, PI);
  3539.       BlendMemEx(Value, P^, GAMMA_TABLE[CI]);
  3540.       // check for overflow and jump to next line...
  3541.       D := EC;
  3542.       Inc(EC, EA);
  3543.       if EC <= D then
  3544.         Inc(yd, Sy);
  3545.  
  3546.       Inc(xd, Sx);
  3547.     end;
  3548.   finally
  3549.     EMMS;
  3550.   end;
  3551.  
  3552.   // draw special case horizontal line exit (draw only first half of exiting segment)
  3553.   If CheckVert then
  3554.   try
  3555.     while xd <> rem do
  3556.     begin
  3557.       BlendMemEx(Value, Bits[D1^ + D2^ * Width], GAMMA_TABLE[EC shr 8 xor 255]);
  3558.       Inc(EC, EA);
  3559.       Inc(xd, Sx);
  3560.     end;
  3561.   finally
  3562.     EMMS;
  3563.   end;
  3564.  
  3565.   Changed;
  3566. end;
  3567.  
  3568. procedure TBitmap32.MoveTo(X, Y: Integer);
  3569. begin
  3570.   RasterX := X;
  3571.   RasterY := Y;
  3572. end;
  3573.  
  3574. procedure TBitmap32.LineToS(X, Y: Integer);
  3575. begin
  3576.   LineS(RasterX, RasterY, X, Y, PenColor);
  3577.   RasterX := X;
  3578.   RasterY := Y;
  3579. end;
  3580.  
  3581. procedure TBitmap32.LineToTS(X, Y: Integer);
  3582. begin
  3583.   LineTS(RasterX, RasterY, X, Y, PenColor);
  3584.   RasterX := X;
  3585.   RasterY := Y;
  3586. end;
  3587.  
  3588. procedure TBitmap32.LineToAS(X, Y: Integer);
  3589. begin
  3590.   LineAS(RasterX, RasterY, X, Y, PenColor);
  3591.   RasterX := X;
  3592.   RasterY := Y;
  3593. end;
  3594.  
  3595. procedure TBitmap32.MoveToX(X, Y: TFixed);
  3596. begin
  3597.   RasterXF := X;
  3598.   RasterYF := Y;
  3599. end;
  3600.  
  3601. procedure TBitmap32.MoveToF(X, Y: Single);
  3602. begin
  3603.   RasterXF := Fixed(X);
  3604.   RasterYF := Fixed(Y);
  3605. end;
  3606.  
  3607. procedure TBitmap32.LineToXS(X, Y: TFixed);
  3608. begin
  3609.   LineXS(RasterXF, RasterYF, X, Y, PenColor);
  3610.   RasterXF := X;
  3611.   RasterYF := Y;
  3612. end;
  3613.  
  3614. procedure TBitmap32.LineToFS(X, Y: Single);
  3615. begin
  3616.   LineToXS(Fixed(X), Fixed(Y));
  3617. end;
  3618.  
  3619. procedure TBitmap32.LineToXSP(X, Y: TFixed);
  3620. begin
  3621.   LineXSP(RasterXF, RasterYF, X, Y);
  3622.   RasterXF := X;
  3623.   RasterYF := Y;
  3624. end;
  3625.  
  3626. procedure TBitmap32.LineToFSP(X, Y: Single);
  3627. begin
  3628.   LineToXSP(Fixed(X), Fixed(Y));
  3629. end;
  3630.  
  3631. procedure TBitmap32.FillRect(X1, Y1, X2, Y2: Integer; Value: TColor32);
  3632. var
  3633.   j: Integer;
  3634.   P: PColor32Array;
  3635. begin
  3636.   for j := Y1 to Y2 - 1 do
  3637.   begin
  3638.     P := Pointer(GetScanLine(j));
  3639.     FillLongword(P[X1], X2 - X1, Value);
  3640.   end;
  3641.   Changed;
  3642. end;
  3643.  
  3644. procedure TBitmap32.FillRectS(X1, Y1, X2, Y2: Integer; Value: TColor32);
  3645. begin
  3646.   if (X2 > X1) and (Y2 > Y1) and
  3647.     (X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and
  3648.     (X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then
  3649.   begin
  3650.     if X1 < FClipRect.Left then X1 := FClipRect.Left;
  3651.     if Y1 < FClipRect.Top then Y1 := FClipRect.Top;
  3652.     if X2 > FClipRect.Right then X2 := FClipRect.Right;
  3653.     if Y2 > FClipRect.Bottom then Y2 := FClipRect.Bottom;
  3654.     FillRect(X1, Y1, X2, Y2, Value);
  3655.   end;
  3656. end;
  3657.  
  3658. procedure TBitmap32.FillRectT(X1, Y1, X2, Y2: Integer; Value: TColor32);
  3659. var
  3660.   i, j: Integer;
  3661.   P: PColor32;
  3662.   A: Integer;
  3663.   CombineMem: TCombineMem;
  3664. begin
  3665.   A := Value shr 24;
  3666.   if A = $FF then FillRect(X1, Y1, X2, Y2, Value)
  3667.   else
  3668.   try
  3669.     Dec(Y2);
  3670.     Dec(X2);
  3671.     CombineMem := COMBINE_MEM[FCombineMode];
  3672.     for j := Y1 to Y2 do
  3673.     begin
  3674.       P := GetPixelPtr(X1, j);
  3675.       for i := X1 to X2 do
  3676.       begin
  3677.         CombineMem(Value, P^, A);
  3678.         Inc(P);
  3679.       end;
  3680.     end;
  3681.   finally
  3682.     EMMS;
  3683.     Changed;
  3684.   end;
  3685. end;
  3686.  
  3687. procedure TBitmap32.FillRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32);
  3688. begin
  3689.   if (X2 > X1) and (Y2 > Y1) and
  3690.     (X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and
  3691.     (X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then
  3692.   begin
  3693.     if X1 < FClipRect.Left then X1 := FClipRect.Left;
  3694.     if Y1 < FClipRect.Top then Y1 := FClipRect.Top;
  3695.     if X2 > FClipRect.Right then X2 := FClipRect.Right;
  3696.     if Y2 > FClipRect.Bottom then Y2 := FClipRect.Bottom;
  3697.     FillRectT(X1, Y1, X2, Y2, Value);
  3698.   end;
  3699. end;
  3700.  
  3701. procedure TBitmap32.FillRectS(const ARect: TRect; Value: TColor32);
  3702. begin
  3703.   with ARect do FillRectS(Left, Top, Right, Bottom, Value);
  3704. end;
  3705.  
  3706. procedure TBitmap32.FillRectTS(const ARect: TRect; Value: TColor32);
  3707. begin
  3708.   with ARect do FillRectTS(Left, Top, Right, Bottom, Value);
  3709. end;
  3710.  
  3711. procedure TBitmap32.FrameRectS(X1, Y1, X2, Y2: Integer; Value: TColor32);
  3712. begin
  3713.   if (X2 > X1) and (Y2 > Y1) and
  3714.     (X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and
  3715.     (X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then
  3716.   begin
  3717.     Dec(Y2);
  3718.     Dec(X2);
  3719.     HorzLineS(X1, Y1, X2, Value);
  3720.     if Y2 > Y1 then HorzLineS(X1, Y2, X2, Value);
  3721.     if Y2 > Y1 + 1 then
  3722.     begin
  3723.       VertLineS(X1, Y1 + 1, Y2 - 1, Value);
  3724.       if X2 > X1 then VertLineS(X2, Y1 + 1, Y2 - 1, Value);
  3725.     end;
  3726.     Changed;
  3727.   end;
  3728. end;
  3729.  
  3730. procedure TBitmap32.FrameRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32);
  3731. begin
  3732.   if (X2 > X1) and (Y2 > Y1) and
  3733.     (X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and
  3734.     (X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then
  3735.   begin
  3736.     Dec(Y2);
  3737.     Dec(X2);
  3738.     HorzLineTS(X1, Y1, X2, Value);
  3739.     if Y2 > Y1 then HorzLineTS(X1, Y2, X2, Value);
  3740.     if Y2 > Y1 + 1 then
  3741.     begin
  3742.       VertLineTS(X1, Y1 + 1, Y2 - 1, Value);
  3743.       if X2 > X1 then VertLineTS(X2, Y1 + 1, Y2 - 1, Value);
  3744.     end;
  3745.     Changed;
  3746.   end;
  3747. end;
  3748.  
  3749. procedure TBitmap32.FrameRectTSP(X1, Y1, X2, Y2: Integer);
  3750. begin
  3751.   if (X2 > X1) and (Y2 > Y1) and
  3752.      (X1 < Width) and (Y1 < Height) and  // don't check against ClipRect here
  3753.      (X2 > 0) and (Y2 > 0) then          // due to StippleCounter
  3754.   begin
  3755.     Dec(X2);
  3756.     Dec(Y2);
  3757.     if X1 = X2 then
  3758.       if Y1 = Y2 then SetPixelT(X1, Y1, GetStippleColor)
  3759.       else VertLineTSP(X1, Y1, Y2)
  3760.     else
  3761.       if Y1 = Y2 then HorzLineTSP(X1, Y1, X2)
  3762.       else
  3763.       begin
  3764.         HorzLineTSP(X1, Y1, X2 - 1);
  3765.         VertLineTSP(X2, Y1, Y2 - 1);
  3766.         HorzLineTSP(X2, Y2, X1 + 1);
  3767.         VertLineTSP(X1, Y2, Y1 + 1);
  3768.       end;
  3769.     Changed;
  3770.   end;
  3771. end;
  3772.  
  3773. procedure TBitmap32.FrameRectS(const ARect: TRect; Value: TColor32);
  3774. begin
  3775.   with ARect do FrameRectS(Left, Top, Right, Bottom, Value);
  3776. end;
  3777.  
  3778. procedure TBitmap32.FrameRectTS(const ARect: TRect; Value: TColor32);
  3779. begin
  3780.   with ARect do FrameRectTS(Left, Top, Right, Bottom, Value);
  3781. end;
  3782.  
  3783. procedure TBitmap32.RaiseRectTS(X1, Y1, X2, Y2: Integer; Contrast: Integer);
  3784. var
  3785.   C1, C2: TColor32;
  3786. begin
  3787.   if (X2 > X1) and (Y2 > Y1) and
  3788.     (X1 < FClipRect.Right) and (Y1 < FClipRect.Bottom) and
  3789.     (X2 > FClipRect.Left) and (Y2 > FClipRect.Top) then
  3790.   try
  3791.     if Contrast > 0 then
  3792.     begin
  3793.       C1 := SetAlpha(clWhite32, Clamp(Contrast * 512 div 100));
  3794.       C2 := SetAlpha(clBlack32, Clamp(Contrast * 255 div 100));
  3795.     end
  3796.     else if Contrast < 0 then
  3797.     begin
  3798.       Contrast := -Contrast;
  3799.       C1 := SetAlpha(clBlack32, Clamp(Contrast * 255 div 100));
  3800.       C2 := SetAlpha(clWhite32, Clamp(Contrast * 512 div 100));
  3801.     end
  3802.     else Exit;
  3803.  
  3804.     Dec(X2);
  3805.     Dec(Y2);
  3806.     HorzLineTS(X1, Y1, X2, C1);
  3807.     HorzLineTS(X1, Y2, X2, C2);
  3808.     Inc(Y1);
  3809.     Dec(Y2);
  3810.     VertLineTS(X1, Y1, Y2, C1);
  3811.     VertLineTS(X2, Y1, Y2, C2);
  3812.   finally
  3813.     Changed;
  3814.   end;
  3815. end;
  3816.  
  3817. procedure TBitmap32.RaiseRectTS(const ARect: TRect; Contrast: Integer);
  3818. begin
  3819.   with ARect do RaiseRectTS(Left, Top, Right, Bottom, Contrast);
  3820. end;
  3821.  
  3822. procedure TBitmap32.LoadFromStream(Stream: TStream);
  3823. var
  3824.   B: TBitmap;
  3825. begin
  3826.   B := TBitmap.Create;
  3827.   try
  3828.     B.LoadFromStream(Stream);
  3829.     Assign(B);
  3830.   finally
  3831.     B.Free;
  3832.     Changed;
  3833.   end;
  3834. end;
  3835.  
  3836. procedure TBitmap32.SaveToStream(Stream: TStream);
  3837. begin
  3838.   with TBitmap.Create do
  3839.   try
  3840.     Assign(Self);
  3841.     SaveToStream(Stream);
  3842.   finally
  3843.     Free;
  3844.   end;
  3845. end;
  3846.  
  3847. function TBitmap32.Equal(B: TBitmap32): Boolean;
  3848. var
  3849.   S1, S2: TMemoryStream;
  3850. begin
  3851.   Result := (B <> nil) and (ClassType = B.ClassType);
  3852.  
  3853.   if Empty or B.Empty then
  3854.   begin
  3855.     Result := Empty and B.Empty;
  3856.     Exit;
  3857.   end;
  3858.  
  3859.   if Result then
  3860.   begin
  3861.     S1 := TMemoryStream.Create;
  3862.     try
  3863.       SaveToStream(S1);
  3864.       S2 := TMemoryStream.Create;
  3865.       try
  3866.         B.SaveToStream(S2);
  3867.         Result := (S1.Size = S2.Size) and CompareMem(S1.Memory, S2.Memory, S1.Size);
  3868.       finally
  3869.         S2.Free;
  3870.       end;
  3871.     finally
  3872.       S1.Free;
  3873.     end;
  3874.   end;
  3875. end;
  3876.  
  3877. procedure TBitmap32.DefineProperties(Filer: TFiler);
  3878.  
  3879.   function DoWrite: Boolean;
  3880.   begin
  3881.     if Filer.Ancestor <> nil then
  3882.       Result := not (Filer.Ancestor is TBitmap32) or
  3883.         not Equal(TBitmap32(Filer.Ancestor))
  3884.     else
  3885.       Result := not Empty;
  3886.   end;
  3887.  
  3888. begin
  3889.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
  3890. end;
  3891.  
  3892. procedure TBitmap32.ReadData(Stream: TStream);
  3893. var
  3894.   w, h: Integer;
  3895. begin
  3896.   try
  3897.     Stream.ReadBuffer(w, 4);
  3898.     Stream.ReadBuffer(h, 4);
  3899.     SetSize(w, h);
  3900.     Stream.ReadBuffer(FBits[0], FWidth * FHeight * 4);
  3901.   finally
  3902.     Changed;
  3903.   end;
  3904. end;
  3905.  
  3906. procedure TBitmap32.WriteData(Stream: TStream);
  3907. begin
  3908.   Stream.WriteBuffer(FWidth, 4);
  3909.   Stream.WriteBuffer(FHeight, 4);
  3910.   Stream.WriteBuffer(FBits[0], FWidth * FHeight * 4);
  3911. end;
  3912.  
  3913. procedure TBitmap32.LoadFromFile(const FileName: string);
  3914. var
  3915.   P: TPicture;
  3916. begin
  3917.   P := TPicture.Create;
  3918.   try
  3919.     P.LoadFromFile(FileName);
  3920.     Assign(P);
  3921.   finally
  3922.     P.Free;
  3923.   end;
  3924. end;
  3925.  
  3926. procedure TBitmap32.SaveToFile(const FileName: string);
  3927. begin
  3928.   with TBitmap.Create do
  3929.   try
  3930.     Assign(Self);
  3931.     SaveToFile(FileName);
  3932.   finally
  3933.     Free;
  3934.   end;
  3935. end;
  3936.  
  3937. procedure TBitmap32.LoadFromResourceID(Instance: THandle; ResID: Integer);
  3938. var
  3939.   B: TBitmap;
  3940. begin
  3941.   B := TBitmap.Create;
  3942.   try
  3943.     B.LoadFromResourceID(Instance, ResID);
  3944.     Assign(B);
  3945.   finally
  3946.     B.Free;
  3947.     Changed;
  3948.   end;
  3949. end;
  3950.  
  3951. procedure TBitmap32.LoadFromResourceName(Instance: THandle; const ResName: string);
  3952. var
  3953.   B: TBitmap;
  3954. begin
  3955.   B := TBitmap.Create;
  3956.   try
  3957.     B.LoadFromResourceName(Instance, ResName);
  3958.     Assign(B);
  3959.   finally
  3960.     B.Free;
  3961.     Changed;
  3962.   end;
  3963. end;
  3964.  
  3965. procedure TBitmap32.SetFont(Value: TFont);
  3966. begin
  3967.   FFont.Assign(Value);
  3968.   FontChanged(Self);
  3969. end;
  3970.  
  3971. procedure TBitmap32.FontChanged(Sender: TObject);
  3972. begin
  3973. {$IFDEF CLX}
  3974.   if Assigned(FontHandle) then FontHandle := nil;
  3975. {$ELSE}
  3976.   if FontHandle <> 0 then
  3977.   begin
  3978.     if Handle <> 0 then SelectObject(Handle, StockFont);
  3979.     FontHandle := 0;
  3980.   end;
  3981. {$ENDIF}
  3982. end;
  3983.  
  3984. procedure TBitmap32.UpdateFont;
  3985. begin
  3986. {$IFDEF CLX}
  3987.   FontHandle := Font.Handle;
  3988. {$ELSE}
  3989.   if (FontHandle = 0) and (Handle <> 0) then
  3990.   begin
  3991.     SelectObject(Handle, Font.Handle);
  3992.     SetTextColor(Handle, ColorToRGB(Font.Color));
  3993.     SetBkMode(Handle, Windows.TRANSPARENT);
  3994.     FontHandle := Font.Handle;
  3995.   end
  3996.   else
  3997.   begin
  3998.     SelectObject(Handle, FontHandle);
  3999.     SetTextColor(Handle, ColorToRGB(Font.Color));
  4000.     SetBkMode(Handle, Windows.TRANSPARENT); 
  4001.   end;
  4002. {$ENDIF}
  4003. end;
  4004.  
  4005. procedure TBitmap32.SetCombineMode(const Value: TCombineMode);
  4006. begin
  4007.   FCombineMode := Value;
  4008.   Changed;
  4009. end;
  4010.  
  4011. procedure TBitmap32.SetDrawMode(Value: TDrawMode);
  4012. begin
  4013.   if FDrawMode <> Value then
  4014.   begin
  4015.     FDrawMode := Value;
  4016.     Changed;
  4017.   end;
  4018. end;
  4019.  
  4020. procedure TBitmap32.SetMasterAlpha(Value: Cardinal);
  4021. begin
  4022.   if FMasterAlpha <> Value then
  4023.   begin
  4024.     FMasterAlpha := Value;
  4025.     Changed;
  4026.   end;
  4027. end;
  4028.  
  4029. procedure TBitmap32.SetStretchFilter(Value: TStretchFilter);
  4030. begin
  4031.   if FStretchFilter <> Value then
  4032.   begin
  4033.     FStretchFilter := Value;
  4034.     Changed;
  4035.   end;
  4036. end;
  4037.  
  4038. // Text and Fonts //
  4039.  
  4040. {$IFDEF CLX}
  4041. function TBitmap32.TextExtent(const Text: Widestring): TSize;
  4042. begin
  4043.   Result := TextExtentW(Text); // QT uses Unicode.
  4044. end;
  4045. {$ELSE}
  4046. function TBitmap32.TextExtent(const Text: String): TSize;
  4047. var
  4048.   DC: HDC;
  4049.   OldFont: HGDIOBJ;
  4050. begin
  4051.   UpdateFont;
  4052.   Result.cX := 0;
  4053.   Result.cY := 0;
  4054.   if Handle <> 0 then
  4055.     Windows.GetTextExtentPoint32(Handle, PChar(Text), Length(Text), Result)
  4056.   else
  4057.   begin
  4058.     StockBitmap.Canvas.Lock;
  4059.     try
  4060.       DC := StockBitmap.Canvas.Handle;
  4061.       OldFont := SelectObject(DC, Font.Handle);
  4062.       Windows.GetTextExtentPoint32(DC, PChar(Text), Length(Text), Result);
  4063.       SelectObject(DC, OldFont);
  4064.     finally
  4065.       StockBitmap.Canvas.Unlock;
  4066.     end;
  4067.   end;
  4068. end;
  4069. {$ENDIF}
  4070.  
  4071. // -------------------------------------------------------------------
  4072.  
  4073. function TBitmap32.TextExtentW(const Text: Widestring): TSize;
  4074. var
  4075. {$IFDEF CLX}
  4076.   OldFont: TFont;
  4077. {$ELSE}
  4078.   DC: HDC;
  4079.   OldFont: HGDIOBJ;
  4080. {$ENDIF}
  4081. begin
  4082.   UpdateFont;
  4083.   Result.cX := 0;
  4084.   Result.cY := 0;
  4085. {$IFDEF CLX}
  4086.   if Assigned(Handle) then
  4087.   begin // doing it the ugly way to avoid QImage <-> QPixMap conversion.
  4088.     with TBitmap.Create do
  4089.     try
  4090.       Width := 5;
  4091.       Height := 5;
  4092.       Canvas.Font.Assign(Font);
  4093.       Result := Canvas.TextExtent(Text);
  4094.     finally
  4095.       Free;
  4096.     end;
  4097.   end
  4098.   else
  4099.   begin
  4100.     StockBitmap.Canvas.Lock;
  4101.     try
  4102.       OldFont := TFont.Create;
  4103.       OldFont.Assign(StockBitmap.Canvas.Font);
  4104.       StockBitmap.Canvas.Font.Assign(Font);
  4105.       Result := StockBitmap.Canvas.TextExtent(Text);
  4106.       StockBitmap.Canvas.Font.Assign(OldFont);
  4107.       OldFont.Free;
  4108.     finally
  4109.       StockBitmap.Canvas.Unlock;
  4110.     end;
  4111.   end;
  4112. {$ELSE}
  4113.   if Handle <> 0 then
  4114.     Windows.GetTextExtentPoint32W(Handle, PWideChar(Text), Length(Text), Result)
  4115.   else
  4116.   begin
  4117.     StockBitmap.Canvas.Lock;
  4118.     try
  4119.       DC := StockBitmap.Canvas.Handle;
  4120.       OldFont := SelectObject(DC, Font.Handle);
  4121.       Windows.GetTextExtentPoint32W(DC, PWideChar(Text), Length(Text), Result);
  4122.       SelectObject(DC, OldFont);
  4123.     finally
  4124.       StockBitmap.Canvas.Unlock;
  4125.     end;
  4126.   end;
  4127. {$ENDIF};
  4128. end;
  4129.  
  4130. // -------------------------------------------------------------------
  4131.  
  4132. {$IFDEF CLX}
  4133. procedure TBitmap32.Textout(X, Y: Integer; const Text: Widestring);
  4134. begin
  4135.   TextoutW(X, Y, Text); // QT uses Unicode
  4136. end;
  4137. {$ELSE}
  4138. procedure TBitmap32.Textout(X, Y: Integer; const Text: String);
  4139. begin
  4140.   UpdateFont;
  4141.   If FClipping then
  4142.     ExtTextout(Handle, X, Y, ETO_CLIPPED, @FClipRect, PChar(Text), Length(Text), nil)
  4143.   else
  4144.     ExtTextout(Handle, X, Y, 0, nil, PChar(Text), Length(Text), nil);
  4145.   Changed;
  4146. end;
  4147. {$ENDIF}
  4148.  
  4149. procedure TBitmap32.TextoutW(X, Y: Integer; const Text: Widestring);
  4150. {$IFDEF CLX}
  4151. var
  4152.   R: TRect;
  4153. {$ENDIF}
  4154. begin
  4155.   UpdateFont;
  4156. {$IFDEF CLX}
  4157.   StartPainter;
  4158.   R := Rect(X, Y, High(Word), High(Word));
  4159.   QPainter_setFont(Handle, Font.Handle);
  4160.   QPainter_setPen(Handle, Font.FontPen);
  4161.  
  4162.   If FClipping then
  4163.   begin
  4164.     QPainter_setClipRect(Handle, @FClipRect);
  4165.     QPainter_setClipping(Handle, True);
  4166.   end;
  4167.   QPainter_drawText(Handle, @R, 0, @Text, -1, nil, nil);
  4168.   If FClipping then QPainter_setClipping(Handle, False);
  4169.   StopPainter;
  4170. {$ELSE}
  4171.   If FClipping then
  4172.     ExtTextoutW(Handle, X, Y, ETO_CLIPPED, @FClipRect, PWideChar(Text), Length(Text), nil)
  4173.   else
  4174.     ExtTextoutW(Handle, X, Y, 0, nil, PWideChar(Text), Length(Text), nil);
  4175. {$ENDIF}
  4176.   Changed;
  4177. end;
  4178.  
  4179. // -------------------------------------------------------------------
  4180.  
  4181. {$IFDEF CLX}
  4182. procedure TBitmap32.Textout(X, Y: Integer; const ClipRect: TRect; const Text: Widestring);
  4183. begin
  4184.   TextoutW(X, Y, ClipRect, Text);
  4185. end;
  4186. {$ELSE}
  4187. procedure TBitmap32.Textout(X, Y: Integer; const ClipRect: TRect; const Text: String);
  4188. begin
  4189.   UpdateFont;
  4190.   ExtTextout(Handle, X, Y, ETO_CLIPPED, @ClipRect, PChar(Text), Length(Text), nil);
  4191.   Changed;
  4192. end;
  4193. {$ENDIF}
  4194.  
  4195. procedure TBitmap32.TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring);
  4196. {$IFDEF CLX}
  4197. var
  4198.   TextW: WideString;
  4199.   R: TRect;
  4200. {$ENDIF}
  4201. begin
  4202.   UpdateFont;
  4203. {$IFDEF CLX}
  4204.   StartPainter;
  4205.   TextW := WideString(Text);
  4206.   R := Rect(X, Y, High(Word), High(Word));
  4207.   QPainter_setFont(Handle, Font.Handle);
  4208.   QPainter_setPen(Handle, Font.FontPen);
  4209.   QPainter_setClipRect(Handle, @ClipRect);
  4210.   QPainter_setClipping(Handle, True);
  4211.   QPainter_drawText(Handle, @R, 0, @TextW, -1, nil, nil);
  4212.   QPainter_setClipping(Handle, False);
  4213.   StopPainter;
  4214. {$ELSE}
  4215.   ExtTextoutW(Handle, X, Y, ETO_CLIPPED, @ClipRect, PWideChar(Text), Length(Text), nil);
  4216. {$ENDIF}
  4217.   Changed;
  4218. end;
  4219.  
  4220. // -------------------------------------------------------------------
  4221.  
  4222. {$IFDEF CLX}
  4223. procedure TBitmap32.Textout(DstRect: TRect; const Flags: Cardinal; const Text: Widestring);
  4224. begin
  4225.   TextoutW(DstRect, Flags, Text);
  4226. end;
  4227. {$ELSE}
  4228. procedure TBitmap32.Textout(DstRect: TRect; const Flags: Cardinal; const Text: String);
  4229. begin
  4230.   UpdateFont;
  4231.   DrawText(Handle, PChar(Text), Length(Text), DstRect, Flags);
  4232.   Changed;
  4233. end;
  4234. {$ENDIF}
  4235.  
  4236. procedure TBitmap32.TextoutW(DstRect: TRect; const Flags: Cardinal;
  4237.   const Text: Widestring);
  4238. begin
  4239.   UpdateFont;
  4240. {$IFDEF CLX}
  4241.   StartPainter;
  4242.   QPainter_setFont(Handle, Font.Handle);
  4243.   QPainter_setPen(Handle, Font.FontPen);
  4244.   QPainter_drawText(Handle, @DstRect, Flags, @Text, -1, nil, nil);
  4245.   StopPainter;
  4246. {$ELSE}
  4247.   DrawTextW(Handle, PWideChar(Text), Length(Text), DstRect, Flags);
  4248. {$ENDIF}
  4249.   Changed;
  4250. end;
  4251.  
  4252. // -------------------------------------------------------------------
  4253.  
  4254. {$IFDEF CLX}
  4255. function TBitmap32.TextHeight(const Text: Widestring): Integer;
  4256. begin
  4257.   Result := TextExtentW(Text).cY;
  4258. end;
  4259. {$ELSE}
  4260. function TBitmap32.TextHeight(const Text: String): Integer;
  4261. begin
  4262.   Result := TextExtent(Text).cY;
  4263. end;
  4264. {$ENDIF}
  4265.  
  4266. function TBitmap32.TextHeightW(const Text: Widestring): Integer;
  4267. begin
  4268.   Result := TextExtentW(Text).cY;
  4269. end;
  4270.  
  4271. // -------------------------------------------------------------------
  4272.  
  4273. {$IFDEF CLX}
  4274. function TBitmap32.TextWidth(const Text: Widestring): Integer;
  4275. begin
  4276.   Result := TextExtentW(Text).cX;
  4277. end;
  4278. {$ELSE}
  4279. function TBitmap32.TextWidth(const Text: String): Integer;
  4280. begin
  4281.   Result := TextExtent(Text).cX;
  4282. end;
  4283. {$ENDIF}
  4284.  
  4285. function TBitmap32.TextWidthW(const Text: Widestring): Integer;
  4286. begin
  4287.   Result := TextExtentW(Text).cX;
  4288. end;
  4289.  
  4290. // -------------------------------------------------------------------
  4291.  
  4292. procedure TBitmap32.TextScaleDown(const B, B2: TBitmap32; const N: Integer;
  4293.   const Color: TColor32); // use only the blue channel
  4294. var
  4295.   I, J, X, Y, P, Q, Sz, S: Integer;
  4296.   Src: PColor32;
  4297.   Dst: PColor32;
  4298. begin
  4299.   Sz := 1 shl N - 1;
  4300.   Dst := B.PixelPtr[0, 0];
  4301.   for J := 0 to B.Height - 1 do
  4302.   begin
  4303.     Y := J shl N;
  4304.     for I := 0 to B.Width - 1 do
  4305.     begin
  4306.       X := I shl N;
  4307.       S := 0;
  4308.       for Q := Y to Y + Sz do
  4309.       begin
  4310.         Src := B2.PixelPtr[X, Q];
  4311.         for P := X to X + Sz do
  4312.         begin
  4313.           S := S + Integer(Src^ and $000000FF);
  4314.           Inc(Src);
  4315.         end;
  4316.       end;
  4317.       S := S shr N shr N;
  4318.       Dst^ := TColor32(S shl 24) + Color;
  4319.       Inc(Dst);
  4320.     end;
  4321.   end;
  4322. end;
  4323.  
  4324. procedure TBitmap32.TextBlueToAlpha(const B: TBitmap32; const Color: TColor32);
  4325. var
  4326.   I: Integer;
  4327.   P: PColor32;
  4328.   C: TColor32;
  4329. begin
  4330.   // convert blue channel to alpha and fill the color
  4331.   P := @B.Bits[0];
  4332.   for I := 0 to B.Width * B.Height - 1 do
  4333.   begin
  4334.     C := P^;
  4335.     if C <> 0 then
  4336.     begin
  4337.       C := P^ shl 24; // transfer blue channel to alpha
  4338.       C := C + Color;
  4339.       P^ := C;
  4340.     end;
  4341.     Inc(P);
  4342.   end;
  4343. end;
  4344.  
  4345. {$IFDEF CLX}
  4346. procedure TBitmap32.RenderText(X, Y: Integer; const Text: Widestring; AALevel: Integer; Color: TColor32);
  4347. begin
  4348.   RenderTextW(X, Y, Text, AALevel, Color); // QT does Unicode
  4349. end;
  4350. {$ELSE}
  4351.  
  4352. procedure SetFontAntialiasing(const Font: TFont; Enabled: Boolean);
  4353. var
  4354.   LogFont: TLogFont;
  4355. begin
  4356.   with LogFont do
  4357.   begin
  4358.     lfHeight := Font.Height;
  4359.     lfWidth := 0; { have font mapper choose }
  4360.  
  4361.     {$IFDEF COMPILER2005}
  4362.     lfEscapement := Font.Orientation;
  4363.     lfOrientation := Font.Orientation;
  4364.     {$ELSE}
  4365.     lfEscapement := 0;
  4366.     lfOrientation := 0;
  4367.     {$ENDIF}
  4368.  
  4369.     if fsBold in Font.Style then
  4370.       lfWeight := FW_BOLD
  4371.     else
  4372.       lfWeight := FW_NORMAL;
  4373.  
  4374.     lfItalic := Byte(fsItalic in Font.Style);
  4375.     lfUnderline := Byte(fsUnderline in Font.Style);
  4376.     lfStrikeOut := Byte(fsStrikeOut in Font.Style);
  4377.     lfCharSet := Byte(Font.Charset);
  4378.  
  4379.     if AnsiCompareText(Font.Name, 'Default') = 0 then  // do not localize
  4380.       StrPCopy(lfFaceName, DefFontData.Name)
  4381.     else
  4382.       StrPCopy(lfFaceName, Font.Name);
  4383.  
  4384.     if Enabled then
  4385.       lfQuality := DEFAULT_QUALITY
  4386.     else
  4387.       lfQuality := NONANTIALIASED_QUALITY;
  4388.  
  4389.     { Only True Type fonts support the angles }
  4390.     if lfOrientation <> 0 then
  4391.       lfOutPrecision := OUT_TT_ONLY_PRECIS
  4392.     else
  4393.       lfOutPrecision := OUT_DEFAULT_PRECIS;
  4394.  
  4395.     lfClipPrecision := CLIP_DEFAULT_PRECIS;
  4396.  
  4397.     case Font.Pitch of
  4398.       fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
  4399.       fpFixed: lfPitchAndFamily := FIXED_PITCH;
  4400.     else
  4401.       lfPitchAndFamily := DEFAULT_PITCH;
  4402.     end;
  4403.   end;
  4404.   Font.Handle := CreateFontIndirect(LogFont);
  4405. end;
  4406.  
  4407. procedure TBitmap32.RenderText(X, Y: Integer; const Text: String; AALevel: Integer; Color: TColor32);
  4408. var
  4409.   B, B2: TBitmap32;
  4410.   Sz: TSize;
  4411.   Alpha: TColor32;
  4412.   StockCanvas: TCanvas;
  4413.   PaddedText: String;
  4414. begin
  4415.   if Empty then Exit;
  4416.  
  4417.   Alpha := Color shr 24;
  4418.   Color := Color and $00FFFFFF;
  4419.   AALevel := Constrain(AALevel, 0, 4);
  4420.   PaddedText := Text + ' ';
  4421.  
  4422.   SetFontAntialiasing(Font, False);
  4423.  
  4424.   { TODO : Optimize Clipping here }
  4425.   B := TBitmap32.Create;
  4426.   try
  4427.     if AALevel = 0 then
  4428.     begin
  4429.       TextBlueToAlpha(B, Color);
  4430.       Sz := TextExtent(PaddedText);
  4431.       B.SetSize(Sz.cX, Sz.cY);
  4432.       B.Font := Font;
  4433.       B.Clear(0);
  4434.       B.Font.Color := clWhite;
  4435.       B.Textout(0, 0, Text);
  4436.       TextBlueToAlpha(B, Color);
  4437.     end
  4438.     else
  4439.     begin
  4440.       StockCanvas := StockBitmap.Canvas;
  4441.       StockCanvas.Lock;
  4442.       try
  4443.         StockCanvas.Font := Font;
  4444.         StockCanvas.Font.Size := Font.Size shl AALevel;
  4445.         Sz := StockCanvas.TextExtent(PaddedText);
  4446.         Sz.Cx := (Sz.cx shr AALevel + 1) shl AALevel;
  4447.         Sz.Cy := (Sz.cy shr AALevel + 1) shl AALevel;
  4448.         B2 := TBitmap32.Create;
  4449.         try
  4450.           B2.SetSize(Sz.Cx, Sz.Cy);
  4451.           B2.Clear(0);
  4452.           B2.Font := StockCanvas.Font;
  4453.           B2.Font.Color := clWhite;
  4454.           B2.Textout(0, 0, Text);
  4455.           B2.StretchFilter := sfLinear;
  4456.           B.SetSize(Sz.cx shr AALevel, Sz.cy shr AALevel);
  4457.           TextScaleDown(B, B2, AALevel, Color);
  4458.         finally
  4459.           B2.Free;
  4460.         end;
  4461.       finally
  4462.         StockCanvas.Unlock;
  4463.       end;
  4464.     end;
  4465.  
  4466.     B.DrawMode := dmBlend;
  4467.     B.MasterAlpha := Alpha;
  4468.     B.CombineMode := CombineMode;
  4469.  
  4470.     B.DrawTo(Self, X, Y);
  4471.   finally
  4472.     B.Free;
  4473.   end;
  4474.  
  4475.   SetFontAntialiasing(Font, True);
  4476. end;
  4477. {$ENDIF}
  4478.  
  4479. procedure TBitmap32.RenderTextW(X, Y: Integer; const Text: Widestring; AALevel: Integer; Color: TColor32);
  4480. var
  4481.   B, B2: TBitmap32;
  4482.   Sz: TSize;
  4483.   Alpha: TColor32;
  4484.   StockCanvas: TCanvas;
  4485.   PaddedText: Widestring;
  4486. begin
  4487.   if Empty then Exit;
  4488.  
  4489.   Alpha := Color shr 24;
  4490.   Color := Color and $00FFFFFF;
  4491.   AALevel := Constrain(AALevel, 0, 4);
  4492.   PaddedText := Text + ' ';
  4493.  
  4494. {$IFNDEF CLX}
  4495.   SetFontAntialiasing(Font, False);
  4496. {$ENDIF}
  4497.  
  4498.   { TODO : Optimize Clipping here }
  4499.   B := TBitmap32.Create;
  4500.   try
  4501.     if AALevel = 0 then
  4502.     begin
  4503. {$IFDEF CLX}
  4504.       B.Font := Font;
  4505.       Sz := B.TextExtentW(PaddedText);
  4506.       B.SetSize(Sz.cX, Sz.cY);
  4507. {$ELSE}
  4508.       Sz := TextExtentW(PaddedText);
  4509.       B.SetSize(Sz.cX, Sz.cY);
  4510.       B.Font := Font;
  4511. {$ENDIF}
  4512.       B.Clear(0);
  4513.       B.Font.Color := clWhite;
  4514.       B.TextoutW(0, 0, Text);
  4515.       TextBlueToAlpha(B, Color);
  4516.     end
  4517.     else
  4518.     begin
  4519.       StockCanvas := StockBitmap.Canvas;
  4520.       StockCanvas.Lock;
  4521.       try
  4522.         StockCanvas.Font := Font;
  4523.         StockCanvas.Font.Size := Font.Size shl AALevel;
  4524. {$IFDEF CLX}
  4525.         Sz := StockCanvas.TextExtent(PaddedText);
  4526. {$ELSE}
  4527.         Windows.GetTextExtentPoint32W(StockCanvas.Handle, PWideChar(PaddedText),
  4528.           Length(PaddedText), Sz);
  4529. {$ENDIF}
  4530.         Sz.Cx := (Sz.cx shr AALevel + 1) shl AALevel;
  4531.         Sz.Cy := (Sz.cy shr AALevel + 1) shl AALevel;
  4532.         B2 := TBitmap32.Create;
  4533.         try
  4534.           B2.SetSize(Sz.Cx, Sz.Cy);
  4535.           B2.Clear(0);
  4536.           B2.Font := StockCanvas.Font;
  4537.           B2.Font.Color := clWhite;
  4538.           B2.TextoutW(0, 0, Text);
  4539.           B2.StretchFilter := sfLinear;
  4540.           B.SetSize(Sz.cx shr AALevel, Sz.cy shr AALevel);
  4541.           TextScaleDown(B, B2, AALevel, Color);
  4542.         finally
  4543.           B2.Free;
  4544.         end;
  4545.       finally
  4546.         StockCanvas.Unlock;
  4547.       end;
  4548.     end;
  4549.  
  4550.     B.DrawMode := dmBlend;
  4551.     B.MasterAlpha := Alpha;
  4552.     B.CombineMode := CombineMode;
  4553.  
  4554.     B.DrawTo(Self, X, Y);
  4555.   finally
  4556.     B.Free;
  4557.   end;
  4558. {$IFNDEF CLX}
  4559.   SetFontAntialiasing(Font, True);
  4560. {$ENDIF}
  4561. end;
  4562.  
  4563. // -------------------------------------------------------------------
  4564.  
  4565. procedure TBitmap32.Roll(Dx, Dy: Integer; FillBack: Boolean; FillColor: TColor32);
  4566. var
  4567.   Shift, L: Integer;
  4568.   R: TRect;
  4569. begin
  4570.   if Empty or ((Dx = 0) and (Dy = 0)) then Exit;
  4571.   if (Abs(Dx) >= Width) or (Abs(Dy) >= Height) then
  4572.   begin
  4573.     if FillBack then Clear(FillColor);
  4574.     Exit;
  4575.   end;
  4576.  
  4577.   Shift := Dx + Dy * Width;
  4578.   L := (Width * Height - Abs(Shift)) shl 2;
  4579.   if Shift > 0 then Move(Bits[0], Bits[Shift], L)
  4580.   else Move(Bits[-Shift], Bits[0], L);
  4581.  
  4582.   if FillBack then
  4583.   begin
  4584.     R := MakeRect(0, 0, Width, Height);
  4585.     OffsetRect(R, Dx, Dy);
  4586.     IntersectRect(R, R, MakeRect(0, 0, Width, Height));
  4587.     if R.Top > 0 then FillRect(0, 0, Width, R.Top, FillColor)
  4588.     else if R.Top = 0 then FillRect(0, R.Bottom, Width, Height, FillColor);
  4589.     if R.Left > 0 then FillRect(0, R.Top, R.Left, R.Bottom, FillColor)
  4590.     else if R.Left = 0 then FillRect(R.Right, R.Top, Width, R.Bottom, FillColor);
  4591.   end;
  4592.  
  4593.   Changed;
  4594. end;
  4595.  
  4596. procedure TBitmap32.FlipHorz(Dst: TBitmap32);
  4597. var
  4598.   i, j: Integer;
  4599.   P1, P2: PColor32;
  4600.   tmp: TColor32;
  4601.   W, W2: Integer;
  4602. begin
  4603.   W := Width;
  4604.   if (Dst = nil) or (Dst = Self) then
  4605.   begin
  4606.     { In-place flipping }
  4607.     P1 := PColor32(Bits);
  4608.     P2 := P1;
  4609.     Inc(P2, Width - 1);
  4610.     W2 := Width shr 1;
  4611.     for J := 0 to Height - 1 do
  4612.     begin
  4613.       for I := 0 to W2 - 1 do
  4614.       begin
  4615.         tmp := P1^;
  4616.         P1^ := P2^;
  4617.         P2^ := tmp;
  4618.         Inc(P1);
  4619.         Dec(P2);
  4620.       end;
  4621.       Inc(P1, W - W2);
  4622.       Inc(P2, W + W2);
  4623.     end;
  4624.     Changed;
  4625.   end
  4626.   else
  4627.   begin
  4628.     { Flip to Dst }
  4629.     Dst.BeginUpdate;
  4630.     Dst.SetSize(W, Height);
  4631.     P1 := PColor32(Bits);
  4632.     P2 := PColor32(Dst.Bits);
  4633.     Inc(P2, W - 1);
  4634.     for J := 0 to Height - 1 do
  4635.     begin
  4636.       for I := 0 to W - 1 do
  4637.       begin
  4638.         P2^ := P1^;
  4639.         Inc(P1);
  4640.         Dec(P2);
  4641.       end;
  4642.       Inc(P2, W shl 1);
  4643.     end;
  4644.     Dst.EndUpdate;
  4645.     Dst.Changed;
  4646.   end;
  4647. end;
  4648.  
  4649. procedure TBitmap32.FlipVert(Dst: TBitmap32);
  4650. var
  4651.   J, J2: Integer;
  4652.   Buffer: PColor32Array;
  4653.   P1, P2: PColor32;
  4654. begin
  4655.   if (Dst = nil) or (Dst = Self) then
  4656.   begin
  4657.     { in-place }
  4658.     J2 := Height - 1;
  4659.     GetMem(Buffer, Width shl 2);
  4660.     for J := 0 to Height div 2 - 1 do
  4661.     begin
  4662.       P1 := PixelPtr[0, J];
  4663.       P2 := PixelPtr[0, J2];
  4664.       MoveLongword(P1^, Buffer^, Width);
  4665.       MoveLongword(P2^, P1^, Width);
  4666.       MoveLongword(Buffer^, P2^, Width);
  4667.       Dec(J2);
  4668.     end;
  4669.     FreeMem(Buffer);
  4670.     Changed;
  4671.   end
  4672.   else
  4673.   begin
  4674.     Dst.SetSize(Width, Height);
  4675.     J2 := Height - 1;
  4676.     for J := 0 to Height - 1 do
  4677.     begin
  4678.       MoveLongword(PixelPtr[0, J]^, Dst.PixelPtr[0, J2]^, Width);
  4679.       Dec(J2);
  4680.     end;
  4681.     Dst.Changed;
  4682.   end;
  4683. end;
  4684.  
  4685. procedure TBitmap32.Rotate90(Dst: TBitmap32);
  4686. var
  4687.   Tmp: TBitmap32;
  4688.   X, Y, I, J: Integer;
  4689. begin
  4690.   if Dst = nil then
  4691.   begin
  4692.     Tmp := TBitmap32.Create;
  4693.     Dst := Tmp;
  4694.   end
  4695.   else
  4696.   begin
  4697.     Tmp := nil;
  4698.     Dst.BeginUpdate;
  4699.   end;
  4700.  
  4701.  
  4702.   Dst.SetSize(Height, Width);
  4703.   I := 0;
  4704.   for Y := 0 to Height - 1 do
  4705.   begin
  4706.     J := Height - 1 - Y;
  4707.     for X := 0 to Width - 1 do
  4708.     begin
  4709.       Dst.Bits[J] := Bits[I];
  4710.       Inc(I);
  4711.       Inc(J, Height);
  4712.     end;
  4713.   end;
  4714.  
  4715.   if Tmp <> nil then
  4716.   begin
  4717.     Tmp.DrawMode := DrawMode;
  4718.     Tmp.StretchFilter := StretchFilter;
  4719.     Tmp.MasterAlpha := MasterAlpha;
  4720.     Tmp.OuterColor := OuterColor;
  4721.     Assign(Tmp);
  4722.     Tmp.Free;
  4723.   end
  4724.   else
  4725.   begin
  4726.     Dst.EndUpdate;
  4727.     Dst.Changed;
  4728.   end;
  4729. end;
  4730.  
  4731. procedure TBitmap32.Rotate180(Dst: TBitmap32);
  4732. var
  4733.   I, I2: Integer;
  4734.   Tmp: TColor32;
  4735. begin
  4736.   if Dst <> nil then
  4737.   begin
  4738.     Dst.SetSize(Width, Height);
  4739.     I2 := Width * Height - 1;
  4740.     for I := 0 to Width * Height - 1 do
  4741.     begin
  4742.       Dst.Bits[I2] := Bits[I];
  4743.       Dec(I2);
  4744.     end;
  4745.     Dst.Changed;
  4746.   end
  4747.   else
  4748.   begin
  4749.     I2 := Width * Height - 1;
  4750.     for I := 0 to Width * Height div 2 - 1 do
  4751.     begin
  4752.       Tmp := Bits[I2];
  4753.       Bits[I2] := Bits[I];
  4754.       Bits[I] := Tmp;
  4755.       Dec(I2);
  4756.     end;
  4757.     Changed;
  4758.   end;
  4759. end;
  4760.  
  4761. procedure TBitmap32.Rotate270(Dst: TBitmap32);
  4762. var
  4763.   Tmp: TBitmap32;
  4764.   X, Y, I, J: Integer;
  4765. begin
  4766.   if Dst = nil then
  4767.   begin
  4768.     Tmp := TBitmap32.Create;
  4769.     Dst := Tmp;
  4770.   end
  4771.   else
  4772.   begin
  4773.     Tmp := nil;
  4774.     Dst.BeginUpdate;
  4775.   end;
  4776.  
  4777.   Dst.SetSize(Height, Width);
  4778.   I := 0;
  4779.   for Y := 0 to Height - 1 do
  4780.   begin
  4781.     J := (Width - 1) * Height + Y;
  4782.     for X := 0 to Width - 1 do
  4783.     begin
  4784.       Dst.Bits[J] := Bits[I];
  4785.       Inc(I);
  4786.       Dec(J, Height);
  4787.     end;
  4788.   end;
  4789.  
  4790.   if Tmp <> nil then
  4791.   begin
  4792.     Tmp.DrawMode := DrawMode;
  4793.     Tmp.StretchFilter := StretchFilter;
  4794.     Tmp.MasterAlpha := MasterAlpha;
  4795.     Tmp.OuterColor := OuterColor;
  4796.     Assign(Tmp);
  4797.     Tmp.Free;
  4798.   end
  4799.   else Dst.Changed;
  4800. end;
  4801.  
  4802. function TBitmap32.BoundsRect: TRect;
  4803. begin
  4804.   Result.Left := 0;
  4805.   Result.Top := 0;
  4806.   Result.Right := Width;
  4807.   Result.Bottom := Height;
  4808. end;
  4809.  
  4810. procedure TBitmap32.UpdateClipRects;
  4811. begin
  4812.   // calculate clip rects in other units, so we can speed things up a bit.
  4813.   FFixedClipRect := FixedRect(FClipRect);
  4814.  
  4815.   F256ClipRect.Left := FClipRect.Left shl 8;
  4816.   F256ClipRect.Top := FClipRect.Top shl 8;
  4817.   F256ClipRect.Right := FClipRect.Right shl 8;
  4818.   F256ClipRect.Bottom := FClipRect.Bottom shl 8;
  4819.  
  4820.   FClipping := not EqualRect(FClipRect, BoundsRect);
  4821. end;
  4822.  
  4823. procedure TBitmap32.SetClipRect(const Value: TRect);
  4824. begin
  4825.   FClipRect.Right := Constrain(Value.Right, 0, Width);
  4826.   FClipRect.Bottom := Constrain(Value.Bottom, 0, Height);
  4827.   FClipRect.Left := Constrain(Value.Left, 0, FClipRect.Right);
  4828.   FClipRect.Top := Constrain(Value.Top, 0, FClipRect.Bottom);
  4829.  
  4830.   UpdateClipRects;
  4831. end;
  4832.  
  4833. procedure TBitmap32.ResetClipRect;
  4834. begin
  4835.   FClipRect.Left := 0;
  4836.   FClipRect.Top := 0;
  4837.   FClipRect.Right := Width;
  4838.   FClipRect.Bottom := Height;
  4839.  
  4840.   UpdateClipRects;
  4841. end;
  4842.  
  4843. {$IFDEF CLX}
  4844. procedure TBitmap32.PixmapNeeded;
  4845. begin
  4846.   if Assigned(FPixmap) and Assigned(FHandle) and not FPixmapActive then
  4847.   begin
  4848.     QPixmap_convertFromImage(FPixmap, FHandle, QPixmapColorMode(QPixmapColorMode_Auto));
  4849.     FPixmapActive := True;
  4850.     FPixmapChanged := False;
  4851.   end;
  4852. end;
  4853.  
  4854. procedure TBitmap32.ImageNeeded;
  4855. begin
  4856.   if Assigned(FPixmap) and Assigned(FHandle) and FPixmapActive and FPixmapChanged then
  4857.   begin
  4858.     QPixmap_convertToImage(FPixmap, FHandle);
  4859.     FPixmapActive := False;
  4860.     FPixmapChanged := False;
  4861.     FBits := Pointer(QImage_bits(FHandle));
  4862.   end;
  4863. end;
  4864.  
  4865. procedure TBitmap32.CheckPixmap;
  4866. begin
  4867.   if not FPixmapChanged then
  4868.     // try to avoid QPixmap -> QImage conversion, since we don't need that.
  4869.     FPixmapActive := False;
  4870.   // else the conversion takes place as soon as the Bits property is accessed.
  4871. end;
  4872.  
  4873. function TBitmap32.GetBits: PColor32Array;
  4874. begin
  4875.   ImageNeeded;
  4876.   Result := FBits;
  4877. end;
  4878.  
  4879. function TBitmap32.GetPixmap: QPixmapH;
  4880. begin
  4881.   PixmapNeeded;
  4882.   Result := FPixmap;
  4883. end;
  4884.  
  4885. function TBitmap32.GetPainter: QPainterH;
  4886. begin
  4887.   PixmapNeeded;
  4888.   Result := FHDC;
  4889. end;
  4890.  
  4891. procedure TBitmap32.StartPainter;
  4892. begin
  4893.   If (FPainterCount = 0) and not QPainter_isActive(Handle) then
  4894.     if not QPainter_begin(Handle, Pixmap) then
  4895.       raise EInvalidGraphicOperation.CreateRes(@SInvalidCanvasState);
  4896.  
  4897.   Inc(FPainterCount);
  4898. end;
  4899.  
  4900. procedure TBitmap32.StopPainter;
  4901. begin
  4902.   Dec(FPainterCount);
  4903.   If (FPainterCount = 0) then
  4904.   begin
  4905.     QPainter_end(Handle);
  4906.     FPixmapChanged := True;
  4907.   end;
  4908. end;
  4909.  
  4910. { TBitmap32Canvas }
  4911.  
  4912. procedure TBitmap32Canvas.BeginPainting;
  4913. begin
  4914.   if not QPainter_isActive(FBitmap.Handle) then
  4915.     if not QPainter_begin(FBitmap.Handle, FBitmap.Pixmap) then
  4916.       raise EInvalidGraphicOperation.CreateRes(@SInvalidCanvasState);
  4917.  
  4918.   FBitmap.PixmapChanged := True; // whatever happens, we've potentially changed
  4919.                                  // the Pixmap, so propagate that status...
  4920. end;
  4921.  
  4922. constructor TBitmap32Canvas.Create(Bitmap: TBitmap32);
  4923. begin
  4924.   inherited Create;
  4925.   FBitmap := Bitmap;
  4926. end;
  4927.  
  4928. procedure TBitmap32Canvas.CreateHandle;
  4929. begin
  4930.   Handle := QPainter_create;
  4931. end;
  4932.  
  4933. {$ENDIF}
  4934.  
  4935. { Interpolators }
  4936.  
  4937. function _Interpolator(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32;
  4938. var
  4939.   C1, C3: TColor32;
  4940. begin
  4941.   if WX_256 > $FF then WX_256:= $FF;
  4942.   if WY_256 > $FF then WY_256:= $FF;
  4943.   C1 := C11^; Inc(C11);
  4944.   C3 := C21^; Inc(C21);
  4945.   Result := CombineReg(CombineReg(C1, C11^, WX_256),
  4946.                        CombineReg(C3, C21^, WX_256), WY_256);
  4947. end;
  4948.  
  4949. function M_Interpolator(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32;
  4950. asm
  4951.         db $0F,$6F,$09           /// MOVQ      MM1,[ECX]
  4952.         MOV       ECX,C21
  4953.         db $0F,$6F,$19           /// MOVQ      MM3,[ECX]
  4954.         db $0F,$6F,$D1           /// MOVQ      MM2,MM1
  4955.         db $0F,$6F,$E3           /// MOVQ      MM4,MM3
  4956.         db $0F,$73,$D1,$20       /// PSRLQ     MM1,32
  4957.         db $0F,$73,$D3,$20       /// PSRLQ     MM3,32
  4958.  
  4959.         db $0F,$6E,$E8           /// MOVD      MM5,EAX
  4960.         db $0F,$61,$ED           /// PUNPCKLWD MM5,MM5
  4961.         db $0F,$62,$ED           /// PUNPCKLDQ MM5,MM5
  4962.  
  4963.         db $0F,$EF,$C0           /// PXOR MM0, MM0
  4964.  
  4965.         db $0F,$60,$C8           /// PUNPCKLBW MM1,MM0
  4966.         db $0F,$60,$D0           /// PUNPCKLBW MM2,MM0
  4967.         db $0F,$F9,$D1           /// PSUBW     MM2,MM1
  4968.         db $0F,$D5,$D5           /// PMULLW    MM2,MM5
  4969.         db $0F,$71,$F1,$08       /// PSLLW     MM1,8
  4970.         db $0F,$FD,$D1           /// PADDW     MM2,MM1
  4971.         db $0F,$71,$D2,$08       /// PSRLW     MM2,8
  4972.  
  4973.         db $0F,$60,$D8           /// PUNPCKLBW MM3,MM0
  4974.         db $0F,$60,$E0           /// PUNPCKLBW MM4,MM0
  4975.         db $0F,$F9,$E3           /// PSUBW     MM4,MM3
  4976.         db $0F,$D5,$E5           /// PMULLW    MM4,MM5
  4977.         db $0F,$71,$F3,$08       /// PSLLW     MM3,8
  4978.         db $0F,$FD,$E3           /// PADDW     MM4,MM3
  4979.         db $0F,$71,$D4,$08       /// PSRLW     MM4,8
  4980.  
  4981.         db $0F,$6E,$EA           /// MOVD      MM5,EDX
  4982.         db $0F,$61,$ED           /// PUNPCKLWD MM5,MM5
  4983.         db $0F,$62,$ED           /// PUNPCKLDQ MM5,MM5
  4984.  
  4985.         db $0F,$F9,$D4           /// PSUBW     MM2,MM4
  4986.         db $0F,$D5,$D5           /// PMULLW    MM2,MM5
  4987.         db $0F,$71,$F4,$08       /// PSLLW     MM4,8
  4988.         db $0F,$FD,$D4           /// PADDW     MM2,MM4
  4989.         db $0F,$71,$D2,$08       /// PSRLW     MM2,8
  4990.  
  4991.         db $0F,$67,$D0           /// PACKUSWB  MM2,MM0
  4992.         db $0F,$7E,$D0           /// MOVD      EAX,MM2
  4993. end;
  4994.  
  4995. procedure SetupFunctions;
  4996. var
  4997.   MMX_ACTIVE: Boolean;
  4998.   ACTIVE_3DNow: Boolean;
  4999. begin
  5000.   MMX_ACTIVE := HasMMX;
  5001.   ACTIVE_3DNow := Has3DNow;
  5002.   if ACTIVE_3DNow then
  5003.   begin
  5004.    // link 3DNow functions
  5005.    Interpolator := M_Interpolator;
  5006.   end
  5007.   else
  5008.   if MMX_ACTIVE then
  5009.   begin
  5010.    // link MMX functions
  5011.    Interpolator := M_Interpolator;
  5012.   end
  5013.   else
  5014.   begin
  5015.    // link IA32 functions
  5016.    Interpolator := _Interpolator;
  5017.   end
  5018. end;
  5019.  
  5020. initialization
  5021.   InitializeCriticalSection(CounterLock);
  5022.   SetupFunctions;
  5023.   SetGamma;
  5024. {$IFDEF CLX}
  5025.   StockFont := TFont.Create;
  5026. {$ELSE}
  5027.   StockFont := GetStockObject(SYSTEM_FONT);
  5028. {$ENDIF}
  5029.   StockBitmap := TBitmap.Create;
  5030.   StockBitmap.Width := 8;
  5031.   StockBitmap.Height := 8;
  5032.  
  5033. finalization
  5034. {$IFDEF CLX}
  5035.   StockFont.Free;
  5036. {$ENDIF}
  5037.   StockBitmap.Free;
  5038.   DeleteCriticalSection(CounterLock);
  5039.  
  5040. end.
  5041.