Subversion Repositories spacemission

Rev

Rev 1 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed

  1. (*******************************************************************************
  2.                        EXTEND UNIT DXDRAWS FROM DELPHIX PACK
  3.  
  4.  *  Copyright (c) 2004-2010 Jaro Benes
  5.  *  All Rights Reserved
  6.  *  Version 1.09
  7.  *  D2D Hardware module
  8.  *  web site: www.micrel.cz/Dx
  9.  *  e-mail: delphix_d2d@micrel.cz
  10.  
  11.  * Enhanced by User137
  12.  
  13.  * DISCLAIMER:
  14.    This software is provided "as is" and is without warranty of any kind.
  15.    The author of this software does not warrant, guarantee or make any
  16.    representations regarding the use or results of use of this software
  17.    in terms of reliability, accuracy or fitness for purpose. You assume
  18.    the entire risk of direct or indirect, consequential or inconsequential
  19.    results from the correct or incorrect usage of this software even if the
  20.    author has been informed of the possibilities of such damage. Neither
  21.    the author nor anybody connected to this software in any way can assume
  22.    any responsibility.
  23.  
  24.    Tested in Delphi 4, 5, 6, 7 and Delphi 2005/2006/2007/2009/2010
  25.  
  26.  * FEATURES:
  27.    a) Implement Hardware acceleration for critical function like DrawAlpha {Blend},
  28.       DrawSub and DrawAdd for both way DXIMAGELIST and DIRECTDRAWSURFACE with rotation too.
  29.    b) Automatic adjustement for texture size different 2^n.
  30.    c) Minimum current source code change, all accelerated code added into:
  31.       DXDraw.BeginScene;
  32.       //code here
  33.       DXDraw.EndScene;
  34.    d) DelphiX facade continues using still.
  35.  
  36.  * HOW TO USE
  37.    a) Design code like as DelphiX and drawing routine put into
  38.       DXDraw.BeginScene;
  39.       //code here
  40.       DXDraw.EndScene;
  41.    b) setup options in code or property for turn-on acceleration like:
  42.       DXDraw.Finalize; {done DXDraw}
  43.       If HardwareSwitch Then
  44.       {hardware}
  45.       Begin
  46.         if NOT (doDirectX7Mode in DXDraw.Options) then
  47.           DXDraw.Options := DXDraw.Options + [doDirectX7Mode];
  48.         if NOT (doHardware in DXDraw.Options) then
  49.           DXDraw.Options := DXDraw.Options + [doHardware];
  50.         if NOT (do3D in DXDraw.Options) then
  51.           DXDraw.Options := DXDraw.Options + [do3D];
  52.         if doSystemMemory in DXDraw.Options then
  53.           DXDraw.Options := DXDraw.Options - [doSystemMemory];
  54.       End
  55.       Else
  56.       {software}
  57.       Begin
  58.         if doDirectX7Mode in DXDraw.Options then
  59.           DXDraw.Options := DXDraw.Options - [doDirectX7Mode];
  60.         if do3D in DXDraw.Options then
  61.           DXDraw.Options := DXDraw.Options - [do3D];
  62.         if doHardware in DXDraw.Options then
  63.           DXDraw.Options := DXDraw.Options - [doHardware];
  64.         if NOT (doSystemMemory in DXDraw.Options) then
  65.           DXDraw.Options := DXDraw.Options + [doSystemMemory];
  66.       End;
  67.       {to fullscreen}
  68.       if doFullScreen in DXDraw.Options then
  69.       begin
  70.         RestoreWindow;
  71.         DXDraw.Cursor := crDefault;
  72.         BorderStyle := bsSingle;
  73.         DXDraw.Options := DXDraw.Options - [doFullScreen];
  74.         DXDraw.Options := DXDraw.Options + [doFlip];
  75.       end else
  76.       begin
  77.         StoreWindow;
  78.         DXDraw.Cursor := crNone;
  79.         BorderStyle := bsNone;
  80.         DXDraw.Options := DXDraw.Options + [doFullScreen];
  81.         DXDraw.Options := DXDraw.Options - [doFlip];
  82.       end;
  83.       DXDraw1.Initialize; {up DXDraw now}
  84.  
  85.  * NOTE Main form has to declare like:
  86.       TForm1 = class(TDXForm)
  87.  
  88.  * KNOWN BUGS OR RESTRICTION:
  89.    1/ Cannot be use DirectDrawSurface other from DXDraw.Surface in HW mode.
  90.    2/ New functions was not tested for two and more DXDraws on form. Sorry.
  91.  
  92.  ******************************************************************************)
  93. unit DXDraws;
  94.  
  95. interface
  96.  
  97. {$INCLUDE DelphiXcfg.inc}
  98.  
  99. uses
  100.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  101.   {$IFDEF VER14UP}
  102.   DXTypes,
  103.   {$ENDIF}
  104.   {$IFDEF VER17UP}System.Types, System.UITypes,{$ENDIF}
  105.   {$IFDEF DXTextureImage_UseZLIB}
  106.   ZLIB,
  107.   {$ENDIF}
  108.   DXClass, DIB,
  109.   {$IFDEF StandardDX}
  110.   DirectDraw, DirectSound,
  111.     {$IFDEF DX7}
  112.       {$IFDEF D3DRM}
  113.   Direct3DRM,
  114.       {$ENDIF}
  115.   Direct3D;
  116.     {$ENDIF}
  117.     {$IFDEF DX9}
  118.   Direct3D9, Direct3D, D3DX9, {Direct3D8,} DX7toDX8;
  119.     {$ENDIF}
  120.   {$ELSE}
  121.   DirectX;
  122.   {$ENDIF}
  123.  
  124. const
  125.   maxTexBlock = 2048; {maximum textures}
  126.   maxVideoBlockSize: Integer = 2048; {maximum size block of one texture}
  127.   SurfaceDivWidth: Integer = 2048;
  128.   SurfaceDivHeight: Integer = 2048;
  129.   {This conditional is for force set square texture when use it alphachannel from DIB32}
  130. {$DEFINE FORCE_SQUARE}
  131.   DXTextureImageGroupType_Normal = 0; // Normal group
  132.   DXTextureImageGroupType_Mipmap = 1; // Mipmap group
  133.  
  134.   Alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ"at  0123456789<>=()-''!_+\/{}^&%.=$#ÅÖÄ?*';
  135.   PowerAlphabet = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ`1234567890-=~!@#$%^&*()_+[];'',./\{}:"<>?|©®™ ';
  136.   ccDefaultSpecular = $FFFFFFFF;
  137.  
  138.   ZeroRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0);
  139.  
  140. type
  141.  
  142.   {  TRenderType  }
  143.  
  144.   TRenderType = (rtDraw, rtBlend, rtAdd, rtSub);
  145.  
  146.   {  TRenderMirrorFlip  }
  147.  
  148.   TRenderMirrorFlip = (rmfMirror, rmfFlip);
  149.   TRenderMirrorFlipSet = set of TRenderMirrorFlip;
  150.  
  151.   {  EDirectDrawError  }
  152.  
  153.   EDirectDrawError = class(EDirectXError);
  154.   EDirectDrawPaletteError = class(EDirectDrawError);
  155.   EDirectDrawClipperError = class(EDirectDrawError);
  156.   EDirectDrawSurfaceError = class(EDirectDrawError);
  157.  
  158.   {  TDirectDraw  }
  159.  
  160.   TDirectDrawClipper = class;
  161.   TDirectDrawPalette = class;
  162.   TDirectDrawSurface = class;
  163.  
  164.   TDirectDraw = class(TDirectX)
  165.   private
  166.     {$IFDEF D3D_deprecated}
  167.     FIDDraw: IDirectDraw;
  168.     FIDDraw4: IDirectDraw4;
  169.     {$ENDIF}
  170.     FIDDraw7: IDirectDraw7;
  171.     FDriverCaps: TDDCaps;
  172.     FHELCaps: TDDCaps;
  173.     FClippers: TList;
  174.     FPalettes: TList;
  175.     FSurfaces: TList;
  176.     function GetClipper(Index: Integer): TDirectDrawClipper;
  177.     function GetClipperCount: Integer;
  178.     function GetDisplayMode: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  179.     {$IFDEF D3D_deprecated}
  180.     function GetIDDraw: IDirectDraw;
  181.     function GetIDDraw4: IDirectDraw4;
  182.     {$ENDIF}
  183.     function GetIDDraw7: IDirectDraw7;
  184.     {$IFDEF D3D_deprecated}
  185.     function GetIDraw: IDirectDraw;
  186.     function GetIDraw4: IDirectDraw4;
  187.     {$ENDIF}
  188.     function GetIDraw7: IDirectDraw7;
  189.     function GetPalette(Index: Integer): TDirectDrawPalette;
  190.     function GetPaletteCount: Integer;
  191.     function GetSurface(Index: Integer): TDirectDrawSurface;
  192.     function GetSurfaceCount: Integer;
  193.   public
  194.     constructor Create(GUID: PGUID);
  195.     constructor CreateEx(GUID: PGUID; DirectX7Mode: Boolean);
  196.     destructor Destroy; override;
  197.     class function Drivers: TDirectXDrivers;
  198.     {$IFDEF _DMO_}class function DriversEx: TDirectXDriversEx;{$ENDIF}
  199.     property ClipperCount: Integer read GetClipperCount;
  200.     property Clippers[Index: Integer]: TDirectDrawClipper read GetClipper;
  201.     property DisplayMode: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF} read GetDisplayMode;
  202.     property DriverCaps: TDDCaps read FDriverCaps;
  203.     property HELCaps: TDDCaps read FHELCaps;
  204.     {$IFDEF D3D_deprecated}
  205.     property IDDraw: IDirectDraw read GetIDDraw;
  206.     property IDDraw4: IDirectDraw4 read GetIDDraw4;
  207.     {$ENDIF}
  208.     property IDDraw7: IDirectDraw7 read GetIDDraw7;
  209.     {$IFDEF D3D_deprecated}
  210.     property IDraw: IDirectDraw read GetIDraw;
  211.     property IDraw4: IDirectDraw4 read GetIDraw4;
  212.     {$ENDIF}
  213.     property IDraw7: IDirectDraw7 read GetIDraw7;
  214.     property PaletteCount: Integer read GetPaletteCount;
  215.     property Palettes[Index: Integer]: TDirectDrawPalette read GetPalette;
  216.     property SurfaceCount: Integer read GetSurfaceCount;
  217.     property Surfaces[Index: Integer]: TDirectDrawSurface read GetSurface;
  218.   end;
  219.  
  220.   {  TDirectDrawClipper  }
  221.  
  222.   TDirectDrawClipper = class(TDirectX)
  223.   private
  224.     FDDraw: TDirectDraw;
  225.     FIDDClipper: IDirectDrawClipper;
  226.     function GetIDDClipper: IDirectDrawClipper;
  227.     function GetIClipper: IDirectDrawClipper;
  228.     procedure SetHandle(Value: THandle);
  229.     procedure SetIDDClipper(Value: IDirectDrawClipper);
  230.     property Handle: THandle write SetHandle;
  231.   public
  232.     constructor Create(ADirectDraw: TDirectDraw);
  233.     destructor Destroy; override;
  234.     procedure SetClipRects(const Rects: array of TRect);
  235.     property DDraw: TDirectDraw read FDDraw;
  236.     property IClipper: IDirectDrawClipper read GetIClipper;
  237.     property IDDClipper: IDirectDrawClipper read GetIDDClipper write SetIDDClipper;
  238.   end;
  239.  
  240.   {  TDirectDrawPalette  }
  241.  
  242.   TDirectDrawPalette = class(TDirectX)
  243.   private
  244.     FDDraw: TDirectDraw;
  245.     FIDDPalette: IDirectDrawPalette;
  246.     function GetEntry(Index: Integer): TPaletteEntry;
  247.     function GetIDDPalette: IDirectDrawPalette;
  248.     function GetIPalette: IDirectDrawPalette;
  249.     procedure SetEntry(Index: Integer; Value: TPaletteEntry);
  250.     procedure SetIDDPalette(Value: IDirectDrawPalette);
  251.   public
  252.     constructor Create(ADirectDraw: TDirectDraw);
  253.     destructor Destroy; override;
  254.     function CreatePalette(Caps: DWORD; const Entries): Boolean;
  255.     function GetEntries(StartIndex, NumEntries: Integer; var Entries): Boolean;
  256.     procedure LoadFromDIB(DIB: TDIB);
  257.     procedure LoadFromFile(const FileName: string);
  258.     procedure LoadFromStream(Stream: TStream);
  259.     function SetEntries(StartIndex, NumEntries: Integer; const Entries): Boolean;
  260.     property DDraw: TDirectDraw read FDDraw;
  261.     property Entries[Index: Integer]: TPaletteEntry read GetEntry write SetEntry;
  262.     property IDDPalette: IDirectDrawPalette read GetIDDPalette write SetIDDPalette;
  263.     property IPalette: IDirectDrawPalette read GetIPalette;
  264.   end;
  265.  
  266.   {  TDirectDrawSurfaceCanvas  }
  267.  
  268.   TDirectDrawSurfaceCanvas = class(TCanvas)
  269.   private
  270.     FDC: HDC;
  271.     FSurface: TDirectDrawSurface;
  272.   protected
  273.     procedure CreateHandle; override;
  274.   public
  275.     constructor Create(ASurface: TDirectDrawSurface);
  276.     destructor Destroy; override;
  277.     procedure Release;
  278.   end;
  279.  
  280.   {  TDirectDrawSurface  }
  281.  
  282.   TDirectDrawSurface = class(TDirectX)
  283.   private
  284.     FCanvas: TDirectDrawSurfaceCanvas;
  285.     FHasClipper: Boolean;
  286.     FDDraw: TDirectDraw;
  287.     {$IFDEF D3D_deprecated}
  288.     FIDDSurface: IDirectDrawSurface;
  289.     FIDDSurface4: IDirectDrawSurface4;
  290.     {$ENDIF}
  291.     FIDDSurface7: IDirectDrawSurface7;
  292.     FSystemMemory: Boolean;
  293.     FStretchDrawClipper: IDirectDrawClipper;
  294.     FSurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  295.     FGammaControl: IDirectDrawGammaControl;
  296.     FLockSurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  297.     FLockCount: Integer;
  298.     FIsLocked: Boolean;
  299.     FModified: Boolean;
  300.     FCaption: TCaption;
  301.     DIB_COLMATCH: TDIB;
  302.     function GetBitCount: Integer;
  303.     function GetCanvas: TDirectDrawSurfaceCanvas;
  304.     function GetClientRect: TRect;
  305.     function GetHeight: Integer;
  306.     {$IFDEF D3D_deprecated}
  307.     function GetIDDSurface: IDirectDrawSurface; {$IFDEF VER9UP}inline;{$ENDIF}
  308.     function GetIDDSurface4: IDirectDrawSurface4; {$IFDEF VER9UP}inline;{$ENDIF}
  309.     {$ENDIF}
  310.     function GetIDDSurface7: IDirectDrawSurface7; {$IFDEF VER9UP}inline;{$ENDIF}
  311.     {$IFDEF D3D_deprecated}
  312.     function GetISurface: IDirectDrawSurface;
  313.     function GetISurface4: IDirectDrawSurface4;
  314.     {$ENDIF}
  315.     function GetISurface7: IDirectDrawSurface7;
  316.     function GetPixel(X, Y: Integer): Longint;
  317.     function GetWidth: Integer;
  318.     procedure SetClipper(Value: TDirectDrawClipper);
  319.     procedure SetColorKey(Flags: DWORD; const Value: TDDColorKey);
  320.     {$IFDEF D3D_deprecated}
  321.     procedure SetIDDSurface(Value: IDirectDrawSurface);
  322.     procedure SetIDDSurface4(Value: IDirectDrawSurface4);
  323.     {$ENDIF}
  324.     procedure SetIDDSurface7(Value: IDirectDrawSurface7);
  325.     procedure SetPalette(Value: TDirectDrawPalette);
  326.     procedure SetPixel(X, Y: Integer; Value: Longint);
  327.     procedure SetTransparentColor(Col: Longint);
  328.     {support RGB routines}
  329.     procedure LoadRGB(Color: cardinal; var R, G, B: Byte);
  330.     function SaveRGB(const R, G, B: Byte): cardinal;
  331.     {asm routine for direct surface by pixel}
  332.     {no clipping}
  333.     function GetPixel16(x, y: Integer): Integer; register;
  334.     function GetPixel24(x, y: Integer): Integer; register;
  335.     function GetPixel32(x, y: Integer): Integer; register;
  336.     function GetPixel8(x, y: Integer): Integer; register;
  337.     procedure PutPixel16(x, y, color: Integer); register;
  338.     procedure PutPixel24(x, y, color: Integer); register;
  339.     procedure PutPixel32(x, y, color: Integer); register;
  340.     procedure PutPixel8(x, y, color: Integer); register;
  341.     {routines calls asm pixel routine}
  342.     function Peek(X, Y: Integer): LongInt; {$IFDEF VER9UP} inline; {$ENDIF}
  343.     procedure Poke(X, Y: Integer; const Value: LongInt); {$IFDEF VER9UP} inline; {$ENDIF}
  344.   public
  345.     constructor Create(ADirectDraw: TDirectDraw);
  346.     destructor Destroy; override;
  347.     procedure Assign(Source: TPersistent); override;
  348.     procedure AssignTo(Dest: TPersistent); override;
  349.     function Blt(const DestRect, SrcRect: TRect; Flags: DWORD;
  350.       const DF: TDDBltFX; Source: TDirectDrawSurface): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  351.     function BltFast(X, Y: Integer; const SrcRect: TRect;
  352.       Flags: DWORD; Source: TDirectDrawSurface): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  353.     function ColorMatch(Col: TColor): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
  354.   {$IFDEF VER4UP}
  355.     {$IFDEF D3D_deprecated}
  356.     function CreateSurface(SurfaceDesc: TDDSurfaceDesc): Boolean; overload;
  357.     {$ENDIF}
  358.     function CreateSurface(SurfaceDesc: TDDSurfaceDesc2): Boolean; overload;
  359.   {$ELSE}
  360.     function CreateSurface(SurfaceDesc: TDDSurfaceDesc): Boolean;
  361.   {$ENDIF}
  362.  
  363.     procedure MirrorFlip(Value: TRenderMirrorFlipSet);
  364.  
  365.   {$IFDEF VER4UP}
  366.     procedure Draw(X, Y: Integer; SrcRect: TRect; Source: TDirectDrawSurface; Transparent: Boolean = True); overload;
  367.     procedure Draw(X, Y: Integer; Source: TDirectDrawSurface; Transparent: Boolean = True); overload;
  368.     procedure StretchDraw(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  369.       Transparent: Boolean = True); overload;
  370.     procedure StretchDraw(const DestRect: TRect; Source: TDirectDrawSurface;
  371.       Transparent: Boolean = True); overload;
  372.   {$ELSE}
  373.     procedure Draw(X, Y: Integer; SrcRect: TRect; Source: TDirectDrawSurface;
  374.       Transparent: Boolean);
  375.     procedure StretchDraw(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  376.       Transparent: Boolean);
  377.   {$ENDIF}
  378.     procedure DrawAdd(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  379.       Transparent: Boolean; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  380.     procedure DrawAlpha(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  381.       Transparent: Boolean; Alpha: Integer);
  382.     procedure DrawSub(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  383.       Transparent: Boolean; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  384.  
  385.     procedure DrawAddCol(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  386.       Transparent: Boolean; Color, Alpha: Integer);
  387.     procedure DrawAlphaCol(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  388.       Transparent: Boolean; Color, Alpha: Integer);
  389.     procedure DrawSubCol(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  390.       Transparent: Boolean; Color, Alpha: Integer);
  391.  
  392.     {Rotate}
  393.     procedure DrawRotate(X, Y, Width, Height: Integer; const SrcRect: TRect;
  394.       Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: single);
  395.     procedure DrawRotateAdd(X, Y, Width, Height: Integer; const SrcRect: TRect;
  396.       Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: single;
  397.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  398.     procedure DrawRotateAlpha(X, Y, Width, Height: Integer; const SrcRect: TRect;
  399.       Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: single;
  400.       Alpha: Integer);
  401.     procedure DrawRotateSub(X, Y, Width, Height: Integer; const SrcRect: TRect;
  402.       Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: single;
  403.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  404.  
  405.     procedure DrawRotateAddCol(X, Y, Width, Height: Integer;
  406.       const SrcRect: TRect; Source: TDirectDrawSurface; CenterX,
  407.       CenterY: Double; Transparent: Boolean; Angle: Single; Color: Integer;
  408.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  409.     procedure DrawRotateAlphaCol(X, Y, Width, Height: Integer;
  410.       const SrcRect: TRect; Source: TDirectDrawSurface; CenterX,
  411.       CenterY: Double; Transparent: Boolean; Angle: Single; Color: Integer;
  412.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  413.     procedure DrawRotateCol(X, Y, Width, Height: Integer; const SrcRect: TRect;
  414.       Source: TDirectDrawSurface; CenterX, CenterY: Double;
  415.       Transparent: Boolean; Angle: Single; Color: Integer);
  416.     procedure DrawRotateSubCol(X, Y, Width, Height: Integer;
  417.       const SrcRect: TRect; Source: TDirectDrawSurface; CenterX,
  418.       CenterY: Double; Transparent: Boolean; Angle: Single; Color: Integer;
  419.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  420.     {WaveX}
  421.     procedure DrawWaveX(X, Y, Width, Height: Integer; const SrcRect: TRect;
  422.       Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer);
  423.     procedure DrawWaveXAdd(X, Y, Width, Height: Integer; const SrcRect: TRect;
  424.       Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
  425.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  426.     procedure DrawWaveXAlpha(X, Y, Width, Height: Integer; const SrcRect: TRect;
  427.       Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
  428.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  429.     procedure DrawWaveXSub(X, Y, Width, Height: Integer; const SrcRect: TRect;
  430.       Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
  431.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  432.     {WaveY}
  433.     procedure DrawWaveY(X, Y, Width, Height: Integer; const SrcRect: TRect;
  434.       Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer);
  435.     procedure DrawWaveYAdd(X, Y, Width, Height: Integer; const SrcRect: TRect;
  436.       Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
  437.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  438.     procedure DrawWaveYAlpha(X, Y, Width, Height: Integer; const SrcRect: TRect;
  439.       Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
  440.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  441.     procedure DrawWaveYSub(X, Y, Width, Height: Integer; const SrcRect: TRect;
  442.       Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
  443.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  444.     {Poke function}
  445.     procedure PokeLine(X1, Y1, X2, Y2: Integer; Color: cardinal); {$IFDEF VER9UP} inline; {$ENDIF}
  446.     procedure PokeLinePolar(x, y: Integer; angle, length: extended;
  447.       Color: cardinal); {$IFDEF VER9UP} inline; {$ENDIF}
  448.     procedure PokeBox(xs, ys, xd, yd: Integer; Color: cardinal);
  449.     procedure PokeBlendPixel(const X, Y: Integer; aColor: cardinal;
  450.       Alpha: byte);
  451.     procedure PokeWuLine(X1, Y1, X2, Y2, aColor: Integer);
  452.     procedure Noise(Oblast: TRect; Density: Byte);
  453.     procedure Blur;
  454.     procedure DoRotate(cent1, cent2, angle: Integer; coord1, coord2: Real;
  455.       color: word);
  456.     procedure PokeCircle(X, Y, Radius, Color: Integer);
  457.     procedure PokeEllipse(exc, eyc, ea, eb, angle, color: Integer);
  458.     procedure PokeFilledEllipse(exc, eyc, ea, eb, color: Integer);
  459.     procedure PokeVLine(x, y1, y2: Integer; Color: cardinal);
  460.     {Fill}
  461.     procedure Fill(DevColor: Longint);
  462.     procedure FillRect(const Rect: TRect; DevColor: Longint);
  463.     procedure FillRectAdd(const DestRect: TRect; Color: TColor; Alpha: Byte{$IFDEF VER4UP} = 128{$ENDIF});
  464.     procedure FillRectAlpha(const DestRect: TRect; Color: TColor; Alpha: Integer);
  465.     procedure FillRectSub(const DestRect: TRect; Color: TColor; Alpha: Byte{$IFDEF VER4UP} = 128{$ENDIF});
  466.     {Load}
  467.     procedure LoadFromDIB(DIB: TDIB);
  468.     procedure LoadFromDIBRect(DIB: TDIB; AWidth, AHeight: Integer; const SrcRect: TRect);
  469.     procedure LoadFromGraphic(Graphic: TGraphic);
  470.     procedure LoadFromGraphicRect(Graphic: TGraphic; AWidth, AHeight: Integer; const SrcRect: TRect);
  471.     procedure LoadFromFile(const FileName: string);
  472.     procedure LoadFromStream(Stream: TStream);
  473.     {$IFDEF VER4UP}
  474.     function Lock(const Rect: TRect; var SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF}): Boolean; overload;
  475.     function Lock(var SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF}): Boolean; overload;
  476.     function Lock: Boolean; overload;
  477.     {$ELSE}
  478.     function LockSurface: Boolean;
  479.     function Lock(const Rect: TRect; var SurfaceDesc: TDDSurfaceDesc): Boolean;
  480.     {$ENDIF}
  481.     procedure UnLock;
  482.     function Restore: Boolean;
  483.     property IsLocked: Boolean read FIsLocked;
  484.     procedure SetSize(AWidth, AHeight: Integer);
  485.     property Modified: Boolean read FModified write FModified;
  486.     property BitCount: Integer read GetBitCount;
  487.     property Canvas: TDirectDrawSurfaceCanvas read GetCanvas;
  488.     property ClientRect: TRect read GetClientRect;
  489.     property Clipper: TDirectDrawClipper write SetClipper;
  490.     property ColorKey[Flags: DWORD]: TDDColorKey write SetColorKey;
  491.     property DDraw: TDirectDraw read FDDraw;
  492.     property GammaControl: IDirectDrawGammaControl read FGammaControl;
  493.     property Height: Integer read GetHeight;
  494.     {$IFDEF D3D_deprecated}
  495.     property IDDSurface: IDirectDrawSurface read GetIDDSurface write SetIDDSurface;
  496.     property IDDSurface4: IDirectDrawSurface4 read GetIDDSurface4 write SetIDDSurface4;
  497.     {$ENDIF}
  498.     property IDDSurface7: IDirectDrawSurface7 read GetIDDSurface7 write SetIDDSurface7;
  499.     {$IFDEF D3D_deprecated}
  500.     property ISurface: IDirectDrawSurface read GetISurface;
  501.     property ISurface4: IDirectDrawSurface4 read GetISurface4;
  502.     {$ENDIF}
  503.     property ISurface7: IDirectDrawSurface7 read GetISurface7;
  504.     property Palette: TDirectDrawPalette write SetPalette;
  505.     property Pixels[X, Y: Integer]: Longint read GetPixel write SetPixel;
  506.     property Pixel[X, Y: Integer]: LongInt read Peek write Poke;
  507.     property SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF} read FSurfaceDesc;
  508.     property SystemMemory: Boolean read FSystemMemory write FSystemMemory;
  509.     property TransparentColor: Longint write SetTransparentColor;
  510.     property Width: Integer read GetWidth;
  511.     property Caption: TCaption read FCaption write FCaption;
  512.   end;
  513.  
  514.   {  TDXDrawDisplay  }
  515.  
  516.   TCustomDXDraw = class;
  517.  
  518.   TDXDrawDisplayMode = class(TCollectionItem)
  519.   private
  520.     FSurfaceDesc: TDDSurfaceDesc;
  521.     function GetBitCount: Integer;
  522.     function GetHeight: Integer;
  523.     function GetWidth: Integer;
  524.   public
  525.     property BitCount: Integer read GetBitCount;
  526.     property Height: Integer read GetHeight;
  527.     property SurfaceDesc: TDDSurfaceDesc read FSurfaceDesc;
  528.     property Width: Integer read GetWidth;
  529.   end;
  530.  
  531.   TDXDrawDisplay = class(TPersistent)
  532.   private
  533.     FBitCount: Integer;
  534.     FDXDraw: TCustomDXDraw;
  535.     FHeight: Integer;
  536.     FModes: TCollection;
  537.     FWidth: Integer;
  538.     FFixedBitCount: Boolean;
  539.     FFixedRatio: Boolean;
  540.     FFixedSize: Boolean;
  541.     function GetCount: Integer;
  542.     function GetMode: TDXDrawDisplayMode;
  543.     function GetMode2(Index: Integer): TDXDrawDisplayMode;
  544.     procedure LoadDisplayModes;
  545.     procedure SetBitCount(Value: Integer);
  546.     procedure SetHeight(Value: Integer);
  547.     procedure SetWidth(Value: Integer);
  548.     function SetSize(AWidth, AHeight, ABitCount{$IFNDEF D3D_deprecated}, ARefreshRate, AFlags{$ENDIF}: Integer): Boolean;
  549.     function DynSetSize(AWidth, AHeight, ABitCount: Integer): Boolean;
  550.   public
  551.     constructor Create(ADXDraw: TCustomDXDraw);
  552.     destructor Destroy; override;
  553.     procedure Assign(Source: TPersistent); override;
  554.     function IndexOf(Width, Height, BitCount: Integer): Integer;
  555.     property Count: Integer read GetCount;
  556.     property Mode: TDXDrawDisplayMode read GetMode;
  557.     property Modes[Index: Integer]: TDXDrawDisplayMode read GetMode2; default;
  558.   published
  559.     property BitCount: Integer read FBitCount write SetBitCount default 16;
  560.     property FixedBitCount: Boolean read FFixedBitCount write FFixedBitCount;
  561.     property FixedRatio: Boolean read FFixedRatio write FFixedRatio;
  562.     property FixedSize: Boolean read FFixedSize write FFixedSize;
  563.     property Height: Integer read FHeight write SetHeight default 480;
  564.     property Width: Integer read FWidth write SetWidth default 640;
  565.   end;
  566.  
  567.   TDirectDrawDisplay = TDXDrawDisplay;
  568.   TDirectDrawDisplayMode = TDXDrawDisplayMode;
  569.  
  570.   {  EDXDrawError  }
  571.  
  572.   EDXDrawError = class(Exception);
  573.  
  574.   { TD2D HW acceleration}
  575.  
  576.   TD2D = class;
  577.  
  578.   {  TTracerCollection  }
  579.  
  580.   TTraces = class;
  581.  
  582.   {  TCustomDXDraw  }
  583.  
  584.   TD2DTextureFilter = (D2D_POINT, D2D_LINEAR, D2D_FLATCUBIC, D2D_GAUSSIANCUBIC, D2D_ANISOTROPIC);
  585.  
  586.  
  587.   TDXDrawOption = (doFullScreen, doNoWindowChange, doAllowReboot, doWaitVBlank,
  588.     doAllowPalette256, doSystemMemory, doStretch, doCenter, doFlip,
  589.     {$IFDEF D3D_deprecated}do3D, doDirectX7Mode,{$ENDIF} {$IFDEF D3DRM} doRetainedMode,{$ENDIF}
  590.     doHardware, doSelectDriver, doZBuffer);
  591.  
  592.   TDXDrawOptions = set of TDXDrawOption;
  593.  
  594.   TDXDrawNotifyType = (dxntDestroying, dxntInitializing, dxntInitialize, dxntInitializeSurface,
  595.     dxntFinalize, dxntFinalizeSurface, dxntRestore, dxntSetSurfaceSize);
  596.  
  597.   TDXDrawNotifyEvent = procedure(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType) of object;
  598.  
  599.   TD2DTextures = class;
  600.   TOnUpdateTextures = procedure(const Sender: TD2DTextures; var Changed: Boolean) of object;
  601.  
  602.   TPictureCollectionItem = class;
  603.  
  604.   {$IFNDEF D3D_deprecated}
  605.   TD3DDeviceType = (dtTnLHAL, dtHAL,dtMMX,dtRGB,dtRamp,dtRef);
  606.   TD3DDeviceTypeSet = Set of TD3DDeviceType;
  607.   {$ENDIF}
  608.  
  609.   TCustomDXDraw = class(TCustomControl)
  610.   private
  611.     FAutoInitialize: Boolean;
  612.     FAutoSize: Boolean;
  613.     FCalledDoInitialize: Boolean;
  614.     FCalledDoInitializeSurface: Boolean;
  615.     FForm: TCustomForm;
  616.     FNotifyEventList: TList;
  617.     FInitialized: Boolean;
  618.     FInitialized2: Boolean;
  619.     FInternalInitialized: Boolean;
  620.     FUpdating: Boolean;
  621.     FSubClass: TControlSubClass;
  622.     FNowOptions: TDXDrawOptions;
  623.     FOptions: TDXDrawOptions;
  624.     FOnFinalize: TNotifyEvent;
  625.     FOnFinalizeSurface: TNotifyEvent;
  626.     FOnInitialize: TNotifyEvent;
  627.     FOnInitializeSurface: TNotifyEvent;
  628.     FOnInitializing: TNotifyEvent;
  629.     FOnRestoreSurface: TNotifyEvent;
  630.     FOffNotifyRestore: Integer;
  631.     { DirectDraw }
  632.     FDXDrawDriver: TObject;
  633.     FDriver: PGUID;
  634.     FDriverGUID: TGUID;
  635.     FDDraw: TDirectDraw;
  636.     FDisplay: TDXDrawDisplay;
  637.     {$IFNDEF D3D_deprecated}
  638.     FDeviceTypeSet: TD3DDeviceTypeSet;{$ENDIF}
  639.     {$IFDEF _DMO_}FAdapters: TDirectXDriversEx;{$ENDIF}
  640.     FClipper: TDirectDrawClipper;
  641.     FPalette: TDirectDrawPalette;
  642.     FPrimary: TDirectDrawSurface;
  643.     FSurface: TDirectDrawSurface;
  644.     FSurfaceWidth: Integer;
  645.     FSurfaceHeight: Integer;
  646.     { Direct3D }
  647.     {$IFDEF D3D_deprecated}
  648.     FD3D: IDirect3D;
  649.     FD3D2: IDirect3D2;
  650.     FD3D3: IDirect3D3;
  651.     {$ENDIF}
  652.     FD3D7: IDirect3D7;
  653.     {$IFDEF D3D_deprecated}
  654.     FD3DDevice: IDirect3DDevice;
  655.     FD3DDevice2: IDirect3DDevice2;
  656.     FD3DDevice3: IDirect3DDevice3;
  657.     {$ENDIF}
  658.     FD3DDevice7: IDirect3DDevice7;
  659. {$IFDEF D3DRM}
  660.     FD3DRM: IDirect3DRM;
  661.     FD3DRM2: IDirect3DRM2;
  662.     FD3DRM3: IDirect3DRM3;
  663.     FD3DRMDevice: IDirect3DRMDevice;
  664.     FD3DRMDevice2: IDirect3DRMDevice2;
  665.     FD3DRMDevice3: IDirect3DRMDevice3;
  666.     FCamera: IDirect3DRMFrame;
  667.     FScene: IDirect3DRMFrame;
  668.     FViewport: IDirect3DRMViewport;
  669. {$ENDIF}
  670.     FZBuffer: TDirectDrawSurface;
  671.     FD2D: TD2D;
  672.     FOnUpdateTextures: TOnUpdateTextures;
  673.     FTraces: TTraces;
  674.     FOnRender: TNotifyEvent;
  675.     procedure FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
  676.     function GetCanDraw: Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  677.     function GetCanPaletteAnimation: Boolean;
  678.     function GetSurfaceHeight: Integer;
  679.     function GetSurfaceWidth: Integer;
  680.     procedure NotifyEventList(NotifyType: TDXDrawNotifyType);
  681.     procedure SetColorTable(const ColorTable: TRGBQuads);
  682.     procedure SetCooperativeLevel;
  683.     procedure SetDisplay(Value: TDXDrawDisplay);
  684.     procedure SetDriver(Value: PGUID);
  685.     procedure SetOptions(Value: TDXDrawOptions);
  686.     procedure SetSurfaceHeight(Value: Integer);
  687.     procedure SetSurfaceWidth(Value: Integer);
  688.     function TryRestore: Boolean;
  689.     procedure WMCreate(var Message: TMessage); message WM_CREATE;
  690.     function Fade2Color(colorfrom, colorto: Integer): LongInt;
  691.     function Grey2Fade(shadefrom, shadeto: Integer): Integer;
  692.     procedure SetTraces(const Value: TTraces);
  693.     function CheckD3: Boolean;
  694.     function CheckD3D(Dest: TDirectDrawSurface): Boolean;
  695.   protected
  696.     procedure DoFinalize; virtual;
  697.     procedure DoFinalizeSurface; virtual;
  698.     procedure DoInitialize; virtual;
  699.     procedure DoInitializeSurface; virtual;
  700.     procedure DoInitializing; virtual;
  701.     procedure DoRestoreSurface; virtual;
  702.     procedure Loaded; override;
  703.     procedure Paint; override;
  704.     function PaletteChanged(Foreground: Boolean): Boolean; override;
  705.     procedure SetParent(AParent: TWinControl); override;
  706.     procedure SetAutoSize(Value: Boolean); {$IFDEF D6UP} override; {$ENDIF}
  707.     property OnUpdateTextures: TOnUpdateTextures read FOnUpdateTextures write FOnUpdateTextures;
  708.     property OnRender: TNotifyEvent read FOnRender write FOnRender;
  709.   public
  710.     ColorTable: TRGBQuads;
  711.     DefColorTable: TRGBQuads;
  712.     //
  713.     function Fade2Black(colorfrom: Integer): Longint;
  714.     function Fade2White(colorfrom: Integer): Longint;
  715.     //
  716.     constructor Create(AOwner: TComponent); override;
  717.     destructor Destroy; override;
  718.     class function Drivers: TDirectXDrivers;
  719.     {$IFDEF _DMO_}class function DriversEx: TDirectXDriversEx;{$ENDIF}
  720.     procedure Finalize;
  721.     procedure Flip;
  722.     procedure Initialize;
  723.     procedure Render(LagCount: Integer{$IFDEF VER4UP} = 0{$ENDIF});
  724.     procedure Restore;
  725.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  726.     procedure SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
  727.     procedure BeginScene;
  728.     procedure EndScene;
  729.     procedure TextureFilter(Grade: TD2DTextureFilter);
  730.     procedure AntialiasFilter(Grade: TD3DAntialiasMode);
  731.     procedure MirrorFlip(Value: TRenderMirrorFlipSet);
  732.     procedure SaveTextures(path: string);
  733.     procedure ClearStack;
  734.     procedure UpdateTextures;
  735.     {grab images}
  736.     procedure PasteImage(sdib: TDIB; x, y: Integer);
  737.     procedure GrabImage(iX, iY, iWidth, iHeight: Integer; ddib: TDIB);
  738.     {fades}
  739.     function Black2Screen(oldcolor: Integer): Longint;
  740.     function Fade2Screen(oldcolor, newcolour: Integer): LongInt;
  741.     function White2Screen(oldcolor: Integer): LongInt;
  742.     function FadeGrey2Screen(oldcolor, newcolour: LongInt): LongInt;
  743.     procedure UpdatePalette;
  744.     procedure RegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
  745.     procedure UnRegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
  746.     property AutoInitialize: Boolean read FAutoInitialize write FAutoInitialize;
  747.     property AutoSize: Boolean read FAutoSize write SetAutoSize;
  748. {$IFDEF D3DRM}property Camera: IDirect3DRMFrame read FCamera; {$ENDIF}
  749.     property CanDraw: Boolean read GetCanDraw;
  750.     property CanPaletteAnimation: Boolean read GetCanPaletteAnimation;
  751.     property Clipper: TDirectDrawClipper read FClipper;
  752.     property Color;
  753.     {$IFDEF D3D_deprecated}
  754.     property D3D: IDirect3D read FD3D;
  755.     property D3D2: IDirect3D2 read FD3D2;
  756.     property D3D3: IDirect3D3 read FD3D3;
  757.     {$ENDIF}
  758.     property D3D7: IDirect3D7 read FD3D7;
  759.     {$IFDEF D3D_deprecated}
  760.     property D3DDevice: IDirect3DDevice read FD3DDevice;
  761.     property D3DDevice2: IDirect3DDevice2 read FD3DDevice2;
  762.     property D3DDevice3: IDirect3DDevice3 read FD3DDevice3;
  763.     {$ENDIF}
  764.     property D3DDevice7: IDirect3DDevice7 read FD3DDevice7;
  765.     {$IFNDEF D3D_deprecated}
  766.     property D3DDeviceTypeSet: TD3DDeviceTypeSet read FDeviceTypeSet;{$ENDIF}
  767. {$IFDEF D3DRM}
  768.     property D3DRM: IDirect3DRM read FD3DRM;
  769.     property D3DRM2: IDirect3DRM2 read FD3DRM2;
  770.     property D3DRM3: IDirect3DRM3 read FD3DRM3;
  771.     property D3DRMDevice: IDirect3DRMDevice read FD3DRMDevice;
  772.     property D3DRMDevice2: IDirect3DRMDevice2 read FD3DRMDevice2;
  773.     property D3DRMDevice3: IDirect3DRMDevice3 read FD3DRMDevice3;
  774. {$ENDIF}
  775.     property DDraw: TDirectDraw read FDDraw;
  776.     property Display: TDXDrawDisplay read FDisplay write SetDisplay;
  777.     {$IFDEF _DMO_}property Adapter: TDirectXDriversEx read FAdapters write FAdapters;{$ENDIF}
  778.     property Driver: PGUID read FDriver write SetDriver;
  779.     property Initialized: Boolean read FInitialized;
  780.     property NowOptions: TDXDrawOptions read FNowOptions;
  781.     property OnFinalize: TNotifyEvent read FOnFinalize write FOnFinalize;
  782.     property OnFinalizeSurface: TNotifyEvent read FOnFinalizeSurface write FOnFinalizeSurface;
  783.     property OnInitialize: TNotifyEvent read FOnInitialize write FOnInitialize;
  784.     property OnInitializeSurface: TNotifyEvent read FOnInitializeSurface write FOnInitializeSurface;
  785.     property OnInitializing: TNotifyEvent read FOnInitializing write FOnInitializing;
  786.     property OnRestoreSurface: TNotifyEvent read FOnRestoreSurface write FOnRestoreSurface;
  787.     property Options: TDXDrawOptions read FOptions write SetOptions;
  788.     property Palette: TDirectDrawPalette read FPalette;
  789.     property Primary: TDirectDrawSurface read FPrimary;
  790. {$IFDEF D3DRM}property Scene: IDirect3DRMFrame read FScene; {$ENDIF}
  791.     property Surface: TDirectDrawSurface read FSurface;
  792.     property SurfaceHeight: Integer read GetSurfaceHeight write SetSurfaceHeight default 480;
  793.     property SurfaceWidth: Integer read GetSurfaceWidth write SetSurfaceWidth default 640;
  794. {$IFDEF D3DRM}property Viewport: IDirect3DRMViewport read FViewport; {$ENDIF}
  795.     property ZBuffer: TDirectDrawSurface read FZBuffer;
  796.     property D2D1: TD2D read FD2D; {public object is here}
  797.     property Traces: TTraces read FTraces write SetTraces;
  798.   end;
  799.  
  800.   {  TDXDraw  }
  801.  
  802.   TDXDraw = class(TCustomDXDraw)
  803.   published
  804.     {$IFDEF _DMO_}property Adapter;{$ENDIF}
  805.     property AutoInitialize;
  806.     property AutoSize;
  807.     property Color;
  808.     property Display;
  809.     property Options;
  810.     property SurfaceHeight;
  811.     property SurfaceWidth;
  812.     property OnFinalize;
  813.     property OnFinalizeSurface;
  814.     property OnInitialize;
  815.     property OnInitializeSurface;
  816.     property OnInitializing;
  817.     property OnRestoreSurface;
  818.     property OnUpdateTextures;
  819.     property OnRender;
  820.  
  821.     property Align;
  822. {$IFDEF VER4UP}property Anchors; {$ENDIF}
  823. {$IFDEF VER4UP}property Constraints; {$ENDIF}
  824.     property DragCursor;
  825.     property DragMode;
  826.     property Enabled;
  827.     property ParentShowHint;
  828.     property PopupMenu;
  829.     property ShowHint;
  830.     property TabOrder;
  831.     property TabStop;
  832.     property Traces;
  833.     property Visible;
  834.     property OnClick;
  835.     property OnDblClick;
  836.     property OnDragDrop;
  837.     property OnDragOver;
  838.     property OnEndDrag;
  839.     property OnEnter;
  840.     property OnExit;
  841.     property OnKeyDown;
  842.     property OnKeyPress;
  843.     property OnKeyUp;
  844.     property OnMouseDown;
  845.     property OnMouseMove;
  846.     property OnMouseUp;
  847. {$IFDEF VER9UP}
  848.     property OnMouseWheel;
  849.     property OnMouseWheelUp;
  850.     property OnMouseWheelDown;
  851. {$ENDIF}
  852. {$IFDEF VER4UP}property OnResize; {$ENDIF}
  853.     property OnStartDrag;
  854.   end;
  855.  
  856.   {  EDX3DError  }
  857.  
  858.   EDX3DError = class(Exception);
  859.  
  860.   {  DxTracer  }
  861.  
  862.   EDXTracerError = class(Exception);
  863.   EDXBlitError = class(Exception);
  864.  
  865.   TTracePointsType = (tptDot, tptLine, tptCircle, tptCurve);
  866.  
  867.   TBlitMoveEvent = procedure(Sender: TObject; LagCount: Integer; var MoveIt: Boolean) of object;
  868.   TWaveType = (wtWaveNone, wtWaveX, wtWaveY);
  869.   TBlitRec = packed record
  870.     FCollisioned: Boolean;
  871.     FMoved: Boolean;
  872.     FVisible: Boolean;
  873.     FX: Double;
  874.     FY: Double;
  875.     FZ: Integer;
  876.     FWidth: Integer;
  877.     FHeight: Integer;
  878.     //--
  879.     FAnimCount: Integer;
  880.     FAnimLooped: Boolean;
  881.     FAnimPos: Double;
  882.     FAnimSpeed: Double;
  883.     FAnimStart: Integer;
  884.     //FTile: Boolean;
  885.     FAngle: Single;
  886.     FAlpha: Integer;
  887.     FCenterX: Double;
  888.     FCenterY: Double;
  889.     FScale: Double;
  890.     FBlendMode: TRenderType;
  891.     FAmplitude: Integer;
  892.     FAmpLength: Integer;
  893.     FPhase: Integer;
  894.     FWaveType: TWaveType;
  895.     FSpeedX, FSpeedY: Single;
  896.     FGravityX, FGravityY: Single;
  897.     FEnergy: Single;
  898.     FBlurImage: Boolean;
  899.     FMirror: Boolean;
  900.     FFlip: Boolean;
  901.     FTextureFilter: TD2DTextureFilter;
  902.   end;
  903.   TBlurImageProp = packed record
  904.     eActive: Boolean;
  905.     eX, eY: Integer;
  906.     ePatternIndex: Integer; {when animated or 0 always}
  907.     eAngle: Single; //angle can be saved too
  908.     eBlendMode: TRenderType; //blend mode
  909.     eIntensity: Byte; {intensity of Blur/Add/Sub}
  910.   end;
  911.  
  912.   TPath = packed record
  913.     X, Y, Z: Single;
  914.     StayOn: Integer; {in milisecond}
  915.     Reserved: string[28]; {for future use}
  916.     Tag: Integer;
  917.   end;
  918.   TPathArr = array{$IFNDEF VER4UP} [0..0]{$ENDIF} of TPath;
  919. {$IFNDEF VER4UP}
  920.   PPathArr = ^TPathArr;
  921. {$ENDIF}
  922.   TBlit = class;
  923.  
  924.   TOnRender = procedure(Sender: TBlit) of object;
  925.  
  926.   TBlurImageArr = array[0..7] of TBlurImageProp;
  927.   TBlit = class(TPersistent)
  928.   private
  929.     FPathArr: {$IFNDEF VER4UP}PPathArr{$ELSE}TPathArr{$ENDIF};
  930. {$IFNDEF VER4UP}
  931.     FPathLen: Integer;
  932. {$ENDIF}
  933.     FParent: TBlit;
  934.     FBlitRec: TBlitRec;
  935.     FBlurImageArr: TBlurImageArr;
  936.     FActive: Boolean;
  937.     //--
  938.     FImage: TPictureCollectionItem;
  939.     FOnMove: TBlitMoveEvent;
  940.     FOnDraw: TNotifyEvent;
  941.     FOnCollision: TNotifyEvent;
  942.     FOnGetImage: TNotifyEvent;
  943.     FEngine: TCustomDXDraw;
  944.     FMovingRepeatly: Boolean;
  945.     FBustrofedon: Boolean;
  946.     FOnRender: TOnRender;
  947.     function GetWorldX: Double;
  948.     function GetWorldY: Double;
  949.     function GetDrawImageIndex: Integer;
  950.     function GetAlpha: Byte;
  951.     function GetAmpLength: Integer;
  952.     function GetAmplitude: Integer;
  953.     function GetAngle: Single;
  954.     function GetAnimCount: Integer;
  955.     function GetAnimLooped: Boolean;
  956.     function GetAnimPos: Double;
  957.     function GetAnimSpeed: Double;
  958.     function GetAnimStart: Integer;
  959.     function GetBlendMode: TRenderType;
  960.     function GetBlurImage: Boolean;
  961.     function GetCenterX: Double;
  962.     function GetCenterY: Double;
  963.     function GetCollisioned: Boolean;
  964.     function GetEnergy: Single;
  965.     function GetFlip: Boolean;
  966.     function GetGravityX: Single;
  967.     function GetGravityY: Single;
  968.     function GetHeight: Integer;
  969.     function GetMirror: Boolean;
  970.     function GetMoved: Boolean;
  971.     function GetPhase: Integer;
  972.     function GetScale: Double;
  973.     function GetSpeedX: Single;
  974.     function GetSpeedY: Single;
  975.     function GetVisible: Boolean;
  976.     function GetWaveType: TWaveType;
  977.     function GetWidth: Integer;
  978.     function GetX: Double;
  979.     function GetY: Double;
  980.     function GetZ: Integer;
  981.     procedure SetAlpha(const Value: Byte);
  982.     procedure SetAmpLength(const Value: Integer);
  983.     procedure SetAmplitude(const Value: Integer);
  984.     procedure SetAngle(const Value: Single);
  985.     procedure SetAnimCount(const Value: Integer);
  986.     procedure SetAnimLooped(const Value: Boolean);
  987.     procedure SetAnimPos(const Value: Double);
  988.     procedure SetAnimSpeed(const Value: Double);
  989.     procedure SetAnimStart(const Value: Integer);
  990.     procedure SetBlendMode(const Value: TRenderType);
  991.     procedure SetBlurImage(const Value: Boolean);
  992.     procedure SetCenterX(const Value: Double);
  993.     procedure SetCenterY(const Value: Double);
  994.     procedure SetCollisioned(const Value: Boolean);
  995.     procedure SetEnergy(const Value: Single);
  996.     procedure SetFlip(const Value: Boolean);
  997.     procedure SetGravityX(const Value: Single);
  998.     procedure SetGravityY(const Value: Single);
  999.     procedure SetHeight(const Value: Integer);
  1000.     procedure SetMirror(const Value: Boolean);
  1001.     procedure SetMoved(const Value: Boolean);
  1002.     procedure SetPhase(const Value: Integer);
  1003.     procedure SetScale(const Value: Double);
  1004.     procedure SetSpeedX(const Value: Single);
  1005.     procedure SetSpeedY(const Value: Single);
  1006.     procedure SetVisible(const Value: Boolean);
  1007.     procedure SetWaveType(const Value: TWaveType);
  1008.     procedure SetWidth(const Value: Integer);
  1009.     procedure SetX(const Value: Double);
  1010.     procedure SetY(const Value: Double);
  1011.     procedure SetZ(const Value: Integer);
  1012.     function StoreAngle: Boolean;
  1013.     function StoreAnimPos: Boolean;
  1014.     function StoreAnimSpeed: Boolean;
  1015.     function StoreCenterX: Boolean;
  1016.     function StoreCenterY: Boolean;
  1017.     function StoreEnergy: Boolean;
  1018.     function StoreGravityX: Boolean;
  1019.     function StoreGravityY: Boolean;
  1020.     function StoreScale: Boolean;
  1021.     function StoreSpeedX: Boolean;
  1022.     function StoreSpeedY: Boolean;
  1023.     function GetBoundsRect: TRect;
  1024.     function GetClientRect: TRect;
  1025.     function GetPath(index: Integer): TPath;
  1026.     procedure SetPath(index: Integer; const Value: TPath);
  1027.     procedure ReadPaths(Stream: TStream);
  1028.     procedure WritePaths(Stream: TStream);
  1029.     function GetMovingRepeatly: Boolean;
  1030.     procedure SetMovingRepeatly(const Value: Boolean);
  1031.     function GetBustrofedon: Boolean;
  1032.     procedure SetBustrofedon(const Value: Boolean);
  1033.     function GetTextureFilter: TD2DTextureFilter;
  1034.     procedure SetTextureFilter(const Value: TD2DTextureFilter);
  1035.   protected
  1036.     procedure DoDraw; virtual;
  1037.     procedure DoMove(LagCount: Integer);
  1038.     function DoCollision: TBlit; virtual;
  1039.     procedure DoGetImage; virtual;
  1040.     procedure DefineProperties(Filer: TFiler); override;
  1041.   public
  1042.     FCurrentPosition, FCurrentTime: Integer;
  1043.     FCurrentDirection: Boolean;
  1044.     constructor Create(AParent: TObject); virtual;
  1045.     destructor Destroy; override;
  1046.     procedure Assign(Source: TPersistent); override;
  1047.     property Engine: TCustomDXDraw read FEngine write FEngine;
  1048.     property Parent: TBlit read FParent;
  1049.     property WorldX: Double read GetWorldX;
  1050.     property WorldY: Double read GetWorldY;
  1051.     procedure ReAnimate(MoveCount: Integer); virtual;
  1052.     property Image: TPictureCollectionItem read FImage write FImage;
  1053.     property BoundsRect: TRect read GetBoundsRect;
  1054.     property ClientRect: TRect read GetClientRect;
  1055.     procedure SetPathLen(Len: Integer);
  1056.     function IsPathEmpty: Boolean;
  1057.     function GetPathCount: Integer;
  1058.     function GetBlitAt(X, Y: Integer): TBlit;
  1059.     property Path[index: Integer]: TPath read GetPath write SetPath; default;
  1060.   published
  1061.     property Active: Boolean read FActive write FActive default False;
  1062.     //--
  1063.     property Collisioned: Boolean read GetCollisioned write SetCollisioned default True;
  1064.     property Moved: Boolean read GetMoved write SetMoved default True;
  1065.     property Visible: Boolean read GetVisible write SetVisible default True;
  1066.     property X: Double read GetX write SetX;
  1067.     property Y: Double read GetY write SetY;
  1068.     property Z: Integer read GetZ write SetZ;
  1069.     property Width: Integer read GetWidth write SetWidth;
  1070.     property Height: Integer read GetHeight write SetHeight;
  1071.     property MovingRepeatly: Boolean read GetMovingRepeatly write SetMovingRepeatly default True;
  1072.     property Bustrofedon: Boolean read GetBustrofedon write SetBustrofedon default False;
  1073.     //--
  1074.     property AnimCount: Integer read GetAnimCount write SetAnimCount default 0;
  1075.     property AnimLooped: Boolean read GetAnimLooped write SetAnimLooped default False;
  1076.     property AnimPos: Double read GetAnimPos write SetAnimPos stored StoreAnimPos;
  1077.     property AnimSpeed: Double read GetAnimSpeed write SetAnimSpeed stored StoreAnimSpeed;
  1078.     property AnimStart: Integer read GetAnimStart write SetAnimStart default 0;
  1079.     property Angle: Single read GetAngle write SetAngle stored StoreAngle;
  1080.     property Alpha: Byte read GetAlpha write SetAlpha default $FF;
  1081.     property CenterX: Double read GetCenterX write SetCenterX stored StoreCenterX;
  1082.     property CenterY: Double read GetCenterY write SetCenterY stored StoreCenterY;
  1083.     property Scale: Double read GetScale write SetScale stored StoreScale;
  1084.     property BlendMode: TRenderType read GetBlendMode write SetBlendMode default rtDraw;
  1085.     property Amplitude: Integer read GetAmplitude write SetAmplitude default 0;
  1086.     property AmpLength: Integer read GetAmpLength write SetAmpLength default 0;
  1087.     property Phase: Integer read GetPhase write SetPhase default 0;
  1088.     property WaveType: TWaveType read GetWaveType write SetWaveType default wtWaveNone;
  1089.     property SpeedX: Single read GetSpeedX write SetSpeedX stored StoreSpeedX;
  1090.     property SpeedY: Single read GetSpeedY write SetSpeedY stored StoreSpeedY;
  1091.     property GravityX: Single read GetGravityX write SetGravityX stored StoreGravityX;
  1092.     property GravityY: Single read GetGravityY write SetGravityY stored StoreGravityY;
  1093.     property Energy: Single read GetEnergy write SetEnergy stored StoreEnergy;
  1094.     property BlurImage: Boolean read GetBlurImage write SetBlurImage default False;
  1095.     property Mirror: Boolean read GetMirror write SetMirror default False;
  1096.     property Flip: Boolean read GetFlip write SetFlip default False;
  1097.     property TextureFilter: TD2DTextureFilter read GetTextureFilter write SetTextureFilter default D2D_POINT;
  1098.  
  1099.     property OnGetImage: TNotifyEvent read FOnGetImage write FOnGetImage;
  1100.     property OnMove: TBlitMoveEvent read FOnMove write FOnMove;
  1101.     property OnDraw: TNotifyEvent read FOnDraw write FOnDraw;
  1102.     property OnCollision: TNotifyEvent read FOnCollision write FOnCollision;
  1103.     property OnRender: TOnRender read FOnRender write FOnRender;
  1104.   end;
  1105.  
  1106.   TTrace = class(THashCollectionItem)
  1107.   private
  1108.     FActualized: Boolean;
  1109.     FTag: Integer;
  1110.     FBlit: TBlit;
  1111.     function GetTraces: TTraces;
  1112.     function GetOnCollision: TNotifyEvent;
  1113.     function GetOnDraw: TNotifyEvent;
  1114.     function GetOnGetImage: TNotifyEvent;
  1115.     function GetOnMove: TBlitMoveEvent;
  1116.     procedure SetOnCollision(const Value: TNotifyEvent);
  1117.     procedure SetOnDraw(const Value: TNotifyEvent);
  1118.     procedure SetOnGetImage(const Value: TNotifyEvent);
  1119.     procedure SetOnMove(const Value: TBlitMoveEvent);
  1120.     function GetActive: Boolean;
  1121.     procedure SetActive(const Value: Boolean);
  1122.     function GetOnRender: TOnRender;
  1123.     procedure SetOnRender(const Value: TOnRender);
  1124.   protected
  1125.     function GetDisplayName: string; override;
  1126.     procedure SetDisplayName(const Value: string); override;
  1127.   public
  1128.     constructor Create(Collection: TCollection); override;
  1129.     destructor Destroy; override;
  1130.     procedure Render(const LagCount: Integer);
  1131.     function IsActualized: Boolean;
  1132.     procedure Assign(Source: TPersistent); override;
  1133.     property Traces: TTraces read GetTraces;
  1134.     function Clone(NewName: string; OffsetX: Integer{$IFDEF VER4UP} = 0{$ENDIF}; OffsetY: Integer{$IFDEF VER4UP} = 0{$ENDIF}; Angle: Single{$IFDEF VER4UP} = 0{$ENDIF}): TTrace;
  1135.   published
  1136.     property Active: Boolean read GetActive write SetActive;
  1137.     property Tag: Integer read FTag write FTag;
  1138.     property Blit: TBlit read FBlit write FBlit;
  1139.     {events}
  1140.     property OnGetImage: TNotifyEvent read GetOnGetImage write SetOnGetImage;
  1141.     property OnMove: TBlitMoveEvent read GetOnMove write SetOnMove;
  1142.     property OnDraw: TNotifyEvent read GetOnDraw write SetOnDraw;
  1143.     property OnCollision: TNotifyEvent read GetOnCollision write SetOnCollision;
  1144.     property OnRender: TOnRender read GetOnRender write SetOnRender;
  1145.   end;
  1146.  
  1147.   TTraces = class(THashCollection)
  1148.   private
  1149.     FOwner: TPersistent;
  1150.     function GetItem(Index: Integer): TTrace;
  1151.     procedure SetItem(Index: Integer; Value: TTrace);
  1152.   protected
  1153.     function GetOwner: TPersistent; override;
  1154.   public
  1155.     constructor Create(AOwner: TComponent);
  1156.     function Add: TTrace;
  1157.     function Find(const Name: string): TTrace;
  1158. {$IFDEF VER4UP}
  1159.     function Insert(Index: Integer): TTrace;
  1160. {$ENDIF}
  1161.     procedure Update(Item: TCollectionItem); override;
  1162.     property Items[Index: Integer]: TTrace read GetItem write SetItem;
  1163.     destructor Destroy; override;
  1164.   end;
  1165.  
  1166. {$IFDEF DX3D_deprecated}
  1167.  
  1168.   {  TCustomDX3D  }
  1169.  
  1170.   TDX3DOption = (toRetainedMode, toSystemMemory, toHardware, toSelectDriver, toZBuffer);
  1171.  
  1172.   TDX3DOptions = set of TDX3DOption;
  1173.  
  1174.   TCustomDX3D = class(TComponent)
  1175.   private
  1176.     FAutoSize: Boolean;
  1177. {$IFDEF D3DRM}FCamera: IDirect3DRMFrame; {$ENDIF}
  1178.     {$IFDEF D3D_deprecated}
  1179.     FD3D: IDirect3D;
  1180.     FD3D2: IDirect3D2;
  1181.     FD3D3: IDirect3D3;
  1182.     {$ENDIF}
  1183.     FD3D7: IDirect3D7;
  1184.     {$IFDEF D3D_deprecated}
  1185.     FD3DDevice: IDirect3DDevice;
  1186.     FD3DDevice2: IDirect3DDevice2;
  1187.     FD3DDevice3: IDirect3DDevice3;
  1188.     {$ENDIF}
  1189.     FD3DDevice7: IDirect3DDevice7;
  1190. {$IFDEF D3DRM}
  1191.     FD3DRM: IDirect3DRM;
  1192.     FD3DRM2: IDirect3DRM2;
  1193.     FD3DRM3: IDirect3DRM3;
  1194.     FD3DRMDevice: IDirect3DRMDevice;
  1195.     FD3DRMDevice2: IDirect3DRMDevice2;
  1196.     FD3DRMDevice3: IDirect3DRMDevice3;
  1197. {$ENDIF}
  1198.     FDXDraw: TCustomDXDraw;
  1199.     FInitFlag: Boolean;
  1200.     FInitialized: Boolean;
  1201.     FNowOptions: TDX3DOptions;
  1202.     FOnFinalize: TNotifyEvent;
  1203.     FOnInitialize: TNotifyEvent;
  1204.     FOptions: TDX3DOptions;
  1205. {$IFDEF D3DRM}FScene: IDirect3DRMFrame; {$ENDIF}
  1206.     FSurface: TDirectDrawSurface;
  1207.     FSurfaceHeight: Integer;
  1208.     FSurfaceWidth: Integer;
  1209. {$IFDEF D3DRM}FViewport: IDirect3DRMViewport; {$ENDIF}
  1210.     FZBuffer: TDirectDrawSurface;
  1211.     procedure Finalize;
  1212.     procedure Initialize;
  1213.     procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
  1214.     function GetCanDraw: Boolean;
  1215.     function GetSurfaceHeight: Integer;
  1216.     function GetSurfaceWidth: Integer;
  1217.     procedure SetAutoSize(Value: Boolean);
  1218.     procedure SetDXDraw(Value: TCustomDXDraw);
  1219.     procedure SetOptions(Value: TDX3DOptions); virtual; {TridenT}
  1220.     procedure SetSurfaceHeight(Value: Integer);
  1221.     procedure SetSurfaceWidth(Value: Integer);
  1222.   protected
  1223.     procedure DoFinalize; virtual;
  1224.     procedure DoInitialize; virtual;
  1225.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  1226.   public
  1227.     constructor Create(AOwner: TComponent); override;
  1228.     destructor Destroy; override;
  1229.     procedure Render;
  1230.     procedure SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
  1231.     property AutoSize: Boolean read FAutoSize write SetAutoSize;
  1232. {$IFDEF D3DRM}property Camera: IDirect3DRMFrame read FCamera; {$ENDIF}
  1233.     property CanDraw: Boolean read GetCanDraw;
  1234.     property D3D: IDirect3D read FD3D;
  1235.     property D3D2: IDirect3D2 read FD3D2;
  1236.     property D3D3: IDirect3D3 read FD3D3;
  1237.     property D3D7: IDirect3D7 read FD3D7;
  1238.     {$IFDEF D3D_deprecated}
  1239.     property D3DDevice: IDirect3DDevice read FD3DDevice;
  1240.     property D3DDevice2: IDirect3DDevice2 read FD3DDevice2;
  1241.     property D3DDevice3: IDirect3DDevice3 read FD3DDevice3;
  1242.     {$ENDIF}
  1243.     property D3DDevice7: IDirect3DDevice7 read FD3DDevice7;
  1244. {$IFDEF D3DRM}
  1245.     property D3DRM: IDirect3DRM read FD3DRM;
  1246.     property D3DRM2: IDirect3DRM2 read FD3DRM2;
  1247.     property D3DRM3: IDirect3DRM3 read FD3DRM3;
  1248.     property D3DRMDevice: IDirect3DRMDevice read FD3DRMDevice;
  1249.     property D3DRMDevice2: IDirect3DRMDevice2 read FD3DRMDevice2;
  1250.     property D3DRMDevice3: IDirect3DRMDevice3 read FD3DRMDevice3;
  1251. {$ENDIF}
  1252.     property DXDraw: TCustomDXDraw read FDXDraw write SetDXDraw;
  1253.     property Initialized: Boolean read FInitialized;
  1254.     property NowOptions: TDX3DOptions read FNowOptions;
  1255.     property OnFinalize: TNotifyEvent read FOnFinalize write FOnFinalize;
  1256.     property OnInitialize: TNotifyEvent read FOnInitialize write FOnInitialize;
  1257.     property Options: TDX3DOptions read FOptions write SetOptions;
  1258. {$IFDEF D3DRM}property Scene: IDirect3DRMFrame read FScene; {$ENDIF}
  1259.     property Surface: TDirectDrawSurface read FSurface;
  1260.     property SurfaceHeight: Integer read GetSurfaceHeight write SetSurfaceHeight default 480;
  1261.     property SurfaceWidth: Integer read GetSurfaceWidth write SetSurfaceWidth default 640;
  1262. {$IFDEF D3DRM}property Viewport: IDirect3DRMViewport read FViewport; {$ENDIF}
  1263.     property ZBuffer: TDirectDrawSurface read FZBuffer;
  1264.   end;
  1265.  
  1266.   {  TDX3D  }
  1267.  
  1268.   TDX3D = class(TCustomDX3D)
  1269.   published
  1270.     property AutoSize;
  1271.     property DXDraw;
  1272.     property Options;
  1273.     property SurfaceHeight;
  1274.     property SurfaceWidth;
  1275.     property OnFinalize;
  1276.     property OnInitialize;
  1277.   end;
  1278. {$ENDIF}
  1279.  
  1280.   {  EDirect3DTextureError  }
  1281.  
  1282.   EDirect3DTextureError = class(Exception);
  1283.  
  1284.   {  TDirect3DTexture  }
  1285.  
  1286.   TDirect3DTexture = class
  1287.   private
  1288.     FBitCount: DWORD;
  1289.     FDXDraw: TComponent;
  1290.     FEnumFormatFlag: Boolean;
  1291.     FFormat: TDDSurfaceDesc;
  1292.     FGraphic: TGraphic;
  1293.     FHandle: TD3DTextureHandle;
  1294.     FPaletteEntries: TPaletteEntries;
  1295.     FSurface: TDirectDrawSurface;
  1296.     FTexture: {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF};
  1297.     FTransparentColor: TColor;
  1298.     procedure Clear;
  1299.     procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
  1300.     function GetHandle: TD3DTextureHandle;
  1301.     function GetSurface: TDirectDrawSurface;
  1302.     function GetTexture: {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF};
  1303.     procedure SetTransparentColor(Value: TColor);
  1304.   public
  1305.     constructor Create(Graphic: TGraphic; DXDraw: TComponent);
  1306.     destructor Destroy; override;
  1307.     procedure Restore;
  1308.     property Handle: TD3DTextureHandle read GetHandle;
  1309.     property Surface: TDirectDrawSurface read GetSurface;
  1310.     property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
  1311.     property Texture: {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF} read GetTexture;
  1312.   end;
  1313.  
  1314.   { EDXTextureImageError }
  1315.  
  1316.   EDXTextureImageError = class(Exception);
  1317.  
  1318.   { channel structure }
  1319.  
  1320.   TDXTextureImageChannel = record
  1321.     Mask: DWORD;
  1322.     BitCount: Integer;
  1323.  
  1324.     {  Internal use  }
  1325.     _Mask2: DWORD;
  1326.     _rshift: Integer;
  1327.     _lshift: Integer;
  1328.     _BitCount2: Integer;
  1329.   end;
  1330.  
  1331.   TDXTextureImage_PaletteEntries = array[0..255] of TPaletteEntry;
  1332.  
  1333.   TDXTextureImageType = (
  1334.     DXTextureImageType_PaletteIndexedColor,
  1335.     DXTextureImageType_RGBColor
  1336.     );
  1337.  
  1338.   TDXTextureImageFileCompressType = (
  1339.     DXTextureImageFileCompressType_None,
  1340.     DXTextureImageFileCompressType_ZLIB
  1341.     );
  1342.  
  1343.   {forward}
  1344.  
  1345.   TDXTextureImage = class;
  1346.  
  1347.   { TDXTextureImageLoadFunc }
  1348.  
  1349.   TDXTextureImageLoadFunc = procedure(Stream: TStream; Image: TDXTextureImage);
  1350.  
  1351.   { TDXTextureImageProgressEvent }
  1352.  
  1353.   TDXTextureImageProgressEvent = procedure(Sender: TObject; Progress, ProgressCount: Integer) of object;
  1354.  
  1355.   { TDXTextureImage }
  1356.  
  1357.   TDXTextureImage = class
  1358.   private
  1359.     FOwner: TDXTextureImage;
  1360.     FFileCompressType: TDXTextureImageFileCompressType;
  1361.     FOnSaveProgress: TDXTextureImageProgressEvent;
  1362.     FSubImage: TList;
  1363.     FImageType: TDXTextureImageType;
  1364.     FWidth: Integer;
  1365.     FHeight: Integer;
  1366.     FPBits: Pointer;
  1367.     FBitCount: Integer;
  1368.     FPackedPixelOrder: Boolean;
  1369.     FWidthBytes: Integer;
  1370.     FNextLine: Integer;
  1371.     FSize: Integer;
  1372.     FTopPBits: Pointer;
  1373.     FTransparent: Boolean;
  1374.     FTransparentColor: DWORD;
  1375.     FImageGroupType: DWORD;
  1376.     FImageID: DWORD;
  1377.     FImageName: string;
  1378.     FAutoFreeImage: Boolean;
  1379.     procedure ClearImage;
  1380.     function GetPixel(x, y: Integer): DWORD;
  1381.     procedure SetPixel(x, y: Integer; c: DWORD);
  1382.     function GetScanLine(y: Integer): Pointer;
  1383.     function GetSubGroupImageCount(GroupTypeID: DWORD): Integer;
  1384.     function GetSubGroupImage(GroupTypeID: DWORD; Index: Integer): TDXTextureImage;
  1385.     function GetSubImageCount: Integer;
  1386.     function GetSubImage(Index: Integer): TDXTextureImage;
  1387.   protected
  1388.     procedure DoSaveProgress(Progress, ProgressCount: Integer); virtual;
  1389.   public
  1390.     idx_index: TDXTextureImageChannel;
  1391.     idx_alpha: TDXTextureImageChannel;
  1392.     idx_palette: TDXTextureImage_PaletteEntries;
  1393.     rgb_red: TDXTextureImageChannel;
  1394.     rgb_green: TDXTextureImageChannel;
  1395.     rgb_blue: TDXTextureImageChannel;
  1396.     rgb_alpha: TDXTextureImageChannel;
  1397.     constructor Create;
  1398.     constructor CreateSub(AOwner: TDXTextureImage);
  1399.     destructor Destroy; override;
  1400.     procedure Assign(Source: TDXTextureImage);
  1401.     procedure Clear;
  1402.     procedure SetImage(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes, NextLine: Integer;
  1403.       PBits, TopPBits: Pointer; Size: Integer; AutoFree: Boolean);
  1404.     procedure SetSize(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes: Integer);
  1405.     procedure LoadFromFile(const FileName: string);
  1406.     procedure LoadFromStream(Stream: TStream);
  1407.     procedure SaveToFile(const FileName: string);
  1408.     procedure SaveToStream(Stream: TStream);
  1409.     function EncodeColor(R, G, B, A: Byte): DWORD;
  1410.     function PaletteIndex(R, G, B: Byte): DWORD;
  1411.     class procedure RegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
  1412.     class procedure UnRegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
  1413.     property BitCount: Integer read FBitCount;
  1414.     property PackedPixelOrder: Boolean read FPackedPixelOrder write FPackedPixelOrder;
  1415.     property Height: Integer read FHeight;
  1416.     property ImageType: TDXTextureImageType read FImageType;
  1417.     property ImageGroupType: DWORD read FImageGroupType write FImageGroupType;
  1418.     property ImageID: DWORD read FImageID write FImageID;
  1419.     property ImageName: string read FImageName write FImageName;
  1420.     property NextLine: Integer read FNextLine;
  1421.     property PBits: Pointer read FPBits;
  1422.     property Pixels[x, y: Integer]: DWORD read GetPixel write SetPixel;
  1423.     property ScanLine[y: Integer]: Pointer read GetScanLine;
  1424.     property Size: Integer read FSize;
  1425.     property SubGroupImageCount[GroupTypeID: DWORD]: Integer read GetSubGroupImageCount;
  1426.     property SubGroupImages[GroupTypeID: DWORD; Index: Integer]: TDXTextureImage read GetSubGroupImage;
  1427.     property SubImageCount: Integer read GetSubImageCount;
  1428.     property SubImages[Index: Integer]: TDXTextureImage read GetSubImage;
  1429.     property TopPBits: Pointer read FTopPBits;
  1430.     property Transparent: Boolean read FTransparent write FTransparent;
  1431.     property TransparentColor: DWORD read FTransparentColor write FTransparentColor;
  1432.     property Width: Integer read FWidth;
  1433.     property WidthBytes: Integer read FWidthBytes;
  1434.     property FileCompressType: TDXTextureImageFileCompressType read FFileCompressType write FFileCompressType;
  1435.     property OnSaveProgress: TDXTextureImageProgressEvent read FOnSaveProgress write FOnSaveProgress;
  1436.   end;
  1437.  
  1438.   {  TDirect3DTexture2  }
  1439.  
  1440.   TDirect3DTexture2 = class
  1441.   private
  1442.     FDXDraw: TCustomDXDraw;
  1443.     FSrcImage: TObject;
  1444.     FImage: TDXTextureImage;
  1445.     FImage2: TDXTextureImage;
  1446.     FAutoFreeGraphic: Boolean;
  1447.     FSurface: TDirectDrawSurface;
  1448.     FTextureFormat: TDDSurfaceDesc2;
  1449.     FMipmap: Boolean;
  1450.     FTransparent: Boolean;
  1451.     FTransparentColor: TColorRef;
  1452.     FUseMipmap: Boolean;
  1453.     FUseColorKey: Boolean;
  1454.     FOnRestoreSurface: TNotifyEvent;
  1455.     FNeedLoadTexture: Boolean;
  1456.     FEnumTextureFormatFlag: Boolean;
  1457.     FD3DDevDesc: TD3DDeviceDesc;
  1458.     procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
  1459.     procedure SetDXDraw(ADXDraw: TCustomDXDraw);
  1460.     procedure LoadSubTexture(Dest: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF}; SrcImage: TDXTextureImage);
  1461.     procedure SetColorKey;
  1462.     procedure SetDIB(DIB: TDIB);
  1463.     function GetIsMipmap: Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  1464.     function GetSurface: TDirectDrawSurface; {$IFDEF VER9UP}inline;{$ENDIF}
  1465.     function GetTransparent: Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  1466.     procedure SetTransparent(Value: Boolean); {$IFDEF VER9UP}inline;{$ENDIF}
  1467.     procedure SetTransparentColor(Value: TColorRef); {$IFDEF VER9UP}inline;{$ENDIF}
  1468.     function GetHeight: Integer;
  1469.     function GetWidth: Integer;
  1470.   protected
  1471.     procedure DoRestoreSurface; virtual;
  1472.   public
  1473.     constructor Create(ADXDraw: TCustomDXDraw; Graphic: TObject; AutoFreeGraphic: Boolean{$IFDEF VER4UP} = False{$ENDIF});
  1474.     constructor CreateFromFile(ADXDraw: TCustomDXDraw; const FileName: string);
  1475.     constructor CreateVideoTexture(ADXDraw: TCustomDXDraw);
  1476.     destructor Destroy; override;
  1477.     procedure Finalize;
  1478.     procedure Load;
  1479.     procedure Initialize;
  1480.     property Height: Integer read GetHeight;
  1481.     property Width: Integer read GetWidth;
  1482.     property IsMipmap: Boolean read GetIsMipmap;
  1483.     property Surface: TDirectDrawSurface read GetSurface;
  1484.     property TextureFormat: TDDSurfaceDesc2 read FTextureFormat write FTextureFormat;
  1485.     property Transparent: Boolean read GetTransparent write SetTransparent;
  1486.     property TransparentColor: TColorRef read FTransparentColor write SetTransparentColor;
  1487.     property OnRestoreSurface: TNotifyEvent read FOnRestoreSurface write FOnRestoreSurface;
  1488.   end;
  1489.  
  1490.   {  EDXTBaseError  }
  1491.  
  1492.   EDXTBaseError = class(Exception);
  1493.  
  1494.   {  parameters for DXT generator  }
  1495.  
  1496.   TDXTImageChannel = (rgbNone, rgbRed, rgbGreen, rgbBlue, rgbAlpha, yuvY);
  1497.   TDXTImageChannels = set of TDXTImageChannel;
  1498.  
  1499.   TDXTImageChannelInfo = packed record
  1500.     Image: TDXTextureImage;
  1501.     BitCount: Integer;
  1502.   end;
  1503.  
  1504.   TDXTImageFormat = packed record
  1505.     ImageType: TDXTextureImageType;
  1506.     Width: Integer;
  1507.     Height: Integer;
  1508.     Bits: Pointer;
  1509.     BitCount: Integer;
  1510.     WidthBytes: Integer;
  1511.     {transparent}
  1512.     Transparent: Boolean;
  1513.     TransparentColor: TColorRef;
  1514.     {texture channels}
  1515.     idx_index: TDXTextureImageChannel;
  1516.     idx_alpha: TDXTextureImageChannel;
  1517.     idx_palette: TDXTextureImage_PaletteEntries;
  1518.     rgb_red: TDXTextureImageChannel;
  1519.     rgb_green: TDXTextureImageChannel;
  1520.     rgb_blue: TDXTextureImageChannel;
  1521.     rgb_alpha: TDXTextureImageChannel;
  1522.     {compress level}
  1523.     Compress: TDXTextureImageFileCompressType;
  1524.     MipmapCount: Integer;
  1525.     Name: string;
  1526.   end;
  1527.  
  1528.   {  TDXTBase  }
  1529.  
  1530.   {Note JB.}
  1531.   {Class for DXT generation files, primary use for load bitmap 32 with alphachannel}
  1532.   {recoded and class created by JB.}
  1533.   TDXTBase = class
  1534.   private
  1535.     FHasChannels: TDXTImageChannels;
  1536.     FHasChannelImages: array[TDXTImageChannel] of TDXTImageChannelInfo;
  1537.     FChannelChangeTable: array[TDXTImageChannel] of TDXTImageChannel;
  1538.     FHasImageList: TList;
  1539.     FParamsFormat: TDXTImageFormat;
  1540.     FStrImageFileName: string;
  1541.     FDIB: TDIB;
  1542.     function GetCompression: TDXTextureImageFileCompressType;
  1543.     function GetHeight: Integer;
  1544.     function GetMipmap: Integer;
  1545.     function GetTransparentColor: TColorRef;
  1546.     function GetWidth: Integer;
  1547.     procedure SetCompression(const Value: TDXTextureImageFileCompressType);
  1548.     procedure SetHeight(const Value: Integer);
  1549.     procedure SetMipmap(const Value: Integer);
  1550.     procedure SetTransparentColor(const Value: TColorRef);
  1551.     procedure SetWidth(const Value: Integer);
  1552.     procedure SetTransparentColorIndexed(const Value: TColorRef);
  1553.     function GetTexture: TDXTextureImage;
  1554.     procedure Resize(Image: TDXTextureImage; NewWidth, NewHeight: Integer;
  1555.       FilterTypeResample: TFilterTypeResample);
  1556.     procedure EvaluateChannels(const CheckChannelUsed: TDXTImageChannels;
  1557.       const CheckChannelChanged, CheckBitCountForChannel: string);
  1558.     function GetPicture: TDXTextureImage;
  1559.   protected
  1560.     procedure CalcOutputBitFormat;
  1561.     procedure BuildImage(Image: TDXTextureImage);
  1562.   public
  1563.     constructor Create;
  1564.     destructor Destroy; override;
  1565.     procedure SetChannelR(T: TDIB);
  1566.     procedure SetChannelG(T: TDIB);
  1567.     procedure SetChannelB(T: TDIB);
  1568.     procedure SetChannelA(T: TDIB);
  1569.     procedure LoadChannelAFromFile(const FileName: string);
  1570.     procedure SetChannelY(T: TDIB);
  1571.     procedure SetChannelRGB(T: TDIB);
  1572.     procedure LoadChannelRGBFromFile(const FileName: string);
  1573.     procedure SetChannelRGBA(T: TDIB);
  1574.     procedure LoadChannelRGBAFromFile(const FileName: string);
  1575.     procedure SaveToFile(iFilename: string {$IFDEF VER4UP} = ''{$ENDIF});
  1576.     function LoadFromFile(iFilename: string): Boolean;
  1577.     property TransparentColor: TColorRef read GetTransparentColor write SetTransparentColor;
  1578.     property TransparentColorIndexed: TColorRef read GetTransparentColor write SetTransparentColorIndexed;
  1579.     property Width: Integer read GetWidth write SetWidth;
  1580.     property Height: Integer read GetHeight write SetHeight;
  1581.     property Compression: TDXTextureImageFileCompressType read GetCompression write SetCompression;
  1582.     property Mipmap: Integer read GetMipmap write SetMipmap;
  1583.     property Texture: TDXTextureImage read GetTexture;
  1584.   end;
  1585.  
  1586. {$IFDEF D3DRM}
  1587.   {  EDirect3DRMUserVisualError  }
  1588.  
  1589.   EDirect3DRMUserVisualError = class(Exception);
  1590.  
  1591.   {  TDirect3DRMUserVisual  }
  1592.  
  1593.   TDirect3DRMUserVisual = class
  1594.   private
  1595.     FUserVisual: IDirect3DRMUserVisual;
  1596.   protected
  1597.     function DoRender(Reason: TD3DRMUserVisualReason;
  1598.       D3DRMDev: IDirect3DRMDevice; D3DRMView: IDirect3DRMViewport): HRESULT; virtual;
  1599.   public
  1600.     constructor Create(D3DRM: IDirect3DRM);
  1601.     destructor Destroy; override;
  1602.     property UserVisual: IDirect3DRMUserVisual read FUserVisual;
  1603.   end;
  1604. {$ENDIF}
  1605.  
  1606.   {  EPictureCollectionError  }
  1607.  
  1608.   EPictureCollectionError = class(Exception);
  1609.  
  1610.   {  TPictureCollectionItem  }
  1611.  
  1612.   TPictureCollection = class;
  1613.  
  1614.   TPictureCollectionItem = class(THashCollectionItem)
  1615.   private
  1616.     FPicture: TPicture;
  1617.     FInitialized: Boolean;
  1618.     FPatternHeight: Integer;
  1619.     FPatternWidth: Integer;
  1620.     FPatterns: TCollection;
  1621.     FSkipHeight: Integer;
  1622.     FSkipWidth: Integer;
  1623.     FSurfaceList: TList;
  1624.     FSystemMemory: Boolean;
  1625.     FTransparent: Boolean;
  1626.     FTransparentColor: TColor;
  1627.     procedure ClearSurface;
  1628.     procedure Finalize;
  1629.     procedure Initialize;
  1630.     function GetHeight: Integer;
  1631.     function GetPictureCollection: TPictureCollection;
  1632.     function GetPatternRect(Index: Integer): TRect;
  1633.     function GetPatternSurface(Index: Integer): TDirectDrawSurface;
  1634.     function GetPatternCount: Integer; {$IFDEF VER9UP}inline;{$ENDIF}
  1635.     function GetWidth: Integer;
  1636.     procedure SetPicture(Value: TPicture);
  1637.     procedure SetTransparentColor(Value: TColor);
  1638.   public
  1639.     constructor Create(Collection: TCollection); override;
  1640.     destructor Destroy; override;
  1641.     procedure UpdateTag;
  1642.     procedure Assign(Source: TPersistent); override;
  1643.     procedure Draw(Dest: TDirectDrawSurface; X, Y: Integer; PatternIndex: Integer);
  1644.     //  Modifier par MKost d'Uk@Team tous droit réservé.
  1645.     //  22:02 04/11/2005
  1646.     //  Ajouté :
  1647.     // Dans TPictureCollectionItem
  1648.     // procedure DrawFlipH(Dest: TDirectDrawSurface; X, Y: Integer; PatternIndex: Integer);
  1649.     //      -Effectue un flip Horizontale de l'image
  1650.     // procedure DrawFlipHV(Dest: TDirectDrawSurface; X, Y: Integer; PatternIndex: Integer);
  1651.     //      -Effectue un flip Oblique de l'image
  1652.     // procedure DrawFlipV(Dest: TDirectDrawSurface; X, Y: Integer; PatternIndex: Integer);
  1653.     //      -Effectue un flip Verticale de l'image
  1654.     procedure DrawFlipH(Dest: TDirectDrawSurface; X, Y: Integer; PatternIndex: Integer);
  1655.     procedure DrawFlipHV(Dest: TDirectDrawSurface; X, Y: Integer; PatternIndex: Integer);
  1656.     procedure DrawFlipV(Dest: TDirectDrawSurface; X, Y: Integer; PatternIndex: Integer);
  1657.     procedure StretchDraw(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer);
  1658.     procedure DrawAdd(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  1659.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1660.     procedure DrawAddCol(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  1661.       Color: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1662.     procedure DrawAlpha(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  1663.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1664.     procedure DrawAlphaCol(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  1665.       Color: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1666.     procedure DrawSub(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  1667.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1668.     procedure DrawSubCol(Dest: TDirectDrawSurface; const DestRect: TRect;
  1669.       PatternIndex, Color: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1670.     {Rotate}
  1671.     procedure DrawRotate(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1672.       CenterX, CenterY: Double; Angle: single);
  1673.     procedure DrawRotateAdd(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1674.       CenterX, CenterY: Double; Angle: single;
  1675.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1676.     procedure DrawRotateAddCol(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1677.       CenterX, CenterY: Double; Angle: single;
  1678.       Color: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1679.     procedure DrawRotateAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1680.       CenterX, CenterY: Double; Angle: single;
  1681.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1682.     procedure DrawRotateAlphaCol(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1683.       CenterX, CenterY: Double; Angle: single;
  1684.       Color: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1685.     procedure DrawRotateSub(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1686.       CenterX, CenterY: Double; Angle: single;
  1687.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1688.     procedure DrawRotateSubCol(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1689.       CenterX, CenterY: Double; Angle: single;
  1690.       Color: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1691.     {WaveX}
  1692.     procedure DrawWaveX(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1693.       amp, Len, ph: Integer);
  1694.     procedure DrawWaveXAdd(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1695.       amp, Len, ph: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1696.     procedure DrawWaveXAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  1697.       amp, Len, ph: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1698.     procedure DrawWaveXSub(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1699.       amp, Len, ph: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1700.     {WaveY}
  1701.     procedure DrawWaveY(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1702.       amp, Len, ph: Integer);
  1703.     procedure DrawWaveYAdd(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1704.       amp, Len, ph: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1705.     procedure DrawWaveYAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  1706.       amp, Len, ph: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1707.     procedure DrawWaveYSub(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
  1708.       amp, Len, ph: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1709.     {SpecialDraw}
  1710.     procedure DrawCol(Dest: TDirectDrawSurface; const DestRect, SourceRect: TRect;
  1711.       PatternIndex: Integer; Faded: Boolean; RenderType: TRenderType; Color,
  1712.       Specular: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1713.     procedure DrawRect(Dest: TDirectDrawSurface;
  1714.       const DestRect, SourceRect: TRect; PatternIndex: Integer;
  1715.       RenderType: TRenderType; Transparent: Boolean{$IFDEF VER4UP} = True{$ENDIF};
  1716.       Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
  1717.     procedure Restore;
  1718.     property Height: Integer read GetHeight;
  1719.     property Initialized: Boolean read FInitialized;
  1720.     property PictureCollection: TPictureCollection read GetPictureCollection;
  1721.     property PatternCount: Integer read GetPatternCount;
  1722.     property PatternRects[Index: Integer]: TRect read GetPatternRect;
  1723.     property PatternSurfaces[Index: Integer]: TDirectDrawSurface read GetPatternSurface;
  1724.     property Width: Integer read GetWidth;
  1725.   published
  1726.     property PatternHeight: Integer read FPatternHeight write FPatternHeight;
  1727.     property PatternWidth: Integer read FPatternWidth write FPatternWidth;
  1728.     property Picture: TPicture read FPicture write SetPicture;
  1729.     property SkipHeight: Integer read FSkipHeight write FSkipHeight default 0;
  1730.     property SkipWidth: Integer read FSkipWidth write FSkipWidth default 0;
  1731.     property SystemMemory: Boolean read FSystemMemory write FSystemMemory;
  1732.     property Transparent: Boolean read FTransparent write FTransparent;
  1733.     property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
  1734.   end;
  1735.  
  1736.   {  TPictureCollection  }
  1737.  
  1738.   TPictureCollection = class(THashCollection)
  1739.   private
  1740.     FDXDraw: TCustomDXDraw;
  1741.     FOwner: TPersistent;
  1742.     function GetItem(Index: Integer): TPictureCollectionItem;
  1743.     procedure ReadColorTable(Stream: TStream);
  1744.     procedure WriteColorTable(Stream: TStream);
  1745.     function Initialized: Boolean;
  1746.   protected
  1747.     procedure DefineProperties(Filer: TFiler); override;
  1748.     function GetOwner: TPersistent; override;
  1749.   public
  1750.     ColorTable: TRGBQuads;
  1751.     constructor Create(AOwner: TPersistent);
  1752.     destructor Destroy; override;
  1753.     function Find(const Name: string): TPictureCollectionItem;
  1754.     procedure Finalize;
  1755.     procedure Initialize(DXDraw: TCustomDXDraw);
  1756.     procedure InitializeImages(DXDraw: TCustomDXDraw; Id : Integer);
  1757.     procedure LoadFromFile(const FileName: string);
  1758.     procedure LoadFromStream(Stream: TStream);
  1759.     procedure MakeColorTable;
  1760.     procedure Restore;
  1761.     procedure SaveToFile(const FileName: string);
  1762.     procedure SaveToStream(Stream: TStream);
  1763.     property DXDraw: TCustomDXDraw read FDXDraw;
  1764.     property Items[Index: Integer]: TPictureCollectionItem read GetItem; default;
  1765.   end;
  1766.  
  1767.   {  TCustomDXImageList  }
  1768.  
  1769.   TCustomDXImageList = class(TComponent)
  1770.   private
  1771.     FDXDraw: TCustomDXDraw;
  1772.     FItems: TPictureCollection;
  1773.     procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
  1774.     procedure SetDXDraw(Value: TCustomDXDraw);
  1775.     procedure SetItems(Value: TPictureCollection);
  1776.   protected
  1777.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  1778.   public
  1779.     constructor Create(AOnwer: TComponent); override;
  1780.     destructor Destroy; override;
  1781.     property DXDraw: TCustomDXDraw read FDXDraw write SetDXDraw;
  1782.     property Items: TPictureCollection read FItems write SetItems;
  1783.   end;
  1784.  
  1785.   {  TDXImageList  }
  1786.  
  1787.   TDXImageList = class(TCustomDXImageList)
  1788.   published
  1789.     property DXDraw;
  1790.     property Items;
  1791.   end;
  1792.  
  1793.   {  EDirectDrawOverlayError  }
  1794.  
  1795.   EDirectDrawOverlayError = class(Exception);
  1796.  
  1797.   {  TDirectDrawOverlay  }
  1798.  
  1799.   TDirectDrawOverlay = class
  1800.   private
  1801.     FDDraw: TDirectDraw;
  1802.     FTargetSurface: TDirectDrawSurface;
  1803.     FDDraw2: TDirectDraw;
  1804.     FTargetSurface2: TDirectDrawSurface;
  1805.     FSurface: TDirectDrawSurface;
  1806.     FBackSurface: TDirectDrawSurface;
  1807.     FOverlayColorKey: TColor;
  1808.     FOverlayRect: TRect;
  1809.     FVisible: Boolean;
  1810.     procedure SetOverlayColorKey(Value: TColor);
  1811.     procedure SetOverlayRect(const Value: TRect);
  1812.     procedure SetVisible(Value: Boolean);
  1813.   public
  1814.     constructor Create(DDraw: TDirectDraw; TargetSurface: TDirectDrawSurface);
  1815.     constructor CreateWindowed(WindowHandle: HWND);
  1816.     destructor Destroy; override;
  1817.     procedure Finalize;
  1818.     procedure Initialize(const SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF});
  1819.     procedure Flip;
  1820.     property OverlayColorKey: TColor read FOverlayColorKey write SetOverlayColorKey;
  1821.     property OverlayRect: TRect read FOverlayRect write SetOverlayRect;
  1822.     property Surface: TDirectDrawSurface read FSurface;
  1823.     property BackSurface: TDirectDrawSurface read FBackSurface;
  1824.     property Visible: Boolean read FVisible write SetVisible;
  1825.   end;
  1826.  
  1827. {
  1828.  Modified by Michael Wilson 2/05/2001
  1829.  - re-added redundant assignment to Offset
  1830.  Modified by Marcus Knight 19/12/2000
  1831.  - replaces all referaces to 'pos' with 'AnsiPos' <- faster
  1832.  - replaces all referaces to 'uppercase' with 'Ansiuppercase' <- faster
  1833.  - Now only uppercases outside the loop
  1834.  - Fixed the non-virtual contructor
  1835.  - renamed & moved Offset to private(fOffSet), and added the property OffSet
  1836.  - Commented out the redundant assignment to Offset<- not needed, as Offset is now a readonly property
  1837.  - Added the Notification method to catch when the image list is destroyed
  1838.  - removed DXclasses from used list
  1839. }
  1840.  
  1841.   TDXFont = class(TComponent)
  1842.   private
  1843.     FDXImageList: TDXImageList;
  1844.     FFont: string;
  1845.     FFontIndex: Integer;
  1846.     FOffset: Integer; // renamed from Offset -> fOffset
  1847.     procedure SetFont(const Value: string);
  1848.     procedure SetFontIndex(const Value: Integer);
  1849.   protected
  1850.     procedure Notification(AComponent: TComponent; Operation: TOperation); override; // added
  1851.   public
  1852.     constructor Create(AOwner: TComponent); override; // Modified
  1853.     destructor Destroy; override;
  1854.     procedure TextOut(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string);
  1855.     property Offset: Integer read FOffset write FOffset; // added
  1856.   published
  1857.     property Font: string read FFont write SetFont;
  1858.     property FontIndex: Integer read FFontIndex write SetFontIndex;
  1859.     property DXImageList: TDXImageList read FDXImageList write FDXImageList;
  1860.   end;
  1861.  
  1862. (*******************************************************************************
  1863.  * Unit Name: DXPowerFont.pas
  1864.  * Information: Writed By Ramin.S.Zaghi (Based On Wilson's DXFont Unit)
  1865.  * Last Changes: Dec 25 2000;
  1866.  * Unit Information:
  1867.  *     This unit includes a VCL-Component for DelphiX. This component draws the
  1868.  *     Character-Strings on a TDirectDrawSurface. This component helps the
  1869.  *     progarmmers to using custom fonts and printing texts easily such as
  1870.  *     TCanvas.TextOut function...
  1871.  * Includes:
  1872.  * 1. TDXPowerFontTextOutEffect ==> The kinds of drawing effects.
  1873.  *    - teNormal: Uses the Draw function. (Normal output)
  1874.  *    - teRotat: Uses the DrawRotate function. (Rotates each character)
  1875.  *    - teAlphaBlend: Uses DrawAlpha function. (Blends each character)
  1876.  *    - teWaveX: Uses DrawWaveX function. (Adds a Wave effect to the each character)
  1877.  *
  1878.  * 2. TDXPowerFontTextOutType ==> The kinds of each caracter.
  1879.  *    - ttUpperCase: Uppers all characters automaticaly.
  1880.  *    - ttLowerCase: Lowers all characters automaticaly.
  1881.  *    - ttNormal: Uses all characters with out any converting.
  1882.  *
  1883.  * 3. TDXPowerFontEffectsParameters ==> Includes the parameters for adding effects to the characters.
  1884.  *    - (CenterX, CenterY): The rotating center point.
  1885.  *    - (Width, Height): The new size of each character.
  1886.  *    - Angle: The angle of rotate.
  1887.  *    - AlphaValue: The value of Alpha-Chanel.
  1888.  *    - WAmplitude: The Amplitude of Wave function. (See The Help Of DelphiX)
  1889.  *    - WLenght: The Lenght Of Wave function. (See The Help Of DelphiX)
  1890.  *    - WPhase: The Phase Of Wave function. (See The Help Of DelphiX)
  1891.  *
  1892.  * 4. TDXPowerFontBeforeTextOutEvent ==> This is an event that occures before
  1893.  *    drawing texts on to TDirectDrawSurface object.
  1894.  *    - Sender: Retrieves the event caller object.
  1895.  *    - Text: Retrieves the text sended text for drawing.
  1896.  *      (NOTE: The changes will have effect)
  1897.  *    - DoTextOut: The False value means that the TextOut function must be stopped.
  1898.  *      (NOTE: The changes will have effect)
  1899.  *
  1900.  * 5. TDXPowerFontAfterTextOutEvent ==> This is an event that occures after
  1901.  *    drawing texts on to TDirectDrawSurface object.
  1902.  *    - Sender: Retrieves the event caller object.
  1903.  *    - Text: Retrieves the text sended text for drawing.
  1904.  *      (NOTE: The changes will not have any effects)
  1905.  *
  1906.  * 6. TDXPowerFont ==> I sthe main class of PowerFont VCL-Component.
  1907.  *    - property Font: string; The name of custom-font's image in the TDXImageList items.
  1908.  *    - property FontIndex: Integer; The index of custom-font's image in the TDXImageList items.
  1909.  *    - property DXImageList: TDXImageList; The TDXImageList that includes the image of custom-fonts.
  1910.  *    - property UseEnterChar: Boolean; When the value of this property is True, The component caculates Enter character.
  1911.  *    - property EnterCharacter: String;
  1912.  *==>   Note that TDXPowerFont calculates tow kinds of enter character:
  1913.  *==>   E1. The Enter character that draws the characters after it self in a new line and after last drawed character, ONLY.
  1914.  *==>   E2. The Enter character that draws the characters after it self in a new line such as #13#10 enter code in delphi.
  1915.  *==>   Imporatant::
  1916.  *==>       (E1) TDXPowerFont uses the first caracter of EnterCharacter string as the first enter caracter (Default value is '|').
  1917.  *==>       (E2) and uses the second character as the scond enter caracter (Default value is '<')
  1918.  *    - property BeforeTextOut: TDXPowerFontBeforeTextOutEvent; See TDXPowerFontBeforeTextOutEvent.
  1919.  *    - property AfterTextOut: TDXPowerFontAfterTextOutEvent; See TDXPowerFontAfterTextOutEvent.
  1920.  *    - property Alphabets: string; TDXPowerFont uses this character-string for retrieving the pattern number of each character.
  1921.  *    - property TextOutType: TDXPowerFontTextOutType; See TDXPowerFontTextOutType.
  1922.  *    - property TextOutEffect: TDXPowerFontTextOutEffect; See TDXPowerFontTextOutEffect.
  1923.  *    - property EffectsParameters: TDXPowerFontEffectsParameters; See TDXPowerFontEffectsParameters.
  1924.  *
  1925.  *    - function TextOut(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string): Boolean;
  1926.  *      This function draws/prints the given text on the given TDirectDrawSurface.
  1927.  *      - DirectDrawSurface: The surface for drawing text (character-string).
  1928.  *      - (X , Y): The first point of outputed text. (Such as X,Y parameters in TCanvas.TextOut function)
  1929.  *      - Text: The text for printing.
  1930.  *      Return values: This function returns False when an error occured or...
  1931.  *    - function TextOutFast(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string): Boolean;
  1932.  *      This function works such as TextOut function but,
  1933.  *      with out calculating any Parameters/Effects/Enter-Characters/etc...
  1934.  *      This function calculates the TextOutType, ONLY.
  1935.  *
  1936.  * Ramin.S.Zaghi (ramin_zaghi@yahoo.com)
  1937.  * (Based on wilson's code for TDXFont VCL-Component/Add-On)
  1938.  * (wilson@no2games.com)
  1939.  *
  1940.  * For more information visit:
  1941.  *  www.no2games.com
  1942.  *  turbo.gamedev.net
  1943.  ******************************************************************************)
  1944.  
  1945.  { DXPowerFont types }
  1946.  
  1947.   TDXPowerFontTextOutEffect = (teNormal, teRotat, teAlphaBlend, teWaveX);
  1948.   TDXPowerFontTextOutType = (ttUpperCase, ttLowerCase, ttNormal);
  1949.   TDXPowerFontBeforeTextOutEvent = procedure(Sender: TObject; var Text: string; var DoTextOut: Boolean) of object;
  1950.   TDXPowerFontAfterTextOutEvent = procedure(Sender: TObject; Text: string) of object;
  1951.  
  1952.  { TDXPowerFontEffectsParameters }
  1953.  
  1954.   TDXPowerFontEffectsParameters = class(TPersistent)
  1955.   private
  1956.     FCenterX: Integer;
  1957.     FCenterY: Integer;
  1958.     FHeight: Integer;
  1959.     FWidth: Integer;
  1960.     FAngle: Integer;
  1961.     FAlphaValue: Integer;
  1962.     FWPhase: Integer;
  1963.     FWAmplitude: Integer;
  1964.     FWLenght: Integer;
  1965.     procedure SetAngle(const Value: Integer);
  1966.     procedure SetCenterX(const Value: Integer);
  1967.     procedure SetCenterY(const Value: Integer);
  1968.     procedure SetHeight(const Value: Integer);
  1969.     procedure SetWidth(const Value: Integer);
  1970.     procedure SetAlphaValue(const Value: Integer);
  1971.     procedure SetWAmplitude(const Value: Integer);
  1972.     procedure SetWLenght(const Value: Integer);
  1973.     procedure SetWPhase(const Value: Integer);
  1974.   published
  1975.     property CenterX: Integer read FCenterX write SetCenterX;
  1976.     property CenterY: Integer read FCenterY write SetCenterY;
  1977.     property Width: Integer read FWidth write SetWidth;
  1978.     property Height: Integer read FHeight write SetHeight;
  1979.     property Angle: Integer read FAngle write SetAngle;
  1980.     property AlphaValue: Integer read FAlphaValue write SetAlphaValue;
  1981.     property WAmplitude: Integer read FWAmplitude write SetWAmplitude;
  1982.     property WLenght: Integer read FWLenght write SetWLenght;
  1983.     property WPhase: Integer read FWPhase write SetWPhase;
  1984.   end;
  1985.  
  1986.  { TDXPowerFont }
  1987.  
  1988.   TDXPowerFont = class(TComponent)
  1989.   private
  1990.     FDXImageList: TDXImageList;
  1991.     FFont: string;
  1992.     FFontIndex: Integer;
  1993.     FUseEnterChar: Boolean;
  1994.     FEnterCharacter: string;
  1995.     FAfterTextOut: TDXPowerFontAfterTextOutEvent;
  1996.     FBeforeTextOut: TDXPowerFontBeforeTextOutEvent;
  1997.     FAlphabets: string;
  1998.     FTextOutType: TDXPowerFontTextOutType;
  1999.     FTextOutEffect: TDXPowerFontTextOutEffect;
  2000.     FEffectsParameters: TDXPowerFontEffectsParameters;
  2001.     procedure SetFont(const Value: string);
  2002.     procedure SetFontIndex(const Value: Integer);
  2003.     procedure SetUseEnterChar(const Value: Boolean);
  2004.     procedure SetEnterCharacter(const Value: string);
  2005.     procedure SetAlphabets(const Value: string);
  2006.     procedure SetTextOutType(const Value: TDXPowerFontTextOutType);
  2007.     procedure SetTextOutEffect(const Value: TDXPowerFontTextOutEffect);
  2008.     procedure SetEffectsParameters(const Value: TDXPowerFontEffectsParameters);
  2009.   published
  2010.     property Font: string read FFont write SetFont;
  2011.     property FontIndex: Integer read FFontIndex write SetFontIndex;
  2012.     property DXImageList: TDXImageList read FDXImageList write FDXImageList;
  2013.     property UseEnterChar: Boolean read FUseEnterChar write SetUseEnterChar;
  2014.     property EnterCharacter: string read FEnterCharacter write SetEnterCharacter;
  2015.     property BeforeTextOut: TDXPowerFontBeforeTextOutEvent read FBeforeTextOut write FBeforeTextOut;
  2016.     property AfterTextOut: TDXPowerFontAfterTextOutEvent read FAfterTextOut write FAfterTextOut;
  2017.     property Alphabets: string read FAlphabets write SetAlphabets;
  2018.     property TextOutType: TDXPowerFontTextOutType read FTextOutType write SetTextOutType;
  2019.     property TextOutEffect: TDXPowerFontTextOutEffect read FTextOutEffect write SetTextOutEffect;
  2020.     property EffectsParameters: TDXPowerFontEffectsParameters read FEffectsParameters write SetEffectsParameters;
  2021.   public
  2022.     Offset: Integer;
  2023.     constructor Create(AOwner: TComponent); override;
  2024.     destructor Destroy; override;
  2025.     function TextOut(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string): Boolean;
  2026.     function TextOutFast(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string): Boolean;
  2027.   end;
  2028.  
  2029.  {D2D unit for pure HW support
  2030.  *  Copyright (c) 2004-2010 Jaro Benes
  2031.  *  All Rights Reserved
  2032.  *  Version 1.09
  2033.  *  D2D Hardware module - interface part
  2034.  *  web site: www.micrel.cz/Dx
  2035.  *  e-mail: delphix_d2d@micrel.cz
  2036.  }
  2037.  
  2038.   {supported texture vertex as substitute type from DirectX}
  2039.  
  2040.   {TD2D4Vertex - used with D2DTexturedOn}
  2041.  
  2042.   TD2D4Vertex = array[0..3] of TD3DTLVERTEX;
  2043.  
  2044.   {TD2DTextures - texture storage used with Direct3D}
  2045.   TTextureRec = packed record
  2046.     {$IFDEF VIDEOTEX}
  2047.     VDIB: TDIB;
  2048.     {$ENDIF}
  2049.     D2DTexture: TDirect3DTexture2;
  2050.     FloatX1, FloatY1, FloatX2, FloatY2: Double; //uschov vyrez
  2051.     Name: string{$IFNDEF VER4UP} [255]{$ENDIF}; //jmeno obrazku pro snadne dohledani
  2052.     Width, Height: Integer;
  2053.     AlphaChannel: Boolean; //.06c
  2054.   end;
  2055.   PTextureRec = ^TTextureRec;
  2056.   TTextureArr = array{$IFNDEF VER4UP} [0..0]{$ENDIF} of TTextureRec;
  2057. {$IFNDEF VER4UP}
  2058.   PTextureArr = ^TTextureArr;
  2059.   EMaxTexturesError = class(Exception);
  2060. {$ENDIF}
  2061.   TD2DTextures = class
  2062.   private
  2063.     FDDraw: TCustomDXDraw;
  2064. {$IFNDEF VER4UP}
  2065.     TexLen: Integer;
  2066.     Texture: PTextureArr;
  2067. {$ELSE}
  2068.     Texture: TTextureArr;
  2069. {$ENDIF}
  2070.     function GetD2DMaxTextures: Integer;
  2071.     procedure SetD2DMaxTextures(const Value: Integer);
  2072.     procedure D2DPruneTextures;
  2073.     procedure D2DPruneAllTextures;
  2074.     procedure SizeAdjust(var DIB: TDIB; var FloatX1, FloatY1, FloatX2,
  2075.       FloatY2: Double);
  2076.     function SetTransparentColor(dds: TDirectDrawSurface; PixelColor: Integer;
  2077.       Transparent: Boolean): Integer;
  2078.     {$IFDEF VIDEOTEX}
  2079.     function GetTexLayoutByName(name: string): TDIB;
  2080.     {$ENDIF}
  2081.     procedure SaveTextures(path: string);
  2082.   public
  2083.     constructor Create(DDraw: TCustomDXDraw);
  2084.     destructor Destroy; override;
  2085.     procedure D2DFreeTextures;
  2086.     function Find(byName: string): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
  2087.     function GetTextureByName(const byName: string): TDirect3DTexture2;
  2088.     function GetTextureByIndex(const byIndex: Integer): TDirect3DTexture2;
  2089.     function GetTextureNameByIndex(const byIndex: Integer): string;
  2090.     function Count: Integer;
  2091.     {functions support loading image or DDS}
  2092. {$IFDEF VER4UP}
  2093.     function CanFindTexture(aImage: TPictureCollectionItem): Boolean; overload; {$IFDEF VER9UP}inline;{$ENDIF}
  2094.     function CanFindTexture(const TexName: string): Boolean; overload; {$IFDEF VER9UP}inline;{$ENDIF}
  2095.     function CanFindTexture(const Color: LongInt): Boolean; overload;{$IFDEF VER9UP}inline;{$ENDIF}
  2096.     function LoadTextures(aImage: TPictureCollectionItem): Boolean; overload; {$IFDEF VER9UP}inline;{$ENDIF}
  2097.     function LoadTextures(dds: TDirectDrawSurface; Transparent: Boolean; asTexName: string): Boolean; overload;
  2098.     function LoadTextures(dds: TDirectDrawSurface; Transparent: Boolean; TransparentColor: Integer; asTexName: string): Boolean; overload;
  2099.     function LoadTextures(Color: Integer): Boolean; overload;
  2100. {$ELSE}
  2101.     function CanFindTexture(aImage: TPictureCollectionItem): Boolean;
  2102.     function CanFindTexture2(const TexName: string): Boolean;
  2103.     function CanFindTexture3(const Color: LongInt): Boolean;
  2104.     function LoadTextures(aImage: TPictureCollectionItem): Boolean;
  2105.     function LoadTextures2(dds: TDirectDrawSurface; Transparent: Boolean; asTexName: string): Boolean;
  2106.     function LoadTextures3(dds: TDirectDrawSurface; Transparent: Boolean; TransparentColor: Integer; asTexName: string): Boolean;
  2107.     function LoadTextures4(Color: Integer): Boolean;
  2108. {$ENDIF}
  2109.     {$IFDEF VIDEOTEX}
  2110.     property TexLayoutByName[name: string]: TDIB read GetTexLayoutByName;
  2111.     {$ENDIF}
  2112.   //published
  2113.     property D2DMaxTextures: Integer read GetD2DMaxTextures write SetD2DMaxTextures;
  2114.   end;
  2115.  
  2116.   {Main component for HW support}
  2117.  
  2118.   TD2D = class
  2119.   private
  2120.     FDDraw: TCustomDXDraw;
  2121.     FCanUseD2D: Boolean;
  2122.     FBitCount: Integer;
  2123.     FMirrorFlipSet: TRenderMirrorFlipSet;
  2124.     FD2DTextureFilter: TD2DTextureFilter;
  2125.     FD2DAntialiasFilter: TD3DAntialiasMode;
  2126.     FVertex: TD2D4Vertex;
  2127.     FD2DTexture: TD2DTextures;
  2128.     FDIB: TDIB;
  2129.     FD3DDevDesc7: TD3DDeviceDesc7;
  2130.     FInitialized: Boolean;
  2131.     {ukazuje pocet textur}
  2132.     procedure D2DUpdateTextures; {$IFDEF VER9UP}inline;{$ENDIF}
  2133.  
  2134.     procedure SetCanUseD2D(const Value: Boolean);
  2135.     function GetCanUseD2D: Boolean;
  2136.     {create the component}
  2137.     constructor Create(DDraw: TCustomDXDraw);
  2138.     procedure SetD2DTextureFilter(const Value: TD2DTextureFilter);
  2139.     procedure SetD2DAntialiasFilter(const Value: TD3DAntialiasMode);
  2140.     procedure D2DEffectSolid; {$IFDEF VER9UP}inline;{$ENDIF}
  2141.     procedure D2DEffectAdd; {$IFDEF VER9UP}inline;{$ENDIF}
  2142.     procedure D2DEffectSub; {$IFDEF VER9UP}inline;{$ENDIF}
  2143.     procedure D2DEffectBlend; {$IFDEF VER9UP}inline;{$ENDIF}// used with alpha
  2144.  
  2145.     {verticies}
  2146.     procedure InitVertex; {$IFDEF VER9UP}inline;{$ENDIF}
  2147.     function D2DWhite: Integer; {$IFDEF VER9UP}inline;{$ENDIF}
  2148.     function D2DVertColor(RenderType: TRenderType; Alpha: Byte): DWORD; {$IFDEF VER9UP}inline;{$ENDIF}
  2149.     procedure D2DColoredVertex(C: Integer); {$IFDEF VER9UP}inline;{$ENDIF}
  2150.     function D2DAlphaVertex(Alpha: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
  2151.     procedure D2DSpecularVertex(C: Integer); {$IFDEF VER9UP}inline;{$ENDIF}
  2152.     {Fade used with Add and Sub}
  2153.     function D2DFade(Alpha: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
  2154.     procedure D2DFadeColored(C, Alpha: Integer); {$IFDEF VER9UP}inline;{$ENDIF}
  2155.  
  2156.     function RenderQuad: Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2157.  
  2158.     procedure D2DRect(R: TRect); {$IFDEF VER9UP}inline;{$ENDIF}
  2159.     procedure D2DTU(T: TTextureRec); {$IFDEF VER9UP}inline;{$ENDIF}
  2160.     {low lever version texturing for DDS}
  2161.     function D2DTexturedOnDDSTex(dds: TDirectDrawSurface; SubPatternRect: TRect;
  2162.       Transparent: Boolean): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
  2163.     {texturing}
  2164.     function D2DTexturedOn(Image: TPictureCollectionItem; Pattern: Integer; SubPatternRect: TRect; RenderType: TRenderType; Alpha: Byte): Boolean;
  2165.     function D2DTexturedOnDDS(dds: TDirectDrawSurface; SubPatternRect: TRect; Transparent: Boolean; RenderType: TRenderType; Alpha: Byte): Boolean;
  2166.     function D2DTexturedOnRect(Rect: TRect; Color: Integer): Boolean;
  2167.     function D2DTexturedOnSubRect(Image: TPictureCollectionItem; Pattern: Integer; SubPatternRect, SubRect: TRect; RenderType: TRenderType; Alpha: Byte): Boolean;
  2168.  
  2169.     {low level for rotate mesh}
  2170.     procedure D2DRotate(X, Y, W, H: Integer; Px, Py: Double; Angle: single);
  2171.     {low lever routine for mesh mapping}
  2172.     function D2DMeshMapToWave(dds: TDirectDrawSurface; Transparent: Boolean;
  2173.       TransparentColor: Integer; X, Y, iWidth, iHeight, PatternIndex: Integer;
  2174.       PatternRect: TRect;
  2175.       Amp, Len, Ph, Alpha: Integer;
  2176.       Effect: TRenderType; DoY: Boolean{$IFDEF VER4UP} = False{$ENDIF}): Boolean;
  2177.     property D2DTextures: TD2DTextures read FD2DTexture;
  2178.   public
  2179.     //added to public
  2180.     procedure D2DColAlpha(C, Alpha: Integer); {$IFDEF VER9UP}inline;{$ENDIF}
  2181.     procedure D2DCol4Alpha(C1, C2, C3, C4, Alpha: Integer); {$IFDEF VER9UP}inline;{$ENDIF}
  2182.     procedure D2DFade4Colored(C1, C2, C3, C4, Alpha: Integer); {$IFDEF VER9UP}inline;{$ENDIF}
  2183.     function RenderTri: Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2184.     procedure D2DMeshMapToRect(R: TRect);
  2185.     //
  2186.     {destruction textures and supported objects here}
  2187.     destructor Destroy; override;
  2188.     {use before starting rendering}
  2189.     procedure BeginScene;
  2190.     {use after all images have been rendered}
  2191.     procedure EndScene;
  2192.     {set directly of texture filter}
  2193.     property TextureFilter: TD2DTextureFilter write SetD2DTextureFilter;
  2194.     property AntialiasFilter: TD3DAntialiasMode write SetD2DAntialiasFilter;
  2195.     {indicate using of this object}
  2196.     property CanUseD2D: Boolean read GetCanUseD2D write SetCanUseD2D;
  2197.  
  2198.     {set property mirror-flip}
  2199.     property MirrorFlip: TRenderMirrorFlipSet read FMirrorFlipSet write FMirrorFlipSet;
  2200.  
  2201.     {initialize surface}
  2202.     function D2DInitializeSurface: Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2203.  
  2204.     {Render routines}
  2205.     function D2DRender(Image: TPictureCollectionItem; DestRect: TRect;
  2206.       Pattern: Integer; SourceRect: TRect; RenderType: TRenderType; Alpha: Byte{$IFDEF VER4UP} = 255{$ENDIF}): Boolean;{$IFDEF VER4UP} overload; {$ENDIF}{$IFDEF VER9UP}inline;{$ENDIF}
  2207.  
  2208.     function {$IFDEF VER4UP}D2DRender{$ELSE}D2DRender2{$ENDIF}(Image: TPictureCollectionItem; R: TRect;
  2209.       Pattern: Integer; RenderType: TRenderType; Alpha: Byte{$IFDEF VER4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER4UP} overload; {$ENDIF}{$IFDEF VER9UP}inline;{$ENDIF}
  2210.  
  2211.     function D2DRenderDDS(Source: TDirectDrawSurface; SourceRect, DestRect: TRect; Transparent: Boolean;
  2212.       Pattern: Integer; RenderType: TRenderType; Alpha: Byte{$IFDEF VER4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2213.  
  2214.     function D2DRenderCol(Image: TPictureCollectionItem; R: TRect;
  2215.       Pattern, Color: Integer; RenderType: TRenderType; Alpha: Byte{$IFDEF VER4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2216.     function D2DRenderColDDS(Source: TDirectDrawSurface; SourceRect, DestRect: TRect;
  2217.       Transparent: Boolean; Pattern, Color: Integer; RenderType:
  2218.       TRenderType; Alpha: Byte{$IFDEF VER4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2219.  
  2220.     function D2DRenderDrawDDSXY(Source: TDirectDrawSurface; X, Y: Integer;
  2221.       Transparent: Boolean; Pattern: Integer; RenderType: TRenderType; Alpha: Byte{$IFDEF VER4UP} = 255{$ENDIF}): Boolean;
  2222. {$IFDEF VER4UP} overload; {$IFDEF VER9UP}inline;{$ENDIF}
  2223.     function D2DRenderDrawDDSXY(Source: TDirectDrawSurface; X, Y: Integer;
  2224.       SrcRect: TRect; Transparent: Boolean; Pattern: Integer; RenderType: TRenderType; Alpha: Byte{$IFDEF Ver4UP} = 255{$ENDIF}): Boolean; overload; {$IFDEF VER9UP}inline;{$ENDIF}
  2225. {$ENDIF}
  2226.     function D2DRenderDrawXY(Image: TPictureCollectionItem; X, Y: Integer;
  2227.       Pattern: Integer; RenderType: TRenderType; Alpha: Byte{$IFDEF VEr4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2228.  
  2229.     {Rotate}
  2230.     function D2DRenderRotate(Image: TPictureCollectionItem; RotX, RotY,
  2231.       PictWidth, PictHeight, PatternIndex: Integer; RenderType: TRenderType;
  2232.       CenterX, CenterY: Double; Angle: single; Alpha: Byte{$IFDEF VER4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2233.     function D2DRenderRotateDDS(Image: TDirectDrawSurface; SourceRect: TRect; RotX, RotY,
  2234.       PictWidth, PictHeight: Integer; RenderType: TRenderType;
  2235.       CenterX, CenterY: Double; Angle: single; Alpha: Byte;
  2236.       Transparent: Boolean): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2237.  
  2238.     function D2DRenderRotateModeCol(Image: TPictureCollectionItem; RenderType: TRenderType; RotX, RotY,
  2239.       PictWidth, PictHeight, PatternIndex: Integer; CenterX, CenterY: Double;
  2240.       Angle: single; Color: Integer; Alpha: Byte{$IFDEF VER4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2241.     function D2DRenderRotateModeColDDS(Image: TDirectDrawSurface;
  2242.       RotX, RotY, PictWidth, PictHeight: Integer; RenderType: TRenderType;
  2243.       CenterX, CenterY: Double; Angle: Single; Color: Integer; Alpha: Byte;
  2244.       Transparent: Boolean): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2245.  
  2246.     {WaveX}
  2247.     function D2DRenderWaveX(Image: TPictureCollectionItem; X, Y, Width, Height,
  2248.       PatternIndex: Integer; RenderType: TRenderType; Transparent: Boolean;
  2249.       Amp, Len, Ph: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2250.     function D2DRenderWaveXDDS(Source: TDirectDrawSurface; X, Y, Width,
  2251.       Height: Integer; RenderType: TRenderType; Transparent: Boolean;
  2252.       Amp, Len, Ph: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2253.  
  2254.     {WaveY}
  2255.     function D2DRenderWaveY(Image: TPictureCollectionItem; X, Y, Width, Height,
  2256.       PatternIndex: Integer; RenderType: TRenderType; Transparent: Boolean;
  2257.       Amp, Len, Ph: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2258.     function D2DRenderWaveYDDS(Source: TDirectDrawSurface; X, Y, Width,
  2259.       Height: Integer; RenderType: TRenderType; Transparent: Boolean;
  2260.       Amp, Len, Ph: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2261.  
  2262.     {Rect}
  2263.     function D2DRenderFillRect(Rect: TRect; RGBColor: LongInt;
  2264.       RenderType: TRenderType; Alpha: Byte{$IFDEF VER4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2265.  
  2266.     {addmod}
  2267.     function D2DRenderColoredPartition(Image: TPictureCollectionItem; DestRect: TRect; PatternIndex,
  2268.       Color, Specular: Integer; Faded: Boolean;
  2269.       SourceRect: TRect;
  2270.       RenderType: TRenderType;
  2271.       Alpha: Byte{$IFDEF VER4UP} = 255{$ENDIF}): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
  2272.  
  2273.     procedure SaveTextures(path: string);
  2274.   end;
  2275.  
  2276. { Support functions for texturing }
  2277. function dxtMakeChannel(Mask: DWORD; indexed: Boolean): TDXTextureImageChannel;
  2278. function dxtEncodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
  2279. function dxtDecodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
  2280.  
  2281. { Single support routine for convert DIB32 to DXT in one line }
  2282. procedure dib2dxt(DIBImage: TDIB; out DXTImage: TDXTextureImage{$IFDEF DXTextureImage_UseZLIB}; const Shrink: Boolean = True{$ENDIF});
  2283.  
  2284. { One line call drawing with attributes }
  2285. {$IFDEF VER4UP}
  2286. procedure DXDraw_Draw(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
  2287.   Rect: TRect; Pattern: Integer; TextureFilter: TD2DTextureFilter = D2D_POINT;
  2288.   MirrorFlip: TRenderMirrorFlipSet = [];
  2289.   BlendMode: TRenderType = rtDraw; Angle: Single = 0; Alpha: Byte = 255;
  2290.   CenterX: Double = 0.5; CenterY: Double = 0.5;
  2291.   Scale: Single = 1.0); {$IFDEF VER9UP}inline;{$ENDIF}
  2292. procedure DXDraw_Paint(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
  2293.   Rect: TRect; Pattern: Integer; var BlurImageArr: TBlurImageArr; BlurImage: Boolean = False;
  2294.   TextureFilter: TD2DTextureFilter = D2D_POINT;
  2295.   MirrorFlip: TRenderMirrorFlipSet = [];
  2296.   BlendMode: TRenderType = rtDraw;
  2297.   Angle: Single = 0;
  2298.   Alpha: Byte = 255;
  2299.   CenterX: Double = 0.5; CenterY: Double = 0.5); {$IFDEF VER9UP}inline;{$ENDIF}
  2300. procedure DXDraw_Render(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
  2301.   Rect: TRect; Pattern: Integer; var BlurImageArr: TBlurImageArr; BlurImage: Boolean = False;
  2302.   TextureFilter: TD2DTextureFilter = D2D_POINT;
  2303.   MirrorFlip: TRenderMirrorFlipSet = [];
  2304.   BlendMode: TRenderType = rtDraw;
  2305.   Angle: Single = 0;
  2306.   Alpha: Byte = 255;
  2307.   CenterX: Double = 0.5; CenterY: Double = 0.5;
  2308.   Scale: Single = 1.0;
  2309.   WaveType: TWaveType = wtWaveNone;
  2310.   Amplitude: Integer = 0; AmpLength: Integer = 0; Phase: Integer = 0); {$IFDEF VER9UP}inline;{$ENDIF}
  2311. {$ELSE}
  2312. procedure DXDraw_Draw(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
  2313.   Rect: TRect; Pattern: Integer; TextureFilter: TD2DTextureFilter;
  2314.   MirrorFlip: TRenderMirrorFlipSet;
  2315.   BlendMode: TRenderType; Angle: Single; Alpha: Byte;
  2316.   CenterX: Double; CenterY: Double;
  2317.   Scale: Single);
  2318. procedure DXDraw_Paint(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
  2319.   Rect: TRect; Pattern: Integer; var BlurImageArr: TBlurImageArr; BlurImage: Boolean;
  2320.   TextureFilter: TD2DTextureFilter;
  2321.   MirrorFlip: TRenderMirrorFlipSet;
  2322.   BlendMode: TRenderType;
  2323.   Angle: Single;
  2324.   Alpha: Byte;
  2325.   CenterX: Double; CenterY: Double);
  2326. procedure DXDraw_Render(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
  2327.   Rect: TRect; Pattern: Integer; var BlurImageArr: TBlurImageArr; BlurImage: Boolean;
  2328.   TextureFilter: TD2DTextureFilter;
  2329.   MirrorFlip: TRenderMirrorFlipSet;
  2330.   BlendMode: TRenderType;
  2331.   Angle: Single;
  2332.   Alpha: Byte;
  2333.   CenterX: Double; CenterY: Double;
  2334.   Scale: Single;
  2335.   WaveType: TWaveType;
  2336.   Amplitude: Integer; AmpLength: Integer; Phase: Integer);
  2337. {$ENDIF}
  2338.  
  2339. implementation
  2340.  
  2341. uses DXConsts{$IFDEF DXR_deprecated}, DXRender{$ENDIF}, D3DUtils;
  2342.  
  2343. function DXDirectDrawEnumerate(lpCallback: {$IFDEF UNICODE}TDDEnumCallbackW{$ELSE}TDDEnumCallbackA{$ENDIF};
  2344.   lpContext: Pointer): HRESULT;
  2345. type
  2346.   TDirectDrawEnumerate = function(lpCallback: {$IFDEF UNICODE}TDDEnumCallbackW{$ELSE}TDDEnumCallbackA{$ENDIF};
  2347.     lpContext: Pointer): HRESULT; stdcall;
  2348. begin
  2349.   Result := TDirectDrawEnumerate(DXLoadLibrary('DDraw.dll', {$IFDEF UNICODE}'DirectDrawEnumerateW'{$ELSE}'DirectDrawEnumerateA'{$ENDIF}))
  2350.     (lpCallback, lpContext);
  2351. end;
  2352.  
  2353. var
  2354.   DirectDrawDrivers: TDirectXDrivers;
  2355.   {$IFDEF _DMO_}DirectDrawDriversEx: TDirectXDriversEx;{$ENDIF}
  2356.   D2D: TD2D = nil; {for internal use only, }
  2357.   RenderError: Boolean = false;
  2358.  
  2359. function EnumDirectDrawDrivers: TDirectXDrivers;
  2360.  
  2361.   function DDENUMCALLBACK(lpGuid: PGUID; lpstrDescription: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF};
  2362.     lpstrModule: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF}; lpContext: Pointer): BOOL; stdcall;
  2363.   begin
  2364.     Result := True;
  2365.     with TDirectXDriver.Create(TDirectXDrivers(lpContext)) do
  2366.     begin
  2367.       Guid := lpGuid;
  2368.       Description := lpstrDescription;
  2369.       DriverName := lpstrModule;
  2370.     end;
  2371.   end;
  2372.  
  2373. begin
  2374.   if DirectDrawDrivers = nil then
  2375.   begin
  2376.     DirectDrawDrivers := TDirectXDrivers.Create;
  2377.     try
  2378.       DXDirectDrawEnumerate(@DDENUMCALLBACK, DirectDrawDrivers);
  2379.     except
  2380.       DirectDrawDrivers.Free;
  2381.       raise;
  2382.     end;
  2383.   end;
  2384.  
  2385.   Result := DirectDrawDrivers;
  2386. end;
  2387.  
  2388. {$IFDEF _DMO_}
  2389. function EnumDirectDrawDriversEx: TDirectXDriversEx;
  2390.  
  2391.   function DDENUMCALLBACKEX(lpGuid: PGUID; lpstrDescription: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF};
  2392.     lpDriverName: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF}; lpContext: Pointer; iMonitor: HMonitor): BOOL; stdcall;
  2393.   var
  2394.     X: TDirectXDriverEx;
  2395.   begin
  2396.     Result := True;
  2397.     X := TDirectXDriverEx(DirectDrawDriversEx.Add);
  2398.     with X do
  2399.     begin
  2400.       Guid := lpGuid;
  2401.       Description := lpstrDescription;
  2402.       Monitor := iMonitor;
  2403.       DriverName := lpDriverName;
  2404.       //GetPhysicalMonitorsFromHMONITOR()
  2405.     end;
  2406.   end;
  2407.  
  2408. //var
  2409. //  DevMode: TDeviceMode;
  2410. begin
  2411.   if DirectDrawDriversEx = nil then DirectDrawDriversEx := TDirectXDriversEx.Create;
  2412.   if Assigned(DirectDrawDriversEx) then
  2413.   begin
  2414.     //FMonitors.Clear;
  2415.     try
  2416.       //FillChar(DevMode, SizeOf(TDeviceMode), 0);
  2417.       if DirectDrawEnumerateEx(@DDENUMCALLBACKEX, nil{DeviceContext}, DDENUM_ATTACHEDSECONDARYDEVICES or DDENUM_DETACHEDSECONDARYDEVICES or DDENUM_NONDISPLAYDEVICES) = DD_OK then;
  2418.     except
  2419.       DirectDrawDriversEx.Free; DirectDrawDriversEx := nil;
  2420.       raise;
  2421.     end;
  2422.   end;
  2423.   Result := DirectDrawDriversEx;
  2424. end;
  2425. {$ENDIF}
  2426.  
  2427. function ClipRect(var DestRect: TRect; const DestRect2: TRect): Boolean;
  2428. begin
  2429.   with DestRect do
  2430.   begin
  2431.     Left := Max(Left, DestRect2.Left);
  2432.     Right := Min(Right, DestRect2.Right);
  2433.     Top := Max(Top, DestRect2.Top);
  2434.     Bottom := Min(Bottom, DestRect2.Bottom);
  2435.  
  2436.     Result := (Left < Right) and (Top < Bottom);
  2437.   end;
  2438. end;
  2439.  
  2440. function ClipRect2(var DestRect, SrcRect: TRect; const DestRect2, SrcRect2: TRect): Boolean;
  2441. begin
  2442.   if DestRect.Left < DestRect2.Left then
  2443.   begin
  2444.     SrcRect.Left := SrcRect.Left + (DestRect2.Left - DestRect.Left);
  2445.     DestRect.Left := DestRect2.Left;
  2446.   end;
  2447.  
  2448.   if DestRect.Top < DestRect2.Top then
  2449.   begin
  2450.     SrcRect.Top := SrcRect.Top + (DestRect2.Top - DestRect.Top);
  2451.     DestRect.Top := DestRect2.Top;
  2452.   end;
  2453.  
  2454.   if SrcRect.Left < SrcRect2.Left then
  2455.   begin
  2456.     DestRect.Left := DestRect.Left + (SrcRect2.Left - SrcRect.Left);
  2457.     SrcRect.Left := SrcRect2.Left;
  2458.   end;
  2459.  
  2460.   if SrcRect.Top < SrcRect2.Top then
  2461.   begin
  2462.     DestRect.Top := DestRect.Top + (SrcRect2.Top - SrcRect.Top);
  2463.     SrcRect.Top := SrcRect2.Top;
  2464.   end;
  2465.  
  2466.   if DestRect.Right > DestRect2.Right then
  2467.   begin
  2468.     SrcRect.Right := SrcRect.Right - (DestRect.Right - DestRect2.Right);
  2469.     DestRect.Right := DestRect2.Right;
  2470.   end;
  2471.  
  2472.   if DestRect.Bottom > DestRect2.Bottom then
  2473.   begin
  2474.     SrcRect.Bottom := SrcRect.Bottom - (DestRect.Bottom - DestRect2.Bottom);
  2475.     DestRect.Bottom := DestRect2.Bottom;
  2476.   end;
  2477.  
  2478.   if SrcRect.Right > SrcRect2.Right then
  2479.   begin
  2480.     DestRect.Right := DestRect.Right - (SrcRect.Right - SrcRect2.Right);
  2481.     SrcRect.Right := SrcRect2.Right;
  2482.   end;
  2483.  
  2484.   if SrcRect.Bottom > SrcRect2.Bottom then
  2485.   begin
  2486.     DestRect.Bottom := DestRect.Bottom - (SrcRect.Bottom - SrcRect2.Bottom);
  2487.     SrcRect.Bottom := SrcRect2.Bottom;
  2488.   end;
  2489.  
  2490.   Result := (DestRect.Left < DestRect.Right) and (DestRect.Top < DestRect.Bottom) and
  2491.     (SrcRect.Left < SrcRect.Right) and (SrcRect.Top < SrcRect.Bottom);
  2492. end;
  2493.  
  2494. {  TDirectDraw  }
  2495.  
  2496. constructor TDirectDraw.Create(GUID: PGUID);
  2497. begin
  2498.   CreateEx(GUID, True);
  2499. end;
  2500.  
  2501. constructor TDirectDraw.CreateEx(GUID: PGUID; DirectX7Mode: Boolean);
  2502. type
  2503.   TDirectDrawCreate = function(lpGUID: PGUID; out lplpDD: IDirectDraw;
  2504.     pUnkOuter: IUnknown): HRESULT; stdcall;
  2505.  
  2506.   TDirectDrawCreateEx = function(lpGUID: PGUID; out lplpDD: IDirectDraw7; const iid: TGUID;
  2507.     pUnkOuter: IUnknown): HRESULT; stdcall;
  2508. begin
  2509.   inherited Create;
  2510.   FClippers := TList.Create;
  2511.   FPalettes := TList.Create;
  2512.   FSurfaces := TList.Create;
  2513.  
  2514.   {$IFDEF D3D_deprecated}
  2515.   if DirectX7Mode then
  2516.   begin {$ENDIF}
  2517.     { DirectX 7 }
  2518.     if TDirectDrawCreateEx(DXLoadLibrary('DDraw.dll', 'DirectDrawCreateEx'))(GUID, FIDDraw7, IID_IDirectDraw7, nil) <> DD_OK then
  2519.       raise EDirectDrawError.CreateFmt(SCannotInitialized, [SDirectDraw]);
  2520.     {$IFDEF D3D_deprecated}
  2521.     try
  2522.       FIDDraw := FIDDraw7 as IDirectDraw;
  2523.       FIDDraw4 := FIDDraw7 as IDirectDraw4;
  2524.     except
  2525.       raise EDirectDrawError.Create(SSinceDirectX7);
  2526.     end;
  2527.     {$ENDIF}
  2528.   {$IFDEF D3D_deprecated}end else
  2529.   begin
  2530.     if TDirectDrawCreate(DXLoadLibrary('DDraw.dll', 'DirectDrawCreate'))(GUID, FIDDraw, nil) <> DD_OK then
  2531.       raise EDirectDrawError.CreateFmt(SCannotInitialized, [SDirectDraw]);
  2532.     try
  2533.       FIDDraw4 := FIDDraw as IDirectDraw4;
  2534.     except
  2535.       raise EDirectDrawError.Create(SSinceDirectX6);
  2536.     end;
  2537.   end;{$ENDIF}
  2538.  
  2539.   FDriverCaps.dwSize := SizeOf(FDriverCaps);
  2540.   FHELCaps.dwSize := SizeOf(FHELCaps);
  2541.   {$IFDEF D3D_deprecated}FIDDraw{$ELSE}FIDDraw7{$ENDIF}.GetCaps(@FDriverCaps, @FHELCaps);
  2542. end;
  2543.  
  2544. destructor TDirectDraw.Destroy;
  2545. begin
  2546.   while SurfaceCount > 0 do
  2547.     Surfaces[SurfaceCount - 1].Free;
  2548.  
  2549.   while PaletteCount > 0 do
  2550.     Palettes[PaletteCount - 1].Free;
  2551.  
  2552.   while ClipperCount > 0 do
  2553.     Clippers[ClipperCount - 1].Free;
  2554.  
  2555.   FSurfaces.Free;
  2556.   FPalettes.Free;
  2557.   FClippers.Free;
  2558.   inherited Destroy;
  2559. end;
  2560.  
  2561. class function TDirectDraw.Drivers: TDirectXDrivers;
  2562. begin
  2563.   Result := EnumDirectDrawDrivers;
  2564. end;
  2565.  
  2566. {$IFDEF _DMO_}
  2567. class function TDirectDraw.DriversEx: TDirectXDriversEx;
  2568. begin
  2569.   Result := EnumDirectDrawDriversEx;
  2570. end;
  2571. {$ENDIF}
  2572.  
  2573. function TDirectDraw.GetClipper(Index: Integer): TDirectDrawClipper;
  2574. begin
  2575.   Result := FClippers[Index];
  2576. end;
  2577.  
  2578. function TDirectDraw.GetClipperCount: Integer;
  2579. begin
  2580.   Result := FClippers.Count;
  2581. end;
  2582.  
  2583. function TDirectDraw.GetDisplayMode: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  2584. begin
  2585.   Result.dwSize := SizeOf(Result);
  2586.   DXResult := {$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.GetDisplayMode(Result);
  2587.   if DXResult <> DD_OK then
  2588.     FillChar(Result, SizeOf(Result), 0);
  2589. end;
  2590. {$IFDEF D3D_deprecated}
  2591. function TDirectDraw.GetIDDraw: IDirectDraw;
  2592. begin
  2593.   if Self <> nil then
  2594.     Result := FIDDraw
  2595.   else
  2596.     Result := nil;
  2597. end;
  2598.  
  2599. function TDirectDraw.GetIDDraw4: IDirectDraw4;
  2600. begin
  2601.   if Self <> nil then
  2602.     Result := FIDDraw4
  2603.   else
  2604.     Result := nil;
  2605. end;
  2606. {$ENDIF}
  2607. function TDirectDraw.GetIDDraw7: IDirectDraw7;
  2608. begin
  2609.   if Self <> nil then
  2610.     Result := FIDDraw7
  2611.   else
  2612.     Result := nil;
  2613. end;
  2614. {$IFDEF D3D_deprecated}
  2615. function TDirectDraw.GetIDraw: IDirectDraw;
  2616. begin
  2617.   Result := IDDraw;
  2618.   if Result = nil then
  2619.     raise EDirectDrawError.CreateFmt(SNotMade, ['IDirectDraw']);
  2620. end;
  2621.  
  2622. function TDirectDraw.GetIDraw4: IDirectDraw4;
  2623. begin
  2624.   Result := IDDraw4;
  2625.   if Result = nil then
  2626.     raise EDirectDrawError.CreateFmt(SNotMade, ['IDirectDraw4']);
  2627. end;
  2628. {$ENDIF}
  2629. function TDirectDraw.GetIDraw7: IDirectDraw7;
  2630. begin
  2631.   Result := IDDraw7;
  2632.   if Result = nil then
  2633.     raise EDirectDrawError.CreateFmt(SNotMade, ['IDirectDraw7']);
  2634. end;
  2635.  
  2636. function TDirectDraw.GetPalette(Index: Integer): TDirectDrawPalette;
  2637. begin
  2638.   Result := FPalettes[Index];
  2639. end;
  2640.  
  2641. function TDirectDraw.GetPaletteCount: Integer;
  2642. begin
  2643.   Result := FPalettes.Count;
  2644. end;
  2645.  
  2646. function TDirectDraw.GetSurface(Index: Integer): TDirectDrawSurface;
  2647. begin
  2648.   Result := FSurfaces[Index];
  2649. end;
  2650.  
  2651. function TDirectDraw.GetSurfaceCount: Integer;
  2652. begin
  2653.   Result := FSurfaces.Count;
  2654. end;
  2655.  
  2656. {  TDirectDrawPalette  }
  2657.  
  2658. constructor TDirectDrawPalette.Create(ADirectDraw: TDirectDraw);
  2659. begin
  2660.   inherited Create;
  2661.   FDDraw := ADirectDraw;
  2662.   FDDraw.FPalettes.Add(Self);
  2663. end;
  2664.  
  2665. destructor TDirectDrawPalette.Destroy;
  2666. begin
  2667.   FDDraw.FPalettes.Remove(Self);
  2668.   inherited Destroy;
  2669. end;
  2670.  
  2671. function TDirectDrawPalette.CreatePalette(Caps: DWORD; const Entries): Boolean;
  2672. var
  2673.   TempPalette: IDirectDrawPalette;
  2674. begin
  2675.   IDDPalette := nil;
  2676.  
  2677.   FDDraw.DXResult := FDDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.CreatePalette(Caps, @Entries, TempPalette, nil);
  2678.   FDXResult := FDDraw.DXResult;
  2679.   Result := FDDraw.DXResult = DD_OK;
  2680.   if Result then
  2681.     IDDPalette := TempPalette;
  2682. end;
  2683.  
  2684. procedure TDirectDrawPalette.LoadFromDIB(DIB: TDIB);
  2685. var
  2686.   Entries: TPaletteEntries;
  2687. begin
  2688.   Entries := RGBQuadsToPaletteEntries(DIB.ColorTable);
  2689.   CreatePalette(DDPCAPS_8BIT, Entries);
  2690. end;
  2691.  
  2692. procedure TDirectDrawPalette.LoadFromFile(const FileName: string);
  2693. var
  2694.   Stream: TFileStream;
  2695. begin
  2696.   Stream := TFileStream.Create(FileName, fmOpenRead);
  2697.   try
  2698.     LoadFromStream(Stream);
  2699.   finally
  2700.     Stream.Free;
  2701.   end;
  2702. end;
  2703.  
  2704. procedure TDirectDrawPalette.LoadFromStream(Stream: TStream);
  2705. var
  2706.   DIB: TDIB;
  2707. begin
  2708.   DIB := TDIB.Create;
  2709.   try
  2710.     DIB.LoadFromStream(Stream);
  2711.     if DIB.Size > 0 then
  2712.       LoadFromDIB(DIB);
  2713.   finally
  2714.     DIB.Free;
  2715.   end;
  2716. end;
  2717.  
  2718. function TDirectDrawPalette.GetEntries(StartIndex, NumEntries: Integer;
  2719.   var Entries): Boolean;
  2720. begin
  2721.   if IDDPalette <> nil then
  2722.   begin
  2723.     DXResult := IPalette.GetEntries(0, StartIndex, NumEntries, @Entries);
  2724.     Result := DXResult = DD_OK;
  2725.   end else
  2726.     Result := False;
  2727. end;
  2728.  
  2729. function TDirectDrawPalette.GetEntry(Index: Integer): TPaletteEntry;
  2730. begin
  2731.   GetEntries(Index, 1, Result);
  2732. end;
  2733.  
  2734. function TDirectDrawPalette.GetIDDPalette: IDirectDrawPalette;
  2735. begin
  2736.   if Self <> nil then
  2737.     Result := FIDDPalette
  2738.   else
  2739.     Result := nil;
  2740. end;
  2741.  
  2742. function TDirectDrawPalette.GetIPalette: IDirectDrawPalette;
  2743. begin
  2744.   Result := IDDPalette;
  2745.   if Result = nil then
  2746.     raise EDirectDrawPaletteError.CreateFmt(SNotMade, ['IDirectDrawPalette']);
  2747. end;
  2748.  
  2749. function TDirectDrawPalette.SetEntries(StartIndex, NumEntries: Integer;
  2750.   const Entries): Boolean;
  2751. begin
  2752.   if IDDPalette <> nil then
  2753.   begin
  2754.     DXResult := IPalette.SetEntries(0, StartIndex, NumEntries, @Entries);
  2755.     Result := DXResult = DD_OK;
  2756.   end else
  2757.     Result := False;
  2758. end;
  2759.  
  2760. procedure TDirectDrawPalette.SetEntry(Index: Integer; Value: TPaletteEntry);
  2761. begin
  2762.   SetEntries(Index, 1, Value);
  2763. end;
  2764.  
  2765. procedure TDirectDrawPalette.SetIDDPalette(Value: IDirectDrawPalette);
  2766. begin
  2767.   if FIDDPalette = Value then Exit;
  2768.   FIDDPalette := Value;
  2769. end;
  2770.  
  2771. {  TDirectDrawClipper  }
  2772.  
  2773. constructor TDirectDrawClipper.Create(ADirectDraw: TDirectDraw);
  2774. begin
  2775.   inherited Create;
  2776.   FDDraw := ADirectDraw;
  2777.   FDDraw.FClippers.Add(Self);
  2778.  
  2779.   FDDraw.DXResult := FDDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.CreateClipper(0, FIDDClipper, nil);
  2780.   if FDDraw.DXResult <> DD_OK then
  2781.     raise EDirectDrawClipperError.CreateFmt(SCannotMade, [SDirectDrawClipper]);
  2782. end;
  2783.  
  2784. destructor TDirectDrawClipper.Destroy;
  2785. begin
  2786.   FDDraw.FClippers.Remove(Self);
  2787.   inherited Destroy;
  2788. end;
  2789.  
  2790. function TDirectDrawClipper.GetIDDClipper: IDirectDrawClipper;
  2791. begin
  2792.   if Self <> nil then
  2793.     Result := FIDDClipper
  2794.   else
  2795.     Result := nil;
  2796. end;
  2797.  
  2798. function TDirectDrawClipper.GetIClipper: IDirectDrawClipper;
  2799. begin
  2800.   Result := IDDClipper;
  2801.   if Result = nil then
  2802.     raise EDirectDrawClipperError.CreateFmt(SNotMade, ['IDirectDrawClipper']);
  2803. end;
  2804.  
  2805. procedure TDirectDrawClipper.SetClipRects(const Rects: array of TRect);
  2806. type
  2807.   PArrayRect = ^TArrayRect;
  2808.   TArrayRect = array[0..0] of TRect;
  2809. var
  2810.   RgnData: PRgnData;
  2811.   i: Integer;
  2812.   BoundsRect: TRect;
  2813. begin
  2814.   BoundsRect := Rect(MaxInt, MaxInt, -MaxInt, -MaxInt);
  2815.   for i := Low(Rects) to High(Rects) do
  2816.   begin
  2817.     with BoundsRect do
  2818.     begin
  2819.       Left := Min(Rects[i].Left, Left);
  2820.       Right := Max(Rects[i].Right, Right);
  2821.       Top := Min(Rects[i].Top, Top);
  2822.       Bottom := Max(Rects[i].Bottom, Bottom);
  2823.     end;
  2824.   end;
  2825.  
  2826.   GetMem(RgnData, SizeOf(TRgnDataHeader) + SizeOf(TRect) * (High(Rects) - Low(Rects) + 1));
  2827.   try
  2828.     with RgnData^.rdh do
  2829.     begin
  2830.       dwSize := SizeOf(TRgnDataHeader);
  2831.       iType := RDH_RECTANGLES;
  2832.       nCount := High(Rects) - Low(Rects) + 1;
  2833.       nRgnSize := nCount * SizeOf(TRect);
  2834.       rcBound := BoundsRect;
  2835.     end;
  2836.     for i := Low(Rects) to High(Rects) do
  2837.       PArrayRect(@RgnData^.Buffer)^[i - Low(Rects)] := Rects[i];
  2838.     DXResult := IClipper.SetClipList(RgnData, 0);
  2839.   finally
  2840.     FreeMem(RgnData);
  2841.   end;
  2842. end;
  2843.  
  2844. procedure TDirectDrawClipper.SetHandle(Value: THandle);
  2845. begin
  2846.   DXResult := IClipper.SetHWnd(0, Value);
  2847. end;
  2848.  
  2849. procedure TDirectDrawClipper.SetIDDClipper(Value: IDirectDrawClipper);
  2850. begin
  2851.   if FIDDClipper = Value then Exit;
  2852.   FIDDClipper := Value;
  2853. end;
  2854.  
  2855. {  TDirectDrawSurfaceCanvas  }
  2856.  
  2857. constructor TDirectDrawSurfaceCanvas.Create(ASurface: TDirectDrawSurface);
  2858. begin
  2859.   inherited Create;
  2860.   FSurface := ASurface;
  2861. end;
  2862.  
  2863. destructor TDirectDrawSurfaceCanvas.Destroy;
  2864. begin
  2865.   Release;
  2866.   FSurface.FCanvas := nil;
  2867.   inherited Destroy;
  2868. end;
  2869.  
  2870. procedure TDirectDrawSurfaceCanvas.CreateHandle;
  2871. begin
  2872.   FSurface.DXResult := FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetDC(FDC);
  2873.   if FSurface.DXResult = DD_OK then
  2874.     Handle := FDC;
  2875. end;
  2876.  
  2877. procedure TDirectDrawSurfaceCanvas.Release;
  2878. begin
  2879.   if (FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) and (FDC <> 0) then
  2880.   begin
  2881.     Handle := 0;
  2882.     FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF}.ReleaseDC(FDC);
  2883.     FDC := 0;
  2884.   end;
  2885. end;
  2886.  
  2887. {  TDirectDrawSurface  }
  2888.  
  2889. constructor TDirectDrawSurface.Create(ADirectDraw: TDirectDraw);
  2890. begin
  2891.   inherited Create;
  2892.   FDDraw := ADirectDraw;
  2893.   FDDraw.FSurfaces.Add(Self);
  2894.   DIB_COLMATCH := TDIB.Create;
  2895. end;
  2896.  
  2897. destructor TDirectDrawSurface.Destroy;
  2898. begin
  2899.   DIB_COLMATCH.Free;
  2900.   FCanvas.Free;
  2901.   {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil;
  2902.   FDDraw.FSurfaces.Remove(Self);
  2903.   inherited Destroy;
  2904. end;
  2905. {$IFDEF D3D_deprecated}
  2906. function TDirectDrawSurface.GetIDDSurface: IDirectDrawSurface;
  2907. begin
  2908.   if Self <> nil then
  2909.     Result := FIDDSurface
  2910.   else
  2911.     Result := nil;
  2912. end;
  2913.  
  2914. function TDirectDrawSurface.GetIDDSurface4: IDirectDrawSurface4;
  2915. begin
  2916.   if Self <> nil then
  2917.     Result := FIDDSurface4
  2918.   else
  2919.     Result := nil;
  2920. end;
  2921. {$ENDIF}
  2922. function TDirectDrawSurface.GetIDDSurface7: IDirectDrawSurface7;
  2923. begin
  2924.   if Self <> nil then
  2925.     Result := FIDDSurface7
  2926.   else
  2927.     Result := nil;
  2928. end;
  2929. {$IFDEF D3D_deprecated}
  2930. function TDirectDrawSurface.GetISurface: IDirectDrawSurface;
  2931. begin
  2932.   Result := IDDSurface;
  2933.   if Result = nil then
  2934.     raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface']);
  2935. end;
  2936.  
  2937. function TDirectDrawSurface.GetISurface4: IDirectDrawSurface4;
  2938. begin
  2939.   Result := IDDSurface4;
  2940.   if Result = nil then
  2941.     raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface4']);
  2942. end;
  2943. {$ENDIF}
  2944. function TDirectDrawSurface.GetISurface7: IDirectDrawSurface7;
  2945. begin
  2946.   Result := IDDSurface7;
  2947.   if Result = nil then
  2948.     raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface7']);
  2949. end;
  2950. {$IFDEF D3D_deprecated}
  2951. procedure TDirectDrawSurface.SetIDDSurface(Value: IDirectDrawSurface);
  2952. var
  2953.   Clipper: IDirectDrawClipper;
  2954. begin
  2955.   if Value = nil then Exit;
  2956.   if Value as IDirectDrawSurface = FIDDSurface then Exit;
  2957.  
  2958.   FIDDSurface := nil;
  2959.   FIDDSurface4 := nil;
  2960.   FIDDSurface7 := nil;
  2961.  
  2962.   FStretchDrawClipper := nil;
  2963.   FGammaControl := nil;
  2964.   FHasClipper := False;
  2965.   FLockCount := 0;
  2966.   FillChar(FSurfaceDesc, SizeOf(FSurfaceDesc), 0);
  2967.  
  2968.   if Value <> nil then
  2969.   begin
  2970.     FIDDSurface := Value as IDirectDrawSurface;
  2971.     FIDDSurface4 := Value as IDirectDrawSurface4;
  2972.     if FDDraw.FIDDraw7 <> nil then FIDDSurface7 := Value as IDirectDrawSurface7;
  2973.  
  2974.     FHasClipper := (FIDDSurface.GetClipper(Clipper) = DD_OK) and (Clipper <> nil);
  2975.  
  2976.     FSurfaceDesc.dwSize := SizeOf(FSurfaceDesc);
  2977.     FIDDSurface.GetSurfaceDesc(FSurfaceDesc);
  2978.  
  2979.     if FDDraw.DriverCaps.dwCaps2 and DDCAPS2_PRIMARYGAMMA <> 0 then
  2980.       FIDDSurface.QueryInterface(IID_IDirectDrawGammaControl, FGammaControl);
  2981.   end;
  2982. end;
  2983.  
  2984. procedure TDirectDrawSurface.SetIDDSurface4(Value: IDirectDrawSurface4);
  2985. begin
  2986.   if Value = nil then
  2987.     SetIDDSurface(nil)
  2988.   else
  2989.     SetIDDSurface(Value as IDirectDrawSurface);
  2990. end;
  2991. {$ENDIF}
  2992. procedure TDirectDrawSurface.SetIDDSurface7(Value: IDirectDrawSurface7);
  2993. {$IFNDEF D3D_deprecated}
  2994. var
  2995.   Clipper: IDirectDrawClipper;
  2996. {$ENDIF}
  2997. begin
  2998.   {$IFDEF D3D_deprecated}
  2999.   if Value = nil then
  3000.     SetIDDSurface(nil)
  3001.   else
  3002.     SetIDDSurface(Value as IDirectDrawSurface);
  3003.   {$ELSE}
  3004.   if Value = nil then Exit;
  3005.   if Value as IDirectDrawSurface7 = FIDDSurface7 then Exit;
  3006.   FIDDSurface7 := nil;
  3007.  
  3008.   FStretchDrawClipper := nil;
  3009.   FGammaControl := nil;
  3010.   FHasClipper := False;
  3011.   FLockCount := 0;
  3012.   FillChar(FSurfaceDesc, SizeOf(FSurfaceDesc), 0);
  3013.  
  3014.   if Value <> nil then
  3015.   begin
  3016.     if FDDraw.FIDDraw7 <> nil then FIDDSurface7 := Value as IDirectDrawSurface7;
  3017.  
  3018.     FHasClipper := (FIDDSurface7.GetClipper(Clipper) = DD_OK) and (Clipper <> nil);
  3019.  
  3020.     FSurfaceDesc.dwSize := SizeOf(FSurfaceDesc);
  3021.     {$IFDEF D3D_deprecated}FIDDSurface{$ELSE}FIDDSurface7{$ENDIF}.GetSurfaceDesc(FSurfaceDesc);
  3022.  
  3023.     if FDDraw.DriverCaps.dwCaps2 and DDCAPS2_PRIMARYGAMMA <> 0 then
  3024.       {$IFDEF D3D_deprecated}FIDDSurface{$ELSE}FIDDSurface7{$ENDIF}.QueryInterface(IID_IDirectDrawGammaControl, FGammaControl);
  3025.   end;
  3026.   {$ENDIF}
  3027. end;
  3028.  
  3029. procedure TDirectDrawSurface.Assign(Source: TPersistent);
  3030. var
  3031.   TempSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface{$ELSE}IDirectDrawSurface7{$ENDIF};
  3032. begin
  3033.   if Source = nil then
  3034.     {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil
  3035.   else if Source is TGraphic then
  3036.     LoadFromGraphic(TGraphic(Source))
  3037.   else if Source is TPicture then
  3038.     LoadFromGraphic(TPicture(Source).Graphic)
  3039.   else if Source is TDirectDrawSurface then
  3040.   begin
  3041.     if TDirectDrawSurface(Source).{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} = nil then
  3042.       {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil
  3043.     else begin
  3044.       FDDraw.DXResult := FDDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.DuplicateSurface(TDirectDrawSurface(Source).{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF},
  3045.         TempSurface);
  3046.       if FDDraw.DXResult = 0 then
  3047.       begin
  3048.         {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := TempSurface;
  3049.       end;
  3050.     end;
  3051.   end else
  3052.     inherited Assign(Source);
  3053. end;
  3054.  
  3055. procedure TDirectDrawSurface.AssignTo(Dest: TPersistent);
  3056. begin
  3057.   if Dest is TBitmap then
  3058.   begin
  3059.     try
  3060.       TBitmap(Dest).PixelFormat := pf24bit;
  3061.       if BitCount >= 24 then {please accept the Alphachannel too}
  3062.         TBitmap(Dest).PixelFormat := pf32bit;
  3063.       TBitmap(Dest).Width := Width;
  3064.       TBitmap(Dest).Height := Height;
  3065.       TBitmap(Dest).Canvas.CopyRect(Rect(0, 0, TBitmap(Dest).Width, TBitmap(Dest).Height), Canvas, ClientRect);
  3066.     finally
  3067.       Canvas.Release;
  3068.     end
  3069.   end
  3070.   else
  3071.   if Dest is TDIB then
  3072.   begin
  3073.     try
  3074.       if BitCount >= 24 then {please accept the Alphachannel too}
  3075.         TDIB(Dest).SetSize(Width, Height, BitCount)
  3076.       else
  3077.         TDIB(Dest).SetSize(Width, Height, 24);
  3078.       TDIB(Dest).Canvas.CopyRect(Rect(0, 0, TDIB(Dest).Width, TDIB(Dest).Height), Canvas, ClientRect);
  3079.     finally
  3080.       Canvas.Release;
  3081.     end
  3082.   end else
  3083.     inherited AssignTo(Dest);
  3084. end;
  3085.  
  3086. function TDirectDrawSurface.Blt(const DestRect, SrcRect: TRect; Flags: DWORD;
  3087.   const DF: TDDBltFX; Source: TDirectDrawSurface): Boolean;
  3088. begin
  3089.   if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  3090.   begin
  3091.     DXResult := {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF}.Blt(@DestRect, Source.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF}, @SrcRect, DWORD(Flags), @DF);
  3092.     Result := DXResult = DD_OK;
  3093.   end else
  3094.     Result := False;
  3095. end;
  3096.  
  3097. function TDirectDrawSurface.BltFast(X, Y: Integer; const SrcRect: TRect;
  3098.   Flags: DWORD; Source: TDirectDrawSurface): Boolean;
  3099. begin
  3100.   if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  3101.   begin
  3102.     DXResult := {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF}.BltFast(X, Y, Source.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF}, @SrcRect, DWORD(Flags));
  3103.     Result := DXResult = DD_OK;
  3104.   end else
  3105.     Result := False;
  3106. end;
  3107.  
  3108. function TDirectDrawSurface.ColorMatch(Col: TColor): Integer;
  3109. var
  3110.   i, oldc: Integer;
  3111. begin
  3112.   if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  3113.   begin
  3114.     oldc := Pixels[0, 0];
  3115.  
  3116.       i := ColorToRGB(Col);
  3117.       DIB_COLMATCH.SetSize(1, 1, 8);
  3118.       DIB_COLMATCH.ColorTable[0] := RGBQuad(GetRValue(i), GetGValue(i), GetBValue(i));
  3119.       DIB_COLMATCH.UpdatePalette;
  3120.       DIB_COLMATCH.Pixels[0, 0] := 0;
  3121.  
  3122.       with Canvas do
  3123.       try
  3124.         Draw(0, 0, DIB_COLMATCH);
  3125.       finally
  3126.         Release;
  3127.       end;
  3128.  
  3129.     Result := Pixels[0, 0];
  3130.     Pixels[0, 0] := oldc;
  3131.   end else
  3132.     Result := 0;
  3133. end;
  3134.  
  3135. {$IFDEF D3D_deprecated}
  3136. function TDirectDrawSurface.CreateSurface(SurfaceDesc: TDDSurfaceDesc): Boolean;
  3137. var
  3138.   TempSurface: IDirectDrawSurface;
  3139. begin
  3140.   IDDSurface := nil;
  3141.  
  3142.   FDDraw.DXResult := FDDraw.IDraw.CreateSurface(SurfaceDesc, TempSurface, nil);
  3143.   FDXResult := FDDraw.DXResult;
  3144.   Result := FDDraw.DXResult = DD_OK;
  3145.   if Result then
  3146.   begin
  3147.     IDDSurface := TempSurface;
  3148.     TransparentColor := 0;
  3149.   end;
  3150. end;
  3151. {$ENDIF}
  3152. {$IFDEF VER4UP}
  3153. function TDirectDrawSurface.CreateSurface(SurfaceDesc: TDDSurfaceDesc2): Boolean;
  3154. var
  3155.   TempSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF};
  3156. begin
  3157.   {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil;
  3158.   FDDraw.DXResult := FDDraw.{$IFDEF D3D_deprecated}IDraw4{$ELSE}IDraw7{$ENDIF}.CreateSurface(SurfaceDesc, TempSurface, nil);
  3159.   FDXResult := FDDraw.DXResult;
  3160.   Result := FDDraw.DXResult = DD_OK;
  3161.   if Result then
  3162.   begin
  3163.     {$IFDEF D3D_deprecated}IDDSurface4{$ELSE}IDDSurface7{$ENDIF} := TempSurface;
  3164.     TransparentColor := 0;
  3165.   end;
  3166. end;
  3167. {$ENDIF}
  3168.  
  3169. procedure TDirectDrawSurface.Draw(X, Y: Integer; SrcRect: TRect; Source: TDirectDrawSurface;
  3170.   Transparent: Boolean);
  3171. const
  3172.   BltFastFlags: array[Boolean] of Integer =
  3173.   (DDBLTFAST_NOCOLORKEY or DDBLTFAST_WAIT, DDBLTFAST_SRCCOLORKEY or DDBLTFAST_WAIT);
  3174.   BltFlags: array[Boolean] of Integer =
  3175.   (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
  3176. {$IFDEF DXR_deprecated}var
  3177.   DestRect: TRect;
  3178.   DF: TDDBltFX;
  3179.   Clipper: IDirectDrawClipper;
  3180.   i: Integer;{$ENDIF}
  3181. begin
  3182.   if Source <> nil then
  3183.   begin
  3184.     if (X > Width) or (Y > Height) then Exit;
  3185. {$IFDEF DrawHWAcc}
  3186.     if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then
  3187.     begin
  3188.       {$IFDEF VER4UP}
  3189.       D2D.D2DRenderDrawDDSXY(Source, X, Y, SrcRect, Transparent, 0, rtDraw{$IFNDEF VER4UP}, $FF{$ENDIF});
  3190.       {$ELSE}
  3191.       D2D.D2DRenderDDS(Source, SrcRect, Bounds(X, Y, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top), Transparent, 0, rtDraw, $FF);
  3192.       {$ENDIF}
  3193.       Exit;
  3194.     end;
  3195. {$ENDIF DrawHWAcc}
  3196.     {$IFDEF DXR_deprecated}
  3197.     if (SrcRect.Left > SrcRect.Right) or (SrcRect.Top > SrcRect.Bottom) then
  3198.     begin
  3199.       {  Mirror  }
  3200.       if ((X + Abs(SrcRect.Left - SrcRect.Right)) <= 0) or
  3201.         ((Y + Abs(SrcRect.Top - SrcRect.Bottom)) <= 0) then Exit;
  3202.  
  3203.       DF.dwsize := SizeOf(DF);
  3204.       DF.dwDDFX := 0;
  3205.  
  3206.       if SrcRect.Left > SrcRect.Right then
  3207.       begin
  3208.         i := SrcRect.Left; SrcRect.Left := SrcRect.Right; SrcRect.Right := i;
  3209.         DF.dwDDFX := DF.dwDDFX or DDBLTFX_MIRRORLEFTRIGHT;
  3210.       end;
  3211.  
  3212.       if SrcRect.Top > SrcRect.Bottom then
  3213.       begin
  3214.         i := SrcRect.Top; SrcRect.Top := SrcRect.Bottom; SrcRect.Bottom := i;
  3215.         DF.dwDDFX := DF.dwDDFX or DDBLTFX_MIRRORUPDOWN;
  3216.       end;
  3217.  
  3218.       with SrcRect do
  3219.         DestRect := Bounds(X, Y, Right - Left, Bottom - Top);
  3220.  
  3221.       if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
  3222.       begin
  3223.         if DF.dwDDFX and DDBLTFX_MIRRORLEFTRIGHT <> 0 then
  3224.         begin
  3225.           i := SrcRect.Left;
  3226.           SrcRect.Left := Source.Width - SrcRect.Right;
  3227.           SrcRect.Right := Source.Width - i;
  3228.         end;
  3229.  
  3230.         if DF.dwDDFX and DDBLTFX_MIRRORUPDOWN <> 0 then
  3231.         begin
  3232.           i := SrcRect.Top;
  3233.           SrcRect.Top := Source.Height - SrcRect.Bottom;
  3234.           SrcRect.Bottom := Source.Height - i;
  3235.         end;
  3236.  
  3237.         Blt(DestRect, SrcRect, BltFlags[Transparent] or DDBLT_DDFX, df, Source);
  3238.       end;
  3239.     end else
  3240.     begin
  3241.       with SrcRect do
  3242.         DestRect := Bounds(X, Y, Right - Left, Bottom - Top);
  3243.  
  3244.       if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
  3245.       begin
  3246.         if FHasClipper then
  3247.         begin
  3248.           DF.dwsize := SizeOf(DF);
  3249.           DF.dwDDFX := 0;
  3250.           Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  3251.         end else
  3252.         begin
  3253.           BltFast(DestRect.Left, DestRect.Top, SrcRect, BltFastFlags[Transparent], Source);
  3254.           if DXResult = DDERR_BLTFASTCANTCLIP then
  3255.           begin
  3256.             {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetClipper(Clipper);
  3257.             if Clipper <> nil then FHasClipper := True;
  3258.  
  3259.             DF.dwsize := SizeOf(DF);
  3260.             DF.dwDDFX := 0;
  3261.             Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  3262.           end;
  3263.         end;
  3264.       end;
  3265.     end;
  3266.     {$ENDIF}
  3267.   end;
  3268. end;
  3269.  
  3270. {$IFDEF VER4UP}
  3271. procedure TDirectDrawSurface.Draw(X, Y: Integer; Source: TDirectDrawSurface; Transparent: Boolean);
  3272. const
  3273.   BltFastFlags: array[Boolean] of Integer =
  3274.   (DDBLTFAST_NOCOLORKEY or DDBLTFAST_WAIT, DDBLTFAST_SRCCOLORKEY or DDBLTFAST_WAIT);
  3275.   BltFlags: array[Boolean] of Integer =
  3276.   (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
  3277. var
  3278.   DestRect, SrcRect: TRect;
  3279.   {$IFDEF DXR_deprecated}DF: TDDBltFX;
  3280.   Clipper: IDirectDrawClipper;{$ENDIF}
  3281. begin
  3282.   if Source <> nil then
  3283.   begin
  3284.     SrcRect := Source.ClientRect;
  3285.     DestRect := Bounds(X, Y, Source.Width, Source.Height);
  3286.     {$IFDEF DrawHWAcc}
  3287.     if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3288.       D2D.D2DRenderDDS(Source, ZeroRect, DestRect, Transparent, 0, rtDraw{$IFNDEF VER4UP}, $FF{$ENDIF});
  3289.       Exit;
  3290.     end;
  3291.     {$ENDIF DrawHWAcc}
  3292.     {$IFDEF DXR_deprecated}
  3293.     if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
  3294.     begin
  3295.       if FHasClipper then
  3296.       begin
  3297.         DF.dwsize := SizeOf(DF);
  3298.         DF.dwDDFX := 0;
  3299.         Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  3300.       end else
  3301.       begin
  3302.         BltFast(DestRect.Left, DestRect.Top, SrcRect, BltFastFlags[Transparent], Source);
  3303.         if DXResult = DDERR_BLTFASTCANTCLIP then
  3304.         begin
  3305.           {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetClipper(Clipper);
  3306.           if Clipper <> nil then FHasClipper := True;
  3307.  
  3308.           DF.dwsize := SizeOf(DF);
  3309.           DF.dwDDFX := 0;
  3310.           Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  3311.         end;
  3312.       end;
  3313.     end;
  3314.     {$ENDIF}
  3315.   end;
  3316. end;
  3317. {$ENDIF}
  3318.  
  3319. procedure TDirectDrawSurface.StretchDraw(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  3320.   Transparent: Boolean);
  3321. const
  3322.   BltFlags: array[Boolean] of Integer =
  3323.   (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
  3324. {$IFDEF DXR_deprecated}var
  3325.   DF: TDDBltFX;
  3326.   OldClipper: IDirectDrawClipper;
  3327.   Clipper: TDirectDrawClipper;{$ENDIF}
  3328. begin
  3329.   if Source <> nil then
  3330.   begin
  3331.     if (DestRect.Bottom <= DestRect.Top) or (DestRect.Right <= DestRect.Left) then Exit;
  3332.     if (SrcRect.Bottom <= SrcRect.Top) or (SrcRect.Right <= SrcRect.Left) then Exit;
  3333.     {$IFDEF DrawHWAcc}
  3334.     if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3335.       D2D.D2DRenderDDS(Source, SrcRect, DestRect, Transparent, 0, rtDraw{$IFNDEF VER4UP}, $FF{$ENDIF});
  3336.       Exit;
  3337.     end;
  3338.     {$ENDIF DrawHWAcc}
  3339.     {$IFDEF DXR_deprecated}
  3340.     if FHasClipper then
  3341.     begin
  3342.       DF.dwsize := SizeOf(DF);
  3343.       DF.dwDDFX := 0;
  3344.       Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  3345.     end else
  3346.     begin
  3347.       if FStretchDrawClipper = nil then
  3348.       begin
  3349.         Clipper := TDirectDrawClipper.Create(DDraw);
  3350.         try
  3351.           Clipper.SetClipRects([ClientRect]);
  3352.           FStretchDrawClipper := Clipper.IClipper;
  3353.         finally
  3354.           Clipper.Free;
  3355.         end;
  3356.       end;
  3357.  
  3358.       {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetClipper(OldClipper);
  3359.       {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetClipper(FStretchDrawClipper);
  3360.       DF.dwsize := SizeOf(DF);
  3361.       DF.dwDDFX := 0;
  3362.       Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  3363.       {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetClipper(nil);
  3364.     end;
  3365.     {$ENDIF}
  3366.   end;
  3367. end;
  3368.  
  3369. {$IFDEF VER4UP}
  3370. procedure TDirectDrawSurface.StretchDraw(const DestRect: TRect; Source: TDirectDrawSurface;
  3371.   Transparent: Boolean);
  3372. const
  3373.   BltFlags: array[Boolean] of Integer = (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
  3374. var
  3375.   {$IFDEF DXR_deprecated}DF: TDDBltFX;
  3376.   OldClipper: IDirectDrawClipper;
  3377.   Clipper: TDirectDrawClipper;{$ENDIF}
  3378.   SrcRect: TRect;
  3379. begin
  3380.   if Source <> nil then
  3381.   begin
  3382.     if (DestRect.Bottom <= DestRect.Top) or (DestRect.Right <= DestRect.Left) then Exit;
  3383.     SrcRect := Source.ClientRect;
  3384.  
  3385.     if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3386.       D2D.D2DRenderDDS(Source, ZeroRect, DestRect, Transparent, 0, rtDraw{$IFNDEF VER4UP}, $FF{$ENDIF});
  3387.       Exit;
  3388.     end;
  3389.     {$IFDEF DXR_deprecated}
  3390.     if {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetClipper(OldClipper) = DD_OK then
  3391.     begin
  3392.       DF.dwsize := SizeOf(DF);
  3393.       DF.dwDDFX := 0;
  3394.       Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  3395.     end else
  3396.     begin
  3397.       if FStretchDrawClipper = nil then
  3398.       begin
  3399.         Clipper := TDirectDrawClipper.Create(DDraw);
  3400.         try
  3401.           Clipper.SetClipRects([ClientRect]);
  3402.           FStretchDrawClipper := Clipper.IClipper;
  3403.         finally
  3404.           Clipper.Free;
  3405.         end;
  3406.       end;
  3407.  
  3408.       {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetClipper(FStretchDrawClipper);
  3409.       try
  3410.         DF.dwsize := SizeOf(DF);
  3411.         DF.dwDDFX := 0;
  3412.         Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  3413.       finally
  3414.         {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetClipper(nil);
  3415.       end;
  3416.     end;
  3417.     {$ENDIF}
  3418.   end;
  3419. end;
  3420. {$ENDIF}
  3421.  
  3422. procedure TDirectDrawSurface.DrawAdd(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  3423.   Transparent: Boolean; Alpha: Integer);
  3424. {$IFDEF DXR_deprecated}var
  3425.   Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  3426.   DestSurface, SrcSurface: TDXR_Surface;
  3427.   Blend: TDXR_Blend;{$ENDIF}
  3428. begin
  3429.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3430.   if (Width = 0) or (Height = 0) then Exit;
  3431.   if Source = nil then Exit;
  3432.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3433.  
  3434.   if Alpha <= 0 then Exit;
  3435.  
  3436.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3437.     D2D.D2DRenderDDS(Source, SrcRect, DestRect, Transparent, 0, rtAdd, Alpha);
  3438.     Exit;
  3439.   end;
  3440.   {$IFDEF DXR_deprecated}
  3441.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  3442.   begin
  3443.     try
  3444.       if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
  3445.       begin
  3446.         try
  3447.           if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
  3448.           begin
  3449.             Blend := DXR_BLEND_ONE1;
  3450.           end else
  3451.             if Alpha >= 255 then
  3452.             begin
  3453.               Blend := DXR_BLEND_ONE1_ADD_ONE2;
  3454.             end else
  3455.             begin
  3456.               Blend := DXR_BLEND_SRCALPHA1_ADD_ONE2;
  3457.             end;
  3458.  
  3459.           dxrCopyRectBlend(DestSurface, SrcSurface,
  3460.             DestRect, SrcRect, Blend, Alpha, Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  3461.         finally
  3462.           dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
  3463.         end;
  3464.       end;
  3465.     finally
  3466.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  3467.     end;
  3468.   end;
  3469.   {$ENDIF}
  3470. end;
  3471.  
  3472. procedure TDirectDrawSurface.DrawAlpha(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  3473.   Transparent: Boolean; Alpha: Integer);
  3474. {$IFDEF DXR_deprecated}var
  3475.   Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  3476.   DestSurface, SrcSurface: TDXR_Surface;
  3477.   Blend: TDXR_Blend;{$ENDIF}
  3478. begin
  3479.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3480.   if (Width = 0) or (Height = 0) then Exit;
  3481.   if Source = nil then Exit;
  3482.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3483.  
  3484.   if Alpha <= 0 then Exit;
  3485.  
  3486.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3487.     D2D.D2DRenderDDS(Source, SrcRect, DestRect, Transparent, 0, rtBlend, Alpha);
  3488.     Exit;
  3489.   end;
  3490.   {$IFDEF DXR_deprecated}
  3491.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  3492.   begin
  3493.     try
  3494.       if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
  3495.       begin
  3496.         try
  3497.           if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
  3498.           begin
  3499.             Blend := DXR_BLEND_ONE1;
  3500.           end else
  3501.             if Alpha >= 255 then
  3502.             begin
  3503.               Blend := DXR_BLEND_ONE1;
  3504.             end else
  3505.             begin
  3506.               Blend := DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2;
  3507.             end;
  3508.  
  3509.           dxrCopyRectBlend(DestSurface, SrcSurface,
  3510.             DestRect, SrcRect, Blend, Alpha, Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  3511.         finally
  3512.           dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
  3513.         end;
  3514.       end;
  3515.     finally
  3516.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  3517.     end;
  3518.   end;
  3519.   {$ENDIF}
  3520. end;
  3521.  
  3522. procedure TDirectDrawSurface.DrawSub(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  3523.   Transparent: Boolean; Alpha: Integer);
  3524. {$IFDEF DXR_deprecated}var
  3525.   Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  3526.   DestSurface, SrcSurface: TDXR_Surface;
  3527.   Blend: TDXR_Blend;{$ENDIF}
  3528. begin
  3529.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3530.   if (Width = 0) or (Height = 0) then Exit;
  3531.   if Source = nil then Exit;
  3532.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3533.  
  3534.   if Alpha <= 0 then Exit;
  3535.  
  3536.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3537.     D2D.D2DRenderDDS(Source, SrcRect, DestRect, Transparent, 0, rtSub, Alpha);
  3538.     Exit;
  3539.   end;
  3540.   {$IFDEF DXR_deprecated}
  3541.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  3542.   begin
  3543.     try
  3544.       if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
  3545.       begin
  3546.         try
  3547.           if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
  3548.           begin
  3549.             Blend := DXR_BLEND_ONE1;
  3550.           end else
  3551.             if Alpha >= 255 then
  3552.             begin
  3553.               Blend := DXR_BLEND_ONE2_SUB_ONE1;
  3554.             end else
  3555.             begin
  3556.               Blend := DXR_BLEND_ONE2_SUB_SRCALPHA1;
  3557.             end;
  3558.  
  3559.           dxrCopyRectBlend(DestSurface, SrcSurface,
  3560.             DestRect, SrcRect, Blend, Alpha, Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  3561.         finally
  3562.           dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
  3563.         end;
  3564.       end;
  3565.     finally
  3566.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  3567.     end;
  3568.   end;
  3569.   {$ENDIF}
  3570. end;
  3571.  
  3572. procedure TDirectDrawSurface.DrawAlphaCol(const DestRect, SrcRect: TRect;
  3573.   Source: TDirectDrawSurface; Transparent: Boolean; Color, Alpha: Integer);
  3574. begin
  3575.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3576.   if (Width = 0) or (Height = 0) then Exit;
  3577.   if Source = nil then Exit;
  3578.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3579.  
  3580.   if Alpha <= 0 then Exit;
  3581.  
  3582.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3583.     D2D.D2DRenderColDDS(Source, SrcRect, DestRect, Transparent, 0, Color, rtBlend, Alpha);
  3584.     Exit;
  3585.   end;
  3586.  
  3587.   // If no hardware acceleration, falls back to non-color DrawAlpha
  3588.   Self.DrawAlpha(DestRect, SrcRect, Source, Transparent, Alpha);
  3589. end;
  3590.  
  3591. procedure TDirectDrawSurface.DrawSubCol(const DestRect, SrcRect: TRect;
  3592.   Source: TDirectDrawSurface; Transparent: Boolean; Color, Alpha: Integer);
  3593. begin
  3594.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3595.   if (Width = 0) or (Height = 0) then Exit;
  3596.   if Source = nil then Exit;
  3597.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3598.  
  3599.   if Alpha <= 0 then Exit;
  3600.  
  3601.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3602.     D2D.D2DRenderColDDS(Source, SrcRect, DestRect, Transparent, 0, Color, rtSub, Alpha);
  3603.     Exit;
  3604.   end;
  3605.  
  3606.   // If no hardware acceleration, falls back to non-color DrawSub
  3607.   Self.DrawSub(DestRect, SrcRect, Source, Transparent, Alpha);
  3608. end;
  3609.  
  3610. procedure TDirectDrawSurface.DrawAddCol(const DestRect, SrcRect: TRect;
  3611.   Source: TDirectDrawSurface; Transparent: Boolean; Color, Alpha: Integer);
  3612. begin
  3613.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3614.   if (Width = 0) or (Height = 0) then Exit;
  3615.   if Source = nil then Exit;
  3616.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3617.  
  3618.   if Alpha <= 0 then Exit;
  3619.  
  3620.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3621.     D2D.D2DRenderColDDS(Source, SrcRect, DestRect, Transparent, 0, Color, rtAdd, Alpha);
  3622.     Exit;
  3623.   end;
  3624.  
  3625.   // If no hardware acceleration, falls back to non-color DrawAdd
  3626.   Self.DrawAdd(DestRect, SrcRect, Source, Transparent, Alpha);
  3627.  
  3628. end;
  3629.  
  3630. procedure TDirectDrawSurface.DrawRotate(X, Y, Width, Height: Integer; const SrcRect: TRect;
  3631.   Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: single);
  3632. {$IFDEF DXR_deprecated}var
  3633.   Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  3634.   DestSurface, SrcSurface: TDXR_Surface;{$ENDIF}
  3635. begin
  3636.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3637.   if (Width = 0) or (Height = 0) then Exit;
  3638.   if Source = nil then Exit;
  3639.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3640.  
  3641.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3642.     D2D.D2DRenderRotateDDS(Source, SrcRect, X, Y, Width, Height, rtDraw, CenterX, CenterY, Angle, $FF, Transparent);
  3643.     Exit;
  3644.   end;
  3645.   {$IFDEF DXR_deprecated}
  3646.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  3647.   begin
  3648.     try
  3649.       if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
  3650.       begin
  3651.         try
  3652.           dxrDrawRotateBlend(DestSurface, SrcSurface,
  3653.             X, Y, Width, Height, SrcRect, CenterX, CenterY, round(Angle), DXR_BLEND_ONE1, 0,
  3654.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  3655.         finally
  3656.           dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
  3657.         end;
  3658.       end;
  3659.     finally
  3660.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  3661.     end;
  3662.   end;
  3663.   {$ENDIF}
  3664. end;
  3665.  
  3666. procedure TDirectDrawSurface.DrawRotateAdd(X, Y, Width, Height: Integer; const SrcRect: TRect;
  3667.   Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: single; Alpha: Integer);
  3668. {$IFDEF DXR_deprecated}var
  3669.   Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  3670.   DestSurface, SrcSurface: TDXR_Surface;
  3671.   Blend: TDXR_Blend; {$ENDIF}
  3672. begin
  3673.   if Alpha <= 0 then Exit;
  3674.  
  3675.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3676.   if (Width = 0) or (Height = 0) then Exit;
  3677.   if Source = nil then Exit;
  3678.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3679.  
  3680.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3681.     D2D.D2DRenderRotateDDS(Source, SrcRect, X, Y, Width, Height, rtAdd, CenterX, CenterY, Angle, Alpha, Transparent);
  3682.     Exit;
  3683.   end;
  3684.   {$IFDEF DXR_deprecated}
  3685.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  3686.   begin
  3687.     try
  3688.       if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
  3689.       begin
  3690.         try
  3691.           if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
  3692.           begin
  3693.             Blend := DXR_BLEND_ONE1;
  3694.           end else
  3695.             if Alpha >= 255 then
  3696.             begin
  3697.               Blend := DXR_BLEND_ONE1_ADD_ONE2;
  3698.             end else
  3699.             begin
  3700.               Blend := DXR_BLEND_SRCALPHA1_ADD_ONE2;
  3701.             end;
  3702.  
  3703.           dxrDrawRotateBlend(DestSurface, SrcSurface,
  3704.             X, Y, Width, Height, SrcRect, CenterX, CenterY, round(Angle), Blend, Alpha,
  3705.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  3706.         finally
  3707.           dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
  3708.         end;
  3709.       end;
  3710.     finally
  3711.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  3712.     end;
  3713.   end;
  3714.   {$ENDIF}
  3715. end;
  3716.  
  3717. procedure TDirectDrawSurface.DrawRotateAlpha(X, Y, Width, Height: Integer; const SrcRect: TRect;
  3718.   Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: single; Alpha: Integer);
  3719. {$IFDEF DXR_deprecated}var
  3720.   Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  3721.   DestSurface, SrcSurface: TDXR_Surface;
  3722.   Blend: TDXR_Blend; {$ENDIF}
  3723. begin
  3724.   if Alpha <= 0 then Exit;
  3725.  
  3726.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3727.   if (Width = 0) or (Height = 0) then Exit;
  3728.   if Source = nil then Exit;
  3729.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3730.  
  3731.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3732.     D2D.D2DRenderRotateDDS(Source, SrcRect, X, Y, Width, Height, rtBlend, CenterX, CenterY, Angle, Alpha, Transparent);
  3733.     Exit;
  3734.   end;
  3735.   {$IFDEF DXR_deprecated}
  3736.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  3737.   begin
  3738.     try
  3739.       if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
  3740.       begin
  3741.         try
  3742.           if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
  3743.           begin
  3744.             Blend := DXR_BLEND_ONE1;
  3745.           end else
  3746.             if Alpha >= 255 then
  3747.             begin
  3748.               Blend := DXR_BLEND_ONE1;
  3749.             end else
  3750.             begin
  3751.               Blend := DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2;
  3752.             end;
  3753.  
  3754.           dxrDrawRotateBlend(DestSurface, SrcSurface,
  3755.             X, Y, Width, Height, SrcRect, CenterX, CenterY, round(Angle), Blend, Alpha,
  3756.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  3757.         finally
  3758.           dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
  3759.         end;
  3760.       end;
  3761.     finally
  3762.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  3763.     end;
  3764.   end;
  3765.   {$ENDIF}
  3766. end;
  3767.  
  3768. procedure TDirectDrawSurface.DrawRotateSub(X, Y, Width, Height: Integer; const SrcRect: TRect;
  3769.   Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: single; Alpha: Integer);
  3770. {$IFDEF DXR_deprecated}var
  3771.   Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  3772.   DestSurface, SrcSurface: TDXR_Surface;
  3773.   Blend: TDXR_Blend;{$ENDIF}
  3774. begin
  3775.   if Alpha <= 0 then Exit;
  3776.  
  3777.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3778.   if (Width = 0) or (Height = 0) then Exit;
  3779.   if Source = nil then Exit;
  3780.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3781.  
  3782.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3783.     D2D.D2DRenderRotateDDS(Source, SrcRect, X, Y, Width, Height, rtSub, CenterX, CenterY, Angle, Alpha, Transparent);
  3784.     Exit;
  3785.   end;
  3786.   {$IFDEF DXR_deprecated}
  3787.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  3788.   begin
  3789.     try
  3790.       if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
  3791.       begin
  3792.         try
  3793.           if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
  3794.           begin
  3795.             Blend := DXR_BLEND_ONE1;
  3796.           end else
  3797.             if Alpha >= 255 then
  3798.             begin
  3799.               Blend := DXR_BLEND_ONE2_SUB_ONE1;
  3800.             end else
  3801.             begin
  3802.               Blend := DXR_BLEND_ONE2_SUB_SRCALPHA1;
  3803.             end;
  3804.  
  3805.           dxrDrawRotateBlend(DestSurface, SrcSurface,
  3806.             X, Y, Width, Height, SrcRect, CenterX, CenterY, round(Angle), Blend, Alpha,
  3807.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  3808.         finally
  3809.           dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
  3810.         end;
  3811.       end;
  3812.     finally
  3813.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  3814.     end;
  3815.   end;
  3816.   {$ENDIF}
  3817. end;
  3818.  
  3819. procedure TDirectDrawSurface.DrawRotateCol(X, Y, Width, Height: Integer; const SrcRect: TRect;
  3820.   Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Single; Color: Integer);
  3821. begin
  3822.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3823.   if (Width = 0) or (Height = 0) then Exit;
  3824.   if Source = nil then Exit;
  3825.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3826.  
  3827.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3828.     D2D.D2DRenderRotateModeColDDS(Source, X, Y, Width, Height, rtDraw, CenterX, CenterY, Angle, Color, $FF, Transparent);
  3829.     Exit;
  3830.   end;
  3831.  
  3832.   // If no hardware acceleration, falls back to non-color, moded DrawRotate
  3833.   Self.DrawRotate(X, Y, Width, Height, SrcRect, Source, CenterX, CenterY, Transparent, Angle);
  3834. end;
  3835.  
  3836. procedure TDirectDrawSurface.DrawRotateAlphaCol(X, Y, Width, Height: Integer; const SrcRect: TRect;
  3837.   Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Single; Color, Alpha: Integer);
  3838. begin
  3839.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3840.   if (Width = 0) or (Height = 0) then Exit;
  3841.   if Source = nil then Exit;
  3842.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3843.  
  3844.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3845.     D2D.D2DRenderRotateModeColDDS(Source, X, Y, Width, Height, rtBlend, CenterX, CenterY, Angle, Color, Alpha, Transparent);
  3846.     Exit;
  3847.   end;
  3848.  
  3849.   // If no hardware acceleration, falls back to non-color, moded DrawRotate
  3850.   Self.DrawRotateAlpha(X, Y, Width, Height, SrcRect, Source, CenterX, CenterY, Transparent, Angle, Alpha);
  3851. end;
  3852.  
  3853. procedure TDirectDrawSurface.DrawRotateAddCol(X, Y, Width, Height: Integer; const SrcRect: TRect;
  3854.   Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Single; Color, Alpha: Integer);
  3855. begin
  3856.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3857.   if (Width = 0) or (Height = 0) then Exit;
  3858.   if Source = nil then Exit;
  3859.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3860.  
  3861.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3862.     D2D.D2DRenderRotateModeColDDS(Source, X, Y, Width, Height, rtAdd, CenterX, CenterY, Angle, Color, Alpha, Transparent);
  3863.     Exit;
  3864.   end;
  3865.  
  3866.   // If no hardware acceleration, falls back to non-color, moded DrawRotate
  3867.   Self.DrawRotateAdd(X, Y, Width, Height, SrcRect, Source, CenterX, CenterY, Transparent, Angle, Alpha);
  3868. end;
  3869.  
  3870. procedure TDirectDrawSurface.DrawRotateSubCol(X, Y, Width, Height: Integer; const SrcRect: TRect;
  3871.   Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Single; Color, Alpha: Integer);
  3872. begin
  3873.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3874.   if (Width = 0) or (Height = 0) then Exit;
  3875.   if Source = nil then Exit;
  3876.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3877.  
  3878.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3879.     D2D.D2DRenderRotateModeColDDS(Source, X, Y, Width, Height, rtSub, CenterX, CenterY, Angle, Color, Alpha, Transparent);
  3880.     Exit;
  3881.   end;
  3882.  
  3883.   // If no hardware acceleration, falls back to non-color, moded DrawRotate
  3884.   Self.DrawRotateSub(X, Y, Width, Height, SrcRect, Source, CenterX, CenterY, Transparent, Angle, Alpha);
  3885. end;
  3886.  
  3887. //waves
  3888.  
  3889. procedure TDirectDrawSurface.DrawWaveX(X, Y, Width, Height: Integer; const SrcRect: TRect;
  3890.   Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer);
  3891. {$IFDEF DXR_deprecated}var
  3892.   Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  3893.   DestSurface, SrcSurface: TDXR_Surface;{$ENDIF}
  3894. begin
  3895.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3896.   if (Width = 0) or (Height = 0) then Exit;
  3897.   if Source = nil then Exit;
  3898.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3899.  
  3900.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3901.     D2D.D2DRenderWaveXDDS(Source, X, Y, Width, Height, rtDraw, Transparent, amp, Len, ph{$IFNDEF VER4UP}, $FF{$ENDIF});
  3902.     Exit;
  3903.   end;
  3904.   {$IFDEF DXR_deprecated}
  3905.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  3906.   begin
  3907.     try
  3908.       if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
  3909.       begin
  3910.         try
  3911.           dxrDrawWaveXBlend(DestSurface, SrcSurface,
  3912.             X, Y, Width, Height, SrcRect, amp, Len, ph, DXR_BLEND_ONE1, 0,
  3913.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  3914.         finally
  3915.           dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
  3916.         end;
  3917.       end;
  3918.     finally
  3919.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  3920.     end;
  3921.   end;
  3922.   {$ENDIF}
  3923. end;
  3924.  
  3925. procedure TDirectDrawSurface.DrawWaveXAdd(X, Y, Width, Height: Integer; const SrcRect: TRect;
  3926.   Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph, Alpha: Integer);
  3927. {$IFDEF DXR_deprecated}var
  3928.   Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  3929.   DestSurface, SrcSurface: TDXR_Surface;
  3930.   Blend: TDXR_Blend;{$ENDIF}
  3931. begin
  3932.   if Alpha <= 0 then Exit;
  3933.  
  3934.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3935.   if (Width = 0) or (Height = 0) then Exit;
  3936.   if Source = nil then Exit;
  3937.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3938.  
  3939.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3940.     D2D.D2DRenderWaveXDDS(Source, X, Y, Width, Height, rtAdd, Transparent, amp, Len, ph, Alpha);
  3941.     Exit;
  3942.   end;
  3943.   {$IFDEF DXR_deprecated}
  3944.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  3945.   begin
  3946.     try
  3947.       if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
  3948.       begin
  3949.         try
  3950.           if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
  3951.           begin
  3952.             Blend := DXR_BLEND_ONE1;
  3953.           end else
  3954.             if Alpha >= 255 then
  3955.             begin
  3956.               Blend := DXR_BLEND_ONE1_ADD_ONE2;
  3957.             end else
  3958.             begin
  3959.               Blend := DXR_BLEND_SRCALPHA1_ADD_ONE2;
  3960.             end;
  3961.  
  3962.           dxrDrawWaveXBlend(DestSurface, SrcSurface,
  3963.             X, Y, Width, Height, SrcRect, amp, Len, ph, Blend, Alpha,
  3964.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  3965.         finally
  3966.           dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
  3967.         end;
  3968.       end;
  3969.     finally
  3970.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  3971.     end;
  3972.   end;
  3973.   {$ENDIF}
  3974. end;
  3975.  
  3976. procedure TDirectDrawSurface.DrawWaveXAlpha(X, Y, Width, Height: Integer; const SrcRect: TRect;
  3977.   Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph, Alpha: Integer);
  3978. {$IFDEF DXR_deprecated}
  3979. var
  3980.   Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  3981.   DestSurface, SrcSurface: TDXR_Surface;
  3982.   Blend: TDXR_Blend;{$ENDIF}
  3983. begin
  3984.   if Alpha <= 0 then Exit;
  3985.  
  3986.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  3987.   if (Width = 0) or (Height = 0) then Exit;
  3988.   if Source = nil then Exit;
  3989.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  3990.  
  3991.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  3992.     D2D.D2DRenderWaveXDDS(Source, X, Y, Width, Height, rtBlend, Transparent, amp, Len, ph, Alpha);
  3993.     Exit;
  3994.   end;
  3995.   {$IFDEF DXR_deprecated}
  3996.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  3997.   begin
  3998.     try
  3999.       if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
  4000.       begin
  4001.         try
  4002.           if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
  4003.           begin
  4004.             Blend := DXR_BLEND_ONE1;
  4005.           end else
  4006.             if Alpha >= 255 then
  4007.             begin
  4008.               Blend := DXR_BLEND_ONE1;
  4009.             end else
  4010.             begin
  4011.               Blend := DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2;
  4012.             end;
  4013.  
  4014.           dxrDrawWaveXBlend(DestSurface, SrcSurface,
  4015.             X, Y, Width, Height, SrcRect, amp, Len, ph, Blend, Alpha,
  4016.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  4017.         finally
  4018.           dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
  4019.         end;
  4020.       end;
  4021.     finally
  4022.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  4023.     end;
  4024.   end;
  4025.   {$ENDIF}
  4026. end;
  4027.  
  4028. procedure TDirectDrawSurface.DrawWaveXSub(X, Y, Width, Height: Integer; const SrcRect: TRect;
  4029.   Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph, Alpha: Integer);
  4030. {$IFDEF DXR_deprecated}
  4031. var
  4032.   Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  4033.   DestSurface, SrcSurface: TDXR_Surface;
  4034.   Blend: TDXR_Blend;{$ENDIF}
  4035. begin
  4036.   if Alpha <= 0 then Exit;
  4037.  
  4038.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  4039.   if (Width = 0) or (Height = 0) then Exit;
  4040.   if Source = nil then Exit;
  4041.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  4042.  
  4043.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  4044.     D2D.D2DRenderWaveXDDS(Source, X, Y, Width, Height, rtSub, Transparent, amp, Len, ph, Alpha);
  4045.     Exit;
  4046.   end;
  4047.   {$IFDEF DXR_deprecated}
  4048.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  4049.   begin
  4050.     try
  4051.       if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
  4052.       begin
  4053.         try
  4054.           if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
  4055.           begin
  4056.             Blend := DXR_BLEND_ONE1;
  4057.           end else
  4058.             if Alpha >= 255 then
  4059.             begin
  4060.               Blend := DXR_BLEND_ONE2_SUB_ONE1;
  4061.             end else
  4062.             begin
  4063.               Blend := DXR_BLEND_ONE2_SUB_SRCALPHA1;
  4064.             end;
  4065.  
  4066.           dxrDrawWaveXBlend(DestSurface, SrcSurface,
  4067.             X, Y, Width, Height, SrcRect, amp, Len, ph, Blend, Alpha,
  4068.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  4069.         finally
  4070.           dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
  4071.         end;
  4072.       end;
  4073.     finally
  4074.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  4075.     end;
  4076.   end;
  4077.   {$ENDIF}
  4078. end;
  4079.  
  4080. procedure TDirectDrawSurface.DrawWaveYSub(X, Y, Width, Height: Integer;
  4081.   const SrcRect: TRect; Source: TDirectDrawSurface; Transparent: Boolean; amp,
  4082.   Len, ph, Alpha: Integer);
  4083. begin
  4084.   if Alpha <= 0 then Exit;
  4085.  
  4086.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  4087.   if (Width = 0) or (Height = 0) then Exit;
  4088.   if Source = nil then Exit;
  4089.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  4090.  
  4091.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  4092.     D2D.D2DRenderWaveYDDS(Source, X, Y, Width, Height, rtSub, Transparent, amp, Len, ph, Alpha);
  4093.     Exit;
  4094.   end;
  4095. end;
  4096.  
  4097. procedure TDirectDrawSurface.DrawWaveY(X, Y, Width, Height: Integer;
  4098.   const SrcRect: TRect; Source: TDirectDrawSurface; Transparent: Boolean; amp,
  4099.   Len, ph: Integer);
  4100. begin
  4101.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  4102.   if (Width = 0) or (Height = 0) then Exit;
  4103.   if Source = nil then Exit;
  4104.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  4105.  
  4106.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  4107.     D2D.D2DRenderWaveYDDS(Source, X, Y, Width, Height, rtDraw, Transparent, amp, Len, ph{$IFNDEF VER4UP}, $FF{$ENDIF});
  4108.     Exit;
  4109.   end;
  4110. end;
  4111.  
  4112. procedure TDirectDrawSurface.DrawWaveYAdd(X, Y, Width, Height: Integer;
  4113.   const SrcRect: TRect; Source: TDirectDrawSurface; Transparent: Boolean; amp,
  4114.   Len, ph, Alpha: Integer);
  4115. begin
  4116.   if Alpha <= 0 then Exit;
  4117.  
  4118.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  4119.   if (Width = 0) or (Height = 0) then Exit;
  4120.   if Source = nil then Exit;
  4121.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  4122.  
  4123.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  4124.     D2D.D2DRenderWaveYDDS(Source, X, Y, Width, Height, rtAdd, Transparent, amp, Len, ph, Alpha);
  4125.     Exit;
  4126.   end;
  4127. end;
  4128.  
  4129. procedure TDirectDrawSurface.DrawWaveYAlpha(X, Y, Width, Height: Integer;
  4130.   const SrcRect: TRect; Source: TDirectDrawSurface; Transparent: Boolean; amp,
  4131.   Len, ph, Alpha: Integer);
  4132. begin
  4133.   if Alpha <= 0 then Exit;
  4134.  
  4135.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  4136.   if (Width = 0) or (Height = 0) then Exit;
  4137.   if Source = nil then Exit;
  4138.   if (Source.Width = 0) or (Source.Height = 0) then Exit;
  4139.  
  4140.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  4141.     D2D.D2DRenderWaveYDDS(Source, X, Y, Width, Height, rtBlend, Transparent, amp, Len, ph, Alpha);
  4142.     Exit;
  4143.   end;
  4144. end;
  4145.  
  4146. procedure TDirectDrawSurface.Fill(DevColor: Longint);
  4147. var
  4148.   DBltEx: TDDBltFX;
  4149. begin
  4150.   DBltEx.dwSize := SizeOf(DBltEx);
  4151.   DBltEx.dwFillColor := DevColor;
  4152.   Blt(TRect(nil^), TRect(nil^), DDBLT_COLORFILL or DDBLT_WAIT, DBltEx, nil);
  4153. end;
  4154.  
  4155. procedure TDirectDrawSurface.FillRect(const Rect: TRect; DevColor: Longint);
  4156. var
  4157.   DBltEx: TDDBltFX;
  4158.   DestRect: TRect;
  4159. begin
  4160.   DBltEx.dwSize := SizeOf(DBltEx);
  4161.   DBltEx.dwFillColor := DevColor;
  4162.   DestRect := Rect;
  4163.   if ClipRect(DestRect, ClientRect) then
  4164.     Blt(DestRect, TRect(nil^), DDBLT_COLORFILL or DDBLT_WAIT, DBltEx, nil);
  4165. end;
  4166.  
  4167. procedure TDirectDrawSurface.FillRectAdd(const DestRect: TRect; Color: TColor; Alpha: Byte);
  4168. {$IFDEF DXR_deprecated}var
  4169.   DestSurface: TDXR_Surface;{$ENDIF}
  4170. begin
  4171.   if Color and $FFFFFF = 0 then Exit;
  4172.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  4173.   if SurfaceDesc.ddpfPixelFormat.dwFlags and (DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
  4174.     DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8) <> 0 then Exit;
  4175.  
  4176.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  4177.     D2D.D2DRenderFillRect(DestRect, ColorToRGB(Color), rtAdd, Alpha);
  4178.     Exit;
  4179.   end;
  4180.   {$IFDEF DXR_deprecated}
  4181.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  4182.   begin
  4183.     try
  4184.       dxrFillRectColorBlend(DestSurface, DestRect, DXR_BLEND_ONE1_ADD_ONE2, ColorToRGB(Color));
  4185.     finally
  4186.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  4187.     end;
  4188.   end;
  4189.   {$ENDIF}
  4190. end;
  4191.  
  4192. procedure TDirectDrawSurface.FillRectAlpha(const DestRect: TRect; Color: TColor;
  4193.   Alpha: Integer);
  4194. {$IFDEF DXR_deprecated}var
  4195.   DestSurface: TDXR_Surface;{$ENDIF}
  4196. begin
  4197.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  4198.   if SurfaceDesc.ddpfPixelFormat.dwFlags and (DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
  4199.     DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8) <> 0 then Exit;
  4200.  
  4201.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  4202.     D2D.D2DRenderFillRect(DestRect, ColorToRGB(Color), rtBlend, Alpha);
  4203.     Exit;
  4204.   end;
  4205.   {$IFDEF DXR_deprecated}
  4206.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  4207.   begin
  4208.     try
  4209.       dxrFillRectColorBlend(DestSurface, DestRect, DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2, ColorToRGB(Color) or (Byte(Alpha) shl 24));
  4210.     finally
  4211.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  4212.     end;
  4213.   end;{$ENDIF}
  4214. end;
  4215.  
  4216. procedure TDirectDrawSurface.FillRectSub(const DestRect: TRect; Color: TColor; Alpha: Byte);
  4217. {$IFDEF DXR_deprecated}var
  4218.   DestSurface: TDXR_Surface;{$ENDIF}
  4219. begin
  4220.   if Color and $FFFFFF = 0 then Exit;
  4221.   if (Self.Width = 0) or (Self.Height = 0) then Exit;
  4222.   if SurfaceDesc.ddpfPixelFormat.dwFlags and (DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
  4223.     DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8) <> 0 then Exit;
  4224.  
  4225.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then begin
  4226.     D2D.D2DRenderFillRect(DestRect, ColorToRGB(Color), rtSub, Alpha);
  4227.     Exit;
  4228.   end;
  4229.   {$IFDEF DXR_deprecated}
  4230.   if dxrDDSurfaceLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface) then
  4231.   begin
  4232.     try
  4233.       dxrFillRectColorBlend(DestSurface, DestRect, DXR_BLEND_ONE2_SUB_ONE1, ColorToRGB(Color));
  4234.     finally
  4235.       dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
  4236.     end;
  4237.   end;{$ENDIF}
  4238. end;
  4239.  
  4240. function TDirectDrawSurface.GetBitCount: Integer;
  4241. begin
  4242.   Result := SurfaceDesc.ddpfPixelFormat.dwRGBBitCount;
  4243. end;
  4244.  
  4245. function TDirectDrawSurface.GetCanvas: TDirectDrawSurfaceCanvas;
  4246. begin
  4247.   if FCanvas = nil then
  4248.     FCanvas := TDirectDrawSurfaceCanvas.Create(Self);
  4249.   Result := FCanvas;
  4250. end;
  4251.  
  4252. function TDirectDrawSurface.GetClientRect: TRect;
  4253. begin
  4254.   Result := Rect(0, 0, Width, Height);
  4255. end;
  4256.  
  4257. function TDirectDrawSurface.GetHeight: Integer;
  4258. begin
  4259.   Result := SurfaceDesc.dwHeight;
  4260. end;
  4261.  
  4262. type
  4263.   PRGB = ^TRGB;
  4264.   TRGB = packed record
  4265.     R, G, B: Byte;
  4266.   end;
  4267.  
  4268. function TDirectDrawSurface.GetPixel(X, Y: Integer): Longint;
  4269. var
  4270.   ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  4271. begin
  4272.   Result := 0;
  4273.   if ({$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) and (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then
  4274.     if Lock(PRect(nil)^, ddsd) then
  4275.     begin
  4276.       try
  4277.         case ddsd.ddpfPixelFormat.dwRGBBitCount of
  4278.           1: Result := Integer(PByte(Integer(ddsd.lpSurface) +
  4279.               Y * ddsd.lPitch + (X shr 3))^ and (1 shl (X and 7)) <> 0);
  4280.           4: begin
  4281.               if X and 1 = 0 then
  4282.                 Result := PByte(Integer(ddsd.lpSurface) + Y * ddsd.lPitch + (X shr 1))^ shr 4
  4283.               else
  4284.                 Result := PByte(Integer(ddsd.lpSurface) + Y * ddsd.lPitch + (X shr 1))^ and $0F;
  4285.             end;
  4286.           8: Result := PByte(Integer(ddsd.lpSurface) + Y * ddsd.lPitch + X)^;
  4287.           16: Result := PWord(Integer(ddsd.lpSurface) + Y * ddsd.lPitch + X * 2)^;
  4288.           24: with PRGB(Integer(ddsd.lpSurface) + Y * ddsd.lPitch + X * 3)^ do
  4289.               Result := R or (G shl 8) or (B shl 16);
  4290.           32: Result := PInteger(Integer(ddsd.lpSurface) + Y * ddsd.lPitch + X * 4)^;
  4291.         end;
  4292.       finally
  4293.         UnLock;
  4294.       end;
  4295.     end;
  4296. end;
  4297.  
  4298. function TDirectDrawSurface.GetWidth: Integer;
  4299. begin
  4300.   Result := SurfaceDesc.dwWidth;
  4301. end;
  4302.  
  4303. procedure TDirectDrawSurface.LoadFromDIB(DIB: TDIB);
  4304. begin
  4305.   LoadFromGraphic(DIB);
  4306. end;
  4307.  
  4308. procedure TDirectDrawSurface.LoadFromDIBRect(DIB: TDIB; AWidth, AHeight: Integer; const SrcRect: TRect);
  4309. begin
  4310.   LoadFromGraphicRect(DIB, AWidth, AHeight, SrcRect);
  4311. end;
  4312.  
  4313. procedure TDirectDrawSurface.LoadFromGraphic(Graphic: TGraphic);
  4314. begin
  4315.   LoadFromGraphicRect(Graphic, 0, 0, Bounds(0, 0, Graphic.Width, Graphic.Height));
  4316. end;
  4317.  
  4318. procedure TDirectDrawSurface.LoadFromGraphicRect(Graphic: TGraphic; AWidth, AHeight: Integer; const SrcRect: TRect);
  4319. var
  4320.   Temp: TDIB;
  4321. begin
  4322.   if AWidth = 0 then
  4323.     AWidth := SrcRect.Right - SrcRect.Left;
  4324.   if AHeight = 0 then
  4325.     AHeight := SrcRect.Bottom - SrcRect.Top;
  4326.  
  4327.   SetSize(AWidth, AHeight);
  4328.  
  4329.   with SrcRect do
  4330.     if Graphic is TDIB then
  4331.     begin
  4332.       with Canvas do
  4333.       try
  4334.         StretchBlt(Handle, 0, 0, AWidth, AHeight, TDIB(Graphic).Canvas.Handle,
  4335.           Left, Top, Right - Left, Bottom - Top, SRCCOPY);
  4336.       finally
  4337.         Release;
  4338.       end;
  4339.     end else if (Right - Left = AWidth) and (Bottom - Top = AHeight) then
  4340.     begin
  4341.       with Canvas do
  4342.       try
  4343.         Draw(-Left, -Top, Graphic);
  4344.       finally
  4345.         Release;
  4346.       end;
  4347.     end else
  4348.     begin
  4349.       Temp := TDIB.Create;
  4350.       try
  4351.         Temp.SetSize(Right - Left, Bottom - Top, 24);
  4352.         Temp.Canvas.Draw(-Left, -Top, Graphic);
  4353.  
  4354.         with Canvas do
  4355.         try
  4356.           StretchDraw(Bounds(0, 0, AWidth, AHeight), Temp);
  4357.         finally
  4358.           Release;
  4359.         end;
  4360.       finally
  4361.         Temp.Free;
  4362.       end;
  4363.     end;
  4364. end;
  4365.  
  4366. procedure TDirectDrawSurface.LoadFromFile(const FileName: string);
  4367. var
  4368.   Picture: TPicture;
  4369. begin
  4370.   Picture := TPicture.Create;
  4371.   try
  4372.     Picture.LoadFromFile(FileName);
  4373.     LoadFromGraphic(Picture.Graphic);
  4374.   finally
  4375.     Picture.Free;
  4376.   end;
  4377. end;
  4378.  
  4379. procedure TDirectDrawSurface.LoadFromStream(Stream: TStream);
  4380. var
  4381.   DIB: TDIB;
  4382. begin
  4383.   DIB := TDIB.Create;
  4384.   try
  4385.     DIB.LoadFromStream(Stream);
  4386.     if DIB.Size > 0 then
  4387.       LoadFromGraphic(DIB);
  4388.   finally
  4389.     DIB.Free;
  4390.   end;
  4391. end;
  4392.  
  4393. function TDirectDrawSurface.Lock(const Rect: TRect; var SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF}): Boolean;
  4394. begin
  4395.   Result := False;
  4396.   if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} = nil then Exit;
  4397.  
  4398.   if FLockCount > 0 then Exit;
  4399.   FIsLocked := False;
  4400.   FLockSurfaceDesc.dwSize := SizeOf(FLockSurfaceDesc);
  4401.  
  4402.   if (@Rect <> nil) and ((Rect.Left <> 0) or (Rect.Top <> 0) or (Rect.Right <> Width) or (Rect.Bottom <> Height)) then
  4403.     DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.Lock(@Rect, FLockSurfaceDesc, DDLOCK_WAIT, 0)
  4404.   else
  4405.     DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.Lock(nil, FLockSurfaceDesc, DDLOCK_WAIT, 0);
  4406.   if DXResult <> DD_OK then Exit;
  4407.  
  4408.   Inc(FLockCount);
  4409.   SurfaceDesc := FLockSurfaceDesc;
  4410.   FIsLocked := True;
  4411.   Result := True;
  4412. end;
  4413.  
  4414. {$IFDEF VER4UP}
  4415. function TDirectDrawSurface.Lock(var SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF}): Boolean;
  4416. begin
  4417.   Result := False;
  4418.   FIsLocked := False;
  4419.   if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} = nil then Exit;
  4420.  
  4421.   if FLockCount = 0 then
  4422.   begin
  4423.     FLockSurfaceDesc.dwSize := SizeOf(FLockSurfaceDesc);
  4424.     DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.Lock(nil, FLockSurfaceDesc, DDLOCK_WAIT, 0);
  4425.     if DXResult <> DD_OK then Exit;
  4426.   end;
  4427.  
  4428.   Inc(FLockCount);
  4429.   SurfaceDesc := FLockSurfaceDesc;
  4430.   FIsLocked := True;
  4431.   Result := True;
  4432. end;
  4433.  
  4434. function TDirectDrawSurface.Lock: Boolean;
  4435. var SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  4436. begin
  4437.   Result := Lock(SurfaceDesc);
  4438. end;
  4439.  
  4440. {$ELSE}
  4441.  
  4442. function TDirectDrawSurface.LockSurface: Boolean;
  4443. var SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF}; R: TRect;
  4444. begin
  4445.   Result := Lock(R, SurfaceDesc);
  4446. end;
  4447. {$ENDIF}
  4448.  
  4449. procedure TDirectDrawSurface.UnLock;
  4450. begin
  4451.   if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} = nil then Exit;
  4452.  
  4453.   if FLockCount > 0 then
  4454.   begin
  4455.     Dec(FLockCount);
  4456.     if FLockCount = 0 then begin
  4457.       DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.UnLock(FLockSurfaceDesc.lpSurface);
  4458.       FIsLocked := False;
  4459.     end;
  4460.   end;
  4461. end;
  4462.  
  4463. function TDirectDrawSurface.Restore: Boolean;
  4464. begin
  4465.   if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  4466.   begin
  4467.     DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}._Restore;
  4468.     Result := DXResult = DD_OK;
  4469.   end else
  4470.     Result := False;
  4471. end;
  4472.  
  4473. procedure TDirectDrawSurface.SetClipper(Value: TDirectDrawClipper);
  4474. begin
  4475.   if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  4476.     DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetClipper(Value.IDDClipper);
  4477.   FHasClipper := (Value <> nil) and (DXResult = DD_OK);
  4478. end;
  4479.  
  4480. procedure TDirectDrawSurface.SetColorKey(Flags: DWORD; const Value: TDDColorKey);
  4481. begin
  4482.   if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  4483.     DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetColorKey(Flags, @Value);
  4484. end;
  4485.  
  4486. procedure TDirectDrawSurface.SetPalette(Value: TDirectDrawPalette);
  4487. begin
  4488.   if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  4489.     DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetPalette(Value.IDDPalette);
  4490. end;
  4491.  
  4492. procedure TDirectDrawSurface.SetPixel(X, Y: Integer; Value: Longint);
  4493. var
  4494.   ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  4495.   P: PByte;
  4496. begin
  4497.   if ({$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) and (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then
  4498.     if Lock(PRect(nil)^, ddsd) then
  4499.     begin
  4500.       try
  4501.         case ddsd.ddpfPixelFormat.dwRGBBitCount of
  4502.           1: begin
  4503.               P := PByte(Integer(ddsd.lpSurface) + Y * ddsd.lPitch + (X shr 3));
  4504.               if Value = 0 then
  4505.                 P^ := P^ and (not (1 shl (7 - (X and 7))))
  4506.               else
  4507.                 P^ := P^ or (1 shl (7 - (X and 7)));
  4508.             end;
  4509.           4: begin
  4510.               P := PByte(Integer(ddsd.lpSurface) + Y * ddsd.lPitch + (X shr 1));
  4511.               if X and 1 = 0 then
  4512.                 P^ := (P^ and $0F) or (Value shl 4)
  4513.               else
  4514.                 P^ := (P^ and $F0) or (Value and $0F);
  4515.             end;
  4516.           8: PByte(Integer(ddsd.lpSurface) + Y * ddsd.lPitch + X)^ := Value;
  4517.           16: PWord(Integer(ddsd.lpSurface) + Y * ddsd.lPitch + X * 2)^ := Value;
  4518.           24: with PRGB(Integer(ddsd.lpSurface) + Y * ddsd.lPitch + X * 3)^ do
  4519.             begin
  4520.               R := Byte(Value);
  4521.               G := Byte(Value shr 8);
  4522.               B := Byte(Value shr 16);
  4523.             end;
  4524.           32: PInteger(Integer(ddsd.lpSurface) + Y * ddsd.lPitch + X * 4)^ := Value;
  4525.         end;
  4526.       finally
  4527.         UnLock;
  4528.       end;
  4529.     end;
  4530. end;
  4531.  
  4532. procedure TDirectDrawSurface.SetSize(AWidth, AHeight: Integer);
  4533. var
  4534.   ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  4535. begin
  4536.   if (AWidth <= 0) or (AHeight <= 0) then
  4537.   begin
  4538.     {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil;
  4539.     Exit;
  4540.   end;
  4541.  
  4542.   FillChar(ddsd, SizeOf(ddsd), 0);
  4543.   with ddsd do
  4544.   begin
  4545.     dwSize := SizeOf(ddsd);
  4546.     dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT;
  4547.     ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
  4548.     if FSystemMemory then
  4549.       ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
  4550.     dwHeight := AHeight;
  4551.     dwWidth := AWidth;
  4552.   end;
  4553.  
  4554.   if CreateSurface(ddsd) then Exit;
  4555.  
  4556.   {  When the Surface cannot be made,  making is attempted to the system memory.  }
  4557.   if ddsd.ddsCaps.dwCaps and DDSCAPS_SYSTEMMEMORY = 0 then
  4558.   begin
  4559.     ddsd.ddsCaps.dwCaps := (ddsd.ddsCaps.dwCaps and (not DDSCAPS_VIDEOMEMORY)) or DDSCAPS_SYSTEMMEMORY;
  4560.     if CreateSurface(ddsd) then
  4561.     begin
  4562.       FSystemMemory := True;
  4563.       Exit;
  4564.     end;
  4565.   end;
  4566.  
  4567.   raise EDirectDrawSurfaceError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
  4568. end;
  4569.  
  4570. procedure TDirectDrawSurface.SetTransparentColor(Col: Longint);
  4571. var
  4572.   ddck: TDDColorKey;
  4573. begin
  4574.   ddck.dwColorSpaceLowValue := Col;
  4575.   ddck.dwColorSpaceHighValue := Col;
  4576.   ColorKey[DDCKEY_SRCBLT] := ddck;
  4577. end;
  4578.  
  4579. {additional pixel routines like turbopixels}
  4580.  
  4581. procedure TDirectDrawSurface.PutPixel8(x, y, color: Integer); assembler;
  4582. { on entry:  self = eax, x = edx,   y = ecx,   color = ? }
  4583. asm
  4584.   push esi                              // must maintain esi
  4585.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface// set to surface
  4586.   add esi,edx                           // add x
  4587.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.dwwidth]  // eax = pitch
  4588.   mul ecx                               // eax = pitch * y
  4589.   add esi,eax                           // esi = pixel offset
  4590.   mov ecx, color
  4591.   mov ds:[esi],cl                       // set pixel (lo byte of ecx)
  4592.   pop esi                               // restore esi
  4593.   //ret                                   // return
  4594. end;
  4595.  
  4596. procedure TDirectDrawSurface.PutPixel16(x, y, color: Integer); assembler;
  4597. { on entry:  self = eax, x = edx,   y = ecx,   color = ? }
  4598. asm
  4599.   push esi
  4600.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
  4601.   shl edx,1
  4602.   add esi,edx
  4603.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
  4604.   mul ecx
  4605.   add esi,eax
  4606.   mov ecx, color
  4607.   mov ds:[esi],cx
  4608.   pop esi
  4609.   //ret
  4610. end;
  4611.  
  4612. procedure TDirectDrawSurface.PutPixel24(x, y, color: Integer); assembler;
  4613. { on entry:  self = eax, x = edx,   y = ecx,   color = ? }
  4614. asm
  4615.   push esi
  4616.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
  4617.   imul edx,3
  4618.   add esi,edx
  4619.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
  4620.   mul ecx
  4621.   add esi,eax
  4622.   mov eax,ds:[esi]
  4623.   and eax,$FF000000
  4624.   mov ecx, color
  4625.   or  ecx,eax
  4626.   mov ds:[esi+1],ecx
  4627.   pop esi
  4628.   //ret
  4629. end;
  4630.  
  4631. procedure TDirectDrawSurface.PutPixel32(x, y, color: Integer); assembler;
  4632. { on entry:  self = eax, x = edx,   y = ecx,   color = ? }
  4633. asm
  4634.   push esi
  4635.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
  4636.   shl edx,2
  4637.   add esi,edx
  4638.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
  4639.   mul ecx
  4640.   add esi,eax
  4641.   mov ecx, color
  4642.   mov ds:[esi],ecx
  4643.   pop esi
  4644.   //ret
  4645. end;
  4646.  
  4647. procedure TDirectDrawSurface.Poke(X, Y: Integer; const Value: LongInt);
  4648. begin
  4649.   if (X < 0) or (X > (Width - 1)) or
  4650.     (Y < 0) or (Y > (Height - 1)) or not FIsLocked then Exit;
  4651.   case Bitcount of
  4652.     8: PutPixel8(x, y, value);
  4653.     16: PutPixel16(x, y, value);
  4654.     24: PutPixel24(x, y, value);
  4655.     32: PutPixel32(x, y, value);
  4656.   end;
  4657. end;
  4658.  
  4659. function TDirectDrawSurface.GetPixel8(x, y: Integer): Integer; assembler;
  4660. { on entry:  self = eax, x = edx,   y = ecx,   result = eax }
  4661. asm
  4662.   push esi                              // myst maintain esi
  4663.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface        // set to surface
  4664.   add esi,edx                           // add x
  4665.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]         // eax = pitch
  4666.   mul ecx                               // eax = pitch * y
  4667.   add esi,eax                           // esi = pixel offset
  4668.   mov eax,ds:[esi]                      // eax = color
  4669.   and eax,$FF                           // map into 8bit
  4670.   pop esi                               // restore esi
  4671.   //ret                                   // return
  4672. end;
  4673.  
  4674. function TDirectDrawSurface.GetPixel16(x, y: Integer): Integer; assembler;
  4675. { on entry:  self = eax, x = edx,   y = ecx,   result = eax }
  4676. asm
  4677.   push esi
  4678.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
  4679.   shl edx,1
  4680.   add esi,edx
  4681.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
  4682.   mul ecx
  4683.   add esi,eax
  4684.   mov eax,ds:[esi]
  4685.   and eax,$FFFF                         // map into 16bit
  4686.   pop esi
  4687.   //ret
  4688. end;
  4689.  
  4690. function TDirectDrawSurface.GetPixel24(x, y: Integer): Integer; assembler;
  4691. { on entry:  self = eax, x = edx,   y = ecx,   result = eax }
  4692. asm
  4693.   push esi
  4694.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
  4695.   imul edx,3
  4696.   add esi,edx
  4697.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
  4698.   mul ecx
  4699.   add esi,eax
  4700.   mov eax,ds:[esi]
  4701.   and eax,$FFFFFF                       // map into 24bit
  4702.   pop esi
  4703.   //ret
  4704. end;
  4705.  
  4706. function TDirectDrawSurface.GetPixel32(x, y: Integer): Integer; assembler;
  4707. { on entry:  self = eax, x = edx,   y = ecx,   result = eax }
  4708. asm
  4709.   push esi
  4710.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
  4711.   shl edx,2
  4712.   add esi,edx
  4713.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
  4714.   mul ecx
  4715.   add esi,eax
  4716.   mov eax,ds:[esi]
  4717.   pop esi
  4718.   //ret
  4719. end;
  4720.  
  4721. function TDirectDrawSurface.Peek(X, Y: Integer): LongInt;
  4722. begin
  4723.   Result := 0;
  4724.   if (X < 0) or (X > (Width - 1)) or
  4725.     (Y < 0) or (Y > (Height - 1)) or not FIsLocked then Exit;
  4726.   case Bitcount of
  4727.     8: Result := GetPixel8(x, y);
  4728.     16: Result := GetPixel16(x, y);
  4729.     24: Result := GetPixel24(x, y);
  4730.     32: Result := GetPixel32(x, y);
  4731.   end;
  4732. end;
  4733.  
  4734. procedure TDirectDrawSurface.PokeLine(X1, Y1, X2, Y2: Integer; Color: cardinal);
  4735. var
  4736.   i, deltax, deltay, numpixels,
  4737.     d, dinc1, dinc2,
  4738.     x, xinc1, xinc2,
  4739.     y, yinc1, yinc2: Integer;
  4740. begin
  4741.   if not FIsLocked then {$IFDEF VER4UP}Lock{$ELSE}LockSurface{$ENDIF}; //force lock the surface
  4742.   { Calculate deltax and deltay for initialisation }
  4743.   deltax := abs(x2 - x1);
  4744.   deltay := abs(y2 - y1);
  4745.  
  4746.   { Initialise all vars based on which is the independent variable }
  4747.   if deltax >= deltay then
  4748.   begin
  4749.     { x is independent variable }
  4750.     numpixels := deltax + 1;
  4751.     d := (2 * deltay) - deltax;
  4752.  
  4753.     dinc1 := deltay shl 1;
  4754.     dinc2 := (deltay - deltax) shl 1;
  4755.     xinc1 := 1;
  4756.     xinc2 := 1;
  4757.     yinc1 := 0;
  4758.     yinc2 := 1;
  4759.   end
  4760.   else
  4761.   begin
  4762.     { y is independent variable }
  4763.     numpixels := deltay + 1;
  4764.     d := (2 * deltax) - deltay;
  4765.     dinc1 := deltax shl 1;
  4766.     dinc2 := (deltax - deltay) shl 1;
  4767.     xinc1 := 0;
  4768.     xinc2 := 1;
  4769.     yinc1 := 1;
  4770.     yinc2 := 1;
  4771.   end;
  4772.   { Make sure x and y move in the right directions }
  4773.   if x1 > x2 then
  4774.   begin
  4775.     xinc1 := -xinc1;
  4776.     xinc2 := -xinc2;
  4777.   end;
  4778.   if y1 > y2 then
  4779.   begin
  4780.     yinc1 := -yinc1;
  4781.     yinc2 := -yinc2;
  4782.   end;
  4783.   x := x1;
  4784.   y := y1;
  4785.   { Draw the pixels }
  4786.   for i := 1 to numpixels do
  4787.   begin
  4788.     if (x > 0) and (x < (Width - 1)) and (y > 0) and (y < (Height - 1)) then
  4789.       Pixel[x, y] := Color;
  4790.     if d < 0 then
  4791.     begin
  4792.       Inc(d, dinc1);
  4793.       Inc(x, xinc1);
  4794.       Inc(y, yinc1);
  4795.     end
  4796.     else
  4797.     begin
  4798.       Inc(d, dinc2);
  4799.       Inc(x, xinc2);
  4800.       Inc(y, yinc2);
  4801.     end;
  4802.   end;
  4803. end;
  4804.  
  4805. procedure TDirectDrawSurface.PokeLinePolar(x, y: Integer; angle, length: extended; Color: cardinal);
  4806. var
  4807.   xp, yp: Integer;
  4808. begin
  4809.   xp := round(sin(angle * pi / 180) * length) + x;
  4810.   yp := round(cos(angle * pi / 180) * length) + y;
  4811.   PokeLine(x, y, xp, yp, Color);
  4812. end;
  4813.  
  4814. procedure TDirectDrawSurface.PokeBox(xs, ys, xd, yd: Integer; Color: cardinal);
  4815. begin
  4816.   pokeline(xs, ys, xd, ys, color);
  4817.   pokeline(xs, ys, xs, yd, color);
  4818.   pokeline(xd, ys, xd, yd, color);
  4819.   pokeline(xs, yd, xd, yd, color);
  4820. end;
  4821.  
  4822. procedure TDirectDrawSurface.PokeBlendPixel(const X, Y: Integer; aColor: cardinal; Alpha: byte);
  4823. var
  4824.   cr, cg, cb: byte;
  4825.   ar, ag, ab: byte;
  4826. begin
  4827.   LoadRGB(aColor, ar, ag, ab);
  4828.   LoadRGB(Pixel[x, y], cr, cg, cb);
  4829.   Pixel[x, y] := SaveRGB((Alpha * (aR - cr) shr 8) + cr, // R alpha
  4830.     (Alpha * (aG - cg) shr 8) + cg, // G alpha
  4831.     (Alpha * (aB - cb) shr 8) + cb); // B alpha
  4832. end;
  4833.  
  4834. function Conv24to16(Color: Integer): Word; register;
  4835. asm
  4836.   mov ecx,eax
  4837.   shl eax,24
  4838.   shr eax,27
  4839.   shl eax,11
  4840.   mov edx,ecx
  4841.   shl edx,16
  4842.   shr edx,26
  4843.   shl edx,5
  4844.   or eax,edx
  4845.   mov edx,ecx
  4846.   shl edx,8
  4847.   shr edx,27
  4848.   or eax,edx
  4849. end;
  4850.  
  4851. procedure TDirectDrawSurface.PokeWuLine(X1, Y1, X2, Y2, aColor: Integer);
  4852. var DeltaX, DeltaY, Loop, Start, Finish: Integer;
  4853.   Dx, Dy, DyDx: Single; // fractional parts
  4854.   Color16: DWord;
  4855. begin
  4856.   DeltaX := Abs(X2 - X1); // Calculate DeltaX and DeltaY for initialization
  4857.   DeltaY := Abs(Y2 - Y1);
  4858.   if (DeltaX = 0) or (DeltaY = 0) then
  4859.   begin // straight lines
  4860.     PokeLine(X1, Y1, X2, Y2, aColor);
  4861.     Exit;
  4862.   end;
  4863.   if BitCount = 16 then
  4864.     Color16 := Conv24to16(aColor)
  4865.   else
  4866.     Color16 := aColor;
  4867.   if DeltaX > DeltaY then // horizontal or vertical
  4868.   begin
  4869.   { determine rise and run }
  4870.     if Y2 > Y1 then DyDx := -(DeltaY / DeltaX)
  4871.     else DyDx := DeltaY / DeltaX;
  4872.     if X2 < X1 then
  4873.     begin
  4874.       Start := X2; // right to left
  4875.       Finish := X1;
  4876.       Dy := Y2;
  4877.     end else
  4878.     begin
  4879.       Start := X1; // left to right
  4880.       Finish := X2;
  4881.       Dy := Y1;
  4882.       DyDx := -DyDx; // inverse slope
  4883.     end;
  4884.     for Loop := Start to Finish do
  4885.     begin
  4886.       PokeBlendPixel(Loop, Trunc(Dy), Color16, Trunc((1 - Frac(Dy)) * 255));
  4887.       PokeBlendPixel(Loop, Trunc(Dy) + 1, Color16, Trunc(Frac(Dy) * 255));
  4888.       Dy := Dy + DyDx; // next point
  4889.     end;
  4890.   end else
  4891.   begin
  4892.    { determine rise and run }
  4893.     if X2 > X1 then DyDx := -(DeltaX / DeltaY)
  4894.     else DyDx := DeltaX / DeltaY;
  4895.     if Y2 < Y1 then
  4896.     begin
  4897.       Start := Y2; // right to left
  4898.       Finish := Y1;
  4899.       Dx := X2;
  4900.     end else
  4901.     begin
  4902.       Start := Y1; // left to right
  4903.       Finish := Y2;
  4904.       Dx := X1;
  4905.       DyDx := -DyDx; // inverse slope
  4906.     end;
  4907.     for Loop := Start to Finish do
  4908.     begin
  4909.       PokeBlendPixel(Trunc(Dx), Loop, Color16, Trunc((1 - Frac(Dx)) * 255));
  4910.       PokeBlendPixel(Trunc(Dx), Loop, Color16, Trunc(Frac(Dx) * 255));
  4911.       Dx := Dx + DyDx; // next point
  4912.     end;
  4913.   end;
  4914. end;
  4915.  
  4916. procedure TDirectDrawSurface.Noise(Oblast: TRect; Density: Byte);
  4917. var
  4918.   dx, dy: Integer;
  4919.   Dens: byte;
  4920. begin
  4921.   {noise}
  4922.   case Density of
  4923.     0..2: Dens := 3;
  4924.     255: Dens := 254;
  4925.   else
  4926.     Dens := Density;
  4927.   end;
  4928.   if Dens >= Oblast.Right then
  4929.     Dens := Oblast.Right div 3;
  4930.   dy := Oblast.Top;
  4931.   while dy <= Oblast.Bottom do begin
  4932.     dx := Oblast.Left;
  4933.     while dx <= Oblast.Right do begin
  4934.       inc(dx, random(dens));
  4935.       if dx <= Oblast.Right then
  4936.         Pixel[dx, dy] := not Pixel[dx, dy];
  4937.     end;
  4938.     inc(dy);
  4939.   end;
  4940. end;
  4941.  
  4942. function Conv16to24(Color: Word): Integer; register;
  4943. asm
  4944.  xor edx,edx
  4945.  mov dx,ax
  4946.  
  4947.  mov eax,edx
  4948.  shl eax,27
  4949.  shr eax,8
  4950.  
  4951.  mov ecx,edx
  4952.  shr ecx,5
  4953.  shl ecx,26
  4954.  shr ecx,16
  4955.  or eax,ecx
  4956.  
  4957.  mov ecx,edx
  4958.  shr ecx,11
  4959.  shl ecx,27
  4960.  shr ecx,24
  4961.  or eax,ecx
  4962. end;
  4963.  
  4964. procedure GetRGB(Color: cardinal; var R, G, B: Byte); {$IFDEF VER9UP}inline; {$ENDIF}
  4965. begin
  4966.   R := Color;
  4967.   G := Color shr 8;
  4968.   B := Color shr 16;
  4969. end;
  4970.  
  4971. procedure TDirectDrawSurface.LoadRGB(Color: cardinal; var R, G, B: Byte);
  4972. var grB: Byte;
  4973. begin
  4974.   grB := 1;
  4975.   if FLockSurfaceDesc.ddpfPixelFormat.dwGBitMask = 2016 then grB := 0; // 565
  4976.   case BitCount of
  4977.     15, 16: begin
  4978.         R := (color shr (11 - grB)) shl 3;
  4979.         if grB = 0 then
  4980.           G := ((color and 2016) shr 5) shl 2
  4981.         else
  4982.           G := ((color and 992) shr 5) shl 3;
  4983.         B := (color and 31) shl 3;
  4984.       end;
  4985.   else
  4986.     GetRGB(Color, R, G, B);
  4987.   end;
  4988. end;
  4989.  
  4990. function TDirectDrawSurface.SaveRGB(const R, G, B: Byte): cardinal;
  4991. begin
  4992.   case BitCount of
  4993.     15, 16: begin
  4994.         Result := Conv24to16(RGB(R, G, B));
  4995.       end;
  4996.   else
  4997.     Result := RGB(R, G, B);
  4998.   end;
  4999. end;
  5000.  
  5001. procedure TDirectDrawSurface.Blur;
  5002. var
  5003.   x, y, tr, tg, tb: Integer;
  5004.   r, g, b: byte;
  5005. begin
  5006.   for y := 1 to GetHeight - 1 do
  5007.     for x := 1 to GetWidth - 1 do begin
  5008.       LoadRGB(peek(x, y), r, g, b);
  5009.       tr := r;
  5010.       tg := g;
  5011.       tb := b;
  5012.       LoadRGB(peek(x, y + 1), r, g, b);
  5013.       Inc(tr, r);
  5014.       Inc(tg, g);
  5015.       Inc(tb, b);
  5016.       LoadRGB(peek(x, y - 1), r, g, b);
  5017.       Inc(tr, r);
  5018.       Inc(tg, g);
  5019.       Inc(tb, b);
  5020.       LoadRGB(peek(x - 1, y), r, g, b);
  5021.       Inc(tr, r);
  5022.       Inc(tg, g);
  5023.       Inc(tb, b);
  5024.       LoadRGB(peek(x + 1, y), r, g, b);
  5025.       Inc(tr, r);
  5026.       Inc(tg, g);
  5027.       Inc(tb, b);
  5028.       tr := tr shr 2;
  5029.       tg := tg shr 2;
  5030.       tb := tb shr 2;
  5031.       Poke(x, y, savergb(tr, tg, tb));
  5032.     end;
  5033. end;
  5034.  
  5035. procedure TDirectDrawSurface.PokeCircle(X, Y, Radius, Color: Integer);
  5036. var
  5037.   a, af, b, bf, c,
  5038.     target, r2: Integer;
  5039. begin
  5040.   Target := 0;
  5041.   A := Radius;
  5042.   B := 0;
  5043.   R2 := Sqr(Radius);
  5044.  
  5045.   while a >= B do
  5046.   begin
  5047.     b := Round(Sqrt(R2 - Sqr(A)));
  5048.     c := target; target := b; b := c;
  5049.     while B < Target do
  5050.     begin
  5051.       Af := (120 * a) div 100;
  5052.       Bf := (120 * b) div 100;
  5053.       pixel[x + af, y + b] := color;
  5054.       pixel[x + bf, y + a] := color;
  5055.       pixel[x - af, y + b] := color;
  5056.       pixel[x - bf, y + a] := color;
  5057.       pixel[x - af, y - b] := color;
  5058.       pixel[x - bf, y - a] := color;
  5059.       pixel[x + af, y - b] := color;
  5060.       pixel[x + bf, y - a] := color;
  5061.       B := B + 1;
  5062.     end;
  5063.     A := A - 1;
  5064.   end;
  5065. end;
  5066.  
  5067. function RGBToBGR(Color: cardinal): cardinal;
  5068. begin
  5069.   result := (LoByte(LoWord(Color)) shr 3 shl 11) or // Red
  5070.     (HiByte((Color)) shr 2 shl 5) or // Green
  5071.     (LoByte(HiWord(Color)) shr 3); // Blue
  5072. end;
  5073.  
  5074. procedure TDirectDrawSurface.PokeVLine(x, y1, y2: Integer; Color: cardinal);
  5075. var
  5076.   y: Integer;
  5077.   NColor: cardinal;
  5078.   r, g, b: byte;
  5079. begin
  5080.   if y1 < 0 then y1 := 0;
  5081.   if y2 >= Height then y2 := Height - 1;
  5082.   GetRGB(Color, r, g, b);
  5083.   NColor := RGBToBGR(rgb(r, g, b));
  5084.   for y := y1 to y2 do
  5085.   begin
  5086.     pixel[x, y] := NColor;
  5087.   end;
  5088. end;
  5089.  
  5090. procedure TDirectDrawSurface.PokeFilledEllipse(exc, eyc, ea, eb, color: Integer);
  5091. var x, y: Integer; aa, aa2, bb, bb2, d, dx, dy: LongInt;
  5092. begin
  5093.   x := 0;
  5094.   y := eb;
  5095.   aa := LongInt(ea) * ea;
  5096.   aa2 := 2 * aa;
  5097.   bb := LongInt(eb) * eb;
  5098.   bb2 := 2 * bb;
  5099.   d := bb - aa * eb + aa div 4;
  5100.   dx := 0;
  5101.   dy := aa2 * eb;
  5102.   PokevLine(exc, eyc - y, eyc + y, color);
  5103.   while (dx < dy) do begin
  5104.     if (d > 0) then begin
  5105.       dec(y); dec(dy, aa2); dec(d, dy);
  5106.     end;
  5107.     inc(x); inc(dx, bb2); inc(d, bb + dx);
  5108.     PokevLine(exc - x, eyc - y, eyc + y, color);
  5109.     PokevLine(exc + x, eyc - y, eyc + y, color);
  5110.   end;
  5111.   inc(d, (3 * (aa - bb) div 2 - (dx + dy)) div 2);
  5112.   while (y >= 0) do begin
  5113.     if (d < 0) then begin
  5114.       inc(x); inc(dx, bb2); inc(d, bb + dx);
  5115.       PokevLine(exc - x, eyc - y, eyc + y, color);
  5116.       PokevLine(exc + x, eyc - y, eyc + y, color);
  5117.     end;
  5118.     dec(y); dec(dy, aa2); inc(d, aa - dy);
  5119.   end;
  5120. end;
  5121.  
  5122. procedure TDirectDrawSurface.DoRotate(cent1, cent2, angle: Integer; coord1, coord2: Real; Color: word);
  5123. var coord1t, coord2t: Real;
  5124.   c1, c2: Integer;
  5125. begin
  5126.   coord1t := coord1 - cent1;
  5127.   coord2t := coord2 - cent2;
  5128.   coord1 := coord1t * cos(angle * pi / 180) - coord2t * sin(angle * pi / 180);
  5129.   coord2 := coord1t * sin(angle * pi / 180) + coord2t * cos(angle * pi / 180);
  5130.   coord1 := coord1 + cent1;
  5131.   coord2 := coord2 + cent2;
  5132.   c1 := round(coord1);
  5133.   c2 := round(coord2);
  5134.   pixel[c1, c2] := Color;
  5135. end;
  5136.  
  5137. procedure TDirectDrawSurface.PokeEllipse(exc, eyc, ea, eb, angle, Color: Integer);
  5138. var
  5139.   elx, ely: Integer;
  5140.   aa, aa2, bb, bb2, d, dx, dy: LongInt;
  5141.   x, y: real;
  5142. begin
  5143.   elx := 0;
  5144.   ely := eb;
  5145.   aa := LongInt(ea) * ea;
  5146.   aa2 := 2 * aa;
  5147.   bb := LongInt(eb) * eb;
  5148.   bb2 := 2 * bb;
  5149.   d := bb - aa * eb + aa div 4;
  5150.   dx := 0;
  5151.   dy := aa2 * eb;
  5152.   x := exc;
  5153.   y := eyc - ely;
  5154.   dorotate(exc, eyc, angle, x, y, Color);
  5155.   x := exc;
  5156.   y := eyc + ely;
  5157.   dorotate(exc, eyc, angle, x, y, Color);
  5158.   x := exc - ea;
  5159.   y := eyc;
  5160.   dorotate(exc, eyc, angle, x, y, Color);
  5161.   x := exc + ea;
  5162.   y := eyc;
  5163.   dorotate(exc, eyc, angle, x, y, Color);
  5164.   while (dx < dy) do begin
  5165.     if (d > 0) then begin Dec(ely); Dec(dy, aa2); Dec(d, dy); end;
  5166.     Inc(elx); Inc(dx, bb2); Inc(d, bb + dx);
  5167.     x := exc + elx; y := eyc + ely;
  5168.     dorotate(exc, eyc, angle, x, y, Color);
  5169.     x := exc - elx; y := eyc + ely;
  5170.     dorotate(exc, eyc, angle, x, y, Color);
  5171.     x := exc + elx; y := eyc - ely;
  5172.     dorotate(exc, eyc, angle, x, y, Color);
  5173.     x := exc - elx; y := eyc - ely;
  5174.     dorotate(exc, eyc, angle, x, y, Color);
  5175.   end;
  5176.   Inc(d, (3 * (aa - bb) div 2 - (dx + dy)) div 2);
  5177.   while (ely > 0) do begin
  5178.     if (d < 0) then begin Inc(elx); Inc(dx, bb2); Inc(d, bb + dx); end;
  5179.     Dec(ely); Dec(dy, aa2); Inc(d, aa - dy);
  5180.     x := exc + elx; y := eyc + ely;
  5181.     dorotate(exc, eyc, angle, x, y, Color);
  5182.     x := exc - elx; y := eyc + ely;
  5183.     dorotate(exc, eyc, angle, x, y, Color);
  5184.     x := exc + elx; y := eyc - ely;
  5185.     dorotate(exc, eyc, angle, x, y, Color);
  5186.     x := exc - elx; y := eyc - ely;
  5187.     dorotate(exc, eyc, angle, x, y, Color);
  5188.   end;
  5189. end;
  5190.  
  5191. procedure TDirectDrawSurface.MirrorFlip(Value: TRenderMirrorFlipSet);
  5192. begin
  5193.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then
  5194.     D2D.MirrorFlip := Value;
  5195. end;
  5196.  
  5197. {  TDXDrawDisplayMode  }
  5198.  
  5199. function TDXDrawDisplayMode.GetBitCount: Integer;
  5200. begin
  5201.   Result := FSurfaceDesc.ddpfPixelFormat.dwRGBBitCount;
  5202. end;
  5203.  
  5204. function TDXDrawDisplayMode.GetHeight: Integer;
  5205. begin
  5206.   Result := FSurfaceDesc.dwHeight;
  5207. end;
  5208.  
  5209. function TDXDrawDisplayMode.GetWidth: Integer;
  5210. begin
  5211.   Result := FSurfaceDesc.dwWidth;
  5212. end;
  5213.  
  5214. {  TDXDrawDisplay  }
  5215.  
  5216. constructor TDXDrawDisplay.Create(ADXDraw: TCustomDXDraw);
  5217. begin
  5218.   inherited Create;
  5219.   FDXDraw := ADXDraw;
  5220.   FModes := TCollection.Create(TDXDrawDisplayMode);
  5221.   FWidth := 640;
  5222.   FHeight := 480;
  5223.   FBitCount := 16;
  5224.   FFixedBitCount := False; //True;
  5225.   FFixedRatio := True;
  5226.   FFixedSize := True; //False;
  5227. end;
  5228.  
  5229. destructor TDXDrawDisplay.Destroy;
  5230. begin
  5231.   FModes.Free;
  5232.   inherited Destroy;
  5233. end;
  5234.  
  5235. procedure TDXDrawDisplay.Assign(Source: TPersistent);
  5236. begin
  5237.   if Source is TDXDrawDisplay then
  5238.   begin
  5239.     if Source <> Self then
  5240.     begin
  5241.       FBitCount := TDXDrawDisplay(Source).BitCount;
  5242.       FHeight := TDXDrawDisplay(Source).Height;
  5243.       FWidth := TDXDrawDisplay(Source).Width;
  5244.  
  5245.       FFixedBitCount := TDXDrawDisplay(Source).FFixedBitCount;
  5246.       FFixedRatio := TDXDrawDisplay(Source).FFixedRatio;
  5247.       FFixedSize := TDXDrawDisplay(Source).FFixedSize;
  5248.     end;
  5249.   end else
  5250.     inherited Assign(Source);
  5251. end;
  5252.  
  5253. function TDXDrawDisplay.GetCount: Integer;
  5254. begin
  5255.   if FModes.Count = 0 then
  5256.     LoadDisplayModes;
  5257.   Result := FModes.Count;
  5258. end;
  5259.  
  5260. function TDXDrawDisplay.GetMode: TDXDrawDisplayMode;
  5261. var
  5262.   i: Integer;
  5263.   ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  5264. begin
  5265.   Result := nil;
  5266.   if FDXDraw.DDraw <> nil then
  5267.   begin
  5268.     ddsd := FDXDraw.DDraw.DisplayMode;
  5269.     with ddsd do
  5270.       i := IndexOf(dwWidth, dwHeight, ddpfPixelFormat.dwRGBBitCount);
  5271.     if i <> -1 then
  5272.       Result := Modes[i];
  5273.   end;
  5274.   if Result = nil then
  5275.     raise EDirectDrawError.Create(SDisplayModeCannotAcquired);
  5276. end;
  5277.  
  5278. function TDXDrawDisplay.GetMode2(Index: Integer): TDXDrawDisplayMode;
  5279. begin
  5280.   if FModes.Count = 0 then
  5281.     LoadDisplayModes;
  5282.   Result := TDXDrawDisplayMode(FModes.Items[Index]);
  5283. end;
  5284.  
  5285. function TDXDrawDisplay.IndexOf(Width, Height, BitCount: Integer): Integer;
  5286. var
  5287.   i: Integer;
  5288. begin
  5289.   Result := -1;
  5290.   for i := 0 to Count - 1 do
  5291.     if (Modes[i].Width = Width) and (Modes[i].Height = Height) and (Modes[i].BitCount = BitCount) then
  5292.     begin
  5293.       Result := i;
  5294.       Exit;
  5295.     end;
  5296. end;
  5297.  
  5298. procedure TDXDrawDisplay.LoadDisplayModes;
  5299.  
  5300.   function EnumDisplayModesProc(const lpTDDSurfaceDesc: TDDSurfaceDesc;
  5301.     lpContext: Pointer): HRESULT; stdcall;
  5302.   begin
  5303.     with TDXDrawDisplayMode.Create(TCollection(lpContext)) do
  5304.       FSurfaceDesc := lpTDDSurfaceDesc;
  5305.     Result := DDENUMRET_OK;
  5306.   end;
  5307.  
  5308.   function Compare(Item1, Item2: TDXDrawDisplayMode): Integer;
  5309.   begin
  5310.     if Item1.Width <> Item2.Width then
  5311.       Result := Item1.Width - Item2.Width
  5312.     else if Item1.Height <> Item2.Height then
  5313.       Result := Item1.Height - Item2.Height
  5314.     else
  5315.       Result := Item1.BitCount - Item2.BitCount;
  5316.   end;
  5317.  
  5318. var
  5319.   DDraw: TDirectDraw;
  5320.   TempList: TList;
  5321.   i: Integer;
  5322. begin
  5323.   FModes.Clear;
  5324.  
  5325.   if FDXDraw.DDraw <> nil then
  5326.   begin
  5327.     FDXDraw.DDraw.DXResult := FDXDraw.DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}
  5328.       .EnumDisplayModes(0, {$IFDEF D3D_deprecated}PDDSurfaceDesc{$ELSE}PDDSurfaceDesc2{$ENDIF}(nil),
  5329.       FModes, @EnumDisplayModesProc);
  5330.   end else
  5331.   begin
  5332.     DDraw := TDirectDraw.Create(PGUID(FDXDraw.FDriver));
  5333.     try
  5334.       DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}
  5335.       .EnumDisplayModes(0, {$IFDEF D3D_deprecated}PDDSurfaceDesc{$ELSE}PDDSurfaceDesc2{$ENDIF}(nil),
  5336.       FModes, @EnumDisplayModesProc);
  5337.     finally
  5338.       DDraw.Free;
  5339.     end;
  5340.   end;
  5341.  
  5342.   TempList := TList.Create;
  5343.   try
  5344.     for i := 0 to FModes.Count - 1 do
  5345.       TempList.Add(FModes.Items[i]);
  5346.     TempList.Sort(@Compare);
  5347.  
  5348.     for i := FModes.Count - 1 downto 0 do
  5349.       TDXDrawDisplayMode(TempList[i]).Index := i;
  5350.   finally
  5351.     TempList.Free;
  5352.   end;
  5353. end;
  5354.  
  5355. function TDXDrawDisplay.SetSize(AWidth, AHeight, ABitCount{$IFNDEF D3D_deprecated}, ARefreshRate, AFlags{$ENDIF}: Integer): Boolean;
  5356. begin
  5357.   Result := False;
  5358.   if FDXDraw.DDraw <> nil then
  5359.   begin
  5360.     FDXDraw.DDraw.DXResult := FDXDraw.DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}
  5361.       .SetDisplayMode(AWidth, AHeight, ABitCount{$IFNDEF D3D_deprecated}, ARefreshRate, AFlags{$ENDIF});
  5362.     Result := FDXDraw.DDraw.DXResult = DD_OK;
  5363.  
  5364.     if Result then
  5365.     begin
  5366.       FWidth := AWidth;
  5367.       FHeight := AHeight;
  5368.       FBitCount := ABitCount;
  5369.     end;
  5370.   end;
  5371. end;
  5372.  
  5373. function TDXDrawDisplay.DynSetSize(AWidth, AHeight, ABitCount: Integer): Boolean;
  5374.  
  5375.   {$IFNDEF D3D_deprecated}
  5376.   function GetDefaultRefreshRate: Integer;
  5377.   begin
  5378.     Result := 60;
  5379.   end;
  5380.   {$ENDIF}
  5381.  
  5382.   function TestBitCount(BitCount, ABitCount: Integer): Boolean;
  5383.   begin
  5384.     if (BitCount > 8) and (ABitCount > 8) then
  5385.     begin
  5386.       Result := True;
  5387.     end else
  5388.     begin
  5389.       Result := BitCount >= ABitCount;
  5390.     end;
  5391.   end;
  5392.  
  5393.   function SetSize2(Ratio: Boolean): Boolean;
  5394.   var
  5395.     DWidth, DHeight, DBitCount{$IFNDEF D3D_deprecated}, DRRate, DFlags{$ENDIF}, i: Integer;
  5396.     Flag: Boolean;
  5397.   begin
  5398.     Result := False;
  5399.  
  5400.     DWidth := Maxint;
  5401.     DHeight := Maxint;
  5402.     DBitCount := ABitCount;
  5403.     {$IFNDEF D3D_deprecated}
  5404.     DRRate := GetDefaultRefreshRate;
  5405.     DFlags := 0;
  5406.     {$ENDIF}
  5407.     Flag := False;
  5408.     for i := 0 to Count - 1 do
  5409.       with Modes[i] do
  5410.       begin
  5411.         if ((DWidth >= Width) and (DHeight >= Width) and
  5412.           ((not Ratio) or (Width / Height = AWidth / AHeight)) and
  5413.           ((FFixedSize and (Width = AWidth) and (Height = Height)) or
  5414.           ((not FFixedSize) and (Width >= AWidth) and (Height >= AHeight))) and
  5415.  
  5416.           ((FFixedBitCount and (BitCount = ABitCount)) or
  5417.           ((not FFixedBitCount) and TestBitCount(BitCount, ABitCount)))) then
  5418.         begin
  5419.           DWidth := Width;
  5420.           DHeight := Height;
  5421.           DBitCount := BitCount;
  5422.           Flag := True;
  5423.         end;
  5424.       end;
  5425.  
  5426.     if Flag then
  5427.     begin
  5428.       if (DBitCount <> ABitCount) then
  5429.       begin
  5430.         if IndexOf(DWidth, DHEight, ABitCount) <> -1 then
  5431.           DBitCount := ABitCount;
  5432.       end;
  5433.  
  5434.       Result := SetSize(DWidth, DHeight, DBitCount{$IFNDEF D3D_deprecated}, DRRate, DFlags{$ENDIF});
  5435.     end;
  5436.   end;
  5437.  
  5438. begin
  5439.   Result := False;
  5440.  
  5441.   if (AWidth <= 0) or (AHeight <= 0) or (not (ABitCount in [8, 16, 24, 32])) then Exit;
  5442.  
  5443.   {  The change is attempted by the size of default.  }
  5444.   if SetSize(AWidth, AHeight, ABitCount{$IFNDEF D3D_deprecated}, GetDefaultRefreshRate, 0{$ENDIF}) then
  5445.   begin
  5446.     Result := True;
  5447.     Exit;
  5448.   end;
  5449.  
  5450.   {  The change is attempted by the screen ratio fixation.  }
  5451.   if FFixedRatio then
  5452.     if SetSize2(True) then
  5453.     begin
  5454.       Result := True;
  5455.       Exit;
  5456.     end;
  5457.  
  5458.   {  The change is unconditionally attempted.  }
  5459.   if SetSize2(False) then
  5460.   begin
  5461.     Result := True;
  5462.     Exit;
  5463.   end;
  5464. end;
  5465.  
  5466. procedure TDXDrawDisplay.SetBitCount(Value: Integer);
  5467. begin
  5468.   if not (Value in [8, 16, 24, 32]) then
  5469.     raise EDirectDrawError.Create(SInvalidDisplayBitCount);
  5470.   FBitCount := Value;
  5471. end;
  5472.  
  5473. procedure TDXDrawDisplay.SetHeight(Value: Integer);
  5474. begin
  5475.   FHeight := Max(Value, 0);
  5476. end;
  5477.  
  5478. procedure TDXDrawDisplay.SetWidth(Value: Integer);
  5479. begin
  5480.   FWidth := Max(Value, 0);
  5481. end;
  5482.  
  5483. {  TCustomDXDraw  }
  5484.  
  5485. function BPPToDDBD(BPP: DWORD): DWORD;
  5486. begin
  5487.   case BPP of
  5488.     1: Result := DDBD_1;
  5489.     2: Result := DDBD_2;
  5490.     4: Result := DDBD_4;
  5491.     8: Result := DDBD_8;
  5492.     16: Result := DDBD_16;
  5493.     24: Result := DDBD_24;
  5494.     32: Result := DDBD_32;
  5495.   else
  5496.     Result := 0;
  5497.   end;
  5498. end;
  5499.  
  5500. procedure FreeZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface);
  5501. begin
  5502.   if ZBuffer <> nil then
  5503.   begin
  5504.     if (Surface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) and (ZBuffer.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) then
  5505.       Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.DeleteAttachedSurface(0, ZBuffer.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF});
  5506.     ZBuffer.Free; ZBuffer := nil;
  5507.   end;
  5508. end;
  5509.  
  5510. type
  5511.   TInitializeDirect3DOption = (idoSelectDriver, idoOptimizeDisplayMode,
  5512.     idoHardware, {$IFDEF D3DRM}idoRetainedMode,{$ENDIF} idoZBuffer);
  5513.  
  5514.   TInitializeDirect3DOptions = set of TInitializeDirect3DOption;
  5515.  
  5516. procedure Direct3DInitializing(Options: TInitializeDirect3DOptions;
  5517.   var BitCount: Integer; var Driver: PGUID; var DriverGUID: TGUID{$IFNDEF D3D_deprecated}; var D3DDeviceTypeSet: TD3DDeviceTypeSet{$ENDIF});
  5518. type
  5519.   PDirect3DInitializingRecord = ^TDirect3DInitializingRecord;
  5520.   TDirect3DInitializingRecord = record
  5521.     Options: TInitializeDirect3DOptions;
  5522.     Driver: ^PGUID;
  5523.     DriverGUID: PGUID;
  5524.     BitCount: Integer;
  5525.  
  5526.     Flag: Boolean;
  5527.     DriverCaps: TDDCaps;
  5528.     HELCaps: TDDCaps;
  5529.     {$IFDEF D3D_deprecated}
  5530.     HWDeviceDesc: TD3DDeviceDesc;
  5531.     HELDeviceDesc: TD3DDeviceDesc;
  5532.     DeviceDesc: TD3DDeviceDesc;
  5533.     {$ELSE}
  5534.     DeviceDesc: TD3DDeviceDesc7;
  5535.     {$ENDIF}
  5536.     D3DFlag: Boolean;
  5537.     {$IFDEF D3D_deprecated}
  5538.     HWDeviceDesc2: TD3DDeviceDesc;
  5539.     HELDeviceDesc2: TD3DDeviceDesc;
  5540.     DeviceDesc2: TD3DDeviceDesc;
  5541.     {$ELSE}
  5542.     DeviceDesc2: TD3DDeviceDesc7;
  5543.     {$ENDIF}
  5544.   end;
  5545.  
  5546.   {$IFDEF D3D_deprecated}
  5547.   function EnumDeviceCallBack(lpGuid: PGUID; // nil for the default device
  5548.       lpDeviceDescription: PAnsiChar; lpDeviceName: PAnsiChar;
  5549.       var lpD3DHWDeviceDesc: TD3DDeviceDesc;
  5550.       var lpD3DHELDeviceDesc: TD3DDeviceDesc;
  5551.       rec: PDirect3DInitializingRecord) : HResult; stdcall;
  5552.  
  5553.     procedure UseThisDevice;
  5554.     begin
  5555.       rec.D3DFlag := True;
  5556.       rec.HWDeviceDesc2 := lpD3DHWDeviceDesc;
  5557.       rec.HELDeviceDesc2 := lpD3DHELDeviceDesc;
  5558.       rec.DeviceDesc2 := lpD3DHWDeviceDesc;
  5559.     end;
  5560.  
  5561.   begin
  5562.     Result := D3DENUMRET_OK;
  5563.  
  5564.     if lpD3DHWDeviceDesc.dcmColorModel = 0 then Exit;
  5565.  
  5566.     if idoOptimizeDisplayMode in rec.Options then
  5567.     begin
  5568.       if (lpD3DHWDeviceDesc.dwDeviceRenderBitDepth and (DDBD_16 or DDBD_24 or DDBD_32)) = 0 then Exit;
  5569.     end
  5570.     else
  5571.     begin
  5572.       if (lpD3DHWDeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then Exit;
  5573.     end;
  5574.  
  5575.     UseThisDevice;
  5576.   end;
  5577.   {$ELSE}
  5578.   function EnumDeviceCallBack(lpDeviceDescription: PAnsiChar; lpDeviceName: PAnsiChar;
  5579.       const lpD3DDeviceDesc: TD3DDeviceDesc7; rec: PDirect3DInitializingRecord) : HResult; stdcall;
  5580.   begin
  5581.     Result := D3DENUMRET_OK;
  5582.  
  5583.     maxVideoBlockSize := Min(lpD3DDeviceDesc.dwMaxTextureWidth, lpD3DDeviceDesc.dwMaxTextureHeight);
  5584.     SurfaceDivWidth := lpD3DDeviceDesc.dwMaxTextureWidth;
  5585.     SurfaceDivHeight := lpD3DDeviceDesc.dwMaxTextureHeight;
  5586.  
  5587.     //if lpD3DHWDeviceDesc.dcmColorModel = 0 then Exit;
  5588.     if idoOptimizeDisplayMode in rec.Options then
  5589.     begin
  5590.       if (lpD3DDeviceDesc.dwDeviceRenderBitDepth and (DDBD_16 or DDBD_24 or DDBD_32)) = 0 then Exit;
  5591.     end
  5592.     else
  5593.     begin
  5594.       if (lpD3DDeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then Exit;
  5595.     end;
  5596.  
  5597.     rec.D3DFlag := True;
  5598.     rec.DeviceDesc2 := lpD3DDeviceDesc;
  5599.   end;
  5600.   {$ENDIF}
  5601.  
  5602.   function EnumDirectDrawDriverCallback(lpGUID: PGUID; lpDriverDescription: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF};
  5603.     lpDriverName: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF}; rec: PDirect3DInitializingRecord): HRESULT; stdcall;
  5604.   var
  5605.     DDraw: TDirectDraw;
  5606.     {$IFDEF D3D_deprecated}
  5607.     Direct3D: IDirect3D;
  5608.     {$ENDIF}
  5609.     Direct3D7: IDirect3D7;
  5610.  
  5611.     function CountBitMask(i: DWORD; const Bits: array of DWORD): DWORD;
  5612.     var
  5613.       j: Integer;
  5614.     begin
  5615.       Result := 0;
  5616.  
  5617.       for j := Low(Bits) to High(Bits) do
  5618.       begin
  5619.         if i and Bits[j] <> 0 then
  5620.           Inc(Result);
  5621.       end;
  5622.     end;
  5623.  
  5624.     function CompareCountBitMask(i, i2: DWORD; const Bits: array of DWORD): Integer;
  5625.     var
  5626.       j, j2: DWORD;
  5627.     begin
  5628.       j := CountBitMask(i, Bits);
  5629.       j2 := CountBitMask(i2, Bits);
  5630.  
  5631.       if j < j2 then
  5632.         Result := -1
  5633.       else if i > j2 then
  5634.         Result := 1
  5635.       else
  5636.         Result := 0;
  5637.     end;
  5638.  
  5639.     function CountBit(i: DWORD): DWORD;
  5640.     var
  5641.       j: Integer;
  5642.     begin
  5643.       Result := 0;
  5644.  
  5645.       for j := 0 to 31 do
  5646.         if i and (1 shl j) <> 0 then
  5647.           Inc(Result);
  5648.     end;
  5649.  
  5650.     function CompareCountBit(i, i2: DWORD): Integer;
  5651.     begin
  5652.       Result := CountBit(i) - CountBit(i2);
  5653.       if Result < 0 then Result := -1;
  5654.       if Result > 0 then Result := 1;
  5655.     end;
  5656.  
  5657.     function FindDevice: Boolean;
  5658.     begin
  5659.       {  The Direct3D driver is examined.  }
  5660.       rec.D3DFlag := False;
  5661.       try
  5662.         {$IFDEF D3D_deprecated}Direct3D{$ELSE}Direct3D7{$ENDIF}.EnumDevices(@EnumDeviceCallBack, rec) {= DD_OK}
  5663.       except
  5664.         on E: Exception do
  5665.         begin
  5666.           rec.D3DFlag := False;
  5667.           // eventually catch  exception to automatic log
  5668.           Log(E.Message {$IFNDEF VER4UP}, ChangefileExt(ParamStr(0), '.log'){$ENDIF});
  5669.           //and cannot continue !!!
  5670.           Result := False;
  5671.           Exit;
  5672.         end;
  5673.       end;
  5674.       Result := rec.D3DFlag;
  5675.  
  5676.       if not Result then Exit;
  5677.  
  5678.       {  Comparison of DirectDraw driver.  }
  5679.       if not rec.Flag then
  5680.       begin
  5681.         {$IFDEF D3D_deprecated}
  5682.         rec.HWDeviceDesc := rec.HWDeviceDesc2;
  5683.         rec.HELDeviceDesc := rec.HELDeviceDesc2;
  5684.         rec.DeviceDesc := rec.DeviceDesc2;
  5685.         {$ENDIF}
  5686.         rec.Flag := True;
  5687.       end
  5688.       else
  5689.       begin
  5690.         {  Comparison of hardware. (One with large number of functions to support is chosen.  }
  5691.         Result := False;
  5692.  
  5693.         if DDraw.DriverCaps.dwVidMemTotal < rec.DriverCaps.dwVidMemTotal then Exit;
  5694.         {$IFDEF D3D_deprecated}
  5695.         if CompareCountBitMask(DDraw.DriverCaps.ddscaps.dwCaps, rec.DriverCaps.ddscaps.dwCaps, [DDSCAPS_TEXTURE, DDSCAPS_ZBUFFER, DDSCAPS_MIPMAP]) +
  5696.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwMiscCaps, rec.HWDeviceDesc2.dpcLineCaps.dwMiscCaps) +
  5697.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwRasterCaps, rec.HWDeviceDesc2.dpcLineCaps.dwRasterCaps) +
  5698.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwAlphaCmpCaps, rec.HWDeviceDesc2.dpcLineCaps.dwAlphaCmpCaps) +
  5699.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwSrcBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwSrcBlendCaps) +
  5700.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwDestBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwDestBlendCaps) +
  5701.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwShadeCaps, rec.HWDeviceDesc2.dpcLineCaps.dwShadeCaps) +
  5702.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureCaps) +
  5703.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureFilterCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureFilterCaps) +
  5704.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureBlendCaps) +
  5705.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureAddressCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureAddressCaps) < 0 then Exit;
  5706.         {$ENDIF}
  5707.         Result := True;
  5708.       end;
  5709.     end;
  5710.  
  5711.   begin
  5712.     Result := DDENUMRET_OK;
  5713.  
  5714.     DDraw := TDirectDraw.Create(lpGUID);
  5715.     try
  5716.       if (DDraw.DriverCaps.dwCaps and DDCAPS_3D <> 0) and
  5717.         (DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE <> 0) then
  5718.       begin
  5719.         try
  5720.         if DDraw.IDDraw7 <> nil then
  5721.           Direct3D7 := DDraw.IDraw7 as IDirect3D7
  5722.         {$IFDEF D3D_deprecated}
  5723.         else
  5724.           Direct3D := DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF} as IDirect3D
  5725.         {$ENDIF};
  5726.         except
  5727.           on E: Exception do
  5728.             log(E.Message {$IFNDEF VER4UP}, ChangefileExt(ParamStr(0), '.log'){$ENDIF});
  5729.         end;
  5730.         try
  5731.           if FindDevice then
  5732.           begin
  5733.             rec.DriverCaps := DDraw.DriverCaps;
  5734.             rec.HELCaps := DDraw.HELCaps;
  5735.  
  5736.             if lpGUID = nil then
  5737.               rec.Driver := nil
  5738.             else
  5739.             begin
  5740.               rec.DriverGUID^ := lpGUID^;
  5741.               rec.Driver^ := @rec.DriverGUID;
  5742.             end;
  5743.           end;
  5744.         finally
  5745.           {$IFDEF D3D_deprecated}
  5746.           Direct3D := nil;
  5747.           {$ENDIF}
  5748.           Direct3D7 := nil;
  5749.         end;
  5750.       end;
  5751.     finally
  5752.       DDraw.Free;
  5753.     end;
  5754.   end;
  5755.  
  5756. var
  5757.   rec: TDirect3DInitializingRecord;
  5758.   DDraw: TDirectDraw;
  5759.   {$IFNDEF D3D_deprecated}
  5760.   devGUID: Tguid;
  5761.   {$ENDIF}
  5762. begin
  5763.   FillChar(rec, SizeOf(rec), 0);
  5764.   rec.BitCount := BitCount;
  5765.   rec.Options := Options;
  5766.  
  5767.   {  Driver selection   }
  5768.   if idoSelectDriver in Options then
  5769.   begin
  5770.     rec.Flag := False;
  5771.     rec.Options := Options;
  5772.     rec.Driver := @Driver;
  5773.     rec.DriverGUID := @DriverGUID;
  5774.     DXDirectDrawEnumerate(@EnumDirectDrawDriverCallback, @rec);
  5775.   end
  5776.   else
  5777.   begin
  5778.     DDraw := TDirectDraw.Create(Driver);
  5779.     try
  5780.       rec.DriverCaps := DDraw.DriverCaps;
  5781.       rec.HELCaps := DDraw.HELCaps;
  5782.  
  5783.       rec.D3DFlag := False;
  5784.       (DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF} as IDirect3D).EnumDevices(@EnumDeviceCallBack, @rec);
  5785.       if rec.D3DFlag then
  5786.         {$IFDEF D3D_deprecated}
  5787.         rec.DeviceDesc := rec.DeviceDesc2;
  5788.         {$ELSE}
  5789.         rec.DeviceDesc := rec.DeviceDesc2;
  5790.         {$ENDIF}
  5791.     finally
  5792.       DDraw.Free;
  5793.     end;
  5794.     rec.Flag := True;
  5795.   end;
  5796.  
  5797.   {  Display mode optimization  }
  5798.   if rec.Flag and (idoOptimizeDisplayMode in Options) then
  5799.   begin
  5800.     if (rec.DeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then
  5801.     begin
  5802.       if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_16 <> 0 then
  5803.         rec.BitCount := 16
  5804.       else
  5805.       if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_24 <> 0 then
  5806.         rec.BitCount := 24
  5807.       else if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_32 <> 0 then
  5808.         rec.BitCount := 32;
  5809.     end;
  5810.   end;
  5811.  
  5812.   {test type of device}
  5813.   {$IFNDEF D3D_deprecated}
  5814.   D3DDeviceTypeSet := [];
  5815.  
  5816.   Move(rec.DeviceDesc2.deviceGUID, devGUID, Sizeof(TGUID) );
  5817.  
  5818.   if CompareMem(@devGUID, @IID_IDirect3DTnLHalDevice, Sizeof(TGUID)) then
  5819.     D3DDeviceTypeSet := D3DDeviceTypeSet + [dtTnLHAL];
  5820.  
  5821.   if CompareMem(@devGUID, @IID_IDirect3DHALDEVICE, Sizeof(TGUID)) then
  5822.     D3DDeviceTypeSet := D3DDeviceTypeSet + [dtHAL];
  5823.  
  5824.   if CompareMem(@devGUID, @IID_IDirect3DMMXDevice, Sizeof(TGUID)) then
  5825.     D3DDeviceTypeSet := D3DDeviceTypeSet + [dtMMX];
  5826.  
  5827.   if CompareMem(@devGUID, @IID_IDirect3DRGBDevice, Sizeof(TGUID)) then
  5828.     D3DDeviceTypeSet := D3DDeviceTypeSet + [dtRGB];
  5829.  
  5830.   if CompareMem(@devGUID, @IID_IDirect3DRampDevice, Sizeof(TGUID)) then
  5831.     D3DDeviceTypeSet := D3DDeviceTypeSet + [dtRamp];
  5832.  
  5833.   if CompareMem(@devGUID, @IID_IDirect3DRefDevice, Sizeof(TGUID)) then
  5834.     D3DDeviceTypeSet := D3DDeviceTypeSet + [dtRef];
  5835.   {$ENDIF}
  5836.   BitCount := rec.BitCount;
  5837. end;
  5838.  
  5839. procedure Direct3DInitializing_DXDraw(Options: TInitializeDirect3DOptions;
  5840.   DXDraw: TCustomDXDraw);
  5841. var
  5842.   BitCount: Integer;
  5843.   Driver: PGUID;
  5844.   DriverGUID: TGUID;
  5845.   {$IFNDEF D3D_deprecated}
  5846.   D3DDeviceTypeSet: TD3DDeviceTypeSet;
  5847.   {$ENDIF}
  5848. begin
  5849.   BitCount := DXDraw.Display.BitCount;
  5850.   Driver := DXDraw.Driver;
  5851.   Direct3DInitializing(Options, BitCount, Driver, DriverGUID{$IFNDEF D3D_deprecated}, D3DDeviceTypeSet{$ENDIF});
  5852.   DXDraw.Driver := Driver;
  5853.   DXDraw.Display.BitCount := BitCount;
  5854.   {$IFNDEF D3D_deprecated}
  5855.   DXDraw.FDeviceTypeSet := D3DDeviceTypeSet;
  5856.   {$ENDIF}
  5857. end;
  5858.  
  5859. {$IFDEF D3D_deprecated}
  5860. procedure InitializeDirect3D(Surface: TDirectDrawSurface;
  5861.   var ZBuffer: TDirectDrawSurface;
  5862.   out D3D: IDirect3D;
  5863.   out D3D2: IDirect3D2;
  5864.   out D3D3: IDirect3D3;
  5865.   out D3DDevice: IDirect3DDevice;
  5866.   out D3DDevice2: IDirect3DDevice2;
  5867.   out D3DDevice3: IDirect3DDevice3;
  5868. {$IFDEF D3DRM}
  5869.   var D3DRM: IDirect3DRM;
  5870.   var D3DRM2: IDirect3DRM2;
  5871.   var D3DRM3: IDirect3DRM3;
  5872.   out D3DRMDevice: IDirect3DRMDevice;
  5873.   out D3DRMDevice2: IDirect3DRMDevice2;
  5874.   out D3DRMDevice3: IDirect3DRMDevice3;
  5875.   out Viewport: IDirect3DRMViewport;
  5876.   var Scene: IDirect3DRMFrame;
  5877.   var Camera: IDirect3DRMFrame;
  5878. {$ENDIF}
  5879.   var NowOptions: TInitializeDirect3DOptions);
  5880. type
  5881.   TInitializeDirect3DRecord = record
  5882.     Flag: Boolean;
  5883.     BitCount: Integer;
  5884.     HWDeviceDesc: TD3DDeviceDesc;
  5885.     HELDeviceDesc: TD3DDeviceDesc;
  5886.     DeviceDesc: TD3DDeviceDesc;
  5887.     Hardware: Boolean;
  5888.     Options: TInitializeDirect3DOptions;
  5889.     GUID: TGUID;
  5890.     SupportHardware: Boolean;
  5891.   end;
  5892.  
  5893.   function CreateZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface;
  5894.     const DeviceDesc: TD3DDeviceDesc; Hardware: Boolean): Boolean;
  5895.   const
  5896.     MemPosition: array[Boolean] of Integer = (DDSCAPS_SYSTEMMEMORY, DDSCAPS_VIDEOMEMORY);
  5897.   var
  5898.     ZBufferBitDepth: Integer;
  5899.     ddsd: TDDSurfaceDesc;
  5900.   begin
  5901.     Result := False;
  5902.     FreeZBufferSurface(Surface, ZBuffer);
  5903.  
  5904.     if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_16 <> 0 then
  5905.       ZBufferBitDepth := 16
  5906.     else
  5907.     if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_24 <> 0 then
  5908.       ZBufferBitDepth := 24
  5909.     else
  5910.     if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_32 <> 0 then
  5911.       ZBufferBitDepth := 32
  5912.     else
  5913.       ZBufferBitDepth := 0;
  5914.  
  5915.     if ZBufferBitDepth <> 0 then
  5916.     begin
  5917.       with ddsd do
  5918.       begin
  5919.         dwSize := SizeOf(ddsd);
  5920.         Surface.ISurface.GetSurfaceDesc(ddsd);
  5921.         dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT or DDSD_ZBUFFERBITDEPTH;
  5922.         ddsCaps.dwCaps := DDSCAPS_ZBUFFER or MemPosition[Hardware];
  5923.         dwHeight := Surface.Height;
  5924.         dwWidth := Surface.Width;
  5925.         dwZBufferBitDepth := ZBufferBitDepth;
  5926.       end;
  5927.  
  5928.       ZBuffer := TDirectDrawSurface.Create(Surface.DDraw);
  5929.       if ZBuffer.CreateSurface(ddsd) then
  5930.       begin
  5931.         if Surface.ISurface.AddAttachedSurface(ZBuffer.ISurface) <> DD_OK then
  5932.         begin
  5933.           ZBuffer.Free; ZBuffer := nil;
  5934.           Exit;
  5935.         end;
  5936.         Result := True;
  5937.       end else
  5938.       begin
  5939.         ZBuffer.Free; ZBuffer := nil;
  5940.         Exit;
  5941.       end;
  5942.     end;
  5943.   end;
  5944.  
  5945.   function EnumDeviceCallBack(const lpGuid: TGUID; lpDeviceDescription, lpDeviceName: PChar;
  5946.     const lpD3DHWDeviceDesc, lpD3DHELDeviceDesc: TD3DDeviceDesc;
  5947.     lpUserArg: Pointer): HRESULT; stdcall;
  5948.   var
  5949.     dev: ^TD3DDeviceDesc;
  5950.     Hardware: Boolean;
  5951.     rec: ^TInitializeDirect3DRecord;
  5952.  
  5953.     procedure UseThisDevice;
  5954.     begin
  5955.       rec.Flag := True;
  5956.       rec.GUID := lpGUID;
  5957.       rec.HWDeviceDesc := lpD3DHWDeviceDesc;
  5958.       rec.HELDeviceDesc := lpD3DHELDeviceDesc;
  5959.       rec.DeviceDesc := dev^;
  5960.       rec.Hardware := Hardware;
  5961.     end;
  5962.  
  5963.   begin
  5964.     Result := D3DENUMRET_OK;
  5965.     rec := lpUserArg;
  5966.  
  5967.     Hardware := lpD3DHWDeviceDesc.dcmColorModel <> 0;
  5968.     if Hardware then
  5969.       dev := @lpD3DHWDeviceDesc
  5970.     else
  5971.       dev := @lpD3DHELDeviceDesc;
  5972.  
  5973.     if (Hardware) and (not rec.SupportHardware) then Exit;
  5974.     if dev.dcmColorModel <> D3DCOLOR_RGB then Exit;
  5975.     if CompareMem(@lpGUID, @IID_IDirect3DRefDevice, SizeOf(TGUID)) then Exit;
  5976.  
  5977.     {  Bit depth test.  }
  5978.     if (dev.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then Exit;
  5979.  
  5980.     if Hardware then
  5981.     begin
  5982.       {  Hardware  }
  5983.       UseThisDevice;
  5984.     end else
  5985.     begin
  5986.       {  Software  }
  5987.       if not rec.Hardware then
  5988.         UseThisDevice;
  5989.     end;
  5990.   end;
  5991.  
  5992. var
  5993.   Hardware: Boolean;
  5994.   SupportHardware: Boolean;
  5995.   D3DDeviceGUID: TGUID;
  5996.   Options: TInitializeDirect3DOptions;
  5997.  
  5998.   procedure InitDevice;
  5999.   var
  6000.     rec: TInitializeDirect3DRecord;
  6001.   begin
  6002.     {  Device search  }
  6003.     rec.Flag := False;
  6004.     rec.BitCount := Surface.BitCount;
  6005.     rec.Hardware := False;
  6006.     rec.Options := Options;
  6007.     rec.SupportHardware := SupportHardware;
  6008.  
  6009.     D3D3.EnumDevices(@EnumDeviceCallBack, @rec);
  6010.     if not rec.Flag then
  6011.       raise EDXDrawError.Create(S3DDeviceNotFound);
  6012.  
  6013.     Hardware := rec.Hardware;
  6014.     D3DDeviceGUID := rec.GUID;
  6015.  
  6016.     if Hardware then
  6017.       NowOptions := NowOptions + [idoHardware];
  6018.  
  6019.     {  Z buffer making  }
  6020.     NowOptions := NowOptions - [idoZBuffer];
  6021.     if idoZBuffer in Options then
  6022.     begin
  6023.       if CreateZBufferSurface(Surface, ZBuffer, rec.DeviceDesc, Hardware) then
  6024.         NowOptions := NowOptions + [idoZBuffer];
  6025.     end;
  6026.   end;
  6027. {$IFDEF D3DRM}
  6028. type
  6029.   TDirect3DRMCreate = function(out lplpDirect3DRM: IDirect3DRM): HRESULT; stdcall;
  6030. {$ENDIF}
  6031. begin
  6032.   try
  6033.     Options := NowOptions;
  6034.     NowOptions := [];
  6035.  
  6036.     D3D3 := Surface.DDraw.IDraw as IDirect3D3;
  6037.     D3D2 := D3D3 as IDirect3D2;
  6038.     D3D := D3D3 as IDirect3D;
  6039.  
  6040.     {  Whether hardware can be used is tested.  }
  6041.     SupportHardware := (Surface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_VIDEOMEMORY <> 0) and
  6042.       (idoHardware in Options) and (Surface.DDraw.DriverCaps.dwCaps and DDCAPS_3D <> 0);
  6043.  
  6044.     if Surface.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE = 0 then
  6045.       SupportHardware := False;
  6046.  
  6047.     {  Direct3D  }
  6048.     InitDevice;
  6049.  
  6050.     if D3D3.CreateDevice(D3DDeviceGUID, Surface.ISurface4, D3DDevice3, nil) <> D3D_OK then
  6051.     begin
  6052.       SupportHardware := False;
  6053.       InitDevice;
  6054.       if D3D3.CreateDevice(D3DDeviceGUID, Surface.ISurface4, D3DDevice3, nil) <> D3D_OK then
  6055.         raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DDevice3']);
  6056.     end;
  6057.  
  6058.     if SupportHardware then NowOptions := NowOptions + [idoHardware];
  6059.  
  6060.     D3DDevice2 := D3DDevice3 as IDirect3DDevice2;
  6061.     D3DDevice := D3DDevice3 as IDirect3DDevice;
  6062.  
  6063.     with D3DDevice3 do
  6064.     begin
  6065.       SetRenderState(TD3DRenderStateType(D3DRENDERSTATE_DITHERENABLE), 1);
  6066.       SetRenderState(TD3DRenderStateType(D3DRENDERSTATE_ZENABLE), Ord(ZBuffer <> nil));
  6067.       SetRenderState(TD3DRenderStateType(D3DRENDERSTATE_ZWRITEENABLE), Ord(ZBuffer <> nil));
  6068.     end;
  6069. {$IFDEF D3DRM}
  6070.     {  Direct3D Retained Mode}
  6071.     if idoRetainedMode in Options then
  6072.     begin
  6073.       NowOptions := NowOptions + [idoRetainedMode];
  6074.       if D3DRM = nil then
  6075.       begin
  6076.         if TDirect3DRMCreate(DXLoadLibrary('D3DRM.dll', 'Direct3DRMCreate'))(D3DRM) <> D3DRM_OK then
  6077.           raise EDXDrawError.CreateFmt(SCannotInitialized, [SDirect3DRM]);
  6078.         D3DRM2 := D3DRM as IDirect3DRM2;
  6079.         D3DRM3 := D3DRM as IDirect3DRM3;
  6080.       end;
  6081.  
  6082.       if D3DRM3.CreateDeviceFromD3D(D3D2, D3DDevice2, D3DRMDevice3) <> D3DRM_OK then
  6083.         raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DRMDevice2']);
  6084.  
  6085.       D3DRMDevice3.SetBufferCount(2);
  6086.       D3DRMDevice := D3DRMDevice3 as IDirect3DRMDevice;
  6087.       D3DRMDevice2 := D3DRMDevice3 as IDirect3DRMDevice2;
  6088.  
  6089.       {  Rendering state setting  }
  6090.       D3DRMDevice.SetQuality(D3DRMLIGHT_ON or D3DRMFILL_SOLID or D3DRMSHADE_GOURAUD);
  6091.       D3DRMDevice.SetTextureQuality(D3DRMTEXTURE_NEAREST);
  6092.       D3DRMDevice.SetDither(True);
  6093.  
  6094.       if Surface.BitCount = 8 then
  6095.       begin
  6096.         D3DRMDevice.SetShades(8);
  6097.         D3DRM.SetDefaultTextureColors(64);
  6098.         D3DRM.SetDefaultTextureShades(32);
  6099.       end else
  6100.       begin
  6101.         D3DRM.SetDefaultTextureColors(64);
  6102.         D3DRM.SetDefaultTextureShades(32);
  6103.       end;
  6104.  
  6105.       {  Frame making  }
  6106.       if Scene = nil then
  6107.       begin
  6108.         D3DRM.CreateFrame(nil, Scene);
  6109.         D3DRM.CreateFrame(Scene, Camera);
  6110.         Camera.SetPosition(Camera, 0, 0, 0);
  6111.       end;
  6112.  
  6113.       {  Viewport making  }
  6114.       D3DRM.CreateViewport(D3DRMDevice, Camera, 0, 0,
  6115.         Surface.Width, Surface.Height, Viewport);
  6116.       Viewport.SetBack(5000.0);
  6117.     end;
  6118. {$ENDIF}
  6119.    except
  6120.     FreeZBufferSurface(Surface, ZBuffer);
  6121.     D3D := nil;
  6122.     D3D2 := nil;
  6123.     D3D3 := nil;
  6124.     D3DDevice := nil;
  6125.     D3DDevice2 := nil;
  6126.     D3DDevice3 := nil;
  6127. {$IFDEF D3DRM}
  6128.     D3DRM := nil;
  6129.     D3DRM2 := nil;
  6130.     D3DRMDevice := nil;
  6131.     D3DRMDevice2 := nil;
  6132.     Viewport := nil;
  6133.     Scene := nil;
  6134.     Camera := nil;
  6135. {$ENDIF}
  6136.     raise;
  6137.   end;
  6138. end;
  6139. {$ENDIF}
  6140.  
  6141. procedure InitializeDirect3D7(Surface: TDirectDrawSurface;
  6142.   var ZBuffer: TDirectDrawSurface;
  6143.   out D3D7: IDirect3D7;
  6144.   out D3DDevice7: IDirect3DDevice7;
  6145.   var NowOptions: TInitializeDirect3DOptions);
  6146. type
  6147.   TInitializeDirect3DRecord = record
  6148.     Flag: Boolean;
  6149.     BitCount: Integer;
  6150.     DeviceDesc: TD3DDeviceDesc7;
  6151.     Hardware: Boolean;
  6152.     Options: TInitializeDirect3DOptions;
  6153.     SupportHardware: Boolean;
  6154.   end;
  6155.  
  6156.   function CreateZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface;
  6157.     const DeviceDesc: TD3DDeviceDesc7; Hardware: Boolean): Boolean;
  6158.   const
  6159.     MemPosition: array[Boolean] of Integer = (DDSCAPS_SYSTEMMEMORY, DDSCAPS_VIDEOMEMORY);
  6160.   var
  6161.     ZBufferBitDepth: Integer;
  6162.     ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  6163.   begin
  6164.     Result := False;
  6165.     FreeZBufferSurface(Surface, ZBuffer);
  6166.  
  6167.     if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_16 <> 0 then
  6168.       ZBufferBitDepth := 16
  6169.     else if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_24 <> 0 then
  6170.       ZBufferBitDepth := 24
  6171.     else if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_32 <> 0 then
  6172.       ZBufferBitDepth := 32
  6173.     else
  6174.       ZBufferBitDepth := 0;
  6175.  
  6176.     if ZBufferBitDepth <> 0 then
  6177.     begin
  6178.       with ddsd do
  6179.       begin
  6180.         dwSize := SizeOf(ddsd);
  6181.         Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetSurfaceDesc(ddsd);
  6182.         dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT or DDSD_ZBUFFERBITDEPTH;
  6183.         ddsCaps.dwCaps := DDSCAPS_ZBUFFER or MemPosition[Hardware];
  6184.         dwHeight := Surface.Height;
  6185.         dwWidth := Surface.Width;
  6186.         {$IFDEF D3D_deprecated}
  6187.         dwZBufferBitDepth := ZBufferBitDepth;
  6188.         {$ELSE}
  6189.         ddpfPixelFormat.dwFlags := DDPF_ZBUFFER;
  6190.         ddpfPixelFormat.dwZBufferBitDepth := ZBufferBitDepth;
  6191.         ddpfPixelFormat.dwStencilBitDepth := 0;
  6192.         ddpfPixelFormat.dwZBitMask := (1 shl ZBufferBitDepth) - 1;
  6193.         ddpfPixelFormat.dwStencilBitMask := 0;
  6194.         ddpfPixelFormat.dwLuminanceAlphaBitMask := 0;
  6195.         {$ENDIF}
  6196.       end;
  6197.  
  6198.       ZBuffer := TDirectDrawSurface.Create(Surface.DDraw);
  6199.       if ZBuffer.CreateSurface(ddsd) then
  6200.       begin
  6201.         if Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.AddAttachedSurface(ZBuffer.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}) <> DD_OK then
  6202.         begin
  6203.           ZBuffer.Free; ZBuffer := nil;
  6204.           Exit;
  6205.         end;
  6206.         Result := True;
  6207.       end else
  6208.       begin
  6209.         ZBuffer.Free; ZBuffer := nil;
  6210.         Exit;
  6211.       end;
  6212.     end;
  6213.   end;
  6214.  
  6215.   function EnumDeviceCallBack(lpDeviceDescription, lpDeviceName: PChar;
  6216.     const lpTD3DDeviceDesc: TD3DDeviceDesc7; lpUserArg: Pointer): HRESULT; stdcall;
  6217.   var
  6218.     Hardware: Boolean;
  6219.     rec: ^TInitializeDirect3DRecord;
  6220.  
  6221.     procedure UseThisDevice;
  6222.     begin
  6223.       rec.Flag := True;
  6224.       rec.DeviceDesc := lpTD3DDeviceDesc;
  6225.       rec.Hardware := Hardware;
  6226.     end;
  6227.  
  6228.   begin
  6229.     Result := D3DENUMRET_OK;
  6230.     rec := lpUserArg;
  6231.  
  6232.     Hardware := lpTD3DDeviceDesc.dwDevCaps and D3DDEVCAPS_HWRASTERIZATION <> 0;
  6233.  
  6234.     if Hardware and (not rec.SupportHardware) then Exit;
  6235.     if CompareMem(@lpTD3DDeviceDesc.deviceGUID, @IID_IDirect3DRefDevice, SizeOf(TGUID)) then Exit;
  6236.  
  6237.     {  Bit depth test.  }
  6238.     if (lpTD3DDeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then Exit;
  6239.  
  6240.     if Hardware then
  6241.     begin
  6242.       {  Hardware  }
  6243.       UseThisDevice;
  6244.     end else
  6245.     begin
  6246.       {  Software  }
  6247.       if not rec.Hardware then
  6248.         UseThisDevice;
  6249.     end;
  6250.   end;
  6251.  
  6252. var
  6253.   Hardware: Boolean;
  6254.   SupportHardware: Boolean;
  6255.   D3DDeviceGUID: TGUID;
  6256.   Options: TInitializeDirect3DOptions;
  6257.  
  6258.   procedure InitDevice;
  6259.   var
  6260.     rec: TInitializeDirect3DRecord;
  6261.   begin
  6262.     {  Device search  }
  6263.     rec.Flag := False;
  6264.     rec.BitCount := Surface.BitCount;
  6265.     rec.Hardware := False;
  6266.     rec.Options := Options;
  6267.     rec.SupportHardware := SupportHardware;
  6268.  
  6269.     D3D7.EnumDevices(@EnumDeviceCallBack, @rec);
  6270.     if not rec.Flag then
  6271.       raise EDXDrawError.Create(S3DDeviceNotFound);
  6272.  
  6273.     Hardware := rec.Hardware;
  6274.     D3DDeviceGUID := rec.DeviceDesc.deviceGUID;
  6275.  
  6276.     if Hardware then
  6277.       NowOptions := NowOptions + [idoHardware];
  6278.  
  6279.     {  Z buffer making  }
  6280.     NowOptions := NowOptions - [idoZBuffer];
  6281.     if idoZBuffer in Options then
  6282.     begin
  6283.       if CreateZBufferSurface(Surface, ZBuffer, rec.DeviceDesc, Hardware) then
  6284.         NowOptions := NowOptions + [idoZBuffer];
  6285.     end;
  6286.   end;
  6287.  
  6288. begin
  6289.  
  6290.   try
  6291.     Options := NowOptions {$IFDEF D3DRM}- [idoRetainedMode]{$ENDIF};
  6292.     NowOptions := [];
  6293.  
  6294.     D3D7 := Surface.DDraw.IDraw7 as IDirect3D7;
  6295.  
  6296.     {  Whether hardware can be used is tested.  }
  6297.     SupportHardware := (Surface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_VIDEOMEMORY <> 0) and
  6298.       (idoHardware in Options) and (Surface.DDraw.DriverCaps.dwCaps and DDCAPS_3D <> 0) and
  6299.       (Surface.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE <> 0);
  6300.  
  6301.     {  Direct3D  }
  6302.     InitDevice;
  6303.  
  6304.     if D3D7.CreateDevice(D3DDeviceGUID, Surface.ISurface7, D3DDevice7) <> D3D_OK then
  6305.     begin
  6306.       SupportHardware := False;
  6307.       InitDevice;
  6308.       if D3D7.CreateDevice(D3DDeviceGUID, Surface.ISurface7, D3DDevice7) <> D3D_OK then
  6309.         raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DDevice7']);
  6310.     end;
  6311.  
  6312.     if SupportHardware then NowOptions := NowOptions + [idoHardware];
  6313.   except
  6314.     FreeZBufferSurface(Surface, ZBuffer);
  6315.     D3D7 := nil;
  6316.     D3DDevice7 := nil;
  6317.     raise;
  6318.   end;
  6319. end;
  6320. type
  6321.  
  6322. {  TDXDrawDriver  }
  6323.  
  6324.   TDXDrawDriver = class
  6325.   private
  6326.     FDXDraw: TCustomDXDraw;
  6327.     constructor Create(ADXDraw: TCustomDXDraw); virtual;
  6328.     destructor Destroy; override;
  6329.     procedure Finalize; virtual;
  6330.     procedure Flip; virtual; abstract;
  6331.     procedure Initialize; virtual; abstract;
  6332.     procedure Initialize3D;
  6333.     function SetSize(AWidth, AHeight: Integer): Boolean; virtual;
  6334.     function Restore: Boolean;
  6335.   end;
  6336.  
  6337.   TDXDrawDriverBlt = class(TDXDrawDriver)
  6338.   private
  6339.     procedure Flip; override;
  6340.     procedure Initialize; override;
  6341.     procedure InitializeSurface;
  6342.     function SetSize(AWidth, AHeight: Integer): Boolean; override;
  6343.   end;
  6344.  
  6345.   TDXDrawDriverFlip = class(TDXDrawDriver)
  6346.   private
  6347.     procedure Flip; override;
  6348.     procedure Initialize; override;
  6349.   end;
  6350.  
  6351. procedure TCustomDXDraw.MirrorFlip(Value: TRenderMirrorFlipSet);
  6352. begin
  6353.   if CheckD3 then
  6354.     FD2D.MirrorFlip := Value;
  6355. end;
  6356.  
  6357. procedure TCustomDXDraw.SaveTextures(path: string);
  6358. begin
  6359.   if CheckD3 then
  6360.     FD2D.SaveTextures(path)
  6361. end;
  6362. {  TDXDrawDriver  }
  6363.  
  6364. constructor TDXDrawDriver.Create(ADXDraw: TCustomDXDraw);
  6365. var
  6366.   AOptions: TInitializeDirect3DOptions;
  6367. begin
  6368.   inherited Create;
  6369.   FDXDraw := ADXDraw;
  6370.  
  6371.   {  Driver selection and Display mode optimizationn }
  6372.   if FDXDraw.FOptions * [doFullScreen, doSystemMemory, {$IFDEF D3D_deprecated}do3D,{$ENDIF} doHardware] =
  6373.     [doFullScreen, {$IFDEF D3D_deprecated}do3D,{$ENDIF} doHardware] then
  6374.   begin
  6375.     AOptions := [];
  6376.     with FDXDraw do
  6377.     begin
  6378.       if doSelectDriver in Options then AOptions := AOptions + [idoSelectDriver];
  6379.       if not FDXDraw.Display.FixedBitCount then AOptions := AOptions + [idoOptimizeDisplayMode];
  6380.  
  6381.       if doHardware in Options then AOptions := AOptions + [idoHardware];
  6382.       {$IFDEF D3DRM}if doRetainedMode in Options then AOptions := AOptions + [idoRetainedMode];{$ENDIF}
  6383.       if doZBuffer in Options then AOptions := AOptions + [idoZBuffer];
  6384.     end;
  6385.  
  6386.     Direct3DInitializing_DXDraw(AOptions, FDXDraw);
  6387.   end;
  6388.  
  6389.   if FDXDraw.Options * [doFullScreen, doHardware, doSystemMemory] = [doFullScreen, doHardware] then
  6390.     FDXDraw.FDDraw := TDirectDraw.CreateEx(PGUID(FDXDraw.FDriver), {$IFDEF D3D_deprecated}doDirectX7Mode in FDXDraw.Options{$ELSE}True{$ENDIF})
  6391.   else
  6392.     FDXDraw.FDDraw := TDirectDraw.CreateEx(nil, {$IFDEF D3D_deprecated}doDirectX7Mode in FDXDraw.Options{$ELSE}True{$ENDIF});
  6393. end;
  6394.  
  6395. procedure TDXDrawDriver.Initialize3D;
  6396. const
  6397.   DXDrawOptions3D = [doHardware, {$IFDEF D3DRM}doRetainedMode,{$ENDIF} doSelectDriver, doZBuffer];
  6398. var
  6399.   AOptions: TInitializeDirect3DOptions;
  6400. begin
  6401.   AOptions := [];
  6402.   with FDXDraw do
  6403.   begin
  6404.     if doHardware in FOptions then AOptions := AOptions + [idoHardware];
  6405.     {$IFDEF D3DRM}if doRetainedMode in FNowOptions then AOptions := AOptions + [idoRetainedMode];{$ENDIF}
  6406.     if doSelectDriver in FOptions then AOptions := AOptions + [idoSelectDriver];
  6407.     if doZBuffer in FOptions then AOptions := AOptions + [idoZBuffer];
  6408.     {$IFDEF D3D_deprecated}
  6409.     if doDirectX7Mode in FOptions then
  6410.     begin
  6411.       InitializeDirect3D7(FSurface, FZBuffer, FD3D7, FD3DDevice7, AOptions);
  6412.     end else
  6413.     begin
  6414.       InitializeDirect3D(FSurface, FZBuffer, FD3D, FD3D2, FD3D3, FD3DDevice, FD3DDevice2, FD3DDevice3,
  6415.         {$IFDEF D3DRM}
  6416.         FD3DRM, FD3DRM2, FD3DRM3, FD3DRMDevice, FD3DRMDevice2, FD3DRMDevice3, FViewport, FScene, FCamera,
  6417.         {$ENDIF}
  6418.         AOptions);
  6419.     end;
  6420.     {$ELSE}
  6421.     InitializeDirect3D7(FSurface, FZBuffer, FD3D7, FD3DDevice7, AOptions);
  6422.     {$ENDIF}
  6423.     FNowOptions := FNowOptions - DXDrawOptions3D;
  6424.     if idoHardware in AOptions then FNowOptions := FNowOptions + [doHardware];
  6425.     {$IFDEF D3DRM}if idoRetainedMode in AOptions then FNowOptions := FNowOptions + [doRetainedMode];{$ENDIF}
  6426.     if idoSelectDriver in AOptions then FNowOptions := FNowOptions + [doSelectDriver];
  6427.     if idoZBuffer in AOptions then FNowOptions := FNowOptions + [doZBuffer];
  6428.   end;
  6429. end;
  6430.  
  6431. destructor TDXDrawDriver.Destroy;
  6432. begin
  6433.   Finalize;
  6434.   FDXDraw.FDDraw.Free;
  6435.   inherited Destroy;
  6436. end;
  6437.  
  6438. procedure TDXDrawDriver.Finalize;
  6439. begin
  6440.   with FDXDraw do
  6441.   begin
  6442.     {$IFDEF D3DRM}
  6443.     FViewport := nil;
  6444.     FCamera := nil;
  6445.     FScene := nil;
  6446.  
  6447.     FD3DRMDevice := nil;
  6448.     FD3DRMDevice2 := nil;
  6449.     FD3DRMDevice3 := nil;
  6450.     FD3DRM3 := nil;
  6451.     FD3DRM2 := nil;
  6452.     FD3DRM := nil;
  6453.     {$ENDIF}
  6454.     {$IFDEF D3D_deprecated}
  6455.     FD3DDevice := nil;
  6456.     FD3DDevice2 := nil;
  6457.     FD3DDevice3 := nil;
  6458.     {$ENDIF}
  6459.     FD3DDevice7 := nil;
  6460.     {$IFDEF D3D_deprecated}
  6461.     FD3D := nil;
  6462.     FD3D2 := nil;
  6463.     FD3D3 := nil;
  6464.     {$ENDIF}
  6465.     FD3D7 := nil;
  6466.  
  6467.     FreeZBufferSurface(FSurface, FZBuffer);
  6468.  
  6469.     FClipper.Free; FClipper := nil;
  6470.     FPalette.Free; FPalette := nil;
  6471.     FSurface.Free; FSurface := nil;
  6472.     FPrimary.Free; FPrimary := nil;
  6473.  
  6474.   end;
  6475. end;
  6476.  
  6477. function TDXDrawDriver.Restore: Boolean;
  6478. begin
  6479.   Result := FDXDraw.FPrimary.Restore and FDXDraw.FSurface.Restore;
  6480.   if Result then
  6481.   begin
  6482.     FDXDraw.FPrimary.Fill(0);
  6483.     FDXDraw.FSurface.Fill(0);
  6484.   end;
  6485. end;
  6486.  
  6487. function TDXDrawDriver.SetSize(AWidth, AHeight: Integer): Boolean;
  6488. begin
  6489.   Result := False;
  6490. end;
  6491.  
  6492. {  TDXDrawDriverBlt  }
  6493.  
  6494. function TDXDrawRGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads;
  6495.   AllowPalette256: Boolean): TPaletteEntries;
  6496. var
  6497.   Entries: TPaletteEntries;
  6498.   dc: THandle;
  6499.   i: Integer;
  6500. begin
  6501.   Result := RGBQuadsToPaletteEntries(RGBQuads);
  6502.  
  6503.   if not AllowPalette256 then
  6504.   begin
  6505.     dc := GetDC(0);
  6506.     try
  6507.       GetSystemPaletteEntries(dc, 0, 256, Entries);
  6508.     finally
  6509.       ReleaseDC(0, dc);
  6510.     end;
  6511.  
  6512.     for i := 0 to 9 do
  6513.       Result[i] := Entries[i];
  6514.  
  6515.     for i := 256 - 10 to 255 do
  6516.       Result[i] := Entries[i];
  6517.   end;
  6518.  
  6519.   for i := 0 to 255 do
  6520.     Result[i].peFlags := D3DPAL_READONLY;
  6521. end;
  6522.  
  6523. procedure TDXDrawDriverBlt.Flip;
  6524. var
  6525.   pt: TPoint;
  6526.   Dest: TRect;
  6527.   DF: TDDBltFX;
  6528. begin
  6529.   pt := FDXDraw.ClientToScreen(Point(0, 0));
  6530.  
  6531.   if doStretch in FDXDraw.NowOptions then
  6532.   begin
  6533.     Dest := Bounds(pt.x, pt.y, FDXDraw.Width, FDXDraw.Height);
  6534.   end else
  6535.   begin
  6536.     if doCenter in FDXDraw.NowOptions then
  6537.     begin
  6538.       Inc(pt.x, (FDXDraw.Width - FDXDraw.FSurface.Width) div 2);
  6539.       Inc(pt.y, (FDXDraw.Height - FDXDraw.FSurface.Height) div 2);
  6540.     end;
  6541.  
  6542.     Dest := Bounds(pt.x, pt.y, FDXDraw.FSurface.Width, FDXDraw.FSurface.Height);
  6543.   end;
  6544.  
  6545.   if doWaitVBlank in FDXDraw.NowOptions then
  6546.     FDXDraw.FDDraw.DXResult := FDXDraw.FDDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.WaitForVerticalBlank(DDWAITVB_BLOCKBEGIN, 0);
  6547.  
  6548.   FillChar(DF, SizeOf(DF), 0);
  6549.   DF.dwsize := SizeOf(DF);
  6550.   DF.dwDDFX := 0;
  6551.  
  6552.   FDXDraw.FPrimary.Blt(Dest, FDXDraw.FSurface.ClientRect, DDBLT_WAIT, df, FDXDraw.FSurface);
  6553. end;
  6554.  
  6555. procedure TDXDrawDriverBlt.Initialize;
  6556. {$IFDEF D3D_deprecated}
  6557. const
  6558.   PrimaryDesc: TDDSurfaceDesc = (
  6559.     dwSize: SizeOf(PrimaryDesc);
  6560.     dwFlags: DDSD_CAPS;
  6561.     ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE)
  6562.     );
  6563. {$ENDIF}
  6564. var
  6565.   Entries: TPaletteEntries;
  6566.   PaletteCaps: Integer;
  6567.   {$IFNDEF D3D_deprecated}
  6568.   PrimaryDesc: TDDSurfaceDesc2;
  6569.   {$ENDIF}
  6570. begin
  6571.   {$IFNDEF D3D_deprecated}
  6572.   FillChar(PrimaryDesc, SizeOf(PrimaryDesc), 0);
  6573.   PrimaryDesc.dwSize := SizeOf(PrimaryDesc);
  6574.   PrimaryDesc.dwFlags := DDSD_CAPS;
  6575.   PrimaryDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
  6576.   {$ENDIF}
  6577.   {  Surface making  }
  6578.   FDXDraw.FPrimary := TDirectDrawSurface.Create(FDXDraw.FDDraw);
  6579.   if not FDXDraw.FPrimary.CreateSurface(PrimaryDesc) then
  6580.     raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawPrimarySurface]);
  6581.  
  6582.   FDXDraw.FSurface := TDirectDrawSurface.Create(FDXDraw.FDDraw);
  6583.  
  6584.   {  Clipper making  }
  6585.   FDXDraw.FClipper := TDirectDrawClipper.Create(FDXDraw.FDDraw);
  6586.   FDXDraw.FClipper.Handle := FDXDraw.Handle;
  6587.   FDXDraw.FPrimary.Clipper := FDXDraw.FClipper;
  6588.  
  6589.   {  Palette making  }
  6590.   PaletteCaps := DDPCAPS_8BIT or DDPCAPS_INITIALIZE;
  6591.   if doAllowPalette256 in FDXDraw.NowOptions then
  6592.     PaletteCaps := PaletteCaps or DDPCAPS_ALLOW256;
  6593.  
  6594.   FDXDraw.FPalette := TDirectDrawPalette.Create(FDXDraw.FDDraw);
  6595.   Entries := TDXDrawRGBQuadsToPaletteEntries(FDXDraw.ColorTable,
  6596.     doAllowPalette256 in FDXDraw.NowOptions);
  6597.   FDXDraw.FPalette.CreatePalette(PaletteCaps, Entries);
  6598.  
  6599.   FDXDraw.FPrimary.Palette := FDXDraw.Palette;
  6600.  
  6601.   InitializeSurface;
  6602. end;
  6603.  
  6604. procedure TDXDrawDriverBlt.InitializeSurface;
  6605. var
  6606.   ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  6607. begin
  6608.   FDXDraw.FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil;
  6609.  
  6610.   {  Surface making  }
  6611.   FDXDraw.FNowOptions := FDXDraw.FNowOptions - [doSystemMemory];
  6612.  
  6613.   FillChar(ddsd, SizeOf(ddsd), 0);
  6614.   with ddsd do
  6615.   begin
  6616.     dwSize := SizeOf(ddsd);
  6617.     dwFlags := DDSD_WIDTH or DDSD_HEIGHT or DDSD_CAPS;
  6618.     dwWidth := Max(FDXDraw.FSurfaceWidth, 1);
  6619.     dwHeight := Max(FDXDraw.FSurfaceHeight, 1);
  6620.     ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
  6621.     if doSystemMemory in FDXDraw.Options then
  6622.       ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
  6623.     {$IFDEF D3D_deprecated}if do3D in FDXDraw.FNowOptions then{$ENDIF}
  6624.       ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_3DDEVICE;
  6625.   end;
  6626.  
  6627.   if not FDXDraw.FSurface.CreateSurface(ddsd) then
  6628.   begin
  6629.     ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
  6630.     if not FDXDraw.FSurface.CreateSurface(ddsd) then
  6631.       raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
  6632.   end;
  6633.  
  6634.   if FDXDraw.FSurface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_VIDEOMEMORY = 0 then
  6635.     FDXDraw.FNowOptions := FDXDraw.FNowOptions + [doSystemMemory];
  6636.  
  6637.   FDXDraw.FSurface.Palette := FDXDraw.Palette;
  6638.   FDXDraw.FSurface.Fill(0);
  6639.  
  6640.   {$IFDEF D3D_deprecated}if do3D in FDXDraw.FNowOptions then{$ENDIF}
  6641.     Initialize3D;
  6642. end;
  6643.  
  6644. function TDXDrawDriverBlt.SetSize(AWidth, AHeight: Integer): Boolean;
  6645. begin
  6646.   Result := True;
  6647.  
  6648.   FDXDraw.FSurfaceWidth := Max(AWidth, 1);
  6649.   FDXDraw.FSurfaceHeight := Max(AHeight, 1);
  6650.  
  6651.   Inc(FDXDraw.FOffNotifyRestore);
  6652.   try
  6653.     FDXDraw.NotifyEventList(dxntFinalizeSurface);
  6654.  
  6655.     if FDXDraw.FCalledDoInitializeSurface then
  6656.     begin
  6657.       FDXDraw.FCalledDoInitializeSurface := False;
  6658.       FDXDraw.DoFinalizeSurface;
  6659.     end;
  6660.  
  6661.     InitializeSurface;
  6662.  
  6663.     FDXDraw.NotifyEventList(dxntInitializeSurface);
  6664.     FDXDraw.FCalledDoInitializeSurface := True; FDXDraw.DoInitializeSurface;
  6665.   finally
  6666.     Dec(FDXDraw.FOffNotifyRestore);
  6667.   end;
  6668. end;
  6669.  
  6670. {  TDXDrawDriverFlip  }
  6671.  
  6672. procedure TDXDrawDriverFlip.Flip;
  6673. begin
  6674.   if (FDXDraw.FForm <> nil) and (FDXDraw.FForm.Active) then
  6675.     FDXDraw.FPrimary.DXResult := FDXDraw.FPrimary.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.Flip(nil, DDFLIP_WAIT)
  6676.   else
  6677.     FDXDraw.FPrimary.DXResult := 0;
  6678. end;
  6679.  
  6680. procedure TDXDrawDriverFlip.Initialize;
  6681. {$IFDEF D3D_deprecated}
  6682. const
  6683.   DefPrimaryDesc: TDDSurfaceDesc = (
  6684.     dwSize: SizeOf(DefPrimaryDesc);
  6685.     dwFlags: DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
  6686.     dwBackBufferCount: 1;
  6687.     ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX)
  6688.     );
  6689.   BackBufferCaps: TDDSCaps = (dwCaps: DDSCAPS_BACKBUFFER);
  6690. {$ENDIF}
  6691. var
  6692.   PrimaryDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  6693.   PaletteCaps: Integer;
  6694.   Entries: TPaletteEntries;
  6695.   DDSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface{$ELSE}IDirectDrawSurface7{$ENDIF};
  6696.   {$IFNDEF D3D_deprecated}
  6697.   BackBufferCaps: TDDSCaps2;
  6698.   {$ENDIF}
  6699. begin
  6700.   {  Surface making  }
  6701.   {$IFDEF D3D_deprecated}
  6702.   PrimaryDesc := DefPrimaryDesc;
  6703.   {$ELSE}
  6704.   FillChar(PrimaryDesc, SizeOf(PrimaryDesc), 0);
  6705.   PrimaryDesc.dwSize := SizeOf(PrimaryDesc);
  6706.   PrimaryDesc.dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
  6707.   PrimaryDesc.dwBackBufferCount := 1;
  6708.   PrimaryDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX;
  6709.   FillChar(BackBufferCaps, SizeOf(BackBufferCaps), 0);
  6710.   BackBufferCaps.dwCaps := DDSCAPS_BACKBUFFER;
  6711.   {$ENDIF}
  6712.   {$IFDEF D3D_deprecated}if do3D in FDXDraw.FNowOptions then{$ENDIF}
  6713.     PrimaryDesc.ddsCaps.dwCaps := PrimaryDesc.ddsCaps.dwCaps or DDSCAPS_3DDEVICE;
  6714.  
  6715.   FDXDraw.FPrimary := TDirectDrawSurface.Create(FDXDraw.FDDraw);
  6716.   if not FDXDraw.FPrimary.CreateSurface(PrimaryDesc) then
  6717.     raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawPrimarySurface]);
  6718.  
  6719.   FDXDraw.FSurface := TDirectDrawSurface.Create(FDXDraw.FDDraw);
  6720.   if FDXDraw.FPrimary.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetAttachedSurface(BackBufferCaps, DDSurface) = DD_OK then
  6721.     FDXDraw.FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := DDSurface;
  6722.  
  6723.   FDXDraw.FNowOptions := FDXDraw.FNowOptions - [doSystemMemory];
  6724.   if FDXDraw.FSurface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_SYSTEMMEMORY <> 0 then
  6725.     FDXDraw.FNowOptions := FDXDraw.FNowOptions + [doSystemMemory];
  6726.  
  6727.   {  Clipper making of dummy  }
  6728.   FDXDraw.FClipper := TDirectDrawClipper.Create(FDXDraw.FDDraw);
  6729.  
  6730.   {  Palette making  }
  6731.   PaletteCaps := DDPCAPS_8BIT;
  6732.   if doAllowPalette256 in FDXDraw.Options then
  6733.     PaletteCaps := PaletteCaps or DDPCAPS_ALLOW256;
  6734.  
  6735.   FDXDraw.FPalette := TDirectDrawPalette.Create(FDXDraw.FDDraw);
  6736.   Entries := TDXDrawRGBQuadsToPaletteEntries(FDXDraw.ColorTable,
  6737.     doAllowPalette256 in FDXDraw.NowOptions);
  6738.   FDXDraw.FPalette.CreatePalette(PaletteCaps, Entries);
  6739.  
  6740.   FDXDraw.FPrimary.Palette := FDXDraw.Palette;
  6741.   FDXDraw.FSurface.Palette := FDXDraw.Palette;
  6742.  
  6743.   {$IFDEF D3D_deprecated}if do3D in FDXDraw.FNowOptions then{$ENDIF}
  6744.     Initialize3D;
  6745.  
  6746. end;
  6747.  
  6748. constructor TCustomDXDraw.Create(AOwner: TComponent);
  6749. var
  6750.   Entries: TPaletteEntries;
  6751.   dc: THandle;
  6752. begin
  6753.   FNotifyEventList := TList.Create;
  6754.   inherited Create(AOwner);
  6755.   FAutoInitialize := True;
  6756.   FDisplay := TDXDrawDisplay.Create(Self);
  6757.   {$IFDEF _DMO_}FAdapters := EnumDirectDrawDriversEx;{$ENDIF}
  6758.   Options := [doAllowReboot, doWaitVBlank, doCenter, {$IFDEF D3D_deprecated}doDirectX7Mode, do3D,{$ENDIF}
  6759.     doHardware, doSelectDriver];
  6760.  
  6761.   FAutoSize := True;
  6762.  
  6763.   dc := GetDC(0);
  6764.   try
  6765.     GetSystemPaletteEntries(dc, 0, 256, Entries);
  6766.   finally
  6767.     ReleaseDC(0, dc);
  6768.   end;
  6769.  
  6770.   ColorTable := PaletteEntriesToRGBQuads(Entries);
  6771.   DefColorTable := ColorTable;
  6772.  
  6773.   Width := 100;
  6774.   Height := 100;
  6775.   ParentColor := False;
  6776.   Color := clBlack; //clBtnFace; // FIX
  6777.  
  6778.   FD2D := TD2D.Create(Self);
  6779.   D2D := FD2D; {as loopback}
  6780.   FTraces := TTraces.Create(Self);
  6781. end;
  6782.  
  6783. destructor TCustomDXDraw.Destroy;
  6784. begin
  6785.   Finalize;
  6786.   NotifyEventList(dxntDestroying);
  6787.   FDisplay.Free;
  6788.   {$IFDEF _DMO_}FAdapters := nil;{$ENDIF}
  6789.   FSubClass.Free; FSubClass := nil;
  6790.   FNotifyEventList.Free;
  6791.   FD2D.Free;
  6792.   FD2D := nil;
  6793.   D2D := nil;
  6794.   FTraces.Free;
  6795.   inherited Destroy;
  6796. end;
  6797.  
  6798. class function TCustomDXDraw.Drivers: TDirectXDrivers;
  6799. begin
  6800.   Result := EnumDirectDrawDrivers;
  6801. end;
  6802.  
  6803. {$IFDEF _DMO_}
  6804. class function TCustomDXDraw.DriversEx: TDirectXDriversEx;
  6805. begin
  6806.   Result := EnumDirectDrawDriversEx;
  6807. end;
  6808. {$ENDIF}
  6809.  
  6810. type
  6811.   PDXDrawNotifyEvent = ^TDXDrawNotifyEvent;
  6812.  
  6813. procedure TCustomDXDraw.RegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
  6814. var
  6815.   Event: PDXDrawNotifyEvent;
  6816. begin
  6817.   UnRegisterNotifyEvent(NotifyEvent);
  6818.  
  6819.   New(Event);
  6820.   Event^ := NotifyEvent;
  6821.   FNotifyEventList.Add(Event);
  6822.  
  6823.   NotifyEvent(Self, dxntSetSurfaceSize);
  6824.  
  6825.   if Initialized then
  6826.   begin
  6827.     NotifyEvent(Self, dxntInitialize);
  6828.     if FCalledDoInitializeSurface then
  6829.       NotifyEvent(Self, dxntInitializeSurface);
  6830.     if FOffNotifyRestore = 0 then
  6831.       NotifyEvent(Self, dxntRestore);
  6832.   end;
  6833. end;
  6834.  
  6835. procedure TCustomDXDraw.UnRegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
  6836. var
  6837.   Event: PDXDrawNotifyEvent;
  6838.   i: Integer;
  6839. begin
  6840.   for i := 0 to FNotifyEventList.Count - 1 do
  6841.   begin
  6842.     Event := FNotifyEventList[i];
  6843.     if (TMethod(Event^).Code = TMethod(NotifyEvent).Code) and
  6844.       (TMethod(Event^).Data = TMethod(NotifyEvent).Data) then
  6845.     begin
  6846.       FreeMem(Event);
  6847.       FNotifyEventList.Delete(i);
  6848.  
  6849.       if FCalledDoInitializeSurface then
  6850.         NotifyEvent(Self, dxntFinalizeSurface);
  6851.       if Initialized then
  6852.         NotifyEvent(Self, dxntFinalize);
  6853.  
  6854.       Break;
  6855.     end;
  6856.   end;
  6857. end;
  6858.  
  6859. procedure TCustomDXDraw.NotifyEventList(NotifyType: TDXDrawNotifyType);
  6860. var
  6861.   i: Integer;
  6862. begin
  6863.   for i := FNotifyEventList.Count - 1 downto 0 do
  6864.     PDXDrawNotifyEvent(FNotifyEventList[i])^(Self, NotifyType);
  6865. end;
  6866.  
  6867. procedure TCustomDXDraw.FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
  6868.  
  6869.   procedure FlipToGDISurface;
  6870.   begin
  6871.     if Initialized and (FNowOptions * [doFullScreen, doFlip] = [doFullScreen, doFlip]) then
  6872.       DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.FlipToGDISurface;
  6873.   end;
  6874.  
  6875. begin
  6876.   case Message.Msg of
  6877.     {CM_ACTIVATE:
  6878.         begin
  6879.           DefWindowProc(Message);
  6880.           if AutoInitialize and (not FInitalized2) then
  6881.             Initialize;
  6882.           Exit;
  6883.         end;   }
  6884.     WM_WINDOWPOSCHANGED:
  6885.       begin
  6886.         if TWMWindowPosChanged(Message).WindowPos^.flags and SWP_SHOWWINDOW <> 0 then
  6887.         begin
  6888.           DefWindowProc(Message);
  6889.           if AutoInitialize and (not FInitialized2) then
  6890.             Initialize;
  6891.           Exit;
  6892.         end;
  6893.       end;
  6894. (*
  6895.     WM_ACTIVATEAPP:
  6896.       begin
  6897.         if TWMActivateApp(Message).Active then
  6898.         begin
  6899.           FActive := True;
  6900.           DoActivate;
  6901. //          PostMessage(FHandle, CM_ACTIVATE, 0, 0)
  6902.         end
  6903.         else
  6904.         begin
  6905.           FActive := False;
  6906.           DoDeactivate;
  6907. //          PostMessage(FHandle, CM_DEACTIVATE, 0, 0);
  6908.         end;
  6909.       end;
  6910. *)
  6911.     WM_ACTIVATE:
  6912.       begin
  6913.         if TWMActivate(Message).Active = WA_INACTIVE then
  6914.           FlipToGDISurface;
  6915.       end;
  6916.     WM_INITMENU:
  6917.       begin
  6918.         FlipToGDISurface;
  6919.       end;
  6920.     WM_DESTROY:
  6921.       begin
  6922.         Finalize;
  6923.       end;
  6924.     WM_ENTERSIZEMOVE:
  6925.       begin
  6926.         if not (csLoading in ComponentState) then
  6927.           Finalize;
  6928.       end;
  6929.     WM_EXITSIZEMOVE:
  6930.       begin
  6931.         if not (csLoading in ComponentState) then
  6932.           Initialize;
  6933.       end;
  6934. //    SW_RESTORE, SW_MAXIMIZE:
  6935. //        begin
  6936. //          {force finalize/initialize loop}
  6937. //          if not AutoInitialize or not (csLoading in ComponentState) then begin
  6938. //            Finalize;
  6939. //            Initialize;
  6940. //          end;
  6941. //        end;
  6942.   end;
  6943.   DefWindowProc(Message);
  6944. end;
  6945.  
  6946. procedure TCustomDXDraw.DoFinalize;
  6947. begin
  6948.   if Assigned(FOnFinalize) then FOnFinalize(Self);
  6949. end;
  6950.  
  6951. procedure TCustomDXDraw.DoFinalizeSurface;
  6952. begin
  6953.   if Assigned(FOnFinalizeSurface) then FOnFinalizeSurface(Self);
  6954. end;
  6955.  
  6956. procedure TCustomDXDraw.DoInitialize;
  6957. begin
  6958.   {$IFDEF _DMO_}
  6959.   {erase items for following refresh}
  6960.   if Assigned(FAdapters) then FAdapters.Clear;
  6961.   EnumDirectDrawDriversEx;
  6962.   {$ENDIF}
  6963.   if Assigned(FOnInitialize) then FOnInitialize(Self);
  6964.   {$IFNDEF DXR_deprecated}
  6965.    {$IFDEF D3D_deprecated}
  6966.     if not (do3D in Options) then
  6967.       Options := Options + [do3D];
  6968.    {$ENDIF}
  6969.   {$ENDIF}
  6970. end;
  6971.  
  6972. procedure TCustomDXDraw.DoInitializeSurface;
  6973. begin
  6974.   {.06 added for better initialization}
  6975.   if Assigned(FD2D) then
  6976.     RenderError := FD2D.D2DInitializeSurface;
  6977.  
  6978.   if Assigned(FOnInitializeSurface) then FOnInitializeSurface(Self);
  6979. end;
  6980.  
  6981. procedure TCustomDXDraw.DoInitializing;
  6982. begin
  6983.   if Assigned(FOnInitializing) then FOnInitializing(Self);
  6984. end;
  6985.  
  6986. procedure TCustomDXDraw.DoRestoreSurface;
  6987. begin
  6988.   if Assigned(FOnRestoreSurface) then FOnRestoreSurface(Self);
  6989. end;
  6990.  
  6991. procedure TCustomDXDraw.Finalize;
  6992. begin
  6993.   if FInternalInitialized then
  6994.   begin
  6995.     FSurfaceWidth := SurfaceWidth;
  6996.     FSurfaceHeight := SurfaceHeight;
  6997.  
  6998.     FDisplay.FModes.Clear;
  6999.  
  7000.     FUpdating := True;
  7001.     try
  7002.       try
  7003.         try
  7004.           if FCalledDoInitializeSurface then
  7005.           begin
  7006.             FCalledDoInitializeSurface := False;
  7007.             DoFinalizeSurface;
  7008.           end;
  7009.         finally
  7010.           NotifyEventList(dxntFinalizeSurface);
  7011.         end;
  7012.       finally
  7013.         try
  7014.           if FCalledDoInitialize then
  7015.           begin
  7016.             FCalledDoInitialize := False;
  7017.             DoFinalize;
  7018.           end;
  7019.         finally
  7020.           NotifyEventList(dxntFinalize);
  7021.         end;
  7022.       end;
  7023.     finally
  7024.       FInternalInitialized := False;
  7025.       FInitialized := False;
  7026.  
  7027.       SetOptions(FOptions);
  7028.  
  7029.       FDXDrawDriver.Free; FDXDrawDriver := nil;
  7030.       FUpdating := False;
  7031.     end;
  7032.   end;
  7033.   if AsSigned(FD2D) then
  7034.     FD2D.Free;
  7035.   FD2D := nil;
  7036.   D2D := nil
  7037. end;
  7038.  
  7039. procedure TCustomDXDraw.Flip;
  7040. begin
  7041.   if Initialized and (not FUpdating) then
  7042.   begin
  7043.     if TryRestore and (not RenderError) then
  7044.       TDXDrawDriver(FDXDrawDriver).Flip;
  7045.   end;
  7046.   RenderError := false;
  7047. end;
  7048.  
  7049. function TCustomDXDraw.GetCanDraw: Boolean;
  7050. begin
  7051.   {$IFNDEF DXR_deprecated}
  7052.   {$IFDEF D3D_deprecated}
  7053.   if not (do3D in Options) then
  7054.     Options := Options + [do3D];
  7055.   {$ENDIF}
  7056.   {$ENDIF}
  7057.   Result := Initialized and (not FUpdating) and (Surface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) and
  7058.     TryRestore;
  7059. end;
  7060.  
  7061. function TCustomDXDraw.GetCanPaletteAnimation: Boolean;
  7062. begin
  7063.   Result := Initialized and (not FUpdating) and (doFullScreen in FNowOptions)
  7064.     and (DDraw.DisplayMode.ddpfPixelFormat.dwRGBBitCount <= 8);
  7065. end;
  7066.  
  7067. function TCustomDXDraw.GetSurfaceHeight: Integer;
  7068. begin
  7069.   if Surface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  7070.     Result := Surface.Height
  7071.   else
  7072.     Result := FSurfaceHeight;
  7073. end;
  7074.  
  7075. function TCustomDXDraw.GetSurfaceWidth: Integer;
  7076. begin
  7077.   if Surface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  7078.     Result := Surface.Width
  7079.   else
  7080.     Result := FSurfaceWidth;
  7081. end;
  7082.  
  7083. procedure TCustomDXDraw.Loaded;
  7084. begin
  7085.   inherited Loaded;
  7086.  
  7087.   if AutoSize then
  7088.   begin
  7089.     FSurfaceWidth := Width;
  7090.     FSurfaceHeight := Height;
  7091.   end;
  7092.  
  7093.   NotifyEventList(dxntSetSurfaceSize);
  7094.  
  7095.   if FAutoInitialize and (not (csDesigning in ComponentState)) then
  7096.   begin
  7097.     if {(not (doFullScreen in FOptions)) or }(FSubClass = nil) then
  7098.       Initialize;
  7099.   end;
  7100. end;
  7101.  
  7102. procedure TCustomDXDraw.Initialize;
  7103. begin
  7104.   FInitialized2 := True;
  7105.  
  7106.   Finalize;
  7107.  
  7108.   if FForm = nil then
  7109.     raise EDXDrawError.Create(SNoForm);
  7110.  
  7111.   try
  7112.     DoInitializing;
  7113.  
  7114.     {  Initialization.  }
  7115.     FUpdating := True;
  7116.     try
  7117.       FInternalInitialized := True;
  7118.  
  7119.       NotifyEventList(dxntInitializing);
  7120.  
  7121.       {  DirectDraw initialization.  }
  7122.       if doFlip in FNowOptions then
  7123.         FDXDrawDriver := TDXDrawDriverFlip.Create(Self)
  7124.       else
  7125.         FDXDrawDriver := TDXDrawDriverBlt.Create(Self);
  7126.  
  7127.       {  Window handle setting.  }
  7128.       SetCooperativeLevel;
  7129.  
  7130.       {  Set display mode.  }
  7131.       if doFullScreen in FNowOptions then
  7132.       begin
  7133.         if not Display.DynSetSize(Display.Width, Display.Height, Display.BitCount) then
  7134.           raise EDXDrawError.CreateFmt(SDisplaymodeChange, [Display.Width, Display.Height, Display.BitCount]);
  7135.       end;
  7136.  
  7137.       {  Resource initialization.  }
  7138.       if AutoSize then
  7139.       begin
  7140.         FSurfaceWidth := Width;
  7141.         FSurfaceHeight := Height;
  7142.       end;
  7143.  
  7144.       TDXDrawDriver(FDXDrawDriver).Initialize;
  7145.     finally
  7146.       FUpdating := False;
  7147.     end;
  7148.   except
  7149.     Finalize;
  7150.     raise;
  7151.   end;
  7152.  
  7153.   FInitialized := True;
  7154.  
  7155.   Inc(FOffNotifyRestore);
  7156.   try
  7157.     NotifyEventList(dxntSetSurfaceSize);
  7158.     NotifyEventList(dxntInitialize);
  7159.     FCalledDoInitialize := True; DoInitialize;
  7160.  
  7161.     NotifyEventList(dxntInitializeSurface);
  7162.     FCalledDoInitializeSurface := True; DoInitializeSurface;
  7163.   finally
  7164.     Dec(FOffNotifyRestore);
  7165.   end;
  7166.  
  7167.   if not Assigned(FD2D) then begin
  7168.     FD2D := TD2D.Create(Self);
  7169.     D2D := FD2D; {as loopback}
  7170.   end;
  7171.  
  7172.   Restore;
  7173. end;
  7174.  
  7175. procedure TCustomDXDraw.Paint;
  7176. var
  7177.   Old: TDXDrawOptions;
  7178.   w, h: Integer;
  7179.   s: string;
  7180. begin
  7181.   inherited Paint;
  7182.   if (csDesigning in ComponentState) then
  7183.   begin
  7184.     Canvas.Brush.Style := bsClear;
  7185.     Canvas.Pen.Color := clBlack;
  7186.     Canvas.Pen.Style := psDash;
  7187.     Canvas.Rectangle(0, 0, Width, Height);
  7188.  
  7189.     Canvas.Pen.Style := psSolid;
  7190.     Canvas.Pen.Color := clGray;
  7191.     Canvas.MoveTo(0, 0);
  7192.     Canvas.LineTo(Width, Height);
  7193.  
  7194.     Canvas.MoveTo(0, Height);
  7195.     Canvas.LineTo(Width, 0);
  7196.  
  7197.     s := Format('(%s)', [ClassName]);
  7198.  
  7199.     w := Canvas.TextWidth(s);
  7200.     h := Canvas.TextHeight(s);
  7201.  
  7202.     Canvas.Brush.Style := bsSolid;
  7203.     Canvas.Brush.Color := clBtnFace;
  7204.     Canvas.TextOut(Width div 2 - w div 2, Height div 2 - h div 2, s);
  7205.   end else
  7206.   begin
  7207.     Old := FNowOptions;
  7208.     try
  7209.       FNowOptions := FNowOptions - [doWaitVBlank];
  7210.       Flip;
  7211.     finally
  7212.       FNowOptions := Old;
  7213.     end;
  7214.     if (Parent <> nil) and (Initialized) and (Surface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_VIDEOMEMORY <> 0) then
  7215.       Parent.Invalidate;
  7216.   end;
  7217. end;
  7218.  
  7219. function TCustomDXDraw.PaletteChanged(Foreground: Boolean): Boolean;
  7220. begin
  7221.   if Foreground then
  7222.   begin
  7223.     Restore;
  7224.     Result := True;
  7225.   end else
  7226.     Result := False;
  7227. end;
  7228.  
  7229. procedure TCustomDXDraw.Render(LagCount: Integer{$IFDEF VER4UP} = 0{$ENDIF});
  7230. var I: Integer;
  7231. begin
  7232. {$IFDEF D3DRM}
  7233.   if FInitialized and {$IFDEF D3D_deprecated}(do3D in FNowOptions) and{$ENDIF} (doRetainedMode in FNowOptions) then
  7234.   begin
  7235.     asm FInit end;
  7236.     FViewport.Clear;
  7237.     FViewport.Render(FScene);
  7238.     FD3DRMDevice.Update;
  7239.     asm FInit end;
  7240.   end;
  7241. {$ENDIF}
  7242.   {traces}
  7243.   if FTraces.Count > 0 then
  7244.     for I := 0 to FTraces.Count - 1 do
  7245.       if FTraces.Items[I].Active then
  7246.         FTraces.Items[I].Render(LagCount);
  7247.   {own rendering event}
  7248.   if Assigned(FOnRender) then
  7249.     FOnRender(Self);
  7250. end;
  7251.  
  7252. procedure TCustomDXDraw.Restore;
  7253. begin
  7254.   if Initialized and (not FUpdating) then
  7255.   begin
  7256.     FUpdating := True;
  7257.     try
  7258.       if TDXDrawDriver(FDXDrawDriver).Restore then
  7259.       begin
  7260.         Primary.Palette := Palette;
  7261.         Surface.Palette := Palette;
  7262.  
  7263.         SetColorTable(DefColorTable);
  7264.         NotifyEventList(dxntRestore);
  7265.         DoRestoreSurface;
  7266.         SetColorTable(ColorTable);
  7267.       end;
  7268.     finally
  7269.       FUpdating := False;
  7270.     end;
  7271.   end;
  7272. end;
  7273.  
  7274. procedure TCustomDXDraw.SetAutoSize(Value: Boolean);
  7275. begin
  7276.   if FAutoSize <> Value then
  7277.   begin
  7278.     FAutoSize := Value;
  7279.     if FAutoSize then
  7280.       SetSize(Width, Height);
  7281.   end;
  7282. end;
  7283.  
  7284. procedure TCustomDXDraw.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  7285. begin
  7286.   inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  7287.   if FAutoSize and (not FUpdating) then
  7288.     SetSize(AWidth, AHeight);
  7289. end;
  7290.  
  7291. procedure TCustomDXDraw.BeginScene;
  7292. begin
  7293.   if CheckD3 then
  7294.     FD2D.BeginScene
  7295. end;
  7296.  
  7297. procedure TCustomDXDraw.EndScene;
  7298. begin
  7299.   if CheckD3 then
  7300.     FD2D.EndScene
  7301. end;
  7302.  
  7303. function TCustomDXDraw.CheckD3: Boolean;
  7304. begin
  7305.   Result := {$IFDEF D3D_deprecated}(do3D in Options) and{$ENDIF} (doHardware in Options) and AsSigned(FD2D);
  7306. end;
  7307.  
  7308. function TCustomDXDraw.CheckD3D(Dest: TDirectDrawSurface): Boolean;
  7309. begin
  7310.   Result := CheckD3 and (FD2D.FDDraw.FSurface = Dest)
  7311. end;
  7312.  
  7313. procedure TCustomDXDraw.ClearStack;
  7314. begin
  7315.   if CheckD3 then
  7316.     FD2D.D2DTextures.D2DPruneAllTextures;
  7317. end;
  7318.  
  7319. procedure TCustomDXDraw.UpdateTextures;
  7320. var Changed: Boolean;
  7321. begin
  7322.   if CheckD3 then begin
  7323.     if Assigned(FOnUpdateTextures) then begin
  7324.       Changed := False;
  7325.       FOnUpdateTextures(FD2D.FD2DTexture, Changed);
  7326.       if Changed then FD2D.D2DUpdateTextures;
  7327.     end
  7328.   end;
  7329. end;
  7330.  
  7331. procedure TCustomDXDraw.TextureFilter(Grade: TD2DTextureFilter);
  7332. begin
  7333.   if CheckD3 then
  7334.     FD2D.TextureFilter := Grade;
  7335. end;
  7336.  
  7337. procedure TCustomDXDraw.AntialiasFilter(Grade: TD3DAntialiasMode);
  7338. begin
  7339.   if CheckD3 then
  7340.     FD2D.AntialiasFilter := Grade;
  7341. end;
  7342.  
  7343. // ***** fade effects
  7344. // do not use in dxtimer cycle
  7345.  
  7346. function TCustomDXDraw.Fade2Color(colorfrom, colorto: LongInt): LongInt;
  7347. var i, r1, r2, g1, g2, b1, b2: Integer;
  7348. begin
  7349.   r1 := GetRValue(colorfrom);
  7350.   r2 := GetRValue(colorto);
  7351.   g1 := GetGValue(colorfrom);
  7352.   g2 := GetGValue(colorto);
  7353.   b1 := GetBValue(colorfrom);
  7354.   b2 := GetBValue(colorto);
  7355.   if r1 < r2 then
  7356.   begin
  7357.     for i := r1 to r2 do
  7358.     begin
  7359.       Surface.Fill(RGB(i, g1, b1));
  7360.       Flip;
  7361.     end;
  7362.   end
  7363.   else
  7364.   begin
  7365.     for i := r1 downto r2 do
  7366.     begin
  7367.       Surface.Fill(RGB(i, g1, b1));
  7368.       Flip;
  7369.     end;
  7370.   end;
  7371.  
  7372.   if g1 < g2 then
  7373.   begin
  7374.     for i := g1 to g2 do
  7375.     begin
  7376.       Surface.Fill(RGB(r2, i, b1));
  7377.       Flip;
  7378.     end;
  7379.   end
  7380.   else
  7381.   begin
  7382.     for i := g1 downto g2 do
  7383.     begin
  7384.       Surface.Fill(RGB(r2, i, b1));
  7385.       Flip;
  7386.     end;
  7387.   end;
  7388.   if b1 < b2 then
  7389.   begin
  7390.     for i := b1 to b2 do
  7391.     begin
  7392.       Surface.Fill(RGB(r2, g2, i));
  7393.       Flip;
  7394.     end;
  7395.   end
  7396.   else
  7397.   begin
  7398.     for i := b1 downto b2 do
  7399.     begin
  7400.       Surface.Fill(RGB(r2, g2, i));
  7401.       Flip;
  7402.     end;
  7403.   end;
  7404.   Result := colorto;
  7405. end;
  7406.  
  7407. function TCustomDXDraw.Fade2Black(colorfrom: LongInt): LongInt;
  7408. var i, r, g, b: Integer;
  7409. begin
  7410.   r := GetRValue(colorfrom);
  7411.   g := GetGValue(colorfrom);
  7412.   b := GetBValue(colorfrom);
  7413.   for i := r downto 0 do
  7414.   begin
  7415.     Surface.Fill(RGB(i, g, b));
  7416.     Flip;
  7417.   end;
  7418.   for i := g downto 0 do
  7419.   begin
  7420.     Surface.Fill(RGB(0, i, b));
  7421.     Flip;
  7422.   end;
  7423.   for i := g downto 0 do
  7424.   begin
  7425.     Surface.Fill(RGB(0, 0, i));
  7426.     Flip;
  7427.   end;
  7428.   Result := 0;
  7429. end;
  7430.  
  7431. function TCustomDXDraw.Fade2White(colorfrom: LongInt): LongInt;
  7432. var i, r, g, b: Integer;
  7433. begin
  7434.   r := GetRValue(colorfrom);
  7435.   g := GetGValue(colorfrom);
  7436.   b := GetBValue(colorfrom);
  7437.   for i := r to 255 do
  7438.   begin
  7439.     Surface.Fill(RGB(i, g, b));
  7440.     Flip;
  7441.   end;
  7442.   for i := g to 255 do
  7443.   begin
  7444.     Surface.Fill(RGB(255, i, b));
  7445.     Flip;
  7446.   end;
  7447.   for i := b to 255 do
  7448.   begin
  7449.     Surface.Fill(RGB(255, 255, i));
  7450.     Flip;
  7451.   end;
  7452.   Result := RGB(255, 255, 255);
  7453. end;
  7454.  
  7455. function TCustomDXDraw.Grey2Fade(shadefrom, shadeto: Integer): Integer;
  7456. var i: Integer;
  7457. begin
  7458.   if shadefrom < shadeto then
  7459.   begin
  7460.     for i := shadefrom to shadeto do
  7461.     begin
  7462.       Surface.Fill(RGB(i, i, i));
  7463.       Flip;
  7464.     end;
  7465.   end
  7466.   else
  7467.   begin
  7468.     for i := shadefrom downto shadeto do
  7469.     begin
  7470.       Surface.Fill(RGB(i, i, i));
  7471.       Flip;
  7472.     end;
  7473.   end;
  7474.   Result := shadeto;
  7475. end;
  7476.  
  7477. function TCustomDXDraw.FadeGrey2Screen(oldcolor, newcolour: LongInt): LongInt;
  7478. begin
  7479.   result := Grey2Fade(oldcolor, newcolour);
  7480. end;
  7481.  
  7482. function TCustomDXDraw.Fade2Screen(oldcolor, newcolour: LongInt): LongInt;
  7483. begin
  7484.   result := Fade2Color(oldcolor, newcolour);
  7485. end;
  7486.  
  7487. function TCustomDXDraw.White2Screen(oldcolor: Integer): LongInt;
  7488. begin
  7489.   result := Fade2Color(oldcolor, RGB(255, 255, 255));
  7490. end;
  7491.  
  7492. function TCustomDXDraw.Black2Screen(oldcolor: Integer): LongInt;
  7493. begin
  7494.   result := Fade2Color(oldcolor, RGB(0, 0, 0));
  7495. end;
  7496.  
  7497. procedure TCustomDXDraw.GrabImage(iX, iY, iWidth, iHeight: Integer; ddib: TDIB);
  7498. var ts, td: trect;
  7499. begin
  7500.   ddib.SetSize(iWidth, iHeight, 24);
  7501.   ts.left := iX;
  7502.   ts.top := iY;
  7503.   ts.right := iX + iWidth - 1;
  7504.   ts.bottom := iY + iHeight - 1;
  7505.   td.left := 0;
  7506.   td.top := 0;
  7507.   td.right := iWidth;
  7508.   td.bottom := iHeight;
  7509.   with Surface.Canvas do
  7510.   begin
  7511.     ddib.Canvas.CopyRect(td, Surface.Canvas, ts);
  7512.     Release;
  7513.   end;
  7514. end;
  7515.  
  7516. procedure TCustomDXDraw.PasteImage(sdib: TDIB; x, y: Integer);
  7517. var
  7518.   ts, td: trect;
  7519.   w, h: Integer;
  7520. begin
  7521.   w := sdib.width - 1;
  7522.   h := sdib.height - 1;
  7523.   ts.left := 0;
  7524.   ts.top := 0;
  7525.   ts.right := w;
  7526.   ts.bottom := h;
  7527.   td.left := x;
  7528.   td.top := y;
  7529.   td.right := x + w;
  7530.   td.bottom := y + h;
  7531.   with Surface.Canvas do
  7532.   begin
  7533.     CopyRect(td, sdib.Canvas, ts);
  7534.     release;
  7535.   end;
  7536. end;
  7537.  
  7538. // *****
  7539.  
  7540. procedure TCustomDXDraw.SetColorTable(const ColorTable: TRGBQuads);
  7541. var
  7542.   Entries: TPaletteEntries;
  7543. begin
  7544.   if Initialized and (Palette <> nil) then
  7545.   begin
  7546.     Entries := TDXDrawRGBQuadsToPaletteEntries(ColorTable,
  7547.       doAllowPalette256 in FNowOptions);
  7548.     Palette.SetEntries(0, 256, Entries);
  7549.   end;
  7550. end;
  7551.  
  7552. procedure TCustomDXDraw.SetCooperativeLevel;
  7553. var
  7554.   Flags: Integer;
  7555.   Control: TWinControl;
  7556. begin
  7557.   Control := FForm;
  7558.   if Control = nil then
  7559.     Control := Self;
  7560.  
  7561.   if doFullScreen in FNowOptions then
  7562.   begin
  7563.     Flags := DDSCL_FULLSCREEN or DDSCL_EXCLUSIVE or DDSCL_ALLOWMODEX{$IFDEF DXDOUBLEPRECISION} or DDSCL_FPUPRESERVE{$ENDIF};
  7564.     if doNoWindowChange in FNowOptions then
  7565.       Flags := Flags or DDSCL_NOWINDOWCHANGES;
  7566.     if doAllowReboot in FNowOptions then
  7567.       Flags := Flags or DDSCL_ALLOWREBOOT;
  7568.   end else
  7569.     Flags := DDSCL_NORMAL{$IFDEF DXDOUBLEPRECISION} or DDSCL_FPUPRESERVE{$ENDIF};
  7570.  
  7571.   DDraw.DXResult := DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.SetCooperativeLevel(Control.Handle, Flags);
  7572. end;
  7573.  
  7574. procedure TCustomDXDraw.SetDisplay(Value: TDXDrawDisplay);
  7575. begin
  7576.   FDisplay.Assign(Value);
  7577. end;
  7578.  
  7579. procedure TCustomDXDraw.SetDriver(Value: PGUID);
  7580. begin
  7581.   if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
  7582.   begin
  7583.     FDriverGUID := Value^;
  7584.     FDriver := @FDriverGUID;
  7585.   end else
  7586.     FDriver := Value;
  7587. end;
  7588.  
  7589. procedure TCustomDXDraw.SetOptions(Value: TDXDrawOptions);
  7590. const
  7591.   InitOptions = [doFullScreen, doNoWindowChange, doAllowReboot,
  7592.     doAllowPalette256, doSystemMemory, doFlip,
  7593.     {$IFDEF D3D_deprecated}doDirectX7Mode, do3D,{$ENDIF}{$IFDEF D3DRM} doRetainedMode, {$ENDIF}
  7594.     doHardware, doSelectDriver, doZBuffer];
  7595. var
  7596.   OldOptions: TDXDrawOptions;
  7597. begin
  7598.   FOptions := Value;
  7599.  
  7600.   if Initialized then
  7601.   begin
  7602.     OldOptions := FNowOptions;
  7603.     FNowOptions := FNowOptions * InitOptions + (FOptions - InitOptions);
  7604.     {$IFDEF D3D_deprecated}
  7605.     if not (do3D in FNowOptions) then
  7606.       FNowOptions := FNowOptions - [doHardware, {$IFDEF D3DRM}doRetainedMode,{$ENDIF} doSelectDriver, doZBuffer];
  7607.     {$ENDIF}
  7608.   end else
  7609.   begin
  7610.     FNowOptions := FOptions;
  7611.  
  7612.     if not (doFullScreen in FNowOptions) then
  7613.       FNowOptions := FNowOptions - [doNoWindowChange, doAllowReBoot, doAllowPalette256, doFlip];
  7614.     {$IFDEF D3D_deprecated}
  7615.     if not (do3D in FNowOptions) then
  7616.       FNowOptions := FNowOptions - [doDirectX7Mode, {$IFDEF D3DRM}doRetainedMode,{$ENDIF} doHardware, doSelectDriver, doZBuffer];
  7617.     {$ENDIF}
  7618.     if doSystemMemory in FNowOptions then
  7619.       FNowOptions := FNowOptions - [doFlip];
  7620.     {$IFDEF D3DRM}
  7621.     if doDirectX7Mode in FNowOptions then
  7622.       FNowOptions := FNowOptions - [doRetainedMode];
  7623.     {$ENDIF}
  7624.     FNowOptions := FNowOptions - [doHardware];
  7625.   end;
  7626. end;
  7627.  
  7628. procedure TCustomDXDraw.SetParent(AParent: TWinControl);
  7629. var
  7630.   Control: TWinControl;
  7631. begin
  7632.   inherited SetParent(AParent);
  7633.  
  7634.   FForm := nil;
  7635.   FSubClass.Free; FSubClass := nil;
  7636.  
  7637.   if not (csDesigning in ComponentState) then
  7638.   begin
  7639.     Control := Parent;
  7640.     while (Control <> nil) and (not (Control is TCustomForm)) do
  7641.       Control := Control.Parent;
  7642.     if Control <> nil then
  7643.     begin
  7644.       FForm := TCustomForm(Control);
  7645.       FSubClass := TControlSubClass.Create(Control, FormWndProc);
  7646.     end;
  7647.   end;
  7648. end;
  7649.  
  7650. procedure TCustomDXDraw.SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
  7651. begin
  7652.   if ((ASurfaceWidth <> SurfaceWidth) or (ASurfaceHeight <> SurfaceHeight)) and
  7653.     (not FUpdating) then
  7654.   begin
  7655.     if Initialized then
  7656.     begin
  7657.       try
  7658.         if not TDXDrawDriver(FDXDrawDriver).SetSize(ASurfaceWidth, ASurfaceHeight) then
  7659.           Exit;
  7660.       except
  7661.         Finalize;
  7662.         raise;
  7663.       end;
  7664.     end else
  7665.     begin
  7666.       FSurfaceWidth := ASurfaceWidth;
  7667.       FSurfaceHeight := ASurfaceHeight;
  7668.     end;
  7669.  
  7670.     NotifyEventList(dxntSetSurfaceSize);
  7671.   end;
  7672. end;
  7673.  
  7674. procedure TCustomDXDraw.SetSurfaceHeight(Value: Integer);
  7675. begin
  7676.   if ComponentState * [csReading, csLoading] = [] then
  7677.     SetSize(SurfaceWidth, Value)
  7678.   else
  7679.     FSurfaceHeight := Value;
  7680. end;
  7681.  
  7682. procedure TCustomDXDraw.SetSurfaceWidth(Value: Integer);
  7683. begin
  7684.   if ComponentState * [csReading, csLoading] = [] then
  7685.     SetSize(Value, SurfaceHeight)
  7686.   else
  7687.     FSurfaceWidth := Value;
  7688. end;
  7689.  
  7690. function TCustomDXDraw.TryRestore: Boolean;
  7691. begin
  7692.   Result := False;
  7693.  
  7694.   if Initialized and (not FUpdating) and (Primary.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) then
  7695.   begin
  7696.     if (Primary.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DDERR_SURFACELOST) or
  7697.       (Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DDERR_SURFACELOST) then
  7698.     begin
  7699.       if Assigned(FD2D) and Assigned(FD2D.FD2DTexture) then FD2D.FD2DTexture.D2DPruneAllTextures;//<-Add Mr.Kawasaki
  7700.       Restore;
  7701.       Result := (Primary.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DD_OK) and (Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DD_OK);
  7702.     end else
  7703.       Result := True;
  7704.   end;
  7705. end;
  7706.  
  7707. procedure TCustomDXDraw.SetTraces(const Value: TTraces);
  7708. begin
  7709.   FTraces.Assign(Value);
  7710. end;
  7711.  
  7712. procedure TCustomDXDraw.UpdatePalette;
  7713. begin
  7714.   if Initialized and (doWaitVBlank in FNowOptions) then
  7715.   begin
  7716.     if FDDraw.FDriverCaps.dwPalCaps and DDPCAPS_VSYNC = 0 then
  7717.       FDDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.WaitForVerticalBlank(DDWAITVB_BLOCKBEGIN, 0);
  7718.   end;
  7719.  
  7720.   SetColorTable(ColorTable);
  7721. end;
  7722.  
  7723. procedure TCustomDXDraw.WMCreate(var Message: TMessage);
  7724. begin
  7725.   inherited;
  7726.   if Initialized and (not FUpdating) then
  7727.   begin
  7728.     if Clipper <> nil then
  7729.       Clipper.Handle := Handle;
  7730.     SetCooperativeLevel;
  7731.   end;
  7732. end;
  7733.  
  7734. {$IFDEF DX3D_deprecated}
  7735.  
  7736. {  TCustomDX3D  }
  7737.  
  7738. constructor TCustomDX3D.Create(AOwner: TComponent);
  7739. begin
  7740.   inherited Create(AOwner);
  7741.   Options := [toHardware, toRetainedMode, toSelectDriver];
  7742.   FSurfaceWidth := 320;
  7743.   FSurfaceHeight := 240;
  7744. end;
  7745.  
  7746. destructor TCustomDX3D.Destroy;
  7747. begin
  7748.   DXDraw := nil;
  7749.   inherited Destroy;
  7750. end;
  7751.  
  7752. procedure TCustomDX3D.DoFinalize;
  7753. begin
  7754.   if Assigned(FOnFinalize) then FOnFinalize(Self);
  7755. end;
  7756.  
  7757. procedure TCustomDX3D.DoInitialize;
  7758. begin
  7759.   if Assigned(FOnInitialize) then FOnInitialize(Self);
  7760. end;
  7761.  
  7762. procedure TCustomDX3D.Finalize;
  7763. begin
  7764.   if FInitialized then
  7765.   begin
  7766.     try
  7767.       if FInitFlag then
  7768.       begin
  7769.         FInitFlag := False;
  7770.         DoFinalize;
  7771.       end;
  7772.     finally
  7773.       FInitialized := False;
  7774.  
  7775.       SetOptions(FOptions);
  7776.       {$IFDEF D3DRM}
  7777.       FViewport := nil;
  7778.       FCamera := nil;
  7779.       FScene := nil;
  7780.  
  7781.       FD3DRMDevice := nil;
  7782.       FD3DRMDevice2 := nil;
  7783.       FD3DRMDevice3 := nil;
  7784.       {$ENDIF}
  7785.       {$IFDEF D3D_deprecated}
  7786.       FD3DDevice := nil;
  7787.       FD3DDevice2 := nil;
  7788.       FD3DDevice3 := nil;
  7789.       {$ENDIF}
  7790.       FD3DDevice7 := nil;
  7791.       {$IFDEF D3D_deprecated}
  7792.       FD3D := nil;
  7793.       FD3D2 := nil;
  7794.       FD3D3 := nil;
  7795.       {$ENDIF}
  7796.       FD3D7 := nil;
  7797.  
  7798.       FreeZBufferSurface(FSurface, FZBuffer);
  7799.  
  7800.       FSurface.Free; FSurface := nil;
  7801.       {$IFDEF D3DRM}
  7802.       FD3DRM3 := nil;
  7803.       FD3DRM2 := nil;
  7804.       FD3DRM := nil;
  7805.       {$ENDIF}
  7806.     end;
  7807.   end;
  7808. end;
  7809.  
  7810. procedure TCustomDX3D.Initialize;
  7811. var
  7812.   ddsd: TDDSurfaceDesc;
  7813.   AOptions: TInitializeDirect3DOptions;
  7814. begin
  7815.   Finalize;
  7816.   try
  7817.     FInitialized := True;
  7818.  
  7819.     {  Make surface.  }
  7820.     FillChar(ddsd, SizeOf(ddsd), 0);
  7821.     ddsd.dwSize := SizeOf(ddsd);
  7822.     ddsd.dwFlags := DDSD_WIDTH or DDSD_HEIGHT or DDSD_CAPS;
  7823.     ddsd.dwWidth := Max(FSurfaceWidth, 1);
  7824.     ddsd.dwHeight := Max(FSurfaceHeight, 1);
  7825.     ddsd.ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN or DDSCAPS_3DDEVICE;
  7826.     if toSystemMemory in FNowOptions then
  7827.       ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY
  7828.     else
  7829.       ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_VIDEOMEMORY;
  7830.  
  7831.     FSurface := TDirectDrawSurface.Create(FDXDraw.DDraw);
  7832.     if not FSurface.CreateSurface(ddsd) then
  7833.     begin
  7834.       ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps and (not DDSCAPS_VIDEOMEMORY) or DDSCAPS_SYSTEMMEMORY;
  7835.       if not FSurface.CreateSurface(ddsd) then
  7836.         raise EDX3DError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
  7837.     end;
  7838.  
  7839.     AOptions := [];
  7840.  
  7841.     if toHardware in FNowOptions then AOptions := AOptions + [idoHardware];
  7842.     if toRetainedMode in FNowOptions then AOptions := AOptions + [idoRetainedMode];
  7843.     if toSelectDriver in FNowOptions then AOptions := AOptions + [idoSelectDriver];
  7844.     if toZBuffer in FNowOptions then AOptions := AOptions + [idoZBuffer];
  7845.  
  7846.     if doDirectX7Mode in FDXDraw.NowOptions then
  7847.     begin
  7848.       InitializeDirect3D7(FSurface, FZBuffer, FD3D7, FD3DDevice7, AOptions);
  7849.     end else
  7850.     begin
  7851.       InitializeDirect3D(FSurface, FZBuffer, FD3D, FD3D2, FD3D3, FD3DDevice, FD3DDevice2, FD3DDevice3,
  7852. {$IFDEF D3DRM}FD3DRM, FD3DRM2, FD3DRM3, FD3DRMDevice, FD3DRMDevice2, FD3DRMDevice3, FViewport, FScene, FCamera, {$ENDIF}
  7853.         AOptions);
  7854.     end;
  7855.  
  7856.     FNowOptions := [];
  7857.  
  7858.     if idoHardware in AOptions then FNowOptions := FNowOptions + [toHardware];
  7859.     if idoRetainedMode in AOptions then FNowOptions := FNowOptions + [toRetainedMode];
  7860.     if idoSelectDriver in AOptions then FNowOptions := FNowOptions + [toSelectDriver];
  7861.     if idoZBuffer in AOptions then FNowOptions := FNowOptions + [toZBuffer];
  7862.   except
  7863.     Finalize;
  7864.     raise;
  7865.   end;
  7866.  
  7867.   FInitFlag := True; DoInitialize;
  7868. end;
  7869.  
  7870. procedure TCustomDX3D.Render;
  7871. begin
  7872. {$IFDEF D3DRM}
  7873.   if FInitialized and (toRetainedMode in FNowOptions) then
  7874.   begin
  7875.     asm FInit end;
  7876.     FViewport.Clear;
  7877.     FViewport.Render(FScene);
  7878.     FD3DRMDevice.Update;
  7879.     asm FInit end;
  7880.   end;
  7881. {$ENDIF}
  7882. end;
  7883.  
  7884. function TCustomDX3D.GetCanDraw: Boolean;
  7885. begin
  7886.   Result := Initialized and (Surface.IDDSurface <> nil) and
  7887.     (Surface.ISurface.IsLost = DD_OK);
  7888. end;
  7889.  
  7890. function TCustomDX3D.GetSurfaceHeight: Integer;
  7891. begin
  7892.   if FSurface.IDDSurface <> nil then
  7893.     Result := FSurface.Height
  7894.   else
  7895.     Result := FSurfaceHeight;
  7896. end;
  7897.  
  7898. function TCustomDX3D.GetSurfaceWidth: Integer;
  7899. begin
  7900.   if FSurface.IDDSurface <> nil then
  7901.     Result := FSurface.Width
  7902.   else
  7903.     Result := FSurfaceWidth;
  7904. end;
  7905.  
  7906. procedure TCustomDX3D.SetAutoSize(Value: Boolean);
  7907. begin
  7908.   if FAutoSize <> Value then
  7909.   begin
  7910.     FAutoSize := Value;
  7911.     if FAutoSize and (DXDraw <> nil) then
  7912.       SetSize(DXDraw.SurfaceWidth, DXDraw.SurfaceHeight);
  7913.   end;
  7914. end;
  7915.  
  7916. procedure TCustomDX3D.SetOptions(Value: TDX3DOptions);
  7917. const
  7918.   DX3DOptions = [toRetainedMode, toSystemMemory, toHardware, toSelectDriver, toZBuffer];
  7919.   InitOptions = [toSystemMemory, toHardware, toSelectDriver, toZBuffer];
  7920. var
  7921.   OldOptions: TDX3DOptions;
  7922. begin
  7923.   FOptions := Value;
  7924.  
  7925.   if Initialized then
  7926.   begin
  7927.     OldOptions := FNowOptions;
  7928.     FNowOptions := FNowOptions * InitOptions + FOptions * (DX3DOptions - InitOptions);
  7929.   end else
  7930.   begin
  7931.     FNowOptions := FOptions;
  7932.  
  7933.     if (FDXDraw <> nil) and (doDirectX7Mode in FDXDraw.FNowOptions) then
  7934.       FNowOptions := FNowOptions - [toRetainedMode];
  7935.   end;
  7936. end;
  7937.  
  7938. procedure TCustomDX3D.SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
  7939. begin
  7940.   if (ASurfaceWidth <> SurfaceWidth) or (ASurfaceHeight <> SurfaceHeight) then
  7941.   begin
  7942.     FSurfaceWidth := ASurfaceWidth;
  7943.     FSurfaceHeight := ASurfaceHeight;
  7944.  
  7945.     if Initialized then
  7946.       Initialize;
  7947.   end;
  7948. end;
  7949.  
  7950. procedure TCustomDX3D.SetSurfaceHeight(Value: Integer);
  7951. begin
  7952.   if ComponentState * [csReading, csLoading] = [] then
  7953.     SetSize(SurfaceWidth, Value)
  7954.   else
  7955.     FSurfaceHeight := Value;
  7956. end;
  7957.  
  7958. procedure TCustomDX3D.SetSurfaceWidth(Value: Integer);
  7959. begin
  7960.   if ComponentState * [csReading, csLoading] = [] then
  7961.     SetSize(Value, SurfaceHeight)
  7962.   else
  7963.     FSurfaceWidth := Value;
  7964. end;
  7965.  
  7966. procedure TCustomDX3D.Notification(AComponent: TComponent;
  7967.   Operation: TOperation);
  7968. begin
  7969.   inherited Notification(AComponent, Operation);
  7970.   if (Operation = opRemove) and (FDXDraw = AComponent) then
  7971.     DXDraw := nil;
  7972. end;
  7973.  
  7974. procedure TCustomDX3D.DXDrawNotifyEvent(Sender: TCustomDXDraw;
  7975.   NotifyType: TDXDrawNotifyType);
  7976. var
  7977.   AOptions: TInitializeDirect3DOptions;
  7978. begin
  7979.   case NotifyType of
  7980.     dxntDestroying:
  7981.       begin
  7982.         DXDraw := nil;
  7983.       end;
  7984.     dxntInitializing:
  7985.       begin
  7986.         if (FDXDraw.FOptions * [do3D, doFullScreen] = [doFullScreen])
  7987.           and (FOptions * [toSystemMemory, toSelectDriver] = [toSelectDriver]) then
  7988.         begin
  7989.           AOptions := [];
  7990.           with FDXDraw do
  7991.           begin
  7992.             if doHardware in Options then AOptions := AOptions + [idoHardware];
  7993.             if doRetainedMode in Options then AOptions := AOptions + [idoRetainedMode];
  7994.             if doSelectDriver in Options then AOptions := AOptions + [idoSelectDriver];
  7995.             if doZBuffer in Options then AOptions := AOptions + [idoZBuffer];
  7996.           end;
  7997.  
  7998.           Direct3DInitializing_DXDraw(AOptions, FDXDraw);
  7999.         end;
  8000.       end;
  8001.     dxntInitialize:
  8002.       begin
  8003.         Initialize;
  8004.       end;
  8005.     dxntFinalize:
  8006.       begin
  8007.         Finalize;
  8008.       end;
  8009.     dxntRestore:
  8010.       begin
  8011.         FSurface.Restore;
  8012.         if FZBuffer <> nil then
  8013.           FZBuffer.Restore;
  8014.         FSurface.Palette := FDXDraw.Palette;
  8015.       end;
  8016.     dxntSetSurfaceSize:
  8017.       begin
  8018.         if AutoSize then
  8019.           SetSize(Sender.SurfaceWidth, Sender.SurfaceHeight);
  8020.       end;
  8021.   end;
  8022. end;
  8023.  
  8024. procedure TCustomDX3D.SetDXDraw(Value: TCustomDXDraw);
  8025. begin
  8026.   if FDXDraw <> Value then
  8027.   begin
  8028.     if FDXDraw <> nil then
  8029.       FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
  8030.  
  8031.     FDXDraw := Value;
  8032.  
  8033.     if FDXDraw <> nil then
  8034.       FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
  8035.   end;
  8036. end;
  8037.  
  8038. {$ENDIF}
  8039.  
  8040. {  TDirect3DTexture  }
  8041.  
  8042. constructor TDirect3DTexture.Create(Graphic: TGraphic; DXDraw: TComponent);
  8043. var
  8044.   i: Integer;
  8045. begin
  8046.   inherited Create;
  8047.   FDXDraw := DXDraw;
  8048.   FGraphic := Graphic;
  8049.  
  8050.   {  The palette is acquired.  }
  8051.   i := GetPaletteEntries(FGraphic.Palette, 0, 256, FPaletteEntries);
  8052.   case i of
  8053.     1..2: FBitCount := 1;
  8054.     3..16: FBitCount := 4;
  8055.     17..256: FBitCount := 8;
  8056.   else
  8057.     FBitCount := 24;
  8058.   end;
  8059.  
  8060.   if FDXDraw is TCustomDXDraw then
  8061.   begin
  8062.     with (FDXDraw as TCustomDXDraw) do
  8063.     begin
  8064.       if (not Initialized) {$IFDEF D3D_deprecated}or (not (do3D in NowOptions)){$ENDIF} then
  8065.         raise EDirect3DTextureError.CreateFmt(SNotMade, [FDXDraw.ClassName]);
  8066.     end;
  8067.     FSurface := TDirectDrawSurface.Create((FDXDraw as TCustomDXDraw).Surface.DDraw);
  8068.     (FDXDraw as TCustomDXDraw).RegisterNotifyEvent(DXDrawNotifyEvent);
  8069.   end
  8070.   else
  8071. {$IFDEF DX3D_deprecated}
  8072.     if FDXDraw is TCustomDX3D then
  8073.     begin
  8074.       with (FDXDraw as TDX3D) do
  8075.       begin
  8076.         if not Initialized then
  8077.           raise EDirect3DTextureError.CreateFmt(SNotMade, [FDXDraw.ClassName]);
  8078.       end;
  8079.  
  8080.       FSurface := TDirectDrawSurface.Create((FDXDraw as TCustomDX3D).Surface.DDraw);
  8081.       (FDXDraw as TCustomDX3D).FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
  8082.     end else
  8083. {$ENDIF}
  8084.       raise EDirect3DTextureError.CreateFmt(SNotSupported, [FDXDraw.ClassName]);
  8085. end;
  8086.  
  8087. destructor TDirect3DTexture.Destroy;
  8088. begin
  8089.   if FDXDraw is TCustomDXDraw then
  8090.   begin
  8091.     (FDXDraw as TCustomDXDraw).UnRegisterNotifyEvent(DXDrawNotifyEvent);
  8092.   end
  8093. {$IFDEF DX3D_deprecated}
  8094.   else if FDXDraw is TCustomDX3D then
  8095.   begin
  8096.     (FDXDraw as TCustomDX3D).FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
  8097.   end
  8098. {$ENDIF};
  8099.   Clear;
  8100.   FSurface.Free;
  8101.   inherited Destroy;
  8102. end;
  8103.  
  8104. procedure TDirect3DTexture.Clear;
  8105. begin
  8106.   FHandle := 0;
  8107.   FTexture := nil;
  8108.   FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil;
  8109. end;
  8110.  
  8111. function TDirect3DTexture.GetHandle: TD3DTextureHandle;
  8112. begin
  8113.   if FTexture = nil then
  8114.     Restore;
  8115.   Result := FHandle;
  8116. end;
  8117.  
  8118. function TDirect3DTexture.GetSurface: TDirectDrawSurface;
  8119. begin
  8120.   if FTexture = nil then
  8121.     Restore;
  8122.   Result := FSurface;
  8123. end;
  8124.  
  8125. function TDirect3DTexture.GetTexture: {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF};
  8126. begin
  8127.   if FTexture = nil then
  8128.     Restore;
  8129.   Result := FTexture;
  8130. end;
  8131.  
  8132. procedure TDirect3DTexture.SetTransparentColor(Value: TColor);
  8133. begin
  8134.   if FTransparentColor <> Value then
  8135.   begin
  8136.     FTransparentColor := Value;
  8137.  
  8138.     if FSurface <> nil then
  8139.       FSurface.TransparentColor := FSurface.ColorMatch(Value);
  8140.   end;
  8141. end;
  8142.  
  8143. procedure TDirect3DTexture.Restore;
  8144.  
  8145.   function EnumTextureFormatCallback(const ddsd: TDDSurfaceDesc;
  8146.     lParam: Pointer): HRESULT; stdcall;
  8147.   var
  8148.     tex: TDirect3DTexture;
  8149.  
  8150.     procedure UseThisFormat;
  8151.     begin
  8152.       tex.FFormat := ddsd;
  8153.       tex.FEnumFormatFlag := True;
  8154.     end;
  8155.  
  8156.   begin
  8157.     Result := DDENUMRET_OK;
  8158.     tex := lParam;
  8159.  
  8160.     if ddsd.ddpfPixelFormat.dwFlags and (DDPF_ALPHA or DDPF_ALPHAPIXELS) <> 0 then
  8161.       Exit;
  8162.  
  8163.     if not tex.FEnumFormatFlag then
  8164.     begin
  8165.       {  When called first,  this format is unconditionally selected.  }
  8166.       UseThisFormat;
  8167.     end else
  8168.     begin
  8169.       if (tex.FBitCount <= 8) and (ddsd.ddpfPixelFormat.dwRGBBitCount >= tex.FBitCount) and
  8170.         (ddsd.ddpfPixelFormat.dwRGBBitCount >= 8) and
  8171.         (ddsd.ddpfPixelFormat.dwFlags and DDPF_RGB <> 0) then
  8172.       begin
  8173.         if tex.FFormat.ddpfPixelFormat.dwRGBBitCount > ddsd.ddpfPixelFormat.dwRGBBitCount then
  8174.           UseThisFormat;
  8175.       end else
  8176.       begin
  8177.         if (tex.FFormat.ddpfPixelFormat.dwRGBBitCount > ddsd.ddpfPixelFormat.dwRGBBitCount) and
  8178.           (ddsd.ddpfPixelFormat.dwRGBBitCount > 8) and
  8179.           (ddsd.ddpfPixelFormat.dwFlags and DDPF_RGB <> 0) then
  8180.           UseThisFormat;
  8181.       end;
  8182.     end;
  8183.   end;
  8184.  
  8185.   function GetBitCount(i: Integer): Integer;
  8186.   var
  8187.     j: Integer;
  8188.   begin
  8189.     for j := 32 downto 1 do
  8190.       if (1 shl j) and i <> 0 then
  8191.       begin
  8192.         Result := j;
  8193.         if 1 shl j <> i then
  8194.           Dec(Result);
  8195.         Exit;
  8196.       end;
  8197.     Result := 0;
  8198.   end;
  8199.  
  8200.   function CreateHalftonePalette(R, G, B: Integer): TPaletteEntries;
  8201.   var
  8202.     i: Integer;
  8203.   begin
  8204.     for i := 0 to 255 do
  8205.       with Result[i] do
  8206.       begin
  8207.         peRed := ((i shr (G + B - 1)) and (1 shl R - 1)) * 255 div (1 shl R - 1);
  8208.         peGreen := ((i shr (B - 1)) and (1 shl G - 1)) * 255 div (1 shl G - 1);
  8209.         peBlue := ((i shr 0) and (1 shl B - 1)) * 255 div (1 shl B - 1);
  8210.         peFlags := 0;
  8211.       end;
  8212.   end;
  8213.  
  8214. var
  8215.   ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  8216.   Palette: TDirectDrawPalette;
  8217.   PaletteCaps: Integer;
  8218.   TempSurface: TDirectDrawSurface;
  8219.   Width2, Height2: Integer;
  8220.   D3DDevice: {$IFDEF D3D_deprecated}IDirect3DDevice{$ELSE}IDirect3DDevice7{$ENDIF};
  8221.   Hardware: Boolean;
  8222.   DDraw: TDirectDraw;
  8223. begin
  8224.   Clear;
  8225.   try
  8226.     DDraw := nil;
  8227.     Hardware := False;
  8228.     if FDXDraw is TCustomDXDraw then
  8229.     begin
  8230.       DDraw := (FDXDraw as TCustomDXDraw).DDraw;
  8231.       D3DDevice := (FDXDraw as TCustomDXDraw).{$IFDEF D3D_deprecated}D3DDevice{$ELSE}D3DDevice7{$ENDIF};
  8232.       Hardware := doHardware in (FDXDraw as TCustomDXDraw).NowOptions;
  8233.     end
  8234.     {$IFDEF DX3D_deprecated}
  8235.     else if FDXDraw is TCustomDX3D then
  8236.     begin
  8237.       DDraw := (FDXDraw as TCustomDX3D).Surface.DDraw;
  8238.       D3DDevice := (FDXDraw as TCustomDX3D).D3DDevice;
  8239.       Hardware := toHardware in (FDXDraw as TCustomDX3D).NowOptions;
  8240.     end
  8241.     {$ENDIF};
  8242.  
  8243.     if (DDraw = nil) or (D3DDevice = nil) then Exit;
  8244.  
  8245.     {  The size of texture is arranged in the size of the square of two.  }
  8246.     Width2 := Max(1 shl GetBitCount(FGraphic.Width), 1);
  8247.     Height2 := Max(1 shl GetBitCount(FGraphic.Height), 1);
  8248.  
  8249.     {  Selection of format of texture.  }
  8250.     FEnumFormatFlag := False;
  8251.     D3DDevice.EnumTextureFormats(@EnumTextureFormatCallback, Self);
  8252.  
  8253.     TempSurface := TDirectDrawSurface.Create(FSurface.DDraw);
  8254.     try
  8255.       {  Make source surface.  }
  8256.       with ddsd do
  8257.       begin
  8258.         dwSize := SizeOf(ddsd);
  8259.         dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
  8260.         ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_SYSTEMMEMORY;
  8261.         dwWidth := Width2;
  8262.         dwHeight := Height2;
  8263.         ddpfPixelFormat := FFormat.ddpfPixelFormat;
  8264.       end;
  8265.  
  8266.       if not TempSurface.CreateSurface(ddsd) then
  8267.         raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
  8268.  
  8269.       {  Make surface.  }
  8270.       with ddsd do
  8271.       begin
  8272.         dwSize := SizeOf(ddsd);
  8273.         dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
  8274.         if Hardware then
  8275.           ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_VIDEOMEMORY
  8276.         else
  8277.           ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_SYSTEMMEMORY;
  8278.         ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_ALLOCONLOAD;
  8279.         dwWidth := Width2;
  8280.         dwHeight := Height2;
  8281.         ddpfPixelFormat := FFormat.ddpfPixelFormat;
  8282.       end;
  8283.  
  8284.       if not FSurface.CreateSurface(ddsd) then
  8285.         raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
  8286.  
  8287.       {  Make palette.  }
  8288.       if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8 <> 0 then
  8289.       begin
  8290.         PaletteCaps := DDPCAPS_8BIT or DDPCAPS_ALLOW256;
  8291.         if FBitCount = 24 then
  8292.           CreateHalftonePalette(3, 3, 2);
  8293.       end else if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4 <> 0 then
  8294.       begin
  8295.         PaletteCaps := DDPCAPS_4BIT;
  8296.         if FBitCount = 24 then
  8297.           CreateHalftonePalette(1, 2, 1);
  8298.       end else if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1 <> 0 then
  8299.       begin
  8300.         PaletteCaps := DDPCAPS_1BIT;
  8301.         if FBitCount = 24 then
  8302.         begin
  8303.           FPaletteEntries[0] := RGBQuadToPaletteEntry(RGBQuad(0, 0, 0));
  8304.           FPaletteEntries[1] := RGBQuadToPaletteEntry(RGBQuad(255, 255, 255));
  8305.         end;
  8306.       end else
  8307.         PaletteCaps := 0;
  8308.  
  8309.       if PaletteCaps <> 0 then
  8310.       begin
  8311.         Palette := TDirectDrawPalette.Create(DDraw);
  8312.         try
  8313.           Palette.CreatePalette(PaletteCaps, FPaletteEntries);
  8314.           TempSurface.Palette := Palette;
  8315.           FSurface.Palette := Palette;
  8316.         finally
  8317.           Palette.Free;
  8318.         end;
  8319.       end;
  8320.  
  8321.       {  The image is loaded into source surface.  }
  8322.       with TempSurface.Canvas do
  8323.       begin
  8324.         StretchDraw(TempSurface.ClientRect, FGraphic);
  8325.         Release;
  8326.       end;
  8327.  
  8328.       {  Source surface is loaded into surface.  }
  8329.       FTexture := FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF} as {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF};
  8330.       FTexture.Load(TempSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF} as {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF});
  8331.     finally
  8332.       TempSurface.Free;
  8333.     end;
  8334.  
  8335.     if FTexture.GetHandle(D3DDevice as {$IFDEF D3D_deprecated}IDirect3DDevice{$ELSE}IDirect3DDevice2{$ENDIF}, FHandle) <> D3D_OK then
  8336.       raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
  8337.  
  8338.     FSurface.TransparentColor := FSurface.ColorMatch(FTransparentColor);
  8339.   except
  8340.     Clear;
  8341.     raise;
  8342.   end;
  8343. end;
  8344.  
  8345. procedure TDirect3DTexture.DXDrawNotifyEvent(Sender: TCustomDXDraw;
  8346.   NotifyType: TDXDrawNotifyType);
  8347. begin
  8348.   case NotifyType of
  8349.     dxntInitializeSurface:
  8350.       begin
  8351.         Restore;
  8352.       end;
  8353.     dxntRestore:
  8354.       begin
  8355.         Restore;
  8356.       end;
  8357.   end;
  8358. end;
  8359.  
  8360. {  TDirect3DTexture2  }
  8361.  
  8362. constructor TDirect3DTexture2.Create(ADXDraw: TCustomDXDraw; Graphic: TObject;
  8363.   AutoFreeGraphic: Boolean);
  8364. begin
  8365.   inherited Create;
  8366.   FSrcImage := Graphic;
  8367.   FAutoFreeGraphic := AutoFreeGraphic;
  8368.   FNeedLoadTexture := True;
  8369.  
  8370.   if FSrcImage is TDXTextureImage then
  8371.     FImage := TDXTextureImage(FSrcImage)
  8372.   else
  8373.   if FSrcImage is TDIB then
  8374.     SetDIB(TDIB(FSrcImage))
  8375.   else
  8376.   if FSrcImage is TGraphic then
  8377.   begin
  8378.     FSrcImage := TDIB.Create;
  8379.     try
  8380.       TDIB(FSrcImage).Assign(TGraphic(Graphic));
  8381.       SetDIB(TDIB(FSrcImage));
  8382.     finally
  8383.       if FAutoFreeGraphic then
  8384.         Graphic.Free;
  8385.       FAutoFreeGraphic := True;
  8386.     end;
  8387.   end
  8388.   else
  8389.     if FSrcImage is TPicture then
  8390.     begin
  8391.       FSrcImage := TDIB.Create;
  8392.       try
  8393.         TDIB(FSrcImage).Assign(TPicture(Graphic).Graphic);
  8394.         SetDIB(TDIB(FSrcImage));
  8395.       finally
  8396.         if FAutoFreeGraphic then
  8397.           Graphic.Free;
  8398.         FAutoFreeGraphic := True;
  8399.       end;
  8400.     end
  8401.     else
  8402.       raise Exception.CreateFmt(SCannotLoadGraphic, [Graphic.ClassName]);
  8403.  
  8404.   FMipmap := FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap] > 0;
  8405.  
  8406.   FTransparent := FImage.Transparent;
  8407.   case FImage.ImageType of
  8408.     DXTextureImageType_PaletteIndexedColor:
  8409.       begin
  8410.         FTransparentColor := PaletteIndex(dxtDecodeChannel(FImage.idx_index, FImage.TransparentColor));
  8411.       end;
  8412.     DXTextureImageType_RGBColor:
  8413.       begin
  8414.         FTransparentColor := RGB(dxtDecodeChannel(FImage.rgb_red, FImage.TransparentColor),
  8415.           dxtDecodeChannel(FImage.rgb_green, FImage.TransparentColor),
  8416.           dxtDecodeChannel(FImage.rgb_blue, FImage.TransparentColor));
  8417.       end;
  8418.   end;
  8419.  
  8420.   SetDXDraw(ADXDraw);
  8421. end;
  8422.  
  8423. constructor TDirect3DTexture2.CreateFromFile(ADXDraw: TCustomDXDraw; const FileName: string);
  8424. var
  8425.   Image: TObject;
  8426. begin
  8427.   Image := nil;
  8428.   try
  8429.     {  TDXTextureImage  }
  8430.     Image := TDXTextureImage.Create;
  8431.     try
  8432.       TDXTextureImage(Image).LoadFromFile(FileName);
  8433.     except
  8434.       Image.Free;
  8435.       Image := nil;
  8436.     end;
  8437.  
  8438.     {  TDIB  }
  8439.     if Image = nil then
  8440.     begin
  8441.       Image := TDIB.Create;
  8442.       try
  8443.         TDIB(Image).LoadFromFile(FileName);
  8444.       except
  8445.         Image.Free;
  8446.         Image := nil;
  8447.       end;
  8448.     end;
  8449.  
  8450.     {  TPicture  }
  8451.     if Image = nil then
  8452.     begin
  8453.       Image := TPicture.Create;
  8454.       try
  8455.         TPicture(Image).LoadFromFile(FileName);
  8456.       except
  8457.         Image.Free;
  8458.         Image := nil;
  8459.         raise;
  8460.       end;
  8461.     end;
  8462.   except
  8463.     Image.Free;
  8464.     raise;
  8465.   end;
  8466.  
  8467.   Create(ADXDraw, Image, True);
  8468. end;
  8469.  
  8470. constructor TDirect3DTexture2.CreateVideoTexture(ADXDraw: TCustomDXDraw);
  8471. begin
  8472.   inherited Create;
  8473.   SetDXDraw(ADXDraw);
  8474. end;
  8475.  
  8476. destructor TDirect3DTexture2.Destroy;
  8477. begin
  8478.   Finalize;
  8479.  
  8480.   SetDXDraw(nil);
  8481.  
  8482.   if FAutoFreeGraphic then
  8483.     FSrcImage.Free;
  8484.   FImage2.Free;
  8485.   inherited Destroy;
  8486. end;
  8487.  
  8488. procedure TDirect3DTexture2.DXDrawNotifyEvent(Sender: TCustomDXDraw;
  8489.   NotifyType: TDXDrawNotifyType);
  8490. begin
  8491.   case NotifyType of
  8492.     dxntDestroying:
  8493.       begin
  8494.         SetDXDraw(nil);
  8495.       end;
  8496.     dxntInitializeSurface:
  8497.       begin
  8498.         Initialize;
  8499.       end;
  8500.     dxntFinalizeSurface:
  8501.       begin
  8502.         Finalize;
  8503.       end;
  8504.     dxntRestore:
  8505.       begin
  8506.         Load;
  8507.       end;
  8508.   end;
  8509. end;
  8510.  
  8511. procedure TDirect3DTexture2.SetDXDraw(ADXDraw: TCustomDXDraw);
  8512. begin
  8513.   if FDXDraw <> ADXDraw then
  8514.   begin
  8515.     if FDXDraw <> nil then
  8516.       FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
  8517.  
  8518.     FDXDraw := ADXDraw;
  8519.  
  8520.     if FDXDraw <> nil then
  8521.       FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
  8522.   end;
  8523. end;
  8524.  
  8525. procedure TDirect3DTexture2.DoRestoreSurface;
  8526. begin
  8527.   if Assigned(FOnRestoreSurface) then
  8528.     FOnRestoreSurface(Self);
  8529. end;
  8530.  
  8531. procedure TDirect3DTexture2.SetDIB(DIB: TDIB);
  8532. var
  8533.   i: Integer;
  8534. begin
  8535.   if FImage2 = nil then
  8536.     FImage2 := TDXTextureImage.Create;
  8537.  
  8538.   if DIB.BitCount <= 8 then
  8539.   begin
  8540.     FImage2.SetImage(DXTextureImageType_PaletteIndexedColor, DIB.Width, DIB.Height, DIB.BitCount,
  8541.       DIB.WidthBytes, DIB.NextLine, DIB.PBits, DIB.TopPBits, DIB.Size, False);
  8542.  
  8543.     FImage2.idx_index := dxtMakeChannel((1 shl DIB.BitCount) - 1, True);
  8544.     for i := 0 to 255 do
  8545.       FImage2.idx_palette[i] := RGBQuadToPaletteEntry(DIB.ColorTable[i]);
  8546.   end else
  8547.   begin
  8548.     FImage2.SetImage(DXTextureImageType_RGBColor, DIB.Width, DIB.Height, DIB.BitCount,
  8549.       DIB.WidthBytes, DIB.NextLine, DIB.PBits, DIB.TopPBits, DIB.Size, False);
  8550.  
  8551.     FImage2.rgb_red := dxtMakeChannel(DIB.NowPixelFormat.RBitMask, False);
  8552.     FImage2.rgb_green := dxtMakeChannel(DIB.NowPixelFormat.GBitMask, False);
  8553.     FImage2.rgb_blue := dxtMakeChannel(DIB.NowPixelFormat.BBitMask, False);
  8554.  
  8555.     i := DIB.NowPixelFormat.RBitCount + DIB.NowPixelFormat.GBitCount + DIB.NowPixelFormat.BBitCount;
  8556.     if i < DIB.BitCount then
  8557.       FImage2.rgb_alpha := dxtMakeChannel(((1 shl (DIB.BitCount - i)) - 1) shl i, False);
  8558.   end;
  8559.  
  8560.   FImage := FImage2;
  8561. end;
  8562.  
  8563. function TDirect3DTexture2.GetHeight: Integer;
  8564. begin
  8565.   if Assigned(FImage) then
  8566.     Result := FImage.Height
  8567.   else
  8568.     if Assigned(FImage2) then
  8569.       Result := FImage2.Height
  8570.     else
  8571.       Result := 0;
  8572. end;
  8573.  
  8574. function TDirect3DTexture2.GetIsMipmap: Boolean;
  8575. begin
  8576.   if FSurface <> nil then
  8577.     Result := FUseMipmap
  8578.   else
  8579.     Result := FMipmap;
  8580. end;
  8581.  
  8582. function TDirect3DTexture2.GetSurface: TDirectDrawSurface;
  8583. begin
  8584.   Result := FSurface;
  8585.   if (Result <> nil) and FNeedLoadTexture then
  8586.     Load;
  8587. end;
  8588.  
  8589. function TDirect3DTexture2.GetTransparent: Boolean;
  8590. begin
  8591.   if FSurface <> nil then
  8592.     Result := FUseColorKey
  8593.   else
  8594.     Result := FTransparent;
  8595. end;
  8596.  
  8597. function TDirect3DTexture2.GetWidth: Integer;
  8598. begin
  8599.   if Assigned(FImage) then
  8600.     Result := FImage.Width
  8601.   else
  8602.     if Assigned(FImage2) then
  8603.       Result := FImage2.Width
  8604.     else
  8605.       Result := 0;
  8606. end;
  8607.  
  8608. procedure TDirect3DTexture2.SetTransparent(Value: Boolean);
  8609. begin
  8610.   if FTransparent <> Value then
  8611.   begin
  8612.     FTransparent := Value;
  8613.     if FSurface <> nil then
  8614.       SetColorKey;
  8615.   end;
  8616. end;
  8617.  
  8618. procedure TDirect3DTexture2.SetTransparentColor(Value: TColorRef);
  8619. begin
  8620.   if FTransparentColor <> Value then
  8621.   begin
  8622.     FTransparentColor := Value;
  8623.     if (FSurface <> nil) and FTransparent then
  8624.       SetColorKey;
  8625.   end;
  8626. end;
  8627.  
  8628. procedure TDirect3DTexture2.Finalize;
  8629. begin
  8630.   FSurface.Free; FSurface := nil;
  8631.  
  8632.   FUseColorKey := False;
  8633.   FUseMipmap := False;
  8634.   FNeedLoadTexture := False;
  8635. end;
  8636.  
  8637. const
  8638.   DDPF_PALETTEINDEXED = DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
  8639.     DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8;
  8640.  
  8641. procedure TDirect3DTexture2.Initialize;
  8642.  
  8643.   function GetBitCount(i: Integer): Integer;
  8644.   begin
  8645.     Result := 31;
  8646.     while (i >= 0) and (((1 shl Result) and i) = 0) do Dec(Result);
  8647.   end;
  8648.  
  8649.   function GetMaskBitCount(b: Integer): Integer;
  8650.   var
  8651.     i: Integer;
  8652.   begin
  8653.     i := 0;
  8654.     while (i < 31) and (((1 shl i) and b) = 0) do Inc(i);
  8655.  
  8656.     Result := 0;
  8657.     while ((1 shl i) and b) <> 0 do
  8658.     begin
  8659.       Inc(i);
  8660.       Inc(Result);
  8661.     end;
  8662.   end;
  8663.  
  8664.   function GetPaletteBitCount(const ddpfPixelFormat: TDDPixelFormat): Integer;
  8665.   begin
  8666.     if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8 <> 0 then
  8667.       Result := 8
  8668.     else if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4 <> 0 then
  8669.       Result := 4
  8670.     else if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED2 <> 0 then
  8671.       Result := 2
  8672.     else if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1 <> 0 then
  8673.       Result := 1
  8674.     else
  8675.       Result := 0;
  8676.   end;
  8677.  
  8678.   function EnumTextureFormatCallback(const lpDDPixFmt: TDDPixelFormat;
  8679.     lParam: Pointer): HRESULT; stdcall;
  8680.   var
  8681.     tex: TDirect3DTexture2;
  8682.  
  8683.     procedure UseThisFormat;
  8684.     begin
  8685.       tex.FTextureFormat.ddpfPixelFormat := lpDDPixFmt;
  8686.       tex.FEnumTextureFormatFlag := True;
  8687.     end;
  8688.  
  8689.   var
  8690.     rgb_red, rgb_green, rgb_blue, rgb_alpha, idx_index: Integer;
  8691.     sum1, sum2: Integer;
  8692.   begin
  8693.     Result := DDENUMRET_OK;
  8694.     tex := lParam;
  8695.  
  8696.     {  Form acquisition of source image  }
  8697.     rgb_red := 0;
  8698.     rgb_green := 0;
  8699.     rgb_blue := 0;
  8700.     rgb_alpha := 0;
  8701.     idx_index := 0;
  8702.  
  8703.     case tex.FImage.ImageType of
  8704.       DXTextureImageType_RGBColor:
  8705.         begin
  8706.           {  RGB Color  }
  8707.           rgb_red := tex.FImage.rgb_red.bitcount;
  8708.           rgb_green := tex.FImage.rgb_green.bitcount;
  8709.           rgb_blue := tex.FImage.rgb_blue.bitcount;
  8710.           rgb_alpha := tex.FImage.rgb_alpha.bitcount;
  8711.           idx_index := 8;
  8712.         end;
  8713.       DXTextureImageType_PaletteIndexedColor:
  8714.         begin
  8715.           {  Index Color  }
  8716.           rgb_red := 8;
  8717.           rgb_green := 8;
  8718.           rgb_blue := 8;
  8719.           rgb_alpha := tex.FImage.idx_alpha.bitcount;
  8720.           idx_index := tex.FImage.idx_index.bitcount;
  8721.         end;
  8722.     end;
  8723.  
  8724.     {  The texture examines whether this pixel format can be used.  }
  8725.     if lpDDPixFmt.dwFlags and DDPF_RGB = 0 then Exit;
  8726.  
  8727.     case tex.FImage.ImageType of
  8728.       DXTextureImageType_RGBColor:
  8729.         begin
  8730.           if lpDDPixFmt.dwFlags and DDPF_PALETTEINDEXED <> 0 then Exit;
  8731.         end;
  8732.       DXTextureImageType_PaletteIndexedColor:
  8733.         begin
  8734.           if (lpDDPixFmt.dwFlags and DDPF_PALETTEINDEXED <> 0) and
  8735.             (GetPaletteBitCount(lpDDPixFmt) < idx_index) then Exit;
  8736.         end;
  8737.     end;
  8738.  
  8739.     {  The pixel format which can be used is selected carefully.  }
  8740.     if tex.FEnumTextureFormatFlag then
  8741.     begin
  8742.       if lpDDPixFmt.dwFlags and DDPF_PALETTEINDEXED <> 0 then
  8743.       begin
  8744.         {  Bit count check  }
  8745.         if Abs(Integer(lpDDPixFmt.dwRGBBitCount) - idx_index) >
  8746.           Abs(Integer(tex.FTextureFormat.ddpfPixelFormat.dwRGBBitCount) - idx_index) then Exit;
  8747.  
  8748.         {  Alpha channel check  }
  8749.         if rgb_alpha > 0 then Exit;
  8750.       end else
  8751.         if lpDDPixFmt.dwFlags and DDPF_RGB <> 0 then
  8752.         begin
  8753.         {  The alpha channel is indispensable.  }
  8754.           if (rgb_alpha > 0) and (tex.FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_ALPHAPIXELS = 0) and
  8755.             (lpDDPixFmt.dwFlags and DDPF_ALPHAPIXELS <> 0) then
  8756.           begin
  8757.             UseThisFormat;
  8758.             Exit;
  8759.           end;
  8760.  
  8761.         {  Alpha channel check  }
  8762.           if (rgb_alpha > 0) and (tex.FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_ALPHAPIXELS <> 0) and
  8763.             (lpDDPixFmt.dwFlags and DDPF_ALPHAPIXELS = 0) then
  8764.           begin
  8765.             Exit;
  8766.           end;
  8767.  
  8768.         {  Bit count check  }
  8769.           if tex.FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED = 0 then
  8770.           begin
  8771.             sum1 := Sqr(GetMaskBitCount(lpDDPixFmt.dwRBitMask) - rgb_red) +
  8772.               Sqr(GetMaskBitCount(lpDDPixFmt.dwGBitMask) - rgb_green) +
  8773.               Sqr(GetMaskBitCount(lpDDPixFmt.dwBBitMask) - rgb_blue) +
  8774.               Sqr(GetMaskBitCount(lpDDPixFmt.dwRGBAlphaBitMask) - rgb_alpha);
  8775.  
  8776.             sum2 := Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwRBitMask) - rgb_red) +
  8777.               Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwGBitMask) - rgb_green) +
  8778.               Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwBBitMask) - rgb_blue) +
  8779.               Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwRGBAlphaBitMask) - rgb_alpha);
  8780.  
  8781.             if sum1 > sum2 then Exit;
  8782.           end;
  8783.         end;
  8784.     end;
  8785.  
  8786.     UseThisFormat;
  8787.   end;
  8788.  
  8789. var
  8790.   Width, Height: Integer;
  8791.   PaletteCaps: DWORD;
  8792.   Palette: IDirectDrawPalette;
  8793.   {$IFDEF D3D_deprecated}TempD3DDevDesc: TD3DDeviceDesc;{$ENDIF}
  8794.   D3DDevDesc7: TD3DDeviceDesc7;
  8795.   TempSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF};
  8796. begin
  8797.   Finalize;
  8798.   try
  8799.     if FDXDraw.D3DDevice7 <> nil then
  8800.     begin
  8801.       FDXDraw.D3DDevice7.GetCaps(D3DDevDesc7);
  8802.       FD3DDevDesc.dpcLineCaps.dwTextureCaps := D3DDevDesc7.dpcLineCaps.dwTextureCaps;
  8803.       FD3DDevDesc.dpcTriCaps.dwTextureCaps := D3DDevDesc7.dpcTriCaps.dwTextureCaps;
  8804.       FD3DDevDesc.dwMinTextureWidth := D3DDevDesc7.dwMinTextureWidth;
  8805.       FD3DDevDesc.dwMaxTextureWidth := D3DDevDesc7.dwMaxTextureWidth;
  8806.     end
  8807.     {$IFDEF D3D_deprecated}
  8808.     else
  8809.     begin
  8810.       FD3DDevDesc.dwSize := SizeOf(FD3DDevDesc);
  8811.       TempD3DDevDesc.dwSize := SizeOf(TempD3DDevDesc);
  8812.       FDXDraw.D3DDevice3.GetCaps(FD3DDevDesc, TempD3DDevDesc);
  8813.     end{$ENDIF};
  8814.  
  8815.     if FImage <> nil then
  8816.     begin
  8817.       {  Size adjustment of texture  }
  8818.       if FD3DDevDesc.dpcTriCaps.dwTextureCaps and D3DPTEXTURECAPS_POW2 <> 0 then
  8819.       begin
  8820.         {  The size of the texture is only Sqr(n).  }
  8821.         Width := Max(1 shl GetBitCount(FImage.Width), 1);
  8822.         Height := Max(1 shl GetBitCount(FImage.Height), 1);
  8823.       end
  8824.       else
  8825.       begin
  8826.         Width := FImage.Width;
  8827.         Height := FImage.Height;
  8828.       end;
  8829.  
  8830.       if FD3DDevDesc.dpcTriCaps.dwTextureCaps and D3DPTEXTURECAPS_SQUAREONLY <> 0 then
  8831.       begin
  8832.         {  The size of the texture is only a square.  }
  8833.         if Width < Height then Width := Height;
  8834.         Height := Width;
  8835.       end;
  8836.  
  8837.       if FD3DDevDesc.dwMinTextureWidth > 0 then
  8838.         Width := Max(Width, FD3DDevDesc.dwMinTextureWidth);
  8839.  
  8840.       if FD3DDevDesc.dwMaxTextureWidth > 0 then
  8841.         Width := Min(Width, FD3DDevDesc.dwMaxTextureWidth);
  8842.  
  8843.       if FD3DDevDesc.dwMinTextureHeight > 0 then
  8844.         Height := Max(Height, FD3DDevDesc.dwMinTextureHeight);
  8845.  
  8846.       if FD3DDevDesc.dwMaxTextureHeight > 0 then
  8847.         Height := Min(Height, FD3DDevDesc.dwMaxTextureHeight);
  8848.  
  8849.       {  Pixel format selection  }
  8850.       FEnumTextureFormatFlag := False;
  8851.       if FDXDraw.D3DDevice7 <> nil then
  8852.         FDXDraw.D3DDevice7.EnumTextureFormats(@EnumTextureFormatCallback, Self)
  8853.       {$IFDEF D3D_deprecated}else
  8854.         FDXDraw.D3DDevice3.EnumTextureFormats(@EnumTextureFormatCallback, Self){$ENDIF};
  8855.  
  8856.       if not FEnumTextureFormatFlag then
  8857.         raise EDirect3DTextureError.CreateFmt(SCannotInitialized, [STexture]);
  8858.  
  8859.       {  Is Mipmap surface used ?  }
  8860.       FUseMipmap := FMipmap and (FTextureFormat.ddpfPixelFormat.dwRGBBitCount > 8) and
  8861.         (FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap] > 0) and (FDXDraw.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_MIPMAP <> 0);
  8862.  
  8863.       {  Surface form setting  }
  8864.       with FTextureFormat do
  8865.       begin
  8866.         dwSize := SizeOf(FTextureFormat);
  8867.         dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
  8868.         ddsCaps.dwCaps := DDSCAPS_TEXTURE;
  8869.         ddsCaps.dwCaps2 := 0;
  8870.         dwWidth := Width;
  8871.         dwHeight := Height;
  8872.  
  8873.         if doHardware in FDXDraw.NowOptions then
  8874.           ddsCaps.dwCaps2 := ddsCaps.dwCaps2 or DDSCAPS2_TEXTUREMANAGE
  8875.         else
  8876.           ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
  8877.  
  8878.         if FUseMipmap then
  8879.         begin
  8880.           dwFlags := dwFlags or DDSD_MIPMAPCOUNT;
  8881.           ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_MIPMAP or DDSCAPS_COMPLEX;
  8882.           dwMipMapCount := FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap];
  8883.         end;
  8884.       end;
  8885.     end;
  8886.  
  8887.     FSurface := TDirectDrawSurface.Create(FDXDraw.DDraw);
  8888.     FSurface.DDraw.DXResult := FSurface.DDraw.{$IFDEF D3D_deprecated}IDraw4{$ELSE}IDraw7{$ENDIF}.CreateSurface(FTextureFormat, TempSurface, nil);
  8889.     if FSurface.DDraw.DXResult <> DD_OK then
  8890.       raise EDirect3DTextureError.CreateFmt(SCannotInitialized, [STexture]);
  8891.     FSurface.{$IFDEF D3D_deprecated}IDDSurface4{$ELSE}IDDSurface7{$ENDIF} := TempSurface;
  8892.  
  8893.     {  Palette making  }
  8894.     if (FImage <> nil) and (FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED <> 0) then
  8895.     begin
  8896.       if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8 <> 0 then
  8897.         PaletteCaps := DDPCAPS_8BIT or DDPCAPS_ALLOW256
  8898.       else
  8899.       if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4 <> 0 then
  8900.         PaletteCaps := DDPCAPS_4BIT
  8901.       else
  8902.       if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED2 <> 0 then
  8903.         PaletteCaps := DDPCAPS_2BIT
  8904.       else
  8905.       if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1 <> 0 then
  8906.         PaletteCaps := DDPCAPS_1BIT
  8907.       else
  8908.         PaletteCaps := 0;
  8909.  
  8910.       if PaletteCaps <> 0 then
  8911.       begin
  8912.         if FDXDraw.DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.CreatePalette(PaletteCaps, @FImage.idx_palette, Palette, nil) <> 0 then
  8913.           Exit;
  8914.  
  8915.         FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetPalette(Palette);
  8916.       end;
  8917.     end;
  8918.  
  8919.     FNeedLoadTexture := True;
  8920.   except
  8921.     Finalize;
  8922.     raise;
  8923.   end;
  8924. end;
  8925.  
  8926. procedure TDirect3DTexture2.Load;
  8927. const
  8928.   MipmapCaps: TDDSCaps2 = (dwCaps: DDSCAPS_TEXTURE or DDSCAPS_MIPMAP);
  8929. var
  8930.   CurSurface, NextSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF};
  8931.   Index: Integer;
  8932.   SrcImage: TDXTextureImage;
  8933. begin
  8934.   if FSurface = nil then
  8935.     Initialize;
  8936.  
  8937.   FNeedLoadTexture := False;
  8938.   if FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DDERR_SURFACELOST then
  8939.     FSurface.Restore;
  8940.  
  8941.   {  Color key setting.  }
  8942.   SetColorKey;
  8943.  
  8944.   {  Image loading into surface.  }
  8945.   if FImage <> nil then
  8946.   begin
  8947.     if FSrcImage is TDIB then
  8948.       SetDIB(TDIB(FSrcImage));
  8949.  
  8950.     CurSurface := FSurface.{$IFDEF D3D_deprecated}ISurface4{$ELSE}ISurface7{$ENDIF};
  8951.     Index := 0;
  8952.     while CurSurface <> nil do
  8953.     begin
  8954.       SrcImage := FImage;
  8955.       if Index > 0 then
  8956.       begin
  8957.         if Index - 1 >= FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap] then
  8958.           Break;
  8959.         SrcImage := FImage.SubGroupImages[DXTextureImageGroupType_Mipmap, Index - 1];
  8960.       end;
  8961.  
  8962.       LoadSubTexture(CurSurface, SrcImage);
  8963.  
  8964.       if CurSurface.GetAttachedSurface(MipmapCaps, NextSurface) = 0 then
  8965.         CurSurface := NextSurface
  8966.       else
  8967.         CurSurface := nil;
  8968.  
  8969.       Inc(Index);
  8970.     end;
  8971.   end
  8972.   else
  8973.     DoRestoreSurface;
  8974. end;
  8975.  
  8976. procedure TDirect3DTexture2.SetColorKey;
  8977. var
  8978.   ck: TDDColorKey;
  8979. begin
  8980.   FUseColorKey := False;
  8981.  
  8982.   if (FSurface <> nil) and FTransparent and (FD3DDevDesc.dpcTriCaps.dwTextureCaps and D3DPTEXTURECAPS_TRANSPARENCY <> 0) then
  8983.   begin
  8984.     FillChar(ck, SizeOf(ck), 0);
  8985.     if FSurface.SurfaceDesc.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED <> 0 then
  8986.     begin
  8987.       if FTransparentColor shr 24 = $01 then
  8988.       begin
  8989.         {  Palette index  }
  8990.         ck.dwColorSpaceLowValue := FTransparentColor and $FF;
  8991.       end
  8992.       else
  8993.         if FImage <> nil then
  8994.         begin
  8995.         {  RGB value  }
  8996.           ck.dwColorSpaceLowValue := FImage.PaletteIndex(GetRValue(FTransparentColor), GetGValue(FTransparentColor), GetBValue(FTransparentColor));
  8997.         end else
  8998.           Exit;
  8999.     end
  9000.     else
  9001.     begin
  9002.       if (FImage <> nil) and (FImage.ImageType = DXTextureImageType_PaletteIndexedColor) and (FTransparentColor shr 24 = $01) then
  9003.       begin
  9004.         {  Palette index  }
  9005.         ck.dwColorSpaceLowValue :=
  9006.           dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwRBitMask, False), FImage.idx_palette[FTransparentColor and $FF].peRed) or
  9007.           dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwGBitMask, False), FImage.idx_palette[FTransparentColor and $FF].peGreen) or
  9008.           dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwBBitMask, False), FImage.idx_palette[FTransparentColor and $FF].peBlue);
  9009.       end
  9010.       else
  9011.         if FTransparentColor shr 24 = $00 then
  9012.         begin
  9013.         {  RGB value  }
  9014.           ck.dwColorSpaceLowValue :=
  9015.             dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwRBitMask, False), GetRValue(FTransparentColor)) or
  9016.             dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwGBitMask, False), GetGValue(FTransparentColor)) or
  9017.             dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwBBitMask, False), GetBValue(FTransparentColor));
  9018.         end
  9019.         else
  9020.           Exit;
  9021.     end;
  9022.  
  9023.     ck.dwColorSpaceHighValue := ck.dwColorSpaceLowValue;
  9024.     FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetColorKey(DDCKEY_SRCBLT, @ck);
  9025.  
  9026.     FUseColorKey := True;
  9027.   end;
  9028. end;
  9029.  
  9030. procedure TDirect3DTexture2.LoadSubTexture(Dest: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF}; SrcImage: TDXTextureImage);
  9031. const
  9032.   Mask1: array[0..7] of DWORD = (1, 2, 4, 8, 16, 32, 64, 128);
  9033.   Mask2: array[0..3] of DWORD = (3, 12, 48, 192);
  9034.   Mask4: array[0..1] of DWORD = ($0F, $F0);
  9035.   Shift1: array[0..7] of DWORD = (0, 1, 2, 3, 4, 5, 6, 7);
  9036.   Shift2: array[0..3] of DWORD = (0, 2, 4, 6);
  9037.   Shift4: array[0..1] of DWORD = (0, 4);
  9038.  
  9039.   procedure SetPixel(const ddsd: TDDSurfaceDesc2; x, y: Integer; c: DWORD);
  9040.   begin
  9041.     case ddsd.ddpfPixelFormat.dwRGBBitCount of
  9042.       1: PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 8)^ :=
  9043.         (PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 8)^ and (not Mask1[x mod 8])) or (c shl Shift1[x mod 8]);
  9044.       2: PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 4)^ :=
  9045.         (PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 4)^ and (not Mask2[x mod 4])) or (c shl Shift2[x mod 4]);
  9046.       4: PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 2)^ :=
  9047.         (PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 2)^ and (not Mask4[x mod 2])) or (c shl Shift4[x mod 2]);
  9048.       8: PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x)^ := c;
  9049.       16: PWord(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 2)^ := c;
  9050.       24: begin
  9051.           PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 3)^ := c shr 0;
  9052.           PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 3 + 1)^ := c shr 8;
  9053.           PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 3 + 2)^ := c shr 16;
  9054.         end;
  9055.       32: PDWORD(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 4)^ := c;
  9056.     end;
  9057.   end;
  9058.  
  9059.   procedure LoadTexture_IndexToIndex;
  9060.   var
  9061.     ddsd: TDDSurfaceDesc2;
  9062.     x, y: Integer;
  9063.   begin
  9064.     ddsd.dwSize := SizeOf(ddsd);
  9065.     if Dest.Lock(nil, ddsd, DDLOCK_WAIT, 0) = 0 then
  9066.     begin
  9067.       try
  9068.         if (SrcImage.idx_index.Mask = DWORD(1 shl ddsd.ddpfPixelFormat.dwRGBBitCount) - 1) and
  9069.           (SrcImage.idx_alpha.Mask = 0) and
  9070.           (SrcImage.BitCount = Integer(ddsd.ddpfPixelFormat.dwRGBBitCount)) and
  9071.           (not SrcImage.PackedPixelOrder)
  9072.         then
  9073.         begin
  9074.           for y := 0 to ddsd.dwHeight - 1 do
  9075.             Move(SrcImage.ScanLine[y]^, Pointer(Integer(ddsd.lpSurface) + ddsd.lPitch * y)^, (Integer(ddsd.dwWidth) * SrcImage.BitCount + 7) div 8);
  9076.         end
  9077.         else
  9078.         begin
  9079.           for y := 0 to ddsd.dwHeight - 1 do
  9080.           begin
  9081.             for x := 0 to ddsd.dwWidth - 1 do
  9082.               SetPixel(ddsd, x, y, dxtDecodeChannel(SrcImage.idx_index, SrcImage.Pixels[x, y]));
  9083.           end;
  9084.         end;
  9085.       finally
  9086.         Dest.UnLock(ddsd.lpSurface);
  9087.       end;
  9088.     end;
  9089.   end;
  9090.  
  9091.   procedure LoadTexture_IndexToRGB;
  9092.   var
  9093.     ddsd: TDDSurfaceDesc2;
  9094.     x, y: Integer;
  9095.     c, cIdx, cA: DWORD;
  9096.     dest_red_fmt, dest_green_fmt, dest_blue_fmt, dest_alpha_fmt: TDXTextureImageChannel;
  9097.   begin
  9098.     ddsd.dwSize := SizeOf(ddsd);
  9099.     if Dest.Lock(nil, ddsd, DDLOCK_WAIT, 0) = 0 then
  9100.     begin
  9101.       try
  9102.         dest_red_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRBitMask, False);
  9103.         dest_green_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwGBitMask, False);
  9104.         dest_blue_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwBBitMask, False);
  9105.         dest_alpha_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRGBAlphaBitMask, False);
  9106.  
  9107.         if SrcImage.idx_alpha.mask <> 0 then
  9108.         begin
  9109.           for y := 0 to ddsd.dwHeight - 1 do
  9110.             for x := 0 to ddsd.dwWidth - 1 do
  9111.             begin
  9112.               c := SrcImage.Pixels[x, y];
  9113.               cIdx := dxtDecodeChannel(SrcImage.idx_index, c);
  9114.  
  9115.               c := dxtEncodeChannel(dest_red_fmt, SrcImage.idx_palette[cIdx].peRed) or
  9116.                 dxtEncodeChannel(dest_green_fmt, SrcImage.idx_palette[cIdx].peGreen) or
  9117.                 dxtEncodeChannel(dest_blue_fmt, SrcImage.idx_palette[cIdx].peBlue) or
  9118.                 dxtEncodeChannel(dest_alpha_fmt, dxtDecodeChannel(SrcImage.idx_alpha, c));
  9119.  
  9120.               SetPixel(ddsd, x, y, c);
  9121.             end;
  9122.         end
  9123.         else
  9124.         begin
  9125.           cA := dxtEncodeChannel(dest_alpha_fmt, 255);
  9126.  
  9127.           for y := 0 to ddsd.dwHeight - 1 do
  9128.             for x := 0 to ddsd.dwWidth - 1 do
  9129.             begin
  9130.               c := SrcImage.Pixels[x, y];
  9131.               cIdx := dxtDecodeChannel(SrcImage.idx_index, c);
  9132.  
  9133.               c := dxtEncodeChannel(dest_red_fmt, SrcImage.idx_palette[cIdx].peRed) or
  9134.                 dxtEncodeChannel(dest_green_fmt, SrcImage.idx_palette[cIdx].peGreen) or
  9135.                 dxtEncodeChannel(dest_blue_fmt, SrcImage.idx_palette[cIdx].peBlue) or cA;
  9136.  
  9137.               SetPixel(ddsd, x, y, c);
  9138.             end;
  9139.         end;
  9140.       finally
  9141.         Dest.UnLock(ddsd.lpSurface);
  9142.       end;
  9143.     end;
  9144.   end;
  9145.  
  9146.   procedure LoadTexture_RGBToRGB;
  9147.   var
  9148.     ddsd: TDDSurfaceDesc2;
  9149.     x, y: Integer;
  9150.     c, cA: DWORD;
  9151.     dest_red_fmt, dest_green_fmt, dest_blue_fmt, dest_alpha_fmt: TDXTextureImageChannel;
  9152.   begin
  9153.     ddsd.dwSize := SizeOf(ddsd);
  9154.     if Dest.Lock(nil, ddsd, DDLOCK_WAIT, 0) = 0 then
  9155.     begin
  9156.       try
  9157.         dest_red_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRBitMask, False);
  9158.         dest_green_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwGBitMask, False);
  9159.         dest_blue_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwBBitMask, False);
  9160.         dest_alpha_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRGBAlphaBitMask, False);
  9161.  
  9162.         if (dest_red_fmt.Mask = SrcImage.rgb_red.Mask) and (dest_green_fmt.Mask = SrcImage.rgb_green.Mask) and
  9163.           (dest_blue_fmt.Mask = SrcImage.rgb_blue.Mask) and (dest_alpha_fmt.Mask = SrcImage.rgb_alpha.Mask) and
  9164.           (Integer(ddsd.ddpfPixelFormat.dwRGBBitCount) = SrcImage.BitCount) and (not SrcImage.PackedPixelOrder)
  9165.         then
  9166.         begin
  9167.           for y := 0 to ddsd.dwHeight - 1 do
  9168.             Move(SrcImage.ScanLine[y]^, Pointer(Integer(ddsd.lpSurface) + ddsd.lPitch * y)^, (Integer(ddsd.dwWidth) * SrcImage.BitCount + 7) div 8);
  9169.         end
  9170.         else
  9171.           if SrcImage.rgb_alpha.mask <> 0 then
  9172.           begin
  9173.             for y := 0 to ddsd.dwHeight - 1 do
  9174.               for x := 0 to ddsd.dwWidth - 1 do
  9175.               begin
  9176.                 c := SrcImage.Pixels[x, y];
  9177.  
  9178.                 c := dxtEncodeChannel(dest_red_fmt, dxtDecodeChannel(SrcImage.rgb_red, c)) or
  9179.                   dxtEncodeChannel(dest_green_fmt, dxtDecodeChannel(SrcImage.rgb_green, c)) or
  9180.                   dxtEncodeChannel(dest_blue_fmt, dxtDecodeChannel(SrcImage.rgb_blue, c)) or
  9181.                   dxtEncodeChannel(dest_alpha_fmt, dxtDecodeChannel(SrcImage.rgb_alpha, c));
  9182.  
  9183.                 SetPixel(ddsd, x, y, c);
  9184.               end;
  9185.           end
  9186.           else
  9187.           begin
  9188.             cA := dxtEncodeChannel(dest_alpha_fmt, 255);
  9189.  
  9190.             for y := 0 to ddsd.dwHeight - 1 do
  9191.               for x := 0 to ddsd.dwWidth - 1 do
  9192.               begin
  9193.                 c := SrcImage.Pixels[x, y];
  9194.  
  9195.                 c := dxtEncodeChannel(dest_red_fmt, dxtDecodeChannel(SrcImage.rgb_red, c)) or
  9196.                   dxtEncodeChannel(dest_green_fmt, dxtDecodeChannel(SrcImage.rgb_green, c)) or
  9197.                   dxtEncodeChannel(dest_blue_fmt, dxtDecodeChannel(SrcImage.rgb_blue, c)) or cA;
  9198.  
  9199.                 SetPixel(ddsd, x, y, c);
  9200.               end;
  9201.           end;
  9202.       finally
  9203.         Dest.UnLock(ddsd.lpSurface);
  9204.       end;
  9205.     end;
  9206.   end;
  9207.  
  9208. var
  9209.   SurfaceDesc: TDDSurfaceDesc2;
  9210. begin
  9211.   SurfaceDesc.dwSize := SizeOf(SurfaceDesc);
  9212.   Dest.GetSurfaceDesc(SurfaceDesc);
  9213.  
  9214.   if SurfaceDesc.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED <> 0 then
  9215.   begin
  9216.     case SrcImage.ImageType of
  9217.       DXTextureImageType_PaletteIndexedColor: LoadTexture_IndexToIndex;
  9218.       DXTextureImageType_RGBColor: ;
  9219.     end;
  9220.   end else if SurfaceDesc.ddpfPixelFormat.dwFlags and DDPF_RGB <> 0 then
  9221.   begin
  9222.     case SrcImage.ImageType of
  9223.       DXTextureImageType_PaletteIndexedColor: LoadTexture_IndexToRGB;
  9224.       DXTextureImageType_RGBColor: LoadTexture_RGBToRGB;
  9225.     end;
  9226.   end;
  9227. end;
  9228.  
  9229. { Support function }
  9230.  
  9231. function GetWidthBytes(Width, BitCount: Integer): Integer;
  9232. begin
  9233.   Result := (((Width * BitCount) + 31) div 32) * 4;
  9234. end;
  9235.  
  9236. function dxtEncodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
  9237. begin
  9238.   Result := ((c shl Channel._rshift) shr Channel._lshift) and Channel.Mask;
  9239. end;
  9240.  
  9241. function dxtDecodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
  9242. begin
  9243.   Result := ((c and Channel.Mask) shr Channel._rshift) shl Channel._lshift;
  9244.   Result := Result or (Result shr Channel._BitCount2);
  9245. end;
  9246.  
  9247. function dxtMakeChannel(Mask: DWORD; indexed: Boolean): TDXTextureImageChannel;
  9248.  
  9249.   function GetMaskBitCount(b: Integer): Integer;
  9250.   var
  9251.     i: Integer;
  9252.   begin
  9253.     i := 0;
  9254.     while (i < 31) and (((1 shl i) and b) = 0) do Inc(i);
  9255.  
  9256.     Result := 0;
  9257.     while ((1 shl i) and b) <> 0 do
  9258.     begin
  9259.       Inc(i);
  9260.       Inc(Result);
  9261.     end;
  9262.   end;
  9263.  
  9264.   function GetBitCount2(b: Integer): Integer;
  9265.   begin
  9266.     Result := 0;
  9267.     while (Result < 31) and (((1 shl Result) and b) = 0) do Inc(Result);
  9268.   end;
  9269.  
  9270. begin
  9271.   Result.BitCount := GetMaskBitCount(Mask);
  9272.   Result.Mask := Mask;
  9273.  
  9274.   if indexed then
  9275.   begin
  9276.     Result._rshift := GetBitCount2(Mask);
  9277.     Result._lshift := 0;
  9278.     Result._Mask2 := 1 shl Result.BitCount - 1;
  9279.     Result._BitCount2 := 0;
  9280.   end
  9281.   else
  9282.   begin
  9283.     Result._rshift := GetBitCount2(Mask) - (8 - Result.BitCount);
  9284.     if Result._rshift < 0 then
  9285.     begin
  9286.       Result._lshift := -Result._rshift;
  9287.       Result._rshift := 0;
  9288.     end
  9289.     else
  9290.       Result._lshift := 0;
  9291.     Result._Mask2 := (1 shl Result.BitCount - 1) shl (8 - Result.BitCount);
  9292.     Result._BitCount2 := 8 - Result.BitCount;
  9293.   end;
  9294. end;
  9295.  
  9296. {  TDXTextureImage  }
  9297.  
  9298. var
  9299.   _DXTextureImageLoadFuncList: TList;
  9300.  
  9301. procedure DXTextureImage_LoadDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage); forward;
  9302. procedure DXTextureImage_LoadBitmapFunc(Stream: TStream; Image: TDXTextureImage); forward;
  9303.  
  9304. function DXTextureImageLoadFuncList: TList;
  9305. begin
  9306.   if _DXTextureImageLoadFuncList = nil then
  9307.   begin
  9308.     _DXTextureImageLoadFuncList := TList.Create;
  9309.     _DXTextureImageLoadFuncList.Add(@DXTextureImage_LoadDXTextureImageFunc);
  9310.     _DXTextureImageLoadFuncList.Add(@DXTextureImage_LoadBitmapFunc);
  9311.   end;
  9312.   Result := _DXTextureImageLoadFuncList;
  9313. end;
  9314.  
  9315. class procedure TDXTextureImage.RegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
  9316. begin
  9317.   if DXTextureImageLoadFuncList.IndexOf(@LoadFunc) = -1 then
  9318.     DXTextureImageLoadFuncList.Add(@LoadFunc);
  9319. end;
  9320.  
  9321. class procedure TDXTextureImage.UnRegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
  9322. begin
  9323.   DXTextureImageLoadFuncList.Remove(@LoadFunc);
  9324. end;
  9325.  
  9326. constructor TDXTextureImage.Create;
  9327. begin
  9328.   inherited Create;
  9329.   FSubImage := TList.Create;
  9330. end;
  9331.  
  9332. constructor TDXTextureImage.CreateSub(AOwner: TDXTextureImage);
  9333. begin
  9334.   Create;
  9335.  
  9336.   FOwner := AOwner;
  9337.   try
  9338.     FOwner.FSubImage.Add(Self);
  9339.   except
  9340.     FOwner := nil;
  9341.     raise;
  9342.   end;
  9343. end;
  9344.  
  9345. destructor TDXTextureImage.Destroy;
  9346. begin
  9347.   Clear;
  9348.   FSubImage.Free;
  9349.   if FOwner <> nil then
  9350.     FOwner.FSubImage.Remove(Self);
  9351.   inherited Destroy;
  9352. end;
  9353.  
  9354. procedure TDXTextureImage.DoSaveProgress(Progress, ProgressCount: Integer);
  9355. begin
  9356.   if Assigned(FOnSaveProgress) then
  9357.     FOnSaveProgress(Self, Progress, ProgressCount);
  9358. end;
  9359.  
  9360. procedure TDXTextureImage.Assign(Source: TDXTextureImage);
  9361. var
  9362.   y: Integer;
  9363. begin
  9364.   SetSize(Source.ImageType, Source.Width, Source.Height, Source.BitCount, Source.WidthBytes);
  9365.  
  9366.   idx_index := Source.idx_index;
  9367.   idx_alpha := Source.idx_alpha;
  9368.   idx_palette := Source.idx_palette;
  9369.  
  9370.   rgb_red := Source.rgb_red;
  9371.   rgb_green := Source.rgb_green;
  9372.   rgb_blue := Source.rgb_blue;
  9373.   rgb_alpha := Source.rgb_alpha;
  9374.  
  9375.   for y := 0 to Height - 1 do
  9376.     Move(Source.ScanLine[y]^, ScanLine[y]^, WidthBytes);
  9377.  
  9378.   Transparent := Source.Transparent;
  9379.   TransparentColor := Source.TransparentColor;
  9380.   ImageGroupType := Source.ImageGroupType;
  9381.   ImageID := Source.ImageID;
  9382.   ImageName := Source.ImageName;
  9383. end;
  9384.  
  9385. procedure TDXTextureImage.ClearImage;
  9386. begin
  9387.   if FAutoFreeImage then
  9388.     FreeMem(FPBits);
  9389.  
  9390.   FImageType := DXTextureImageType_PaletteIndexedColor;
  9391.   FWidth := 0;
  9392.   FHeight := 0;
  9393.   FBitCount := 0;
  9394.   FWidthBytes := 0;
  9395.   FNextLine := 0;
  9396.   FSize := 0;
  9397.   FPBits := nil;
  9398.   FTopPBits := nil;
  9399.   FAutoFreeImage := False;
  9400. end;
  9401.  
  9402. procedure TDXTextureImage.Clear;
  9403. begin
  9404.   ClearImage;
  9405.  
  9406.   while SubImageCount > 0 do
  9407.     SubImages[SubImageCount - 1].Free;
  9408.  
  9409.   FImageGroupType := 0;
  9410.   FImageID := 0;
  9411.   FImageName := '';
  9412.  
  9413.   FTransparent := False;
  9414.   FTransparentColor := 0;
  9415.  
  9416.   FillChar(idx_index, SizeOf(idx_index), 0);
  9417.   FillChar(idx_alpha, SizeOf(idx_alpha), 0);
  9418.   FillChar(idx_palette, SizeOf(idx_palette), 0);
  9419.   FillChar(rgb_red, SizeOf(rgb_red), 0);
  9420.   FillChar(rgb_green, SizeOf(rgb_green), 0);
  9421.   FillChar(rgb_blue, SizeOf(rgb_blue), 0);
  9422.   FillChar(rgb_alpha, SizeOf(rgb_alpha), 0);
  9423. end;
  9424.  
  9425. procedure TDXTextureImage.SetImage(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes, NextLine: Integer;
  9426.   PBits, TopPBits: Pointer; Size: Integer; AutoFree: Boolean);
  9427. begin
  9428.   ClearImage;
  9429.  
  9430.   FAutoFreeImage := AutoFree;
  9431.   FImageType := ImageType;
  9432.   FWidth := Width;
  9433.   FHeight := Height;
  9434.   FBitCount := BitCount;
  9435.   FWidthBytes := WidthBytes;
  9436.   FNextLine := NextLine;
  9437.   FSize := Size;
  9438.   FPBits := PBits;
  9439.   FTopPBits := TopPBits;
  9440. end;
  9441.  
  9442. procedure TDXTextureImage.SetSize(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes: Integer);
  9443. var
  9444.   APBits: Pointer;
  9445. begin
  9446.   ClearImage;
  9447.  
  9448.   if WidthBytes = 0 then
  9449.     WidthBytes := GetWidthBytes(Width, BitCount);
  9450.  
  9451.   GetMem(APBits, WidthBytes * Height);
  9452.   SetImage(ImageType, Width, Height, BitCount, WidthBytes,
  9453.     WidthBytes, APBits, APBits, WidthBytes * Height, True);
  9454. end;
  9455.  
  9456. function TDXTextureImage.GetScanLine(y: Integer): Pointer;
  9457. begin
  9458.   Result := Pointer(Integer(FTopPBits) + FNextLine * y);
  9459. end;
  9460.  
  9461. function TDXTextureImage.GetSubGroupImageCount(GroupTypeID: DWORD): Integer;
  9462. var
  9463.   i: Integer;
  9464. begin
  9465.   Result := 0;
  9466.   for i := 0 to SubImageCount - 1 do
  9467.     if SubImages[i].ImageGroupType = GroupTypeID then
  9468.       Inc(Result);
  9469. end;
  9470.  
  9471. function TDXTextureImage.GetSubGroupImage(GroupTypeID: DWORD; Index: Integer): TDXTextureImage;
  9472. var
  9473.   i, j: Integer;
  9474. begin
  9475.   j := 0;
  9476.   for i := 0 to SubImageCount - 1 do
  9477.     if SubImages[i].ImageGroupType = GroupTypeID then
  9478.     begin
  9479.       if j = Index then
  9480.       begin
  9481.         Result := SubImages[i];
  9482.         Exit;
  9483.       end;
  9484.  
  9485.       Inc(j);
  9486.     end;
  9487.  
  9488.   Result := nil;
  9489.   SubImages[-1];
  9490. end;
  9491.  
  9492. function TDXTextureImage.GetSubImageCount: Integer;
  9493. begin
  9494.   Result := 0;
  9495.   if Assigned(FSubImage) then
  9496.     Result := FSubImage.Count;
  9497. end;
  9498.  
  9499. function TDXTextureImage.GetSubImage(Index: Integer): TDXTextureImage;
  9500. begin
  9501.   Result := FSubImage[Index];
  9502. end;
  9503.  
  9504. function TDXTextureImage.EncodeColor(R, G, B, A: Byte): DWORD;
  9505. begin
  9506.   if ImageType = DXTextureImageType_PaletteIndexedColor then
  9507.   begin
  9508.     Result := dxtEncodeChannel(idx_index, PaletteIndex(R, G, B)) or
  9509.       dxtEncodeChannel(idx_alpha, A);
  9510.   end
  9511.   else
  9512.   begin
  9513.     Result := dxtEncodeChannel(rgb_red, R) or
  9514.       dxtEncodeChannel(rgb_green, G) or
  9515.       dxtEncodeChannel(rgb_blue, B) or
  9516.       dxtEncodeChannel(rgb_alpha, A);
  9517.   end;
  9518. end;
  9519.  
  9520. function TDXTextureImage.PaletteIndex(R, G, B: Byte): DWORD;
  9521. var
  9522.   i, d, d2: Integer;
  9523. begin
  9524.   Result := 0;
  9525.   if ImageType = DXTextureImageType_PaletteIndexedColor then
  9526.   begin
  9527.     d := MaxInt;
  9528.     for i := 0 to (1 shl idx_index.BitCount) - 1 do
  9529.       with idx_palette[i] do
  9530.       begin
  9531.         d2 := Abs((peRed - R)) * Abs((peRed - R)) + Abs((peGreen - G)) * Abs((peGreen - G)) + Abs((peBlue - B)) * Abs((peBlue - B));
  9532.         if d > d2 then
  9533.         begin
  9534.           d := d2;
  9535.           Result := i;
  9536.         end;
  9537.       end;
  9538.   end;
  9539. end;
  9540.  
  9541. const
  9542.   Mask1: array[0..7] of DWORD = (1, 2, 4, 8, 16, 32, 64, 128);
  9543.   Mask2: array[0..3] of DWORD = (3, 12, 48, 192);
  9544.   Mask4: array[0..1] of DWORD = ($0F, $F0);
  9545.  
  9546.   Shift1: array[0..7] of DWORD = (0, 1, 2, 3, 4, 5, 6, 7);
  9547.   Shift2: array[0..3] of DWORD = (0, 2, 4, 6);
  9548.   Shift4: array[0..1] of DWORD = (0, 4);
  9549.  
  9550. type
  9551.   PByte3 = ^TByte3;
  9552.   TByte3 = array[0..2] of Byte;
  9553.  
  9554. function TDXTextureImage.GetPixel(x, y: Integer): DWORD;
  9555. begin
  9556.   Result := 0;
  9557.   if (x >= 0) and (x < FWidth) and (y >= 0) and (y < FHeight) then
  9558.   begin
  9559.     case FBitCount of
  9560.       1: begin
  9561.           if FPackedPixelOrder then
  9562.             Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 3)^ and Mask1[7 - x and 7]) shr Shift1[7 - x and 7]
  9563.           else
  9564.             Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7];
  9565.         end;
  9566.       2: begin
  9567.           if FPackedPixelOrder then
  9568.             Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 2)^ and Mask2[3 - x and 3]) shr Shift2[3 - x and 3]
  9569.           else
  9570.             Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 2)^ and Mask2[x and 3]) shr Shift2[x and 3];
  9571.         end;
  9572.       4: begin
  9573.           if FPackedPixelOrder then
  9574.             Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 1)^ and Mask4[1 - x and 1]) shr Shift4[1 - x and 1]
  9575.           else
  9576.             Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1];
  9577.         end;
  9578.       8: Result := PByte(Integer(FTopPBits) + FNextLine * y + x)^;
  9579.       16: Result := PWord(Integer(FTopPBits) + FNextLine * y + x * 2)^;
  9580.       24: PByte3(@Result)^ := PByte3(Integer(FTopPBits) + FNextLine * y + x * 3)^;
  9581.       32: Result := PDWORD(Integer(FTopPBits) + FNextLine * y + x * 4)^;
  9582.     end;
  9583.   end;
  9584. end;
  9585.  
  9586. procedure TDXTextureImage.SetPixel(x, y: Integer; c: DWORD);
  9587. var
  9588.   P: PByte;
  9589. begin
  9590.   if (x >= 0) and (x < FWidth) and (y >= 0) and (y < FHeight) then
  9591.   begin
  9592.     case FBitCount of
  9593.       1: begin
  9594.           P := Pointer(Integer(FTopPBits) + FNextLine * y + x shr 3);
  9595.           if FPackedPixelOrder then
  9596.             P^ := (P^ and (not Mask1[7 - x and 7])) or ((c and 1) shl Shift1[7 - x and 7])
  9597.           else
  9598.             P^ := (P^ and (not Mask1[x and 7])) or ((c and 1) shl Shift1[x and 7]);
  9599.         end;
  9600.       2: begin
  9601.           P := Pointer(Integer(FTopPBits) + FNextLine * y + x shr 2);
  9602.           if FPackedPixelOrder then
  9603.             P^ := (P^ and (not Mask2[3 - x and 3])) or ((c and 3) shl Shift2[3 - x and 3])
  9604.           else
  9605.             P^ := (P^ and (not Mask2[x and 3])) or ((c and 3) shl Shift2[x and 3]);
  9606.         end;
  9607.       4: begin
  9608.           P := Pointer(Integer(FTopPBits) + FNextLine * y + x shr 1);
  9609.           if FPackedPixelOrder then
  9610.             P^ := (P^ and (not Mask4[1 - x and 1])) or ((c and 7) shl Shift4[1 - x and 1])
  9611.           else
  9612.             P^ := (P^ and (not Mask4[x and 1])) or ((c and 7) shl Shift4[x and 1]);
  9613.         end;
  9614.       8: PByte(Integer(FTopPBits) + FNextLine * y + x)^ := c;
  9615.       16: PWord(Integer(FTopPBits) + FNextLine * y + x * 2)^ := c;
  9616.       24: PByte3(Integer(FTopPBits) + FNextLine * y + x * 3)^ := PByte3(@c)^;
  9617.       32: PDWORD(Integer(FTopPBits) + FNextLine * y + x * 4)^ := c;
  9618.     end;
  9619.   end;
  9620. end;
  9621.  
  9622. procedure TDXTextureImage.LoadFromFile(const FileName: string);
  9623. var
  9624.   Stream: TFileStream;
  9625. begin
  9626.   Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  9627.   try
  9628.     LoadFromStream(Stream);
  9629.   finally
  9630.     Stream.Free;
  9631.   end;
  9632. end;
  9633.  
  9634. procedure TDXTextureImage.LoadFromStream(Stream: TStream);
  9635. var
  9636.   i, p: Integer;
  9637. begin
  9638.   Clear;
  9639.  
  9640.   p := Stream.Position;
  9641.   for i := 0 to DXTextureImageLoadFuncList.Count - 1 do
  9642.   begin
  9643.     Stream.Position := p;
  9644.     try
  9645.       TDXTextureImageLoadFunc(DXTextureImageLoadFuncList[i])(Stream, Self);
  9646.       Exit;
  9647.     except
  9648.       Clear;
  9649.     end;
  9650.   end;
  9651.  
  9652.   raise EDXTextureImageError.Create(SNotSupportGraphicFile);
  9653. end;
  9654.  
  9655. procedure TDXTextureImage.SaveToFile(const FileName: string);
  9656. var
  9657.   Stream: TFileStream;
  9658. begin
  9659.   Stream := TFileStream.Create(FileName, fmCreate);
  9660.   try
  9661.     SaveToStream(Stream);
  9662.   finally
  9663.     Stream.Free;
  9664.   end;
  9665. end;
  9666.  
  9667. procedure DXTextureImage_SaveDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage); forward;
  9668.  
  9669. procedure TDXTextureImage.SaveToStream(Stream: TStream);
  9670. begin
  9671.   DXTextureImage_SaveDXTextureImageFunc(Stream, Self);
  9672. end;
  9673.  
  9674. {  DXTextureImage_LoadDXTextureImageFunc  }
  9675.  
  9676. const
  9677.   DXTextureImageFile_Type = 'dxt:';
  9678.   DXTextureImageFile_Version = $100;
  9679.  
  9680.   DXTextureImageCompress_None = 0;
  9681.   DXTextureImageCompress_ZLIB = 1; // ZLIB enabled
  9682.  
  9683.   DXTextureImageFileCategoryType_Image = $100;
  9684.  
  9685.   DXTextureImageFileBlockID_EndFile = 0;
  9686.   DXTextureImageFileBlockID_EndGroup = 1;
  9687.   DXTextureImageFileBlockID_StartGroup = 2;
  9688.   DXTextureImageFileBlockID_Image_Format = DXTextureImageFileCategoryType_Image + 1;
  9689.   DXTextureImageFileBlockID_Image_PixelData = DXTextureImageFileCategoryType_Image + 2;
  9690.   DXTextureImageFileBlockID_Image_GroupInfo = DXTextureImageFileCategoryType_Image + 3;
  9691.   DXTextureImageFileBlockID_Image_Name = DXTextureImageFileCategoryType_Image + 4;
  9692.   DXTextureImageFileBlockID_Image_TransparentColor = DXTextureImageFileCategoryType_Image + 5;
  9693.  
  9694. type
  9695.   TDXTextureImageFileHeader = packed record
  9696.     FileType: array[0..4] of Char;
  9697.     ver: DWORD;
  9698.   end;
  9699.  
  9700.   TDXTextureImageFileBlockHeader = packed record
  9701.     ID: DWORD;
  9702.     Size: Integer;
  9703.   end;
  9704.  
  9705.   TDXTextureImageFileBlockHeader_StartGroup = packed record
  9706.     CategoryType: DWORD;
  9707.   end;
  9708.  
  9709.   TDXTextureImageHeader_Image_Format = packed record
  9710.     ImageType: TDXTextureImageType;
  9711.     Width: DWORD;
  9712.     Height: DWORD;
  9713.     BitCount: DWORD;
  9714.     WidthBytes: DWORD;
  9715.   end;
  9716.  
  9717.   TDXTextureImageHeader_Image_Format_Index = packed record
  9718.     idx_index_Mask: DWORD;
  9719.     idx_alpha_Mask: DWORD;
  9720.     idx_palette: array[0..255] of TPaletteEntry;
  9721.   end;
  9722.  
  9723.   TDXTextureImageHeader_Image_Format_RGB = packed record
  9724.     rgb_red_Mask: DWORD;
  9725.     rgb_green_Mask: DWORD;
  9726.     rgb_blue_Mask: DWORD;
  9727.     rgb_alpha_Mask: DWORD;
  9728.   end;
  9729.  
  9730.   TDXTextureImageHeader_Image_GroupInfo = packed record
  9731.     ImageGroupType: DWORD;
  9732.     ImageID: DWORD;
  9733.   end;
  9734.  
  9735.   TDXTextureImageHeader_Image_PixelData = packed record
  9736.     Compress: DWORD;
  9737.   end;
  9738.  
  9739.   TDXTextureImageHeader_Image_TransparentColor = packed record
  9740.     Transparent: Boolean;
  9741.     TransparentColor: DWORD;
  9742.   end;
  9743.  
  9744. procedure DXTextureImage_LoadDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage);
  9745.  
  9746.   procedure ReadGroup_Image(Image: TDXTextureImage);
  9747.   var
  9748.     i: Integer;
  9749.     BlockHeader: TDXTextureImageFileBlockHeader;
  9750.     NextPos: Integer;
  9751.     SubImage: TDXTextureImage;
  9752.     Header_StartGroup: TDXTextureImageFileBlockHeader_StartGroup;
  9753.     Header_Image_Format: TDXTextureImageHeader_Image_Format;
  9754.     Header_Image_Format_Index: TDXTextureImageHeader_Image_Format_Index;
  9755.     Header_Image_Format_RGB: TDXTextureImageHeader_Image_Format_RGB;
  9756.     Header_Image_GroupInfo: TDXTextureImageHeader_Image_GroupInfo;
  9757.     Header_Image_TransparentColor: TDXTextureImageHeader_Image_TransparentColor;
  9758.     Header_Image_PixelData: TDXTextureImageHeader_Image_PixelData;
  9759.     ImageName: string;
  9760.     {$IFDEF DXTextureImage_UseZLIB}
  9761.     Decompression: TDecompressionStream;
  9762.     {$ENDIF}
  9763.   begin
  9764.     while True do
  9765.     begin
  9766.       Stream.ReadBuffer(BlockHeader, SizeOf(BlockHeader));
  9767.       NextPos := Stream.Position + BlockHeader.Size;
  9768.  
  9769.       case BlockHeader.ID of
  9770.         DXTextureImageFileBlockID_EndGroup:
  9771.           begin
  9772.             {  End of group  }
  9773.             Break;
  9774.           end;
  9775.         DXTextureImageFileBlockID_StartGroup:
  9776.           begin
  9777.             {  Beginning of group  }
  9778.             Stream.ReadBuffer(Header_StartGroup, SizeOf(Header_StartGroup));
  9779.             case Header_StartGroup.CategoryType of
  9780.               DXTextureImageFileCategoryType_Image:
  9781.                 begin
  9782.                   {  Image group  }
  9783.                   SubImage := TDXTextureImage.CreateSub(Image);
  9784.                   try
  9785.                     ReadGroup_Image(SubImage);
  9786.                   except
  9787.                     SubImage.Free;
  9788.                     raise;
  9789.                   end;
  9790.                 end;
  9791.             end;
  9792.           end;
  9793.         DXTextureImageFileBlockID_Image_Format:
  9794.           begin
  9795.             {  Image information reading (size etc.)  }
  9796.             Stream.ReadBuffer(Header_Image_Format, SizeOf(Header_Image_Format));
  9797.  
  9798.             if (Header_Image_Format.ImageType <> DXTextureImageType_PaletteIndexedColor) and
  9799.               (Header_Image_Format.ImageType <> DXTextureImageType_RGBColor)
  9800.             then
  9801.               raise EDXTextureImageError.Create(SInvalidDXTFile);
  9802.  
  9803.             Image.SetSize(Header_Image_Format.ImageType, Header_Image_Format.Width, Header_Image_Format.Height,
  9804.               Header_Image_Format.BitCount, Header_Image_Format.Widthbytes);
  9805.  
  9806.             if Header_Image_Format.ImageType = DXTextureImageType_PaletteIndexedColor then
  9807.             begin
  9808.               {  INDEX IMAGE  }
  9809.               Stream.ReadBuffer(Header_Image_Format_Index, SizeOf(Header_Image_Format_Index));
  9810.  
  9811.               Image.idx_index := dxtMakeChannel(Header_Image_Format_Index.idx_index_Mask, True);
  9812.               Image.idx_alpha := dxtMakeChannel(Header_Image_Format_Index.idx_alpha_Mask, False);
  9813.  
  9814.               for i := 0 to 255 do
  9815.                 Image.idx_palette[i] := Header_Image_Format_Index.idx_palette[i];
  9816.             end
  9817.             else
  9818.             if Header_Image_Format.ImageType = DXTextureImageType_RGBColor then
  9819.             begin
  9820.               {  RGB IMAGE  }
  9821.               Stream.ReadBuffer(Header_Image_Format_RGB, SizeOf(Header_Image_Format_RGB));
  9822.  
  9823.               Image.rgb_red := dxtMakeChannel(Header_Image_Format_RGB.rgb_red_Mask, False);
  9824.               Image.rgb_green := dxtMakeChannel(Header_Image_Format_RGB.rgb_green_Mask, False);
  9825.               Image.rgb_blue := dxtMakeChannel(Header_Image_Format_RGB.rgb_blue_Mask, False);
  9826.               Image.rgb_alpha := dxtMakeChannel(Header_Image_Format_RGB.rgb_alpha_Mask, False);
  9827.             end;
  9828.           end;
  9829.         DXTextureImageFileBlockID_Image_Name:
  9830.           begin
  9831.             {  Name reading  }
  9832.             SetLength(ImageName, BlockHeader.Size);
  9833.             Stream.ReadBuffer(ImageName[1], BlockHeader.Size);
  9834.  
  9835.             Image.ImageName := ImageName;
  9836.           end;
  9837.         DXTextureImageFileBlockID_Image_GroupInfo:
  9838.           begin
  9839.             {  Image group information reading  }
  9840.             Stream.ReadBuffer(Header_Image_GroupInfo, SizeOf(Header_Image_GroupInfo));
  9841.  
  9842.             Image.ImageGroupType := Header_Image_GroupInfo.ImageGroupType;
  9843.             Image.ImageID := Header_Image_GroupInfo.ImageID;
  9844.           end;
  9845.         DXTextureImageFileBlockID_Image_TransparentColor:
  9846.           begin
  9847.             {  Transparent color information reading  }
  9848.             Stream.ReadBuffer(Header_Image_TransparentColor, SizeOf(Header_Image_TransparentColor));
  9849.  
  9850.             Image.Transparent := Header_Image_TransparentColor.Transparent;
  9851.             Image.TransparentColor := Header_Image_TransparentColor.TransparentColor;
  9852.           end;
  9853.         DXTextureImageFileBlockID_Image_PixelData:
  9854.           begin
  9855.             {  Pixel data reading  }
  9856.             Stream.ReadBuffer(Header_Image_PixelData, SizeOf(Header_Image_PixelData));
  9857.  
  9858.             case Header_Image_PixelData.Compress of
  9859.               DXTextureImageCompress_None:
  9860.                 begin
  9861.                    {  NO compress  }
  9862.                   for i := 0 to Image.Height - 1 do
  9863.                     Stream.ReadBuffer(Image.ScanLine[i]^, Header_Image_Format.Widthbytes);
  9864.                 end;
  9865.               {$IFDEF DXTextureImage_UseZLIB}
  9866.               DXTextureImageCompress_ZLIB:
  9867.                 begin
  9868.                    {  ZLIB compress enabled  }
  9869.                   Decompression := TDecompressionStream.Create(Stream);
  9870.                   try
  9871.                     for i := 0 to Image.Height - 1 do
  9872.                       Decompression.ReadBuffer(Image.ScanLine[i]^, Header_Image_Format.Widthbytes);
  9873.                   finally
  9874.                     Decompression.Free;
  9875.                   end;
  9876.                 end;
  9877.               {$ENDIF}
  9878.             else
  9879.               raise EDXTextureImageError.CreateFmt('Decompression error (%d)', [Header_Image_PixelData.Compress]);
  9880.             end;
  9881.           end;
  9882.  
  9883.       end;
  9884.  
  9885.       Stream.Seek(NextPos, soFromBeginning);
  9886.     end;
  9887.   end;
  9888.  
  9889. var
  9890.   FileHeader: TDXTextureImageFileHeader;
  9891.   BlockHeader: TDXTextureImageFileBlockHeader;
  9892.   Header_StartGroup: TDXTextureImageFileBlockHeader_StartGroup;
  9893.   NextPos: Integer;
  9894. begin
  9895.   {  File header reading  }
  9896.   Stream.ReadBuffer(FileHeader, SizeOf(FileHeader));
  9897.  
  9898.   if FileHeader.FileType <> DXTextureImageFile_Type then
  9899.     raise EDXTextureImageError.Create(SInvalidDXTFile);
  9900.   if FileHeader.ver <> DXTextureImageFile_Version then
  9901.     raise EDXTextureImageError.Create(SInvalidDXTFile);
  9902.  
  9903.   while True do
  9904.   begin
  9905.     Stream.ReadBuffer(BlockHeader, SizeOf(BlockHeader));
  9906.     NextPos := Stream.Position + BlockHeader.Size;
  9907.  
  9908.     case BlockHeader.ID of
  9909.       DXTextureImageFileBlockID_EndFile:
  9910.         begin
  9911.           {  End of file  }
  9912.           Break;
  9913.         end;
  9914.       DXTextureImageFileBlockID_StartGroup:
  9915.         begin
  9916.           {  Beginning of group  }
  9917.           Stream.ReadBuffer(Header_StartGroup, SizeOf(Header_StartGroup));
  9918.           case Header_StartGroup.CategoryType of
  9919.             DXTextureImageFileCategoryType_Image: ReadGroup_Image(Image);
  9920.           end;
  9921.         end;
  9922.     end;
  9923.  
  9924.     Stream.Seek(NextPos, soFromBeginning);
  9925.   end;
  9926. end;
  9927.  
  9928. type
  9929.   PDXTextureImageFileBlockHeaderWriter_BlockInfo = ^TDXTextureImageFileBlockHeaderWriter_BlockInfo;
  9930.   TDXTextureImageFileBlockHeaderWriter_BlockInfo = record
  9931.     BlockID: DWORD;
  9932.     StreamPos: Integer;
  9933.   end;
  9934.  
  9935.   TDXTextureImageFileBlockHeaderWriter = class
  9936.   private
  9937.     FStream: TStream;
  9938.     FList: TList;
  9939.   public
  9940.     constructor Create(Stream: TStream);
  9941.     destructor Destroy; override;
  9942.     procedure StartBlock(BlockID: DWORD);
  9943.     procedure EndBlock;
  9944.     procedure WriteBlock(BlockID: DWORD);
  9945.     procedure StartGroup(CategoryType: DWORD);
  9946.     procedure EndGroup;
  9947.   end;
  9948.  
  9949. constructor TDXTextureImageFileBlockHeaderWriter.Create(Stream: TStream);
  9950. begin
  9951.   inherited Create;
  9952.   FStream := Stream;
  9953.   FList := TList.Create;
  9954. end;
  9955.  
  9956. destructor TDXTextureImageFileBlockHeaderWriter.Destroy;
  9957. var
  9958.   i: Integer;
  9959. begin
  9960.   for i := 0 to FList.Count - 1 do
  9961.     Dispose(PDXTextureImageFileBlockHeaderWriter_BlockInfo(FList[i]));
  9962.   FList.Free;
  9963.   inherited Destroy;
  9964. end;
  9965.  
  9966. procedure TDXTextureImageFileBlockHeaderWriter.StartBlock(BlockID: DWORD);
  9967. var
  9968.   BlockInfo: PDXTextureImageFileBlockHeaderWriter_BlockInfo;
  9969.   BlockHeader: TDXTextureImageFileBlockHeader;
  9970. begin
  9971.   New(BlockInfo);
  9972.   BlockInfo.BlockID := BlockID;
  9973.   BlockInfo.StreamPos := FStream.Position;
  9974.   FList.Add(BlockInfo);
  9975.  
  9976.   BlockHeader.ID := BlockID;
  9977.   BlockHeader.Size := 0;
  9978.   FStream.WriteBuffer(BlockHeader, SizeOf(BlockHeader));
  9979. end;
  9980.  
  9981. procedure TDXTextureImageFileBlockHeaderWriter.EndBlock;
  9982. var
  9983.   BlockHeader: TDXTextureImageFileBlockHeader;
  9984.   BlockInfo: PDXTextureImageFileBlockHeaderWriter_BlockInfo;
  9985.   CurStreamPos: Integer;
  9986. begin
  9987.   CurStreamPos := FStream.Position;
  9988.   try
  9989.     BlockInfo := FList[FList.Count - 1];
  9990.  
  9991.     FStream.Position := BlockInfo.StreamPos;
  9992.     BlockHeader.ID := BlockInfo.BlockID;
  9993.     BlockHeader.Size := CurStreamPos - (BlockInfo.StreamPos + SizeOf(TDXTextureImageFileBlockHeader));
  9994.     FStream.WriteBuffer(BlockHeader, SizeOf(BlockHeader));
  9995.   finally
  9996.     FStream.Position := CurStreamPos;
  9997.  
  9998.     Dispose(FList[FList.Count - 1]);
  9999.     FList.Count := FList.Count - 1;
  10000.   end;
  10001. end;
  10002.  
  10003. procedure TDXTextureImageFileBlockHeaderWriter.WriteBlock(BlockID: DWORD);
  10004. var
  10005.   BlockHeader: TDXTextureImageFileBlockHeader;
  10006. begin
  10007.   BlockHeader.ID := BlockID;
  10008.   BlockHeader.Size := 0;
  10009.   FStream.WriteBuffer(BlockHeader, SizeOf(BlockHeader));
  10010. end;
  10011.  
  10012. procedure TDXTextureImageFileBlockHeaderWriter.StartGroup(CategoryType: DWORD);
  10013. var
  10014.   Header_StartGroup: TDXTextureImageFileBlockHeader_StartGroup;
  10015. begin
  10016.   StartBlock(DXTextureImageFileBlockID_StartGroup);
  10017.  
  10018.   Header_StartGroup.CategoryType := CategoryType;
  10019.   FStream.WriteBuffer(Header_StartGroup, SizeOf(Header_StartGroup));
  10020. end;
  10021.  
  10022. procedure TDXTextureImageFileBlockHeaderWriter.EndGroup;
  10023. begin
  10024.   WriteBlock(DXTextureImageFileBlockID_EndGroup);
  10025.   EndBlock;
  10026. end;
  10027.  
  10028. procedure DXTextureImage_SaveDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage);
  10029. var
  10030.   Progress: Integer;
  10031.   ProgressCount: Integer;
  10032.   BlockHeaderWriter: TDXTextureImageFileBlockHeaderWriter;
  10033.  
  10034.   function CalcProgressCount(Image: TDXTextureImage): Integer;
  10035.   var
  10036.     i: Integer;
  10037.   begin
  10038.     Result := Image.WidthBytes * Image.Height;
  10039.     for i := 0 to Image.SubImageCount - 1 do
  10040.       Inc(Result, CalcProgressCount(Image.SubImages[i]));
  10041.   end;
  10042.  
  10043.   procedure AddProgress(Count: Integer);
  10044.   begin
  10045.     Inc(Progress, Count);
  10046.     Image.DoSaveProgress(Progress, ProgressCount);
  10047.   end;
  10048.  
  10049.   procedure WriteGroup_Image(Image: TDXTextureImage);
  10050.   var
  10051.     i: Integer;
  10052.     Header_Image_Format: TDXTextureImageHeader_Image_Format;
  10053.     Header_Image_Format_Index: TDXTextureImageHeader_Image_Format_Index;
  10054.     Header_Image_Format_RGB: TDXTextureImageHeader_Image_Format_RGB;
  10055.     Header_Image_GroupInfo: TDXTextureImageHeader_Image_GroupInfo;
  10056.     Header_Image_TransparentColor: TDXTextureImageHeader_Image_TransparentColor;
  10057.     Header_Image_PixelData: TDXTextureImageHeader_Image_PixelData;
  10058.   {$IFDEF DXTextureImage_UseZLIB}
  10059.     Compression: TCompressionStream;
  10060.   {$ENDIF}
  10061.   begin
  10062.     BlockHeaderWriter.StartGroup(DXTextureImageFileCategoryType_Image);
  10063.     try
  10064.       {  Image format writing  }
  10065.       if Image.Size > 0 then
  10066.       begin
  10067.         Header_Image_Format.ImageType := Image.ImageType;
  10068.         Header_Image_Format.Width := Image.Width;
  10069.         Header_Image_Format.Height := Image.Height;
  10070.         Header_Image_Format.BitCount := Image.BitCount;
  10071.         Header_Image_Format.WidthBytes := Image.WidthBytes;
  10072.  
  10073.         BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_Format);
  10074.         try
  10075.           Stream.WriteBuffer(Header_Image_Format, SizeOf(Header_Image_Format));
  10076.  
  10077.           case Image.ImageType of
  10078.             DXTextureImageType_PaletteIndexedColor:
  10079.               begin
  10080.                 {  INDEX IMAGE  }
  10081.                 Header_Image_Format_Index.idx_index_Mask := Image.idx_index.Mask;
  10082.                 Header_Image_Format_Index.idx_alpha_Mask := Image.idx_alpha.Mask;
  10083.                 for i := 0 to 255 do
  10084.                   Header_Image_Format_Index.idx_palette[i] := Image.idx_palette[i];
  10085.  
  10086.                 Stream.WriteBuffer(Header_Image_Format_Index, SizeOf(Header_Image_Format_Index));
  10087.               end;
  10088.             DXTextureImageType_RGBColor:
  10089.               begin
  10090.                 {  RGB IMAGE  }
  10091.                 Header_Image_Format_RGB.rgb_red_Mask := Image.rgb_red.Mask;
  10092.                 Header_Image_Format_RGB.rgb_green_Mask := Image.rgb_green.Mask;
  10093.                 Header_Image_Format_RGB.rgb_blue_Mask := Image.rgb_blue.Mask;
  10094.                 Header_Image_Format_RGB.rgb_alpha_Mask := Image.rgb_alpha.Mask;
  10095.  
  10096.                 Stream.WriteBuffer(Header_Image_Format_RGB, SizeOf(Header_Image_Format_RGB));
  10097.               end;
  10098.           end;
  10099.         finally
  10100.           BlockHeaderWriter.EndBlock;
  10101.         end;
  10102.       end;
  10103.  
  10104.       {  Image group information writing  }
  10105.       BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_GroupInfo);
  10106.       try
  10107.         Header_Image_GroupInfo.ImageGroupType := Image.ImageGroupType;
  10108.         Header_Image_GroupInfo.ImageID := Image.ImageID;
  10109.  
  10110.         Stream.WriteBuffer(Header_Image_GroupInfo, SizeOf(Header_Image_GroupInfo));
  10111.       finally
  10112.         BlockHeaderWriter.EndBlock;
  10113.       end;
  10114.  
  10115.       {  Name writing  }
  10116.       BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_Name);
  10117.       try
  10118.         Stream.WriteBuffer(Image.ImageName[1], Length(Image.ImageName));
  10119.       finally
  10120.         BlockHeaderWriter.EndBlock;
  10121.       end;
  10122.  
  10123.       {  Transparent color writing  }
  10124.       BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_TransparentColor);
  10125.       try
  10126.         Header_Image_TransparentColor.Transparent := Image.Transparent;
  10127.         Header_Image_TransparentColor.TransparentColor := Image.TransparentColor;
  10128.  
  10129.         Stream.WriteBuffer(Header_Image_TransparentColor, SizeOf(Header_Image_TransparentColor));
  10130.       finally
  10131.         BlockHeaderWriter.EndBlock;
  10132.       end;
  10133.  
  10134.       {  Pixel data writing  }
  10135.       if Image.Size > 0 then
  10136.       begin
  10137.         {  Writing start  }
  10138.         BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_PixelData);
  10139.         try
  10140.           {  Scan compress type  }
  10141.           case Image.FileCompressType of
  10142.             DXTextureImageFileCompressType_None:
  10143.               begin
  10144.                 Header_Image_PixelData.Compress := DXTextureImageCompress_None;
  10145.               end;
  10146.             {$IFDEF DXTextureImage_UseZLIB}
  10147.             DXTextureImageFileCompressType_ZLIB:
  10148.               begin
  10149.                 Header_Image_PixelData.Compress := DXTextureImageCompress_ZLIB;
  10150.               end;
  10151.             {$ENDIF}
  10152.           else
  10153.             Header_Image_PixelData.Compress := DXTextureImageCompress_None;
  10154.           end;
  10155.  
  10156.           Stream.WriteBuffer(Header_Image_PixelData, SizeOf(Header_Image_PixelData));
  10157.  
  10158.           case Header_Image_PixelData.Compress of
  10159.             DXTextureImageCompress_None:
  10160.               begin
  10161.                 for i := 0 to Image.Height - 1 do
  10162.                 begin
  10163.                   Stream.WriteBuffer(Image.ScanLine[i]^, Image.Widthbytes);
  10164.                   AddProgress(Image.Widthbytes);
  10165.                 end;
  10166.               end;
  10167.             {$IFDEF DXTextureImage_UseZLIB}
  10168.             DXTextureImageCompress_ZLIB:
  10169.               begin
  10170.                 Compression := TCompressionStream.Create(clMax, Stream);
  10171.                 try
  10172.                   for i := 0 to Image.Height - 1 do
  10173.                   begin
  10174.                     Compression.WriteBuffer(Image.ScanLine[i]^, Image.WidthBytes);
  10175.                     AddProgress(Image.Widthbytes);
  10176.                   end;
  10177.                 finally
  10178.                   Compression.Free;
  10179.                 end;
  10180.               end;
  10181.             {$ENDIF}
  10182.           end;
  10183.         finally
  10184.           BlockHeaderWriter.EndBlock;
  10185.         end;
  10186.       end;
  10187.  
  10188.       {  Sub-image writing  }
  10189.       for i := 0 to Image.SubImageCount - 1 do
  10190.         WriteGroup_Image(Image.SubImages[i]);
  10191.     finally
  10192.       BlockHeaderWriter.EndGroup;
  10193.     end;
  10194.   end;
  10195.  
  10196. var
  10197.   FileHeader: TDXTextureImageFileHeader;
  10198. begin
  10199.   Progress := 0;
  10200.   ProgressCount := CalcProgressCount(Image);
  10201.  
  10202.   {  File header writing  }
  10203.   FileHeader.FileType := DXTextureImageFile_Type;
  10204.   FileHeader.ver := DXTextureImageFile_Version;
  10205.   Stream.WriteBuffer(FileHeader, SizeOf(FileHeader));
  10206.  
  10207.   {  Image writing  }
  10208.   BlockHeaderWriter := TDXTextureImageFileBlockHeaderWriter.Create(Stream);
  10209.   try
  10210.     {  Image writing  }
  10211.     WriteGroup_Image(Image);
  10212.  
  10213.     {  End of file  }
  10214.     BlockHeaderWriter.WriteBlock(DXTextureImageFileBlockID_EndFile);
  10215.   finally
  10216.     BlockHeaderWriter.Free;
  10217.   end;
  10218. end;
  10219.  
  10220. {  DXTextureImage_LoadBitmapFunc  }
  10221.  
  10222. procedure DXTextureImage_LoadBitmapFunc(Stream: TStream; Image: TDXTextureImage);
  10223. type
  10224.   TDIBPixelFormat = packed record
  10225.     RBitMask, GBitMask, BBitMask: DWORD;
  10226.   end;
  10227. var
  10228.   TopDown: Boolean;
  10229.   BF: TBitmapFileHeader;
  10230.   BI: TBitmapInfoHeader;
  10231.  
  10232.   procedure DecodeRGB;
  10233.   var
  10234.     y: Integer;
  10235.   begin
  10236.     for y := 0 to Image.Height - 1 do
  10237.     begin
  10238.       if TopDown then
  10239.         Stream.ReadBuffer(Image.ScanLine[y]^, Image.WidthBytes)
  10240.       else
  10241.         Stream.ReadBuffer(Image.ScanLine[Image.Height - y - 1]^, Image.WidthBytes);
  10242.     end;
  10243.   end;
  10244.  
  10245.   procedure DecodeRLE4;
  10246.   var
  10247.     SrcDataP: Pointer;
  10248.     B1, B2, C: Byte;
  10249.     Dest, Src, P: PByte;
  10250.     X, Y, i: Integer;
  10251.   begin
  10252.     GetMem(SrcDataP, BI.biSizeImage);
  10253.     try
  10254.       Stream.ReadBuffer(SrcDataP^, BI.biSizeImage);
  10255.  
  10256.       Dest := Image.TopPBits;
  10257.       Src := SrcDataP;
  10258.       X := 0;
  10259.       Y := 0;
  10260.  
  10261.       while True do
  10262.       begin
  10263.         B1 := Src^; Inc(Src);
  10264.         B2 := Src^; Inc(Src);
  10265.  
  10266.         if B1 = 0 then
  10267.         begin
  10268.           case B2 of
  10269.             0: begin {  End of line  }
  10270.                 X := 0; Inc(Y);
  10271.                 Dest := Image.ScanLine[Y];
  10272.               end;
  10273.             1: Break; {  End of bitmap  }
  10274.             2: begin {  Difference of coordinates  }
  10275.                 Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
  10276.                 Dest := Image.ScanLine[Y];
  10277.               end;
  10278.           else
  10279.             {  Absolute mode  }
  10280.             C := 0;
  10281.             for i := 0 to B2 - 1 do
  10282.             begin
  10283.               if i and 1 = 0 then
  10284.               begin
  10285.                 C := Src^; Inc(Src);
  10286.               end
  10287.               else
  10288.               begin
  10289.                 C := C shl 4;
  10290.               end;
  10291.  
  10292.               P := Pointer(Integer(Dest) + X shr 1);
  10293.               if X and 1 = 0 then
  10294.                 P^ := (P^ and $0F) or (C and $F0)
  10295.               else
  10296.                 P^ := (P^ and $F0) or ((C and $F0) shr 4);
  10297.  
  10298.               Inc(X);
  10299.             end;
  10300.           end;
  10301.         end
  10302.         else
  10303.         begin
  10304.           {  Encoding mode  }
  10305.           for i := 0 to B1 - 1 do
  10306.           begin
  10307.             P := Pointer(Integer(Dest) + X shr 1);
  10308.             if X and 1 = 0 then
  10309.               P^ := (P^ and $0F) or (B2 and $F0)
  10310.             else
  10311.               P^ := (P^ and $F0) or ((B2 and $F0) shr 4);
  10312.  
  10313.             Inc(X);
  10314.  
  10315.             // Swap nibble
  10316.             B2 := (B2 shr 4) or (B2 shl 4);
  10317.           end;
  10318.         end;
  10319.  
  10320.         {  Word arrangement  }
  10321.         Inc(Src, Longint(Src) and 1);
  10322.       end;
  10323.     finally
  10324.       FreeMem(SrcDataP);
  10325.     end;
  10326.   end;
  10327.  
  10328.   procedure DecodeRLE8;
  10329.   var
  10330.     SrcDataP: Pointer;
  10331.     B1, B2: Byte;
  10332.     Dest, Src: PByte;
  10333.     X, Y: Integer;
  10334.   begin
  10335.     GetMem(SrcDataP, BI.biSizeImage);
  10336.     try
  10337.       Stream.ReadBuffer(SrcDataP^, BI.biSizeImage);
  10338.  
  10339.       Dest := Image.TopPBits;
  10340.       Src := SrcDataP;
  10341.       X := 0;
  10342.       Y := 0;
  10343.  
  10344.       while True do
  10345.       begin
  10346.         B1 := Src^; Inc(Src);
  10347.         B2 := Src^; Inc(Src);
  10348.  
  10349.         if B1 = 0 then
  10350.         begin
  10351.           case B2 of
  10352.             0: begin {  End of line  }
  10353.                 X := 0; Inc(Y);
  10354.                 Dest := Pointer(Longint(Image.TopPBits) + Y * Image.NextLine + X);
  10355.               end;
  10356.             1: Break; {  End of bitmap  }
  10357.             2: begin {  Difference of coordinates  }
  10358.                 Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
  10359.                 Dest := Pointer(Longint(Image.TopPBits) + Y * Image.NextLine + X);
  10360.               end;
  10361.           else
  10362.             {  Absolute mode  }
  10363.             Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
  10364.           end;
  10365.         end
  10366.         else
  10367.         begin
  10368.           {  Encoding mode  }
  10369.           FillChar(Dest^, B1, B2); Inc(Dest, B1);
  10370.         end;
  10371.  
  10372.         {  Word arrangement  }
  10373.         Inc(Src, Longint(Src) and 1);
  10374.       end;
  10375.     finally
  10376.       FreeMem(SrcDataP);
  10377.     end;
  10378.   end;
  10379.  
  10380. var
  10381.   BC: TBitmapCoreHeader;
  10382.   RGBTriples: array[0..255] of TRGBTriple;
  10383.   RGBQuads: array[0..255] of TRGBQuad;
  10384.   i, PalCount, j: Integer;
  10385.   OS2: Boolean;
  10386.   PixelFormat: TDIBPixelFormat;
  10387. begin
  10388.   {  File header reading  }
  10389.   i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
  10390.   if i = 0 then Exit;
  10391.   if i <> SizeOf(TBitmapFileHeader) then
  10392.     raise EDXTextureImageError.Create(SInvalidDIB);
  10393.  
  10394.   {  Is the head 'BM'?  }
  10395.   if BF.bfType <> Ord('B') + Ord('M') * $100 then
  10396.     raise EDXTextureImageError.Create(SInvalidDIB);
  10397.  
  10398.   {  Reading of size of header  }
  10399.   i := Stream.Read(BI.biSize, 4);
  10400.   if i <> 4 then
  10401.     raise EDXTextureImageError.Create(SInvalidDIB);
  10402.  
  10403.   {  Kind check of DIB  }
  10404.   OS2 := False;
  10405.  
  10406.   case BI.biSize of
  10407.     SizeOf(TBitmapCoreHeader):
  10408.       begin
  10409.         {  OS/2 type  }
  10410.         Stream.ReadBuffer(Pointer(Integer(@BC) + 4)^, SizeOf(TBitmapCoreHeader) - 4);
  10411.  
  10412.         FilLChar(BI, SizeOf(BI), 0);
  10413.         with BI do
  10414.         begin
  10415.           biClrUsed := 0;
  10416.           biCompression := BI_RGB;
  10417.           biBitCount := BC.bcBitCount;
  10418.           biHeight := BC.bcHeight;
  10419.           biWidth := BC.bcWidth;
  10420.         end;
  10421.  
  10422.         OS2 := True;
  10423.       end;
  10424.     SizeOf(TBitmapInfoHeader):
  10425.       begin
  10426.         {  Windows type  }
  10427.         Stream.ReadBuffer(Pointer(Integer(@BI) + 4)^, SizeOf(TBitmapInfoHeader) - 4);
  10428.       end;
  10429.   else
  10430.     raise EDXTextureImageError.Create(SInvalidDIB);
  10431.   end;
  10432.  
  10433.   {  Bit mask reading  }
  10434.   if BI.biCompression = BI_BITFIELDS then
  10435.   begin
  10436.     Stream.ReadBuffer(PixelFormat, SizeOf(PixelFormat));
  10437.   end
  10438.   else
  10439.   begin
  10440.     if BI.biBitCount = 16 then
  10441.     begin
  10442.       PixelFormat.RBitMask := $7C00;
  10443.       PixelFormat.GBitMask := $03E0;
  10444.       PixelFormat.BBitMask := $001F;
  10445.     end else if (BI.biBitCount = 24) or (BI.biBitCount = 32) then
  10446.     begin
  10447.       PixelFormat.RBitMask := $00FF0000;
  10448.       PixelFormat.GBitMask := $0300FF00;
  10449.       PixelFormat.BBitMask := $000000FF;
  10450.     end;
  10451.   end;
  10452.  
  10453.   {  DIB making  }
  10454.   if BI.biHeight < 0 then
  10455.   begin
  10456.     BI.biHeight := -BI.biHeight;
  10457.     TopDown := True;
  10458.   end
  10459.   else
  10460.     TopDown := False;
  10461.  
  10462.   if BI.biBitCount in [1, 4, 8] then
  10463.   begin
  10464.     Image.SetSize(DXTextureImageType_PaletteIndexedColor, BI.biWidth, BI.biHeight, BI.biBitCount,
  10465.       (((BI.biWidth * BI.biBitCount) + 31) div 32) * 4);
  10466.  
  10467.     Image.idx_index := dxtMakeChannel(1 shl BI.biBitCount - 1, True);
  10468.     Image.PackedPixelOrder := True;
  10469.   end
  10470.   else
  10471.   begin
  10472.     Image.SetSize(DXTextureImageType_RGBColor, BI.biWidth, BI.biHeight, BI.biBitCount,
  10473.       (((BI.biWidth * BI.biBitCount) + 31) div 32) * 4);
  10474.  
  10475.     Image.rgb_red := dxtMakeChannel(PixelFormat.RBitMask, False);
  10476.     Image.rgb_green := dxtMakeChannel(PixelFormat.GBitMask, False);
  10477.     Image.rgb_blue := dxtMakeChannel(PixelFormat.BBitMask, False);
  10478.  
  10479.     j := Image.rgb_red.BitCount + Image.rgb_green.BitCount + Image.rgb_blue.BitCount;
  10480.     if j < BI.biBitCount then
  10481.       Image.rgb_alpha := dxtMakeChannel((1 shl (BI.biBitCount - j) - 1) shl j, False);
  10482.  
  10483.     Image.PackedPixelOrder := False;
  10484.   end;
  10485.  
  10486.   {  palette reading  }
  10487.   PalCount := BI.biClrUsed;
  10488.   if (PalCount = 0) and (BI.biBitCount <= 8) then
  10489.     PalCount := 1 shl BI.biBitCount;
  10490.   if PalCount > 256 then PalCount := 256;
  10491.  
  10492.   if OS2 then
  10493.   begin
  10494.     {  OS/2 type  }
  10495.     Stream.ReadBuffer(RGBTriples, SizeOf(TRGBTriple) * PalCount);
  10496.     for i := 0 to PalCount - 1 do
  10497.     begin
  10498.       Image.idx_palette[i].peRed := RGBTriples[i].rgbtRed;
  10499.       Image.idx_palette[i].peGreen := RGBTriples[i].rgbtGreen;
  10500.       Image.idx_palette[i].peBlue := RGBTriples[i].rgbtBlue;
  10501.     end;
  10502.   end
  10503.   else
  10504.   begin
  10505.     {  Windows type  }
  10506.     Stream.ReadBuffer(RGBQuads, SizeOf(TRGBQuad) * PalCount);
  10507.     for i := 0 to PalCount - 1 do
  10508.     begin
  10509.       Image.idx_palette[i].peRed := RGBQuads[i].rgbRed;
  10510.       Image.idx_palette[i].peGreen := RGBQuads[i].rgbGreen;
  10511.       Image.idx_palette[i].peBlue := RGBQuads[i].rgbBlue;
  10512.     end;
  10513.   end;
  10514.  
  10515.   {  Pixel data reading  }
  10516.   case BI.biCompression of
  10517.     BI_RGB: DecodeRGB;
  10518.     BI_BITFIELDS: DecodeRGB;
  10519.     BI_RLE4: DecodeRLE4;
  10520.     BI_RLE8: DecodeRLE8;
  10521.   else
  10522.     raise EDXTextureImageError.Create(SInvalidDIB);
  10523.   end;
  10524. end;
  10525.  
  10526. { TDXTBase }
  10527.  
  10528. //Note by JB.
  10529. //This class is supplement of original Hori's code.
  10530. //For use alphablend you can have a bitmap 32 bit RGBA
  10531. //when isn't alphachannel present, it works like RGB 24bit
  10532.  
  10533. //functions required actualized DIB source for works with alphachannel
  10534.  
  10535. function TDXTBase.GetCompression: TDXTextureImageFileCompressType;
  10536. begin
  10537.   Result := FParamsFormat.Compress;
  10538. end;
  10539.  
  10540. procedure TDXTBase.SetCompression(const Value: TDXTextureImageFileCompressType);
  10541. begin
  10542.   FParamsFormat.Compress := Value;
  10543. end;
  10544.  
  10545. function TDXTBase.GetWidth: Integer;
  10546. begin
  10547.   Result := FParamsFormat.Width;
  10548. end;
  10549.  
  10550. procedure TDXTBase.SetWidth(const Value: Integer);
  10551. begin
  10552.   FParamsFormat.Width := Value;
  10553. end;
  10554.  
  10555. function TDXTBase.GetMipmap: Integer;
  10556. begin
  10557.   Result := FParamsFormat.MipmapCount;
  10558. end;
  10559.  
  10560. procedure TDXTBase.SetMipmap(const Value: Integer);
  10561. begin
  10562.   if Value = -1 then
  10563.     FParamsFormat.MipmapCount := MaxInt
  10564.   else
  10565.     FParamsFormat.MipmapCount := Value;
  10566. end;
  10567.  
  10568. function TDXTBase.GetTransparentColor: TColorRef;
  10569. begin
  10570.   Result := FParamsFormat.TransparentColor;
  10571. end;
  10572.  
  10573. procedure TDXTBase.SetTransparentColor(const Value: TColorRef);
  10574. begin
  10575.   FParamsFormat.Transparent := True;
  10576.   FParamsFormat.TransparentColor := RGB(Value shr 16, Value shr 8, Value);
  10577. end;
  10578.  
  10579. procedure TDXTBase.SetTransparentColorIndexed(const Value: TColorRef);
  10580. begin
  10581.   FParamsFormat.TransparentColor := PaletteIndex(Value);
  10582. end;
  10583.  
  10584. function TDXTBase.GetHeight: Integer;
  10585. begin
  10586.   Result := FParamsFormat.Height;
  10587. end;
  10588.  
  10589. procedure TDXTBase.SetHeight(const Value: Integer);
  10590. begin
  10591.   FParamsFormat.Height := Value;
  10592. end;
  10593.  
  10594. procedure TDXTBase.SetChannelY(T: TDIB);
  10595. begin
  10596.  
  10597. end;
  10598.  
  10599. procedure TDXTBase.LoadChannelRGBFromFile(const FileName: string);
  10600. begin
  10601.   FStrImageFileName := FileName;
  10602.   try
  10603.     EvaluateChannels([rgbRed, rgbGreen, rgbBlue], '', '');
  10604.   finally
  10605.     FStrImageFileName := '';
  10606.   end;
  10607. end;
  10608.  
  10609. function TDXTBase.LoadFromFile(iFilename: string): Boolean;
  10610. begin
  10611.   Result := FileExists(iFilename);
  10612.   if Result then
  10613.   try
  10614.     Texture.LoadFromFile(iFileName);
  10615.   except
  10616.     Result := False;
  10617.   end;
  10618. end;
  10619.  
  10620. procedure TDXTBase.LoadChannelAFromFile(const FileName: string);
  10621. begin
  10622.   FStrImageFileName := FileName;
  10623.   try
  10624.     EvaluateChannels([rgbAlpha], '', '');
  10625.   finally
  10626.     FStrImageFileName := '';
  10627.   end;
  10628. end;
  10629.  
  10630. constructor TDXTBase.Create;
  10631. var
  10632.   Channel: TDXTImageChannel;
  10633. begin
  10634.   FillChar(Channel, SizeOf(Channel), 0);
  10635.   FilLChar(FParamsFormat, SizeOf(FParamsFormat), 0);
  10636.   FParamsFormat.Compress := DXTextureImageFileCompressType_None;
  10637.   FHasImageList := TList.Create;
  10638.   for Channel := Low(Channel) to High(Channel) do
  10639.     FChannelChangeTable[Channel] := Channel;
  10640.   FChannelChangeTable[rgbAlpha] := yuvY;
  10641.   FDIB := nil;
  10642.   FStrImageFileName := '';
  10643. end;
  10644.  
  10645. procedure TDXTBase.SetChannelRGBA(T: TDIB);
  10646. begin
  10647.   FDIB := T;
  10648.   try
  10649.     EvaluateChannels([rgbRed, rgbGreen, rgbBlue, rgbAlpha], '', '');
  10650.   finally
  10651.     FDIB := nil;
  10652.   end;
  10653. end;
  10654.  
  10655. procedure TDXTBase.BuildImage(Image: TDXTextureImage);
  10656. type
  10657.   TOutputImageChannelInfo2 = record
  10658.     Image: TDXTextureImage;
  10659.     Channels: TDXTImageChannels;
  10660.   end;
  10661. var
  10662.   cR, cG, cB: Byte;
  10663.  
  10664.   function GetChannelVal(const Channel: TDXTextureImageChannel; SrcChannel: TDXTImageChannel): DWORD;
  10665.   begin
  10666.     case SrcChannel of
  10667.       rgbRed: Result := dxtEncodeChannel(Channel, cR);
  10668.       rgbGreen: Result := dxtEncodeChannel(Channel, cG);
  10669.       rgbBlue: Result := dxtEncodeChannel(Channel, cB);
  10670.       yuvY: Result := dxtEncodeChannel(Channel, (cR * 306 + cG * 602 + cB * 116) div 1024);
  10671.     else Result := 0;
  10672.     end;
  10673.   end;
  10674.  
  10675. var
  10676.   HasImageChannelList: array[0..Ord(High(TDXTImageChannel)) + 1] of TOutputImageChannelInfo2;
  10677.   HasImageChannelListCount: Integer;
  10678.   x, y, i: Integer;
  10679.   c, c2, c3: DWORD;
  10680.   Channel: TDXTImageChannel;
  10681.   Flag: Boolean;
  10682.  
  10683.   SrcImage: TDXTextureImage;
  10684.   UseChannels: TDXTImageChannels;
  10685. begin
  10686.   HasImageChannelListCount := 0;
  10687.   for Channel := Low(Channel) to High(Channel) do
  10688.     if Channel in FHasChannels then
  10689.     begin
  10690.       Flag := False;
  10691.       for i := 0 to HasImageChannelListCount - 1 do
  10692.         if HasImageChannelList[i].Image = FHasChannelImages[Channel].Image then
  10693.         begin
  10694.           HasImageChannelList[i].Channels := HasImageChannelList[i].Channels + [Channel];
  10695.           Flag := True;
  10696.           Break;
  10697.         end;
  10698.       if not Flag then
  10699.       begin
  10700.         HasImageChannelList[HasImageChannelListCount].Image := FHasChannelImages[Channel].Image;
  10701.         HasImageChannelList[HasImageChannelListCount].Channels := [Channel];
  10702.         Inc(HasImageChannelListCount);
  10703.       end;
  10704.     end;
  10705.  
  10706.   cR := 0;
  10707.   cG := 0;
  10708.   cB := 0;
  10709.  
  10710.   if Image.ImageType = DXTextureImageType_PaletteIndexedColor then
  10711.   begin
  10712.     {  Index color  }
  10713.     for y := 0 to Image.Height - 1 do
  10714.       for x := 0 to Image.Width - 1 do
  10715.       begin
  10716.         c := 0;
  10717.  
  10718.         for i := 0 to HasImageChannelListCount - 1 do
  10719.         begin
  10720.           SrcImage := HasImageChannelList[i].Image;
  10721.           UseChannels := HasImageChannelList[i].Channels;
  10722.  
  10723.           case SrcImage.ImageType of
  10724.             DXTextureImageType_PaletteIndexedColor:
  10725.               begin
  10726.                 c2 := SrcImage.Pixels[x, y];
  10727.                 c3 := dxtDecodeChannel(SrcImage.idx_index, c2);
  10728.  
  10729.                 if rgbRed in UseChannels then
  10730.                   c := c or dxtEncodeChannel(Image.idx_index, c3);
  10731.  
  10732.                 cR := SrcImage.idx_palette[c3].peRed;
  10733.                 cG := SrcImage.idx_palette[c3].peGreen;
  10734.                 cB := SrcImage.idx_palette[c3].peBlue;
  10735.               end;
  10736.             DXTextureImageType_RGBColor:
  10737.               begin
  10738.                 c2 := SrcImage.Pixels[x, y];
  10739.  
  10740.                 cR := dxtDecodeChannel(SrcImage.rgb_red, c2);
  10741.                 cG := dxtDecodeChannel(SrcImage.rgb_green, c2);
  10742.                 cB := dxtDecodeChannel(SrcImage.rgb_blue, c2);
  10743.               end;
  10744.           end;
  10745.  
  10746.           if rgbAlpha in UseChannels then
  10747.             c := c or GetChannelVal(Image.idx_alpha, FChannelChangeTable[rgbAlpha]);
  10748.         end;
  10749.  
  10750.         Image.Pixels[x, y] := c;
  10751.       end;
  10752.   end
  10753.   else
  10754.     if Image.ImageType = DXTextureImageType_RGBColor then
  10755.     begin
  10756.     {  RGB color  }
  10757.       for y := 0 to Image.Height - 1 do
  10758.         for x := 0 to Image.Width - 1 do
  10759.         begin
  10760.           c := 0;
  10761.  
  10762.           for i := 0 to HasImageChannelListCount - 1 do
  10763.           begin
  10764.             SrcImage := HasImageChannelList[i].Image;
  10765.             UseChannels := HasImageChannelList[i].Channels;
  10766.  
  10767.             case SrcImage.ImageType of
  10768.               DXTextureImageType_PaletteIndexedColor:
  10769.                 begin
  10770.                   c2 := SrcImage.Pixels[x, y];
  10771.                   c3 := dxtDecodeChannel(SrcImage.idx_index, c2);
  10772.  
  10773.                   cR := SrcImage.idx_palette[c3].peRed;
  10774.                   cG := SrcImage.idx_palette[c3].peGreen;
  10775.                   cB := SrcImage.idx_palette[c3].peBlue;
  10776.                 end;
  10777.               DXTextureImageType_RGBColor:
  10778.                 begin
  10779.                   c2 := SrcImage.Pixels[x, y];
  10780.  
  10781.                   cR := dxtDecodeChannel(SrcImage.rgb_red, c2);
  10782.                   cG := dxtDecodeChannel(SrcImage.rgb_green, c2);
  10783.                   cB := dxtDecodeChannel(SrcImage.rgb_blue, c2);
  10784.                 end;
  10785.             end;
  10786.  
  10787.             if rgbRed in UseChannels then
  10788.               c := c or GetChannelVal(Image.rgb_red, FChannelChangeTable[rgbRed]);
  10789.             if rgbGreen in UseChannels then
  10790.               c := c or GetChannelVal(Image.rgb_green, FChannelChangeTable[rgbGreen]);
  10791.             if rgbBlue in UseChannels then
  10792.               c := c or GetChannelVal(Image.rgb_Blue, FChannelChangeTable[rgbBlue]);
  10793.             if rgbAlpha in UseChannels then
  10794.               c := c or GetChannelVal(Image.rgb_alpha, FChannelChangeTable[rgbAlpha]);
  10795.           end;
  10796.  
  10797.           Image.Pixels[x, y] := c;
  10798.         end;
  10799.     end;
  10800. end;
  10801.  
  10802. procedure TDXTBase.SetChannelR(T: TDIB);
  10803. begin
  10804.   FDIB := T;
  10805.   try
  10806.     EvaluateChannels([rgbRed], '', '');
  10807.   finally
  10808.     FDIB := nil;
  10809.   end;
  10810. end;
  10811.  
  10812. function GetBitCount(b: Integer): Integer;
  10813. begin
  10814.   Result := 32;
  10815.   while (Result > 0) and (((1 shl (Result - 1)) and b) = 0) do Dec(Result);
  10816. end;
  10817.  
  10818. procedure TDXTBase.CalcOutputBitFormat;
  10819. var
  10820.   BitCount: DWORD;
  10821.   NewWidth, NewHeight, i, j: Integer;
  10822.   Channel: TDXTImageChannel;
  10823. begin
  10824.   {  Size calculation  }
  10825.   NewWidth := 1 shl GetBitCount(TDXTextureImage(FHasImageList[0]).Width);
  10826.   NewHeight := 1 shl GetBitCount(TDXTextureImage(FHasImageList[0]).Height);
  10827.   NewWidth := Max(NewWidth, NewHeight);
  10828.   NewHeight := NewWidth;
  10829.   if Abs(FParamsFormat.Width - NewWidth) > Abs(FParamsFormat.Width - NewWidth div 2) then
  10830.     NewWidth := NewWidth div 2;
  10831.   if Abs(FParamsFormat.Height - NewHeight) > Abs(FParamsFormat.Height - NewHeight div 2) then
  10832.     NewHeight := NewHeight div 2;
  10833.  
  10834.   if FParamsFormat.Width = 0 then FParamsFormat.Width := NewWidth;
  10835.   if FParamsFormat.Height = 0 then FParamsFormat.Height := NewHeight;
  10836.  
  10837.   {  Other several calculation  }
  10838.   i := Min(FParamsFormat.Width, FParamsFormat.Height);
  10839.   j := 0;
  10840.   while i > 1 do
  10841.   begin
  10842.     i := i div 2;
  10843.     Inc(j);
  10844.   end;
  10845.  
  10846.   FParamsFormat.MipmapCount := Min(j, FParamsFormat.MipmapCount);
  10847.  
  10848.   {  Output type calculation  }
  10849.   if (FHasChannelImages[rgbRed].Image = FHasChannelImages[rgbGreen].Image) and
  10850.     (FHasChannelImages[rgbRed].Image = FHasChannelImages[rgbBlue].Image) and
  10851.     (FHasChannelImages[rgbRed].Image <> nil) and
  10852.     (FHasChannelImages[rgbRed].Image.ImageType = DXTextureImageType_PaletteIndexedColor) and
  10853.  
  10854.     (FHasChannelImages[rgbRed].BitCount = 8) and
  10855.     (FHasChannelImages[rgbGreen].BitCount = 8) and
  10856.     (FHasChannelImages[rgbBlue].BitCount = 8) and
  10857.  
  10858.     (FChannelChangeTable[rgbRed] = rgbRed) and
  10859.     (FChannelChangeTable[rgbGreen] = rgbGreen) and
  10860.     (FChannelChangeTable[rgbBlue] = rgbBlue) and
  10861.  
  10862.     (FParamsFormat.Width = FHasChannelImages[rgbRed].Image.Width) and
  10863.     (FParamsFormat.Height = FHasChannelImages[rgbRed].Image.Height) and
  10864.  
  10865.     (FParamsFormat.MipmapCount = 0)
  10866.   then
  10867.   begin
  10868.     FParamsFormat.ImageType := DXTextureImageType_PaletteIndexedColor;
  10869.   end
  10870.   else
  10871.     FParamsFormat.ImageType := DXTextureImageType_RGBColor;
  10872.  
  10873.   {  Bit several calculations  }
  10874.   FParamsFormat.BitCount := 0;
  10875.  
  10876.   for Channel := Low(TDXTImageChannel) to High(TDXTImageChannel) do
  10877.     if (FHasChannelImages[Channel].Image <> nil) and (FHasChannelImages[Channel].Image.ImageType = DXTextureImageType_PaletteIndexedColor) then
  10878.     begin
  10879.       FParamsFormat.idx_palette := FHasChannelImages[Channel].Image.idx_palette;
  10880.       Break;
  10881.     end;
  10882.  
  10883.   if FParamsFormat.ImageType = DXTextureImageType_PaletteIndexedColor then
  10884.   begin
  10885.     {  Index channel }
  10886.     if rgbRed in FHasChannels then
  10887.     begin
  10888.       BitCount := FHasChannelImages[rgbRed].BitCount;
  10889.       FParamsFormat.idx_index := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, True);
  10890.       Inc(FParamsFormat.BitCount, BitCount);
  10891.     end;
  10892.  
  10893.     {  Alpha channel  }
  10894.     if rgbAlpha in FHasChannels then
  10895.     begin
  10896.       BitCount := FHasChannelImages[rgbAlpha].BitCount;
  10897.       FParamsFormat.idx_alpha := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
  10898.       Inc(FParamsFormat.BitCount, BitCount);
  10899.     end;
  10900.   end
  10901.   else
  10902.   begin
  10903.     {  B channel }
  10904.     if rgbBlue in FHasChannels then
  10905.     begin
  10906.       BitCount := FHasChannelImages[rgbBlue].BitCount;
  10907.       FParamsFormat.rgb_blue := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
  10908.       Inc(FParamsFormat.BitCount, BitCount);
  10909.     end;
  10910.  
  10911.     {  G channel }
  10912.     if rgbGreen in FHasChannels then
  10913.     begin
  10914.       BitCount := FHasChannelImages[rgbGreen].BitCount;
  10915.       FParamsFormat.rgb_green := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
  10916.       Inc(FParamsFormat.BitCount, BitCount);
  10917.     end;
  10918.  
  10919.     {  R channel }
  10920.     if rgbRed in FHasChannels then
  10921.     begin
  10922.       BitCount := FHasChannelImages[rgbRed].BitCount;
  10923.       FParamsFormat.rgb_red := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
  10924.       Inc(FParamsFormat.BitCount, BitCount);
  10925.     end;
  10926.  
  10927.     {  Alpha channel }
  10928.     if rgbAlpha in FHasChannels then
  10929.     begin
  10930.       BitCount := FHasChannelImages[rgbAlpha].BitCount;
  10931.       FParamsFormat.rgb_alpha := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
  10932.       Inc(FParamsFormat.BitCount, BitCount);
  10933.     end;
  10934.   end;
  10935.  
  10936.   {  As for the number of bits only either of 1, 2, 4, 8, 16, 24, 32  }
  10937.   if FParamsFormat.BitCount in [3] then
  10938.     FParamsFormat.BitCount := 4
  10939.   else
  10940.   if FParamsFormat.BitCount in [5..7] then
  10941.     FParamsFormat.BitCount := 8
  10942.   else
  10943.   if FParamsFormat.BitCount in [9..15] then
  10944.     FParamsFormat.BitCount := 16
  10945.   else
  10946.   if FParamsFormat.BitCount in [17..23] then
  10947.     FParamsFormat.BitCount := 24
  10948.   else
  10949.   if FParamsFormat.BitCount in [25..31] then
  10950.     FParamsFormat.BitCount := 32;
  10951.  
  10952.   {  Transparent color  }
  10953.   if (FParamsFormat.ImageType = DXTextureImageType_RGBColor) and (FParamsFormat.TransparentColor shr 24 = $01) then
  10954.   begin
  10955.     FParamsFormat.TransparentColor := RGB(FParamsFormat.idx_palette[Byte(FParamsFormat.TransparentColor)].peRed,
  10956.       FParamsFormat.idx_palette[Byte(FParamsFormat.TransparentColor)].peGreen,
  10957.       FParamsFormat.idx_palette[Byte(FParamsFormat.TransparentColor)].peBlue);
  10958.   end;
  10959. end;
  10960.  
  10961. procedure TDXTBase.LoadChannelRGBAFromFile(const FileName: string);
  10962. begin
  10963.   FStrImageFileName := FileName;
  10964.   try
  10965.     EvaluateChannels([rgbRed, rgbGreen, rgbBlue, rgbAlpha], '', '');
  10966.   finally
  10967.     FStrImageFileName := '';
  10968.   end;
  10969. end;
  10970.  
  10971. procedure TDXTBase.SetChannelB(T: TDIB);
  10972. begin
  10973.   FDIB := T;
  10974.   try
  10975.     EvaluateChannels([rgbBlue], '', '');
  10976.   finally
  10977.     FDIB := nil;
  10978.   end;
  10979. end;
  10980.  
  10981. procedure TDXTBase.SetChannelRGB(T: TDIB);
  10982. begin
  10983.   FDIB := T;
  10984.   try
  10985.     EvaluateChannels([rgbRed, rgbGreen, rgbBlue], '', '');
  10986.   finally
  10987.     FDIB := nil;
  10988.   end;
  10989. end;
  10990.  
  10991. procedure TDXTBase.SaveToFile(iFilename: string {$IFDEF VER4UP} = ''{$ENDIF});
  10992. var
  10993.   Image: TDXTextureImage;
  10994. begin
  10995.   {  Create output stream  }
  10996.   Image := Self.Texture;
  10997.   if (FHasImageList.Count > 0) and Assigned(Image) then
  10998.   begin
  10999.     if iFilename <> '' then
  11000.       Image.SaveToFile(iFilename)
  11001.     else
  11002.       Image.SaveToFile(FParamsFormat.Name + '.dxt');
  11003.   end;
  11004. end;
  11005.  
  11006. procedure TDXTBase.SetChannelA(T: TDIB);
  11007. begin
  11008.   FDIB := T;
  11009.   try
  11010.     EvaluateChannels([rgbAlpha], '', '');
  11011.   finally
  11012.     FDIB := nil;
  11013.   end;
  11014. end;
  11015.  
  11016. procedure TDXTBase.SetChannelG(T: TDIB);
  11017. begin
  11018.   FDIB := T;
  11019.   try
  11020.     EvaluateChannels([rgbGreen], '', '');
  11021.   finally
  11022.     FDIB := nil;
  11023.   end;
  11024. end;
  11025.  
  11026. destructor TDXTBase.Destroy;
  11027. var I: Integer;
  11028. begin
  11029.   for I := 0 to FHasImageList.Count - 1 do
  11030.     TDXTextureImage(FHasImageList[I]).Free;
  11031.   FHasImageList.Free;
  11032.   inherited Destroy;
  11033. end;
  11034.  
  11035. function TDXTBase.GetPicture: TDXTextureImage;
  11036. var
  11037.   MemoryStream: TMemoryStream;
  11038. begin
  11039.   Result := TDXTextureImage.Create;
  11040.   try
  11041.     if (FStrImageFileName <> '') and FileExists(FStrImageFileName) then
  11042.     begin
  11043.       Result.LoadFromFile(FStrImageFileName);
  11044.       Result.FImageName := ExtractFilename(FStrImageFileName);
  11045.     end
  11046.     else
  11047.       if Assigned(FDIB) then
  11048.       begin
  11049.         MemoryStream := TMemoryStream.Create;
  11050.         try
  11051.           FDIB.SaveToStream(MemoryStream);
  11052.           MemoryStream.Position := 0; //reading from 0
  11053.           Result.LoadFromStream(MemoryStream);
  11054.         finally
  11055.           MemoryStream.Free;
  11056.         end;
  11057.         Result.FImageName := Format('DIB%x', [Integer(Result)]); //supplement name
  11058.       end;
  11059.   except
  11060.     on E: Exception do
  11061.     begin
  11062.       EDXTBaseError.Create(E.Message);
  11063.     end;
  11064.   end
  11065. end;
  11066.  
  11067. procedure TDXTBase.Resize(Image: TDXTextureImage; NewWidth, NewHeight: Integer;
  11068.   FilterTypeResample: TFilterTypeResample);
  11069.   //resize used for Mipmap
  11070. var
  11071.   DIB: TDIB;
  11072.   x, y: Integer;
  11073.   c: DWORD;
  11074.   MemoryStream: TMemoryStream;
  11075. begin
  11076.   {  Exit when no resize  }
  11077.   if (Image.Width = NewWidth) and (Image.Height = NewHeight) then Exit;
  11078.   {  Supplement for image resizing  }
  11079.   //raise EDXTBaseError.Create('Invalid image size for texture.');
  11080.   {  No image at start  }
  11081.   DIB := TDIB.Create; //DIB accept
  11082.   try
  11083.     DIB.SetSize(Image.Width, Image.Height, Image.BitCount);
  11084.     {  of type  }
  11085.     for y := 0 to Image.Height - 1 do
  11086.       for x := 0 to Image.Width - 1 do
  11087.       begin
  11088.         if Image.ImageType = DXTextureImageType_PaletteIndexedColor then
  11089.         begin
  11090.           c := dxtDecodeChannel(Image.idx_index, Image.Pixels[x, y]);
  11091.           DIB.Pixels[x, y] := (Image.idx_palette[c].peRed shl 16) or
  11092.             (Image.idx_palette[c].peGreen shl 8) or
  11093.             Image.idx_palette[c].peBlue;
  11094.         end
  11095.         else begin
  11096.           c := Image.Pixels[x, y];
  11097.           DIB.Pixels[x, y] := (dxtDecodeChannel(Image.rgb_red, c) shl 16) or
  11098.             (dxtDecodeChannel(Image.rgb_green, c) shl 8) or
  11099.             dxtDecodeChannel(Image.rgb_blue, c);
  11100.         end;
  11101.       end;
  11102.  
  11103.     {  Resize for 24 bitcount deep }
  11104.     Image.SetSize(DXTextureImageType_RGBColor, Width, Height, Image.BitCount, 0);
  11105.  
  11106.     Image.rgb_red := dxtMakeChannel($FF0000, False);
  11107.     Image.rgb_green := dxtMakeChannel($00FF00, False);
  11108.     Image.rgb_blue := dxtMakeChannel($0000FF, False);
  11109.     Image.rgb_alpha := dxtMakeChannel(0, False);
  11110.  
  11111.     {  Resample routine DIB based there  }
  11112.     DIB.DoResample(Width, Height, FilterTypeResample);
  11113.  
  11114.     {Image returned through stream}
  11115.     Image.ClearImage;
  11116.     MemoryStream := TMemoryStream.Create;
  11117.     try
  11118.       DIB.SaveToStream(MemoryStream);
  11119.       MemoryStream.Position := 0; //from first byte
  11120.       Image.LoadFromStream(MemoryStream);
  11121.     finally
  11122.       MemoryStream.Free;
  11123.     end;
  11124.   finally
  11125.     DIB.Free;
  11126.   end;
  11127. end;
  11128.  
  11129. procedure TDXTBase.EvaluateChannels
  11130.   (const CheckChannelUsed: TDXTImageChannels;
  11131.   const CheckChannelChanged, CheckBitCountForChannel: string);
  11132. var J: Integer;
  11133.   Channel: TDXTImageChannel;
  11134.   ChannelBitCount: array[TDXTImageChannel] of Integer;
  11135.   ChannelParamName: TDXTImageChannels;
  11136.   Image: TDXTextureImage;
  11137.   Q: TDXTImageChannel;
  11138. begin
  11139.   Fillchar(ChannelBitCount, SizeOf(ChannelBitCount), 0);
  11140.   ChannelParamName := [];
  11141.   {  The channel which you use acquisition  }
  11142.   J := 0;
  11143.   for Q := rgbRed to rgbAlpha do
  11144.   begin
  11145.     if Q in CheckChannelUsed then
  11146.     begin
  11147.       Inc(J);
  11148.       Channel := Q;
  11149.       if not (Channel in FHasChannels) then
  11150.       begin
  11151.         if CheckBitCountForChannel <> '' then
  11152.           ChannelBitCount[Channel] := StrToInt(Copy(CheckBitCountForChannel, j, 1))
  11153.         else
  11154.           ChannelBitCount[Channel] := 8; {poke default value}
  11155.         if ChannelBitCount[Channel] <> 0 then
  11156.           ChannelParamName := ChannelParamName + [Channel];
  11157.  
  11158.         if CheckChannelChanged <> '' then
  11159.         begin
  11160.           case UpCase(CheckChannelChanged[j]) of
  11161.             'R': FChannelChangeTable[Channel] := rgbRed;
  11162.             'G': FChannelChangeTable[Channel] := rgbGreen;
  11163.             'B': FChannelChangeTable[Channel] := rgbBlue;
  11164.             'Y': FChannelChangeTable[Channel] := yuvY;
  11165.             'N': FChannelChangeTable[Channel] := rgbNone;
  11166.           else
  11167.             raise EDXTBaseError.CreateFmt('Invalid channel type(%s)', [CheckChannelChanged[j]]);
  11168.           end;
  11169.         end;
  11170.       end;
  11171.     end;
  11172.   end;
  11173.   {  Processing of each  }
  11174.   if ChannelParamName <> [] then
  11175.   begin
  11176.     {  Picture load  }
  11177.     Image := nil;
  11178.     {pokud je image uz nahrany tj. stejneho jmena, pokracuj dale}
  11179.     for j := 0 to FHasImageList.Count - 1 do
  11180.       if AnsiCompareFileName(TDXTextureImage(FHasImageList[j]).ImageName, FStrImageFileName) = 0 then
  11181.       begin
  11182.         Image := FHasImageList[j];
  11183.         Break;
  11184.       end;
  11185.     {obrazek neexistuje, musi se dotahnout bud z proudu, souboru nebo odjinut}
  11186.     if Image = nil then
  11187.     begin
  11188.       try
  11189.         Image := GetPicture;
  11190.       except
  11191.         if Assigned(Image) then
  11192.         begin
  11193.           {$IFNDEF VER5UP}
  11194.           Image.Free; Image := nil;
  11195.           {$ELSE}
  11196.           FreeAndNil(Image);
  11197.           {$ENDIF}
  11198.         end;
  11199.         raise;
  11200.       end;
  11201.       FHasImageList.Add(Image);
  11202.     end;
  11203.  
  11204.     {  Each channel processing  }
  11205.     for Channel := Low(Channel) to High(Channel) do
  11206.       if Channel in ChannelParamName then
  11207.       begin
  11208.         if ChannelBitCount[Channel] >= 0 then
  11209.           FHasChannelImages[Channel].BitCount := ChannelBitCount[Channel]
  11210.         else
  11211.         begin
  11212.           case Image.ImageType of
  11213.             DXTextureImageType_PaletteIndexedColor:
  11214.               begin
  11215.                 case Channel of
  11216.                   rgbRed: FHasChannelImages[Channel].BitCount := 8;
  11217.                   rgbGreen: FHasChannelImages[Channel].BitCount := 8;
  11218.                   rgbBlue: FHasChannelImages[Channel].BitCount := 8;
  11219.                   rgbAlpha: FHasChannelImages[Channel].BitCount := 8;
  11220.                 end;
  11221.               end;
  11222.             DXTextureImageType_RGBColor:
  11223.               begin
  11224.                 case Channel of
  11225.                   rgbRed: FHasChannelImages[Channel].BitCount := Image.rgb_red.BitCount;
  11226.                   rgbGreen: FHasChannelImages[Channel].BitCount := Image.rgb_green.BitCount;
  11227.                   rgbBlue: FHasChannelImages[Channel].BitCount := Image.rgb_blue.BitCount;
  11228.                   rgbAlpha: FHasChannelImages[Channel].BitCount := 8;
  11229.                 end;
  11230.               end;
  11231.           end;
  11232.         end;
  11233.         if FHasChannelImages[Channel].BitCount = 0 then Continue;
  11234.         FHasChannels := FHasChannels + [Channel];
  11235.         FHasChannelImages[Channel].Image := Image;
  11236.       end;
  11237.   end;
  11238. end;
  11239.  
  11240. function TDXTBase.GetTexture: TDXTextureImage;
  11241. var
  11242.   i, j: Integer;
  11243.   SubImage: TDXTextureImage;
  11244.   CurWidth, CurHeight: Integer;
  11245. begin
  11246.   Result := nil;
  11247.   if FHasImageList.Count = 0 then
  11248.     raise EDXTBaseError.Create('No image found');
  11249.  
  11250.   {  Output format calculation  }
  11251.   CalcOutputBitFormat;
  11252.   Result := TDXTextureImage.Create;
  11253.   try
  11254.     Result.SetSize(FParamsFormat.ImageType, FParamsFormat.Width, FParamsFormat.Height, FParamsFormat.BitCount, 0);
  11255.  
  11256.     Result.idx_index := FParamsFormat.idx_index;
  11257.     Result.idx_alpha := FParamsFormat.idx_alpha;
  11258.     Result.idx_palette := FParamsFormat.idx_palette;
  11259.  
  11260.     Result.rgb_red := FParamsFormat.rgb_red;
  11261.     Result.rgb_green := FParamsFormat.rgb_green;
  11262.     Result.rgb_blue := FParamsFormat.rgb_blue;
  11263.     Result.rgb_alpha := FParamsFormat.rgb_alpha;
  11264.  
  11265.     Result.ImageName := FParamsFormat.Name;
  11266.  
  11267.     Result.Transparent := FParamsFormat.Transparent;
  11268.     if FParamsFormat.TransparentColor shr 24 = $01 then
  11269.       Result.TransparentColor := dxtEncodeChannel(Result.idx_index, PaletteIndex(Byte(FParamsFormat.TransparentColor)))
  11270.     else
  11271.       Result.TransparentColor := Result.EncodeColor(GetRValue(FParamsFormat.TransparentColor), GetGValue(FParamsFormat.TransparentColor), GetBValue(FParamsFormat.TransparentColor), 0);
  11272.  
  11273.     BuildImage(Result);
  11274.  
  11275.     if FParamsFormat.ImageType = DXTextureImageType_RGBColor then
  11276.     begin
  11277.       BuildImage(Result);
  11278.       {  Picture information store here  }
  11279.       CurWidth := FParamsFormat.Width;
  11280.       CurHeight := FParamsFormat.Height;
  11281.       for i := 0 to FParamsFormat.MipmapCount - 1 do
  11282.       begin
  11283.         CurWidth := CurWidth div 2;
  11284.         CurHeight := CurHeight div 2;
  11285.         if (CurWidth <= 0) or (CurHeight <= 0) then Break;
  11286.         {  Resize calc here }
  11287.         for j := 0 to FHasImageList.Count - 1 do
  11288.           Resize(FHasImageList[j], CurWidth, CurHeight, ftrTriangle);
  11289.  
  11290.         SubImage := TDXTextureImage.CreateSub(Result);
  11291.         SubImage.SetSize(FParamsFormat.ImageType, CurWidth, CurHeight, FParamsFormat.BitCount, 0);
  11292.  
  11293.         SubImage.idx_index := FParamsFormat.idx_index;
  11294.         SubImage.idx_alpha := FParamsFormat.idx_alpha;
  11295.         SubImage.idx_palette := FParamsFormat.idx_palette;
  11296.  
  11297.         SubImage.rgb_red := FParamsFormat.rgb_red;
  11298.         SubImage.rgb_green := FParamsFormat.rgb_green;
  11299.         SubImage.rgb_blue := FParamsFormat.rgb_blue;
  11300.         SubImage.rgb_alpha := FParamsFormat.rgb_alpha;
  11301.  
  11302.         SubImage.ImageGroupType := DXTextureImageGroupType_Normal;
  11303.         SubImage.ImageID := i;
  11304.         SubImage.ImageName := Format('%s - mimap #%d', [Result.ImageName, i + 1]);
  11305.  
  11306.         BuildImage(SubImage);
  11307.       end;
  11308.     end;
  11309.     Result.FileCompressType := FParamsFormat.Compress;
  11310.   except
  11311.     on E: Exception do
  11312.     begin
  11313.       {$IFNDEF VER5UP}
  11314.       Result.Free;
  11315.       Result := nil;
  11316.       {$ELSE}
  11317.       FreeAndNil(Result);
  11318.       {$ENDIF}
  11319.       raise EDXTBaseError.Create(E.Message);
  11320.     end;
  11321.   end;
  11322. end;
  11323.  
  11324. { DIB2DTX }
  11325.  
  11326. procedure dib2dxt(DIBImage: TDIB; out DXTImage: TDXTextureImage{$IFDEF DXTextureImage_UseZLIB}; const Shrink: Boolean = True{$ENDIF});
  11327. var
  11328.   TexImage: TDXTBase;
  11329.   DIB: TDIB;
  11330. begin
  11331.   TexImage := TDXTBase.Create;
  11332.   try
  11333.     {$IFDEF DXTextureImage_UseZLIB}
  11334.     if Shrink then
  11335.     begin
  11336.       TexImage.Compression := DXTextureImageFileCompressType_ZLIB;
  11337.       TexImage.Mipmap := 4;
  11338.     end;
  11339.     {$ENDIF}
  11340.     try
  11341.       if DIBImage.HasAlphaChannel then
  11342.       begin
  11343.         DIB := DIBImage.RGBChannel;
  11344.         TexImage.SetChannelRGB(DIB);
  11345.         DIB.Free;
  11346.         DIB := DIBImage.AlphaChannel;
  11347.         TexImage.SetChannelA(DIB);
  11348.         DIB.Free;
  11349.       end
  11350.       else
  11351.         TexImage.SetChannelRGB(DIBImage);
  11352.  
  11353.       DXTImage := TexImage.Texture;
  11354.     except
  11355.       if Assigned(DXTImage) then
  11356.         DXTImage.Free;
  11357.       DXTImage := nil;
  11358.     end;
  11359.   finally
  11360.     TexImage.Free;
  11361.   end
  11362. end;
  11363.  
  11364. {$IFDEF D3DRM}
  11365.  
  11366. {  TDirect3DRMUserVisual  }
  11367.  
  11368. procedure TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK(lpD3DRMobj: IDirect3DRMObject;
  11369.   lpArg: Pointer); cdecl;
  11370. begin
  11371.   TDirect3DRMUserVisual(lpArg).Free;
  11372. end;
  11373.  
  11374. function TDirect3DRMUserVisual_D3DRMUSERVISUALCALLBACK(lpD3DRMUV: IDirect3DRMUserVisual;
  11375.   lpArg: Pointer; lpD3DRMUVreason: TD3DRMUserVisualReason;
  11376.   lpD3DRMDev: IDirect3DRMDevice; lpD3DRMview: IDirect3DRMViewport): Integer; cdecl;
  11377. begin
  11378.   Result := TDirect3DRMUserVisual(lpArg).DoRender(lpD3DRMUVreason, lpD3DRMDev, lpD3DRMview);
  11379. end;
  11380.  
  11381. constructor TDirect3DRMUserVisual.Create(D3DRM: IDirect3DRM);
  11382. begin
  11383.   inherited Create;
  11384.  
  11385.   if D3DRM.CreateUserVisual(@TDirect3DRMUserVisual_D3DRMUSERVISUALCALLBACK,
  11386.     Self, FUserVisual) <> D3DRM_OK
  11387.   then
  11388.     raise EDirect3DRMUserVisualError.CreateFmt(SCannotMade, ['IDirect3DRMUserVisual']);
  11389.  
  11390.   FUserVisual.AddDestroyCallback(@TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK, Self);
  11391. end;
  11392.  
  11393. destructor TDirect3DRMUserVisual.Destroy;
  11394. begin
  11395.   if FUserVisual <> nil then
  11396.     FUserVisual.DeleteDestroyCallback(@TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK, Self);
  11397.   FUserVisual := nil;
  11398.   inherited Destroy;
  11399. end;
  11400.  
  11401. function TDirect3DRMUserVisual.DoRender(Reason: TD3DRMUserVisualReason;
  11402.   D3DRMDev: IDirect3DRMDevice; D3DRMView: IDirect3DRMViewport): HRESULT;
  11403. begin
  11404.   Result := 0;
  11405. end;
  11406. {$ENDIF}
  11407.  
  11408. {  TPictureCollectionItem  }
  11409.  
  11410. type
  11411.   TPictureCollectionItemPattern = class(TCollectionItem)
  11412.   private
  11413.     FRect: TRect;
  11414.     FSurface: TDirectDrawSurface;
  11415.   end;
  11416.  
  11417. constructor TPictureCollectionItem.Create(Collection: TCollection);
  11418. begin
  11419.   inherited Create(Collection);
  11420.   FPicture := TPicture.Create;
  11421.   FPatterns := TCollection.Create(TPictureCollectionItemPattern);
  11422.   FSurfaceList := TList.Create;
  11423.   FTransparent := True;
  11424. end;
  11425.  
  11426. destructor TPictureCollectionItem.Destroy;
  11427. begin
  11428.   Finalize;
  11429.   FPicture.Free;
  11430.   FPatterns.Free;
  11431.   FSurfaceList.Free;
  11432.   inherited Destroy;
  11433. end;
  11434.  
  11435. procedure TPictureCollectionItem.Assign(Source: TPersistent);
  11436. var
  11437.   PrevInitialized: Boolean;
  11438. begin
  11439.   if Source is TPictureCollectionItem then
  11440.   begin
  11441.     PrevInitialized := Initialized;
  11442.     Finalize;
  11443.  
  11444.     FPatternHeight := TPictureCollectionItem(Source).FPatternHeight;
  11445.     FPatternWidth := TPictureCollectionItem(Source).FPatternWidth;
  11446.     FSkipHeight := TPictureCollectionItem(Source).FSkipHeight;
  11447.     FSkipWidth := TPictureCollectionItem(Source).FSkipWidth;
  11448.     FSystemMemory := TPictureCollectionItem(Source).FSystemMemory;
  11449.     FTransparent := TPictureCollectionItem(Source).FTransparent;
  11450.     FTransparentColor := TPictureCollectionItem(Source).FTransparentColor;
  11451.  
  11452.     FPicture.Assign(TPictureCollectionItem(Source).FPicture);
  11453.  
  11454.     if PrevInitialized then
  11455.       Restore;
  11456.   end else
  11457.     inherited Assign(Source);
  11458. end;
  11459.  
  11460. procedure TPictureCollectionItem.ClearSurface;
  11461. var
  11462.   i: Integer;
  11463. begin
  11464.   FPatterns.Clear;
  11465.   for i := 0 to FSurfaceList.Count - 1 do
  11466.     TDirectDrawSurface(FSurfaceList[i]).Free;
  11467.   FSurfaceList.Clear;
  11468. end;
  11469.  
  11470. function TPictureCollectionItem.GetHeight: Integer;
  11471. begin
  11472.   Result := FPatternHeight;
  11473.   if (Result <= 0) then
  11474.     Result := FPicture.Height;
  11475. end;
  11476.  
  11477. function TPictureCollectionItem.GetPictureCollection: TPictureCollection;
  11478. begin
  11479.   Result := Collection as TPictureCollection;
  11480. end;
  11481.  
  11482. function TPictureCollectionItem.GetPatternRect(Index: Integer): TRect;
  11483. begin
  11484.   if (Index >= 0) and (index < FPatterns.Count) then
  11485.     //Result := (FPatterns.Items[Index] as TPictureCollectionItemPattern).FRect
  11486.     Result := TPictureCollectionItemPattern(FPatterns.Items[Index]).FRect
  11487.   else
  11488.     Result := Rect(0, 0, 0, 0);
  11489. end;
  11490.  
  11491. function TPictureCollectionItem.GetPatternSurface(Index: Integer): TDirectDrawSurface;
  11492. begin
  11493.   if (Index >= 0) and (index < FPatterns.Count) then
  11494.     Result := TPictureCollectionItemPattern(FPatterns.Items[Index]).FSurface
  11495.   else
  11496.     Result := nil;
  11497. end;
  11498.  
  11499. function TPictureCollectionItem.GetPatternCount: Integer;
  11500. var
  11501.   XCount, YCount: Integer;
  11502. begin
  11503.   if FSurfaceList.Count = 0 then
  11504.   begin
  11505.     if PatternWidth = 0 then PatternWidth := FPicture.Width; //prevent division by zero
  11506.     XCount := FPicture.Width div (PatternWidth + SkipWidth);
  11507.     if FPicture.Width - XCount * (PatternWidth + SkipWidth) = PatternWidth then
  11508.       Inc(XCount);
  11509.     if PatternHeight = 0 then PatternHeight := FPicture.Height; //prevent division by zero
  11510.     YCount := FPicture.Height div (PatternHeight + SkipHeight);
  11511.     if FPicture.Height - YCount * (PatternHeight + SkipHeight) = PatternHeight then
  11512.       Inc(YCount);
  11513.     Result := XCount * YCount;
  11514.   end else
  11515.     Result := FPatterns.Count;
  11516. end;
  11517.  
  11518. function TPictureCollectionItem.GetWidth: Integer;
  11519. begin
  11520.   Result := FPatternWidth;
  11521.   if (Result <= 0) then
  11522.     Result := FPicture.Width;
  11523. end;
  11524.  
  11525. procedure TPictureCollectionItem.Draw(Dest: TDirectDrawSurface; X, Y,
  11526.   PatternIndex: Integer);
  11527. begin
  11528.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11529.   begin
  11530.     {$IFDEF DrawHWAcc}
  11531.     with TPictureCollection(Self.GetPictureCollection) do
  11532.       if FDXDraw.CheckD3D(Dest) then
  11533.       begin
  11534.         FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, Bounds(X, Y, Width, Height), PatternIndex, rtDraw{$IFNDEF VER4UP}, $FF{$ENDIF});
  11535.       end
  11536.       else
  11537.     {$ENDIF DrawHWAcc}
  11538.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11539.           Dest.Draw(X, Y, FRect, FSurface, Transparent);
  11540.   end;
  11541. end;
  11542.  
  11543. procedure TPictureCollectionItem.DrawFlipHV(Dest: TDirectDrawSurface; X, Y,
  11544.   PatternIndex: Integer);
  11545. var
  11546.   flrc: trect;
  11547. begin
  11548.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11549.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11550.     begin
  11551.       flrc.Left := frect.right; flrc.Right := frect.left;
  11552.       flrc.Top := fpicture.height - frect.top;
  11553.       flrc.Bottom := fpicture.height - frect.bottom;
  11554.       Dest.Draw(X, Y, Flrc, FSurface, Transparent);
  11555.     end;
  11556. end;
  11557.  
  11558. procedure TPictureCollectionItem.DrawFlipH(Dest: TDirectDrawSurface; X, Y,
  11559.   PatternIndex: Integer);
  11560. var
  11561.   flrc: TRect;
  11562. begin
  11563.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11564.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11565.     begin
  11566.       if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Dest) then
  11567.       begin
  11568.         flrc := frect;
  11569.         Dest.MirrorFlip([rmfMirror]);
  11570.       end
  11571.       else
  11572.       begin
  11573.         flrc.Left := fpicture.width - frect.left;
  11574.         flrc.Right := fpicture.width - frect.right;
  11575.         flrc.Top := frect.Top; flrc.Bottom := frect.Bottom;
  11576.       end;
  11577.       Dest.Draw(X, Y, Flrc, FSurface, Transparent);
  11578.     end;
  11579. end;
  11580.  
  11581. procedure TPictureCollectionItem.DrawFlipV(Dest: TDirectDrawSurface; X, Y,
  11582.   PatternIndex: Integer);
  11583. var
  11584.   flrc: TRect;
  11585. begin
  11586.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11587.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11588.     begin
  11589.       if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Dest) then
  11590.       begin
  11591.         flrc := frect;
  11592.         Dest.MirrorFlip([rmfFlip]);
  11593.       end
  11594.       else
  11595.       begin
  11596.         flrc.Left := frect.left; flrc.Right := frect.right;
  11597.         flrc.Top := fpicture.height - frect.top;
  11598.         flrc.Bottom := fpicture.height - frect.bottom;
  11599.       end;
  11600.       Dest.Draw(X, Y, Flrc, FSurface, Transparent);
  11601.     end;
  11602. end;
  11603.  
  11604. procedure TPictureCollectionItem.StretchDraw(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer);
  11605. begin
  11606.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11607.   begin
  11608.     {$IFDEF DrawHWAcc}
  11609.     with TPictureCollection(Self.GetPictureCollection) do
  11610.       if FDXDraw.CheckD3D(Dest) then
  11611.       begin
  11612.         FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, DestRect, PatternIndex, rtDraw{$IFNDEF VER4UP}, $FF{$ENDIF})
  11613.       end
  11614.       else
  11615.     {$ENDIF DrawHWAcc}
  11616.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11617.           Dest.StretchDraw(DestRect, FRect, FSurface, Transparent);
  11618.   end;
  11619. end;
  11620.  
  11621. procedure TPictureCollectionItem.DrawAdd(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  11622.   Alpha: Integer);
  11623. begin
  11624.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11625.   begin
  11626.     with TPictureCollection(Self.GetPictureCollection) do
  11627.       if FDXDraw.CheckD3D(Dest) then
  11628.       begin
  11629.         FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, DestRect, PatternIndex, rtAdd, Alpha)
  11630.       end
  11631.       else
  11632.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11633.           Dest.DrawAdd(DestRect, FRect, FSurface, Transparent, Alpha);
  11634.   end;
  11635. end;
  11636.  
  11637. procedure TPictureCollectionItem.DrawAddCol(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  11638.   Color: Integer; Alpha: Integer);
  11639. begin
  11640.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11641.   begin
  11642.     with TPictureCollection(Self.GetPictureCollection) do
  11643.       if FDXDraw.CheckD3D(Dest) then
  11644.       begin
  11645.         FDXDraw.FD2D.D2DRenderCol(Self, DestRect, PatternIndex, Color, rtAdd, Alpha)
  11646.       end
  11647.       else
  11648.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11649.           Dest.DrawAdd(DestRect, FRect, FSurface, Transparent, Alpha);
  11650.   end;
  11651. end;
  11652.  
  11653. procedure TPictureCollectionItem.DrawAlpha(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  11654.   Alpha: Integer);
  11655. begin
  11656.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11657.   begin
  11658.     with TPictureCollection(Self.GetPictureCollection) do
  11659.       if FDXDraw.CheckD3D(Dest) then
  11660.       begin
  11661.         FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, DestRect, PatternIndex, rtBlend, Alpha)
  11662.       end
  11663.       else
  11664.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11665.           Dest.DrawAlpha(DestRect, FRect, FSurface, Transparent, Alpha);
  11666.   end;
  11667. end;
  11668.  
  11669. procedure TPictureCollectionItem.DrawSub(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  11670.   Alpha: Integer);
  11671. begin
  11672.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11673.   begin
  11674.     with TPictureCollection(Self.GetPictureCollection) do
  11675.       if FDXDraw.CheckD3D(Dest) then
  11676.       begin
  11677.         FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, DestRect, PatternIndex, rtSub, Alpha)
  11678.       end
  11679.       else
  11680.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11681.           Dest.DrawSub(DestRect, FRect, FSurface, Transparent, Alpha);
  11682.   end;
  11683. end;
  11684.  
  11685. procedure TPictureCollectionItem.DrawSubCol(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  11686.   Color: Integer; Alpha: Integer);
  11687. begin
  11688.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11689.   begin
  11690.     with TPictureCollection(Self.GetPictureCollection) do
  11691.       if FDXDraw.CheckD3D(Dest) then
  11692.       begin
  11693.         FDXDraw.FD2D.D2DRenderCol(Self, DestRect, PatternIndex, Color, rtSub, Alpha)
  11694.       end
  11695.       else
  11696.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11697.           Dest.DrawSub(DestRect, FRect, FSurface, Transparent, Alpha);
  11698.   end;
  11699. end;
  11700.  
  11701. procedure TPictureCollectionItem.DrawRotate(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11702.   CenterX, CenterY: Double; Angle: single);
  11703. begin
  11704.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11705.   begin
  11706.     with TPictureCollection(Self.GetPictureCollection) do
  11707.       if FDXDraw.CheckD3D(Dest) then
  11708.       begin
  11709.         //X,Y................ Center of rotation
  11710.         //Width,Height....... Picture
  11711.         //PatternIndex....... Piece of picture
  11712.         //CenterX,CenterY ... Center of rotation on picture
  11713.         //Angle.............. Angle of rotation
  11714.         FDXDraw.FD2D.D2DRenderRotate(Self, X, Y, Width, Height, PatternIndex, rtDraw, CenterX, CenterY, Angle{$IFNDEF VER4UP}, $FF{$ENDIF});
  11715.       end
  11716.       else
  11717.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11718.           Dest.DrawRotate(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle);
  11719.   end;
  11720. end;
  11721.  
  11722. procedure TPictureCollectionItem.DrawRotateAdd(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11723.   CenterX, CenterY: Double; Angle: single; Alpha: Integer);
  11724. begin
  11725.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11726.   begin
  11727.     with TPictureCollection(Self.GetPictureCollection) do
  11728.       if FDXDraw.CheckD3D(Dest) then
  11729.       begin
  11730.         FDXDraw.FD2D.D2DRenderRotate(Self, X, Y, Width, Height, PatternIndex, rtAdd, CenterX, CenterY, Angle, Alpha);
  11731.       end
  11732.       else
  11733.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11734.           Dest.DrawRotateAdd(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  11735.   end;
  11736. end;
  11737.  
  11738. procedure TPictureCollectionItem.DrawRotateAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11739.   CenterX, CenterY: Double; Angle: single; Alpha: Integer);
  11740. begin
  11741.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11742.   begin
  11743.     with TPictureCollection(Self.GetPictureCollection) do
  11744.       if FDXDraw.CheckD3D(Dest) then
  11745.       begin
  11746.         FDXDraw.FD2D.D2DRenderRotate(Self, X, Y, Width, Height, PatternIndex, rtBlend, CenterX, CenterY, Angle, Alpha);
  11747.       end
  11748.       else
  11749.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11750.           Dest.DrawRotateAlpha(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  11751.   end;
  11752. end;
  11753.  
  11754. procedure TPictureCollectionItem.DrawRotateSub(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11755.   CenterX, CenterY: Double; Angle: single; Alpha: Integer);
  11756. begin
  11757.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11758.   begin
  11759.     with TPictureCollection(Self.GetPictureCollection) do
  11760.       if FDXDraw.CheckD3D(Dest) then
  11761.       begin
  11762.         FDXDraw.FD2D.D2DRenderRotate(Self, X, Y, Width, Height, PatternIndex, rtSub, CenterX, CenterY, Angle, Alpha);
  11763.       end
  11764.       else
  11765.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11766.           Dest.DrawRotateSub(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  11767.   end;
  11768. end;
  11769.  
  11770. procedure TPictureCollectionItem.DrawWaveX(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11771.   amp, Len, ph: Integer);
  11772. begin
  11773.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11774.   begin
  11775.     with TPictureCollection(Self.GetPictureCollection) do
  11776.       if FDXDraw.CheckD3D(Dest) then
  11777.       begin
  11778.         FDXDraw.FD2D.D2DRenderWaveX(Self, X, Y, Width, Height, PatternIndex, rtDraw,
  11779.           Transparent, amp, Len, ph{$IFNDEF VER4UP}, $FF{$ENDIF});
  11780.       end
  11781.       else
  11782.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11783.           Dest.DrawWaveX(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph);
  11784.   end;
  11785. end;
  11786.  
  11787. procedure TPictureCollectionItem.DrawWaveXAdd(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11788.   amp, Len, ph, Alpha: Integer);
  11789. begin
  11790.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11791.   begin
  11792.     with TPictureCollection(Self.GetPictureCollection) do
  11793.       if FDXDraw.CheckD3D(Dest) then
  11794.       begin
  11795.         FDXDraw.FD2D.D2DRenderWaveX(Self, X, Y, Width, Height, PatternIndex, rtAdd,
  11796.           Transparent, amp, Len, ph, Alpha);
  11797.       end
  11798.       else
  11799.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11800.           Dest.DrawWaveXAdd(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
  11801.   end;
  11802. end;
  11803.  
  11804. procedure TPictureCollectionItem.DrawWaveXAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11805.   amp, Len, ph, Alpha: Integer);
  11806. begin
  11807.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11808.   begin
  11809.     with TPictureCollection(Self.GetPictureCollection) do
  11810.       if FDXDraw.CheckD3D(Dest) then
  11811.       begin
  11812.         FDXDraw.FD2D.D2DRenderWaveX(Self, X, Y, Width, Height, PatternIndex, rtBlend,
  11813.           Transparent, amp, Len, ph, Alpha);
  11814.       end
  11815.       else
  11816.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11817.           Dest.DrawWaveXAlpha(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
  11818.   end;
  11819. end;
  11820.  
  11821. procedure TPictureCollectionItem.DrawWaveXSub(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11822.   amp, Len, ph, Alpha: Integer);
  11823. begin
  11824.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11825.   begin
  11826.     with TPictureCollection(Self.GetPictureCollection) do
  11827.       if FDXDraw.CheckD3D(Dest) then
  11828.       begin
  11829.         FDXDraw.FD2D.D2DRenderWaveX(Self, X, Y, Width, Height, PatternIndex, rtSub,
  11830.           Transparent, amp, Len, ph, Alpha);
  11831.       end
  11832.       else
  11833.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11834.           Dest.DrawWaveXSub(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
  11835.   end;
  11836. end;
  11837.  
  11838. procedure TPictureCollectionItem.DrawWaveYSub(Dest: TDirectDrawSurface; X, Y,
  11839.   Width, Height, PatternIndex, amp, Len, ph, Alpha: Integer);
  11840. begin
  11841.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11842.   begin
  11843.     with TPictureCollection(Self.GetPictureCollection) do
  11844.       if FDXDraw.CheckD3D(Dest) then
  11845.       begin
  11846.         FDXDraw.FD2D.D2DRenderWaveY(Self, X, Y, Width, Height, PatternIndex, rtSub,
  11847.           Transparent, amp, Len, ph, Alpha);
  11848.       end
  11849.       {there is not software version}
  11850.   end;
  11851. end;
  11852.  
  11853. procedure TPictureCollectionItem.DrawWaveY(Dest: TDirectDrawSurface; X, Y,
  11854.   Width, Height, PatternIndex, amp, Len, ph: Integer);
  11855. begin
  11856.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11857.   begin
  11858.     with TPictureCollection(Self.GetPictureCollection) do
  11859.       if FDXDraw.CheckD3D(Dest) then
  11860.       begin
  11861.         FDXDraw.FD2D.D2DRenderWaveY(Self, X, Y, Width, Height, PatternIndex, rtDraw,
  11862.           Transparent, amp, Len, ph{$IFNDEF VER4UP}, $FF{$ENDIF});
  11863.       end
  11864.   end;
  11865. end;
  11866.  
  11867. procedure TPictureCollectionItem.DrawWaveYAdd(Dest: TDirectDrawSurface; X, Y,
  11868.   Width, Height, PatternIndex, amp, Len, ph, Alpha: Integer);
  11869. begin
  11870.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11871.   begin
  11872.     with TPictureCollection(Self.GetPictureCollection) do
  11873.       if FDXDraw.CheckD3D(Dest) then
  11874.       begin
  11875.         FDXDraw.FD2D.D2DRenderWaveY(Self, X, Y, Width, Height, PatternIndex, rtAdd,
  11876.           Transparent, amp, Len, ph, Alpha);
  11877.       end
  11878.   end;
  11879. end;
  11880.  
  11881. procedure TPictureCollectionItem.DrawWaveYAlpha(Dest: TDirectDrawSurface; X, Y,
  11882.   Width, Height, PatternIndex, amp, Len, ph, Alpha: Integer);
  11883. begin
  11884.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11885.   begin
  11886.     with TPictureCollection(Self.GetPictureCollection) do
  11887.       if FDXDraw.CheckD3D(Dest) then
  11888.       begin
  11889.         FDXDraw.FD2D.D2DRenderWaveY(Self, X, Y, Width, Height, PatternIndex, rtBlend,
  11890.           Transparent, amp, Len, ph, Alpha);
  11891.       end
  11892.   end;
  11893. end;
  11894.  
  11895. procedure TPictureCollectionItem.Finalize;
  11896. begin
  11897.   if FInitialized then
  11898.   begin
  11899.     FInitialized := False;
  11900.     ClearSurface;
  11901.   end;
  11902. end;
  11903.  
  11904. procedure TPictureCollectionItem.UpdateTag;
  11905.  
  11906.   function AddSurface(const SrcRect: TRect): TDirectDrawSurface;
  11907.   begin
  11908.     Result := TDirectDrawSurface.Create(PictureCollection.DXDraw.DDraw);
  11909.     FSurfaceList.Add(Result);
  11910.  
  11911.     Result.SystemMemory := FSystemMemory;
  11912.     Result.LoadFromGraphicRect(FPicture.Graphic, 0, 0, SrcRect);
  11913.     Result.TransparentColor := Result.ColorMatch(FTransparentColor);
  11914.   end;
  11915.  
  11916. var
  11917.   x, y, x2, y2: Integer;
  11918.   BlockWidth, BlockHeight, BlockXCount, BlockYCount: Integer;
  11919.   Width2, Height2: Integer;
  11920.   TempSurface : TDirectDrawSurface;
  11921. begin
  11922.   if FPicture.Graphic = nil then Exit;
  11923. //  ClearSurface;
  11924.   Width2 := Width + SkipWidth;
  11925.   Height2 := Height + SkipHeight;
  11926.  
  11927.   if (Width = FPicture.Width) and (Height = FPicture.Height) then
  11928.   begin
  11929.     with TPictureCollectionItemPattern.Create(FPatterns) do
  11930.     begin
  11931.      TempSurface := TDirectDrawSurface.Create(PictureCollection.DXDraw.DDraw);
  11932.      FSurface := TempSurface;
  11933.       FRect := Bounds(0, 0, FPicture.Width, FPicture.Height);
  11934.      TempSurface.LoadFromGraphicRect(FPicture.Graphic, 0, 0, FRect);
  11935.      TempSurface.SystemMemory := FSystemMemory;
  11936.      TempSurface.TransparentColor := TempSurface.ColorMatch(FTransparentColor);
  11937.      FSurfaceList.Add(TempSurface);
  11938.     end;
  11939.   end
  11940.  else
  11941.  if FSystemMemory then
  11942.   begin
  11943.     AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
  11944.     for y := 0 to (FPicture.Height + SkipHeight) div Height2 - 1 do
  11945.       for x := 0 to (FPicture.Width + SkipWidth) div Width2 - 1 do
  11946.         with TPictureCollectionItemPattern.Create(FPatterns) do
  11947.         begin
  11948.           FRect := Bounds(x * Width2, y * Height2, Width, Height);
  11949.           FSurface := TDirectDrawSurface(FSurfaceList[0]);
  11950.         end;
  11951.   end
  11952.   else
  11953.   begin
  11954.     {  Load to a video memory with dividing the image.   }
  11955.     BlockWidth := Min(((SurfaceDivWidth + Width2 - 1) div Width2) * Width2,
  11956.       (FPicture.Width + SkipWidth) div Width2 * Width2);
  11957.     BlockHeight := Min(((SurfaceDivHeight + Height2 - 1) div Height2) * Height2,
  11958.       (FPicture.Height + SkipHeight) div Height2 * Height2);
  11959.  
  11960.     if (BlockWidth = 0) or (BlockHeight = 0) then Exit;
  11961.  
  11962.     BlockXCount := (FPicture.Width + BlockWidth - 1) div BlockWidth;
  11963.     BlockYCount := (FPicture.Height + BlockHeight - 1) div BlockHeight;
  11964.  
  11965.     for y := 0 to BlockYCount - 1 do
  11966.       for x := 0 to BlockXCount - 1 do
  11967.       begin
  11968.         x2 := Min(BlockWidth, Max(FPicture.Width - x * BlockWidth, 0));
  11969.         if x2 = 0 then x2 := BlockWidth;
  11970.  
  11971.         y2 := Min(BlockHeight, Max(FPicture.Height - y * BlockHeight, 0));
  11972.         if y2 = 0 then y2 := BlockHeight;
  11973.  
  11974.         AddSurface(Bounds(x * BlockWidth, y * BlockHeight, x2, y2));
  11975.       end;
  11976.  
  11977.     for y := 0 to (FPicture.Height + SkipHeight) div Height2 - 1 do
  11978.       for x := 0 to (FPicture.Width + SkipWidth) div Width2 - 1 do
  11979.       begin
  11980.         x2 := x * Width2;
  11981.         y2 := y * Height2;
  11982.         with TPictureCollectionItemPattern.Create(FPatterns) do
  11983.         begin
  11984.           FRect := Bounds(x2 - (x2 div BlockWidth * BlockWidth), y2 - (y2 div BlockHeight * BlockHeight), Width, Height);
  11985.           FSurface := TDirectDrawSurface(FSurfaceList[(x2 div BlockWidth) + ((y2 div BlockHeight) * BlockXCount)]);
  11986.         end;
  11987.       end;
  11988.   end;
  11989. end;
  11990.  
  11991. procedure TPictureCollectionItem.Initialize;
  11992. begin
  11993.   Finalize;
  11994.   FInitialized := PictureCollection.Initialized;
  11995.   UpdateTag;
  11996. end;
  11997.  
  11998. procedure TPictureCollectionItem.Restore;
  11999.  
  12000.   function AddSurface(const SrcRect: TRect): TDirectDrawSurface;
  12001.   begin
  12002.     Result := TDirectDrawSurface.Create(PictureCollection.DXDraw.DDraw);
  12003.     FSurfaceList.Add(Result);
  12004.  
  12005.     Result.SystemMemory := FSystemMemory;
  12006.     Result.LoadFromGraphicRect(FPicture.Graphic, 0, 0, SrcRect);
  12007.     Result.TransparentColor := Result.ColorMatch(FTransparentColor);
  12008.   end;
  12009.  
  12010. var
  12011.   x, y, x2, y2: Integer;
  12012.   BlockWidth, BlockHeight, BlockXCount, BlockYCount: Integer;
  12013.   Width2, Height2: Integer;
  12014. begin
  12015.   if FPicture.Graphic = nil then Exit;
  12016.  
  12017.   if not FInitialized then
  12018.   begin
  12019.     if PictureCollection.Initialized then
  12020.       Initialize;
  12021.     if not FInitialized then Exit;
  12022.   end;
  12023.  
  12024.   ClearSurface;
  12025.  
  12026.   Width2 := Width + SkipWidth;
  12027.   Height2 := Height + SkipHeight;
  12028.  
  12029.   if (Width = FPicture.Width) and (Height = FPicture.Height) then
  12030.   begin
  12031.     {  There is no necessity of division because the number of patterns is one.   }
  12032.     with TPictureCollectionItemPattern.Create(FPatterns) do
  12033.     begin
  12034.       FRect := Bounds(0, 0, FPicture.Width, FPicture.Height);
  12035.       FSurface := AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
  12036.     end;
  12037.   end
  12038.   else
  12039.   if FSystemMemory then
  12040.   begin
  12041.     {  Load to a system memory.  }
  12042.     AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
  12043.  
  12044.     for y := 0 to (FPicture.Height + SkipHeight) div Height2 - 1 do
  12045.       for x := 0 to (FPicture.Width + SkipWidth) div Width2 - 1 do
  12046.         with TPictureCollectionItemPattern.Create(FPatterns) do
  12047.         begin
  12048.           FRect := Bounds(x * Width2, y * Height2, Width, Height);
  12049.           FSurface := TDirectDrawSurface(FSurfaceList[0]);
  12050.         end;
  12051.   end
  12052.   else
  12053.   begin
  12054.     {  Load to a video memory with dividing the image.   }
  12055.     BlockWidth := Min(((SurfaceDivWidth + Width2 - 1) div Width2) * Width2,
  12056.       (FPicture.Width + SkipWidth) div Width2 * Width2);
  12057.     BlockHeight := Min(((SurfaceDivHeight + Height2 - 1) div Height2) * Height2,
  12058.       (FPicture.Height + SkipHeight) div Height2 * Height2);
  12059.  
  12060.     if (BlockWidth = 0) or (BlockHeight = 0) then Exit;
  12061.  
  12062.     BlockXCount := (FPicture.Width + BlockWidth - 1) div BlockWidth;
  12063.     BlockYCount := (FPicture.Height + BlockHeight - 1) div BlockHeight;
  12064.  
  12065.     for y := 0 to BlockYCount - 1 do
  12066.       for x := 0 to BlockXCount - 1 do
  12067.       begin
  12068.         x2 := Min(BlockWidth, Max(FPicture.Width - x * BlockWidth, 0));
  12069.         if x2 = 0 then x2 := BlockWidth;
  12070.  
  12071.         y2 := Min(BlockHeight, Max(FPicture.Height - y * BlockHeight, 0));
  12072.         if y2 = 0 then y2 := BlockHeight;
  12073.  
  12074.         AddSurface(Bounds(x * BlockWidth, y * BlockHeight, x2, y2));
  12075.       end;
  12076.  
  12077.     for y := 0 to (FPicture.Height + SkipHeight) div Height2 - 1 do
  12078.       for x := 0 to (FPicture.Width + SkipWidth) div Width2 - 1 do
  12079.       begin
  12080.         x2 := x * Width2;
  12081.         y2 := y * Height2;
  12082.         with TPictureCollectionItemPattern.Create(FPatterns) do
  12083.         begin
  12084.           FRect := Bounds(x2 - (x2 div BlockWidth * BlockWidth), y2 - (y2 div BlockHeight * BlockHeight), Width, Height);
  12085.           FSurface := TDirectDrawSurface(FSurfaceList[(x2 div BlockWidth) + ((y2 div BlockHeight) * BlockXCount)]);
  12086.         end;
  12087.       end;
  12088.   end;
  12089.   {Code added for better compatibility}
  12090.   {When is any picture changed, then all textures cleared and list have to reloaded}
  12091.   with PictureCollection do
  12092.     {$IFDEF D3D_deprecated}if (do3D in FDXDraw.Options) then{$ENDIF}
  12093.       if AsSigned(FDXDraw.FD2D) then
  12094.         if Assigned(FDXDraw.FD2D.D2DTextures) then
  12095.           FDXDraw.FD2D.D2DTextures.D2DPruneAllTextures;
  12096. end;
  12097.  
  12098. procedure TPictureCollectionItem.SetPicture(Value: TPicture);
  12099. begin
  12100.   FPicture.Assign(Value);
  12101. end;
  12102.  
  12103. procedure TPictureCollectionItem.SetTransparentColor(Value: TColor);
  12104. var
  12105.   i: Integer;
  12106.   Surface: TDirectDrawSurface;
  12107. begin
  12108.   if Value <> FTransparentColor then
  12109.   begin
  12110.     FTransparentColor := Value;
  12111.     for i := 0 to FSurfaceList.Count - 1 do
  12112.     begin
  12113.       try
  12114.         Surface := TDirectDrawSurface(FSurfaceList[i]);
  12115.         Surface.TransparentColor := Surface.ColorMatch(FTransparentColor);
  12116.       except
  12117.       end;
  12118.     end;
  12119.   end;
  12120. end;
  12121.  
  12122. procedure TPictureCollectionItem.DrawAlphaCol(Dest: TDirectDrawSurface;
  12123.   const DestRect: TRect; PatternIndex, Color, Alpha: Integer);
  12124. begin
  12125.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12126.   begin
  12127.     with TPictureCollection(Self.GetPictureCollection) do
  12128.       if FDXDraw.CheckD3D(Dest) then
  12129.       begin
  12130.         FDXDraw.FD2D.D2DRenderCol(Self, DestRect, PatternIndex, color, rtBlend, Alpha)
  12131.       end else
  12132.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  12133.           Dest.DrawAlpha(DestRect, FRect, FSurface, Transparent, Alpha);
  12134.   end;
  12135. end;
  12136.  
  12137. procedure TPictureCollectionItem.DrawRotateAddCol(Dest: TDirectDrawSurface;
  12138.   X, Y, Width, Height, PatternIndex: Integer; CenterX, CenterY: Double;
  12139.   Angle: single; Color, Alpha: Integer);
  12140. begin
  12141.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12142.   begin
  12143.     with TPictureCollection(Self.GetPictureCollection) do
  12144.       if FDXDraw.CheckD3D(Dest) then
  12145.       begin
  12146.         FDXDraw.FD2D.D2DRenderRotateModeCol(Self, rtAdd, X, Y, Width,
  12147.           Height, PatternIndex, CenterX, CenterY, Angle, Color, Alpha);
  12148.       end
  12149.       else
  12150.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  12151.           Dest.DrawRotateAdd(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  12152.   end;
  12153. end;
  12154.  
  12155. procedure TPictureCollectionItem.DrawRotateAlphaCol(Dest: TDirectDrawSurface;
  12156.   X, Y, Width, Height, PatternIndex: Integer; CenterX, CenterY: Double;
  12157.   Angle: single; Color, Alpha: Integer);
  12158. begin
  12159.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12160.   begin
  12161.     with TPictureCollection(Self.GetPictureCollection) do
  12162.       if FDXDraw.CheckD3D(Dest) then
  12163.       begin
  12164.         FDXDraw.FD2D.D2DRenderRotateModeCol(Self, rtBlend, X, Y, Width,
  12165.           Height, PatternIndex, CenterX, CenterY, Angle, Color, Alpha);
  12166.       end
  12167.       else
  12168.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  12169.           Dest.DrawRotateAlpha(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  12170.   end;
  12171. end;
  12172.  
  12173. procedure TPictureCollectionItem.DrawRotateSubCol(Dest: TDirectDrawSurface;
  12174.   X, Y, Width, Height, PatternIndex: Integer; CenterX, CenterY: Double;
  12175.   Angle: single; Color, Alpha: Integer);
  12176. begin
  12177.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12178.   begin
  12179.     with TPictureCollection(Self.GetPictureCollection) do
  12180.       if FDXDraw.CheckD3D(Dest) then
  12181.       begin
  12182.         FDXDraw.FD2D.D2DRenderRotateModeCol(Self, rtSub, X, Y, Width,
  12183.           Height, PatternIndex, CenterX, CenterY, Angle, Color, Alpha);
  12184.       end
  12185.       else
  12186.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  12187.           Dest.DrawRotateSub(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  12188.   end;
  12189. end;
  12190.  
  12191. procedure TPictureCollectionItem.DrawCol(Dest: TDirectDrawSurface;
  12192.   const DestRect, SourceRect: TRect; PatternIndex: Integer; Faded: Boolean;
  12193.   RenderType: TRenderType; Color, Specular: Integer; Alpha: Integer);
  12194. begin
  12195.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12196.   begin
  12197.     with TPictureCollection(Self.GetPictureCollection) do
  12198.       if FDXDraw.CheckD3D(Dest) then
  12199.       begin
  12200.         FDXDraw.FD2D.D2DRenderColoredPartition(Self, DestRect, PatternIndex,
  12201.           Color, Specular, Faded, SourceRect, RenderType,
  12202.           Alpha)
  12203.       end
  12204.       else
  12205.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  12206.           Dest.DrawAlpha(DestRect, FRect, FSurface, Transparent, Alpha);
  12207.   end;
  12208. end;
  12209.  
  12210. procedure TPictureCollectionItem.DrawRect(Dest: TDirectDrawSurface;
  12211.   const DestRect, SourceRect: TRect; PatternIndex: Integer;
  12212.   RenderType: TRenderType; Transparent: Boolean; Alpha: Integer);
  12213. begin
  12214.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12215.   begin
  12216.     {$IFDEF DrawHWAcc}
  12217.     with TPictureCollection(Self.GetPictureCollection) do
  12218.       if FDXDraw.CheckD3D(Dest) then
  12219.       begin
  12220.         FDXDraw.FD2D.D2DRender(Self, DestRect, PatternIndex, SourceRect, RenderType, Alpha);
  12221.       end
  12222.       else
  12223.     {$ENDIF DrawHWAcc}
  12224.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  12225.         begin
  12226.           case RenderType of
  12227.             rtDraw: Dest.StretchDraw(DestRect, SourceRect, FSurface, Transparent);
  12228.               //Dest.Draw(DestRect.Left, DestRect.Top, SourceRect, FSurface, Transparent);
  12229.             rtBlend: Dest.DrawAlpha(DestRect, SourceRect, FSurface, Transparent, Alpha);
  12230.             rtAdd: Dest.DrawAdd(DestRect, SourceRect, FSurface, Transparent, Alpha);
  12231.             rtSub: Dest.DrawSub(DestRect, SourceRect, FSurface, Transparent, Alpha);
  12232.           end;
  12233.         end;
  12234.   end;
  12235. end;
  12236.  
  12237. {  TPictureCollection  }
  12238.  
  12239. constructor TPictureCollection.Create(AOwner: TPersistent);
  12240. begin
  12241.   inherited Create(TPictureCollectionItem);
  12242.   FOwner := AOwner;
  12243. end;
  12244.  
  12245. destructor TPictureCollection.Destroy;
  12246. begin
  12247.   Finalize;
  12248.   inherited Destroy;
  12249. end;
  12250.  
  12251. function TPictureCollection.GetItem(Index: Integer): TPictureCollectionItem;
  12252. begin
  12253.   Result := TPictureCollectionItem(inherited Items[Index]);
  12254. end;
  12255.  
  12256. function TPictureCollection.GetOwner: TPersistent;
  12257. begin
  12258.   Result := FOwner;
  12259. end;
  12260.  
  12261. function TPictureCollection.Find(const Name: string): TPictureCollectionItem;
  12262. var
  12263.   i: Integer;
  12264. begin
  12265.   i := IndexOf(Name);
  12266.   if i = -1 then
  12267.     raise EPictureCollectionError.CreateFmt(SImageNotFound, [Name]);
  12268.   Result := Items[i];
  12269. end;
  12270.  
  12271. procedure TPictureCollection.Finalize;
  12272. var
  12273.   i: Integer;
  12274. begin
  12275.   try
  12276.     for i := 0 to Count - 1 do
  12277.       Items[i].Finalize;
  12278.   finally
  12279.     FDXDraw := nil;
  12280.   end;
  12281. end;
  12282.  
  12283. procedure TPictureCollection.InitializeImages(DXDraw: TCustomDXDraw; Id : Integer);
  12284. var
  12285.   i: Integer;
  12286. begin
  12287.   If id = -1 Then
  12288.    Finalize;
  12289.   FDXDraw := DXDraw;
  12290.  
  12291.   if not Initialized then
  12292.     raise EPictureCollectionError.CreateFmt(SCannotInitialized, [ClassName]);
  12293.  
  12294.   for i := 0 to Count - 1 do
  12295.    If (id = -1) or (id = i) Then
  12296.     Items[i].Initialize;
  12297. end;
  12298.  
  12299. procedure TPictureCollection.Initialize(DXDraw: TCustomDXDraw);
  12300. var
  12301.   i: Integer;
  12302. begin
  12303.   Finalize;
  12304.   FDXDraw := DXDraw;
  12305.  
  12306.   if not Initialized then
  12307.     raise EPictureCollectionError.CreateFmt(SCannotInitialized, [ClassName]);
  12308.  
  12309.   for i := 0 to Count - 1 do
  12310.     Items[i].Initialize;
  12311. end;
  12312.  
  12313. function TPictureCollection.Initialized: Boolean;
  12314. begin
  12315.   Result := (FDXDraw <> nil) and (FDXDraw.Initialized);
  12316. end;
  12317.  
  12318. procedure TPictureCollection.Restore;
  12319. var
  12320.   i: Integer;
  12321. begin
  12322.   for i := 0 to Count - 1 do
  12323.     Items[i].Restore;
  12324. end;
  12325.  
  12326. procedure TPictureCollection.MakeColorTable;
  12327. var
  12328.   UseColorTable: array[0..255] of Boolean;
  12329.   PaletteCount: Integer;
  12330.  
  12331.   procedure SetColor(Index: Integer; Col: TRGBQuad);
  12332.   begin
  12333.     UseColorTable[Index] := True;
  12334.     ColorTable[Index] := Col;
  12335.     Inc(PaletteCount);
  12336.   end;
  12337.  
  12338.   procedure AddColor(Col: TRGBQuad);
  12339.   var
  12340.     i: Integer;
  12341.   begin
  12342.     for i := 0 to 255 do
  12343.       if UseColorTable[i] then
  12344.         if DWORD(ColorTable[i]) = DWORD(Col) then
  12345.           Exit;
  12346.     for i := 0 to 255 do
  12347.       if not UseColorTable[i] then
  12348.       begin
  12349.         SetColor(i, Col);
  12350.         Exit;
  12351.       end;
  12352.   end;
  12353.  
  12354.   procedure AddDIB(DIB: TDIB);
  12355.   var
  12356.     i: Integer;
  12357.   begin
  12358.     if DIB.BitCount > 8 then Exit;
  12359.  
  12360.     for i := 0 to 255 do
  12361.       AddColor(DIB.ColorTable[i]);
  12362.   end;
  12363.  
  12364.   procedure AddGraphic(Graphic: TGraphic);
  12365.   var
  12366.     i, n: Integer;
  12367.     PaletteEntries: TPaletteEntries;
  12368.   begin
  12369.     if Graphic.Palette <> 0 then
  12370.     begin
  12371.       n := GetPaletteEntries(Graphic.Palette, 0, 256, PaletteEntries);
  12372.       for i := 0 to n - 1 do
  12373.         AddColor(PaletteEntryToRGBQuad(PaletteEntries[i]));
  12374.     end;
  12375.   end;
  12376.  
  12377. var
  12378.   i: Integer;
  12379. begin
  12380.   FillChar(UseColorTable, SizeOf(UseColorTable), 0);
  12381.   FillChar(ColorTable, SizeOf(ColorTable), 0);
  12382.  
  12383.   PaletteCount := 0;
  12384.  
  12385.   {  The system color is included.  }
  12386.   SetColor(0, RGBQuad(0, 0, 0));
  12387.   SetColor(1, RGBQuad(128, 0, 0));
  12388.   SetColor(2, RGBQuad(0, 128, 0));
  12389.   SetColor(3, RGBQuad(128, 128, 0));
  12390.   SetColor(4, RGBQuad(0, 0, 128));
  12391.   SetColor(5, RGBQuad(128, 0, 128));
  12392.   SetColor(6, RGBQuad(0, 128, 128));
  12393.   SetColor(7, RGBQuad(192, 192, 192));
  12394.  
  12395.   SetColor(248, RGBQuad(128, 128, 128));
  12396.   SetColor(249, RGBQuad(255, 0, 0));
  12397.   SetColor(250, RGBQuad(0, 255, 0));
  12398.   SetColor(251, RGBQuad(255, 255, 0));
  12399.   SetColor(252, RGBQuad(0, 0, 255));
  12400.   SetColor(253, RGBQuad(255, 0, 255));
  12401.   SetColor(254, RGBQuad(0, 255, 255));
  12402.   SetColor(255, RGBQuad(255, 255, 255));
  12403.  
  12404.   for i := 0 to Count - 1 do
  12405.     if Items[i].Picture.Graphic <> nil then
  12406.     begin
  12407.       if Items[i].Picture.Graphic is TDIB then
  12408.         AddDIB(TDIB(Items[i].Picture.Graphic))
  12409.       else
  12410.         AddGraphic(Items[i].Picture.Graphic);
  12411.       if PaletteCount = 256 then Break;
  12412.     end;
  12413. end;
  12414.  
  12415. procedure TPictureCollection.DefineProperties(Filer: TFiler);
  12416. begin
  12417.   inherited DefineProperties(Filer);
  12418.   Filer.DefineBinaryProperty('ColorTable', ReadColorTable, WriteColorTable, True);
  12419. end;
  12420.  
  12421. type
  12422.   TPictureCollectionComponent = class(TComponent)
  12423.   private
  12424.     FList: TPictureCollection;
  12425.   published
  12426.     property List: TPictureCollection read FList write FList;
  12427.   end;
  12428.  
  12429. procedure TPictureCollection.LoadFromFile(const FileName: string);
  12430. var
  12431.   Stream: TFileStream;
  12432. begin
  12433.   Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  12434.   try
  12435.     LoadFromStream(Stream);
  12436.   finally
  12437.     Stream.Free;
  12438.   end;
  12439. end;
  12440.  
  12441. procedure TPictureCollection.LoadFromStream(Stream: TStream);
  12442. var
  12443.   Component: TPictureCollectionComponent;
  12444. begin
  12445.   Clear;
  12446.   Component := TPictureCollectionComponent.Create(nil);
  12447.   try
  12448.     Component.FList := Self;
  12449.     Stream.ReadComponentRes(Component);
  12450.  
  12451.     if Initialized then
  12452.     begin
  12453.       Initialize(FDXDraw);
  12454.       Restore;
  12455.     end;
  12456.   finally
  12457.     Component.Free;
  12458.   end;
  12459. end;
  12460.  
  12461. procedure TPictureCollection.SaveToFile(const FileName: string);
  12462. var
  12463.   Stream: TFileStream;
  12464. begin
  12465.   Stream := TFileStream.Create(FileName, fmCreate);
  12466.   try
  12467.     SaveToStream(Stream);
  12468.   finally
  12469.     Stream.Free;
  12470.   end;
  12471. end;
  12472.  
  12473. procedure TPictureCollection.SaveToStream(Stream: TStream);
  12474. var
  12475.   Component: TPictureCollectionComponent;
  12476. begin
  12477.   Component := TPictureCollectionComponent.Create(nil);
  12478.   try
  12479.     Component.FList := Self;
  12480.     Stream.WriteComponentRes('DelphiXPictureCollection', Component);
  12481.   finally
  12482.     Component.Free;
  12483.   end;
  12484. end;
  12485.  
  12486. procedure TPictureCollection.ReadColorTable(Stream: TStream);
  12487. begin
  12488.   Stream.ReadBuffer(ColorTable, SizeOf(ColorTable));
  12489. end;
  12490.  
  12491. procedure TPictureCollection.WriteColorTable(Stream: TStream);
  12492. begin
  12493.   Stream.WriteBuffer(ColorTable, SizeOf(ColorTable));
  12494. end;
  12495.  
  12496. {  TCustomDXImageList  }
  12497.  
  12498. constructor TCustomDXImageList.Create(AOnwer: TComponent);
  12499. begin
  12500.   inherited Create(AOnwer);
  12501.   FItems := TPictureCollection.Create(Self);
  12502. end;
  12503.  
  12504. destructor TCustomDXImageList.Destroy;
  12505. begin
  12506.   DXDraw := nil;
  12507.   FItems.Free;
  12508.   inherited Destroy;
  12509. end;
  12510.  
  12511. procedure TCustomDXImageList.Notification(AComponent: TComponent;
  12512.   Operation: TOperation);
  12513. begin
  12514.   inherited Notification(AComponent, Operation);
  12515.   if (Operation = opRemove) and (DXDraw = AComponent) then
  12516.     DXDraw := nil;
  12517. end;
  12518.  
  12519. procedure TCustomDXImageList.DXDrawNotifyEvent(Sender: TCustomDXDraw;
  12520.   NotifyType: TDXDrawNotifyType);
  12521. begin
  12522.   case NotifyType of
  12523.     dxntDestroying: DXDraw := nil;
  12524.     dxntInitialize: FItems.Initialize(Sender);
  12525.     dxntFinalize: FItems.Finalize;
  12526.     dxntRestore: FItems.Restore;
  12527.   end;
  12528. end;
  12529.  
  12530. procedure TCustomDXImageList.SetDXDraw(Value: TCustomDXDraw);
  12531. begin
  12532.   if FDXDraw <> nil then
  12533.     FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
  12534.  
  12535.   FDXDraw := Value;
  12536.  
  12537.   if FDXDraw <> nil then
  12538.     FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
  12539. end;
  12540.  
  12541. procedure TCustomDXImageList.SetItems(Value: TPictureCollection);
  12542. begin
  12543.   FItems.Assign(Value);
  12544. end;
  12545.  
  12546. {  TDirectDrawOverlay  }
  12547.  
  12548. constructor TDirectDrawOverlay.Create(DDraw: TDirectDraw; TargetSurface: TDirectDrawSurface);
  12549. begin
  12550.   inherited Create;
  12551.   FDDraw := DDraw;
  12552.   FTargetSurface := TargetSurface;
  12553.   FVisible := True;
  12554. end;
  12555.  
  12556. constructor TDirectDrawOverlay.CreateWindowed(WindowHandle: HWND);
  12557. {$IFDEF D3D_deprecated}
  12558. const
  12559.   PrimaryDesc: TDDSurfaceDesc = (
  12560.     dwSize: SizeOf(PrimaryDesc);
  12561.     dwFlags: DDSD_CAPS;
  12562.     ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE)
  12563.     );
  12564. {$ELSE}
  12565. var
  12566.   PrimaryDesc: TDDSurfaceDesc2;
  12567. {$ENDIF}
  12568. begin
  12569.   FDDraw2 := TDirectDraw.CreateEx(nil, False);
  12570.   if FDDraw2.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.SetCooperativeLevel(WindowHandle, DDSCL_NORMAL) <> DD_OK then
  12571.     raise EDirectDrawOverlayError.CreateFmt(SCannotInitialized, [SOverlay]);
  12572.  
  12573.   FTargetSurface2 := TDirectDrawSurface.Create(FDDraw2);
  12574.   {$IFNDEF D3D_deprecated}
  12575.   FillChar(PrimaryDesc, SizeOf(PrimaryDesc), 0);
  12576.   PrimaryDesc.dwSize := SizeOf(PrimaryDesc);
  12577.   PrimaryDesc.dwFlags := DDSD_CAPS;
  12578.   PrimaryDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
  12579.   {$ENDIF}
  12580.   if not FTargetSurface2.CreateSurface(PrimaryDesc) then
  12581.     raise EDirectDrawOverlayError.CreateFmt(SCannotInitialized, [SOverlay]);
  12582.  
  12583.   Create(FDDraw2, FTargetSurface2);
  12584. end;
  12585.  
  12586. destructor TDirectDrawOverlay.Destroy;
  12587. begin
  12588.   Finalize;
  12589.   FTargetSurface2.Free;
  12590.   FDDraw2.Free;
  12591.   inherited Destroy;
  12592. end;
  12593.  
  12594. procedure TDirectDrawOverlay.Finalize;
  12595. begin
  12596.   FBackSurface.Free; FBackSurface := nil;
  12597.   FSurface.Free; FSurface := nil;
  12598. end;
  12599.  
  12600. procedure TDirectDrawOverlay.Initialize(const SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF});
  12601. {$IFDEF D3D_deprecated}
  12602. const
  12603.   BackBufferCaps: TDDSCaps = (dwCaps: DDSCAPS_BACKBUFFER);
  12604. var
  12605.   DDSurface: IDirectDrawSurface;
  12606. {$ELSE}
  12607. var
  12608.   DDSurface: IDirectDrawSurface7;
  12609.   BackBufferCaps: TDDSCaps2;
  12610. {$ENDIF}
  12611. begin
  12612.   Finalize;
  12613.   try
  12614.     FSurface := TDirectDrawSurface.Create(FDDraw);
  12615.     if not FSurface.CreateSurface(SurfaceDesc) then
  12616.       raise EDirectDrawOverlayError.CreateFmt(SCannotInitialized, [SOverlay]);
  12617.  
  12618.     FBackSurface := TDirectDrawSurface.Create(FDDraw);
  12619.     {$IFNDEF D3D_deprecated}
  12620.     BackBufferCaps.dwCaps := DDSCAPS_BACKBUFFER;
  12621.     {$ENDIF}
  12622.     if SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_FLIP <> 0 then
  12623.     begin
  12624.       if FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetAttachedSurface(BackBufferCaps, DDSurface) = DD_OK then
  12625.         FBackSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := DDSurface;
  12626.     end
  12627.     else
  12628.       FBackSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF};
  12629.  
  12630.     if FVisible then
  12631.       SetOverlayRect(FOverlayRect)
  12632.     else
  12633.       FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.UpdateOverlay(PRect(nil), FTargetSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, PRect(nil), DDOVER_HIDE, PDDOverlayFX(nil));
  12634.   except
  12635.     Finalize;
  12636.     raise;
  12637.   end;
  12638. end;
  12639.  
  12640. procedure TDirectDrawOverlay.Flip;
  12641. begin
  12642.   if FSurface = nil then Exit;
  12643.  
  12644.   if FSurface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_FLIP <> 0 then
  12645.     FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.Flip(nil, DDFLIP_WAIT);
  12646. end;
  12647.  
  12648. procedure TDirectDrawOverlay.SetOverlayColorKey(Value: TColor);
  12649. begin
  12650.   FOverlayColorKey := Value;
  12651.   if FSurface <> nil then
  12652.     SetOverlayRect(FOverlayRect);
  12653. end;
  12654.  
  12655. procedure TDirectDrawOverlay.SetOverlayRect(const Value: TRect);
  12656. var
  12657.   DestRect, SrcRect: TRect;
  12658.   XScaleRatio, YScaleRatio: Integer;
  12659.   OverlayFX: TDDOverlayFX;
  12660.   OverlayFlags: DWORD;
  12661. begin
  12662.   FOverlayRect := Value;
  12663.   if (FSurface <> nil) and FVisible then
  12664.   begin
  12665.     DestRect := FOverlayRect;
  12666.     SrcRect.Left := 0;
  12667.     SrcRect.Top := 0;
  12668.     SrcRect.Right := FSurface.SurfaceDesc.dwWidth;
  12669.     SrcRect.Bottom := FSurface.SurfaceDesc.dwHeight;
  12670.  
  12671.     OverlayFlags := DDOVER_SHOW;
  12672.  
  12673.     FillChar(OverlayFX, SizeOf(OverlayFX), 0);
  12674.     OverlayFX.dwSize := SizeOf(OverlayFX);
  12675.  
  12676.     {  Scale rate limitation  }
  12677.     XScaleRatio := (DestRect.right - DestRect.left) * 1000 div (SrcRect.right - SrcRect.left);
  12678.     YScaleRatio := (DestRect.bottom - DestRect.top) * 1000 div (SrcRect.bottom - SrcRect.top);
  12679.  
  12680.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH <> 0)
  12681.       and (FDDraw.DriverCaps.dwMinOverlayStretch <> 0)
  12682.       and (XScaleRatio < Integer(FDDraw.DriverCaps.dwMinOverlayStretch))
  12683.     then
  12684.     begin
  12685.       DestRect.Right := DestRect.Left + (Integer(FSurface.SurfaceDesc.dwWidth) * (Integer(FDDraw.DriverCaps.dwMinOverlayStretch) + 1)) div 1000;
  12686.     end;
  12687.  
  12688.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH <> 0)
  12689.       and (FDDraw.DriverCaps.dwMaxOverlayStretch <> 0)
  12690.       and (XScaleRatio > Integer(FDDraw.DriverCaps.dwMaxOverlayStretch))
  12691.     then
  12692.     begin
  12693.       DestRect.Right := DestRect.Left + (Integer(FSurface.SurfaceDesc.dwWidth) * (Integer(FDDraw.DriverCaps.dwMaxOverlayStretch) + 999)) div 1000;
  12694.     end;
  12695.  
  12696.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH <> 0)
  12697.       and (FDDraw.DriverCaps.dwMinOverlayStretch <> 0)
  12698.       and (YScaleRatio < Integer(FDDraw.DriverCaps.dwMinOverlayStretch))
  12699.     then
  12700.     begin
  12701.       DestRect.Bottom := DestRect.Top + (Integer(FSurface.SurfaceDesc.dwHeight) * (Integer(FDDraw.DriverCaps.dwMinOverlayStretch) + 1)) div 1000;
  12702.     end;
  12703.  
  12704.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH <> 0)
  12705.       and (FDDraw.DriverCaps.dwMaxOverlayStretch <> 0)
  12706.       and (YScaleRatio > Integer(FDDraw.DriverCaps.dwMaxOverlayStretch))
  12707.     then
  12708.     begin
  12709.       DestRect.Bottom := DestRect.Top + (Integer(FSurface.SurfaceDesc.dwHeight) * (Integer(FDDraw.DriverCaps.dwMaxOverlayStretch) + 999)) div 1000;
  12710.     end;
  12711.  
  12712.     {  Clipping at forwarding destination  }
  12713.     XScaleRatio := (DestRect.Right - DestRect.Left) * 1000 div (SrcRect.Right - SrcRect.Left);
  12714.     YScaleRatio := (DestRect.Bottom - DestRect.Top) * 1000 div (SrcRect.Bottom - SrcRect.Top);
  12715.  
  12716.     if DestRect.Top < 0 then
  12717.     begin
  12718.       SrcRect.Top := -DestRect.Top * 1000 div YScaleRatio;
  12719.       DestRect.Top := 0;
  12720.     end;
  12721.  
  12722.     if DestRect.Left < 0 then
  12723.     begin
  12724.       SrcRect.Left := -DestRect.Left * 1000 div XScaleRatio;
  12725.       DestRect.Left := 0;
  12726.     end;
  12727.  
  12728.     if DestRect.Right > Integer(FTargetSurface.SurfaceDesc.dwWidth) then
  12729.     begin
  12730.       SrcRect.Right := Integer(FSurface.SurfaceDesc.dwWidth) - ((DestRect.Right - Integer(FTargetSurface.SurfaceDesc.dwWidth)) * 1000 div XScaleRatio);
  12731.       DestRect.Right := FTargetSurface.SurfaceDesc.dwWidth;
  12732.     end;
  12733.  
  12734.     if DestRect.Bottom > Integer(FTargetSurface.SurfaceDesc.dwHeight) then
  12735.     begin
  12736.       SrcRect.Bottom := Integer(FSurface.SurfaceDesc.dwHeight) - ((DestRect.Bottom - Integer(FTargetSurface.SurfaceDesc.dwHeight)) * 1000 div YScaleRatio);
  12737.       DestRect.Bottom := FTargetSurface.SurfaceDesc.dwHeight;
  12738.     end;
  12739.  
  12740.     {  Forwarding former arrangement  }
  12741.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNBOUNDARYSRC <> 0) and (FDDraw.DriverCaps.dwAlignBoundarySrc <> 0) then
  12742.     begin
  12743.       SrcRect.Left := (SrcRect.Left + Integer(FDDraw.DriverCaps.dwAlignBoundarySrc) div 2) div
  12744.         Integer(FDDraw.DriverCaps.dwAlignBoundarySrc) * Integer(FDDraw.DriverCaps.dwAlignBoundarySrc);
  12745.     end;
  12746.  
  12747.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNSIZESRC <> 0) and (FDDraw.DriverCaps.dwAlignSizeSrc <> 0) then
  12748.     begin
  12749.       SrcRect.Right := SrcRect.Left + (SrcRect.Right - SrcRect.Left + Integer(FDDraw.DriverCaps.dwAlignSizeSrc) div 2) div
  12750.         Integer(FDDraw.DriverCaps.dwAlignSizeSrc) * Integer(FDDraw.DriverCaps.dwAlignSizeSrc);
  12751.     end;
  12752.  
  12753.     {  Forwarding destination arrangement  }
  12754.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNBOUNDARYDEST <> 0) and (FDDraw.DriverCaps.dwAlignBoundaryDest <> 0) then
  12755.     begin
  12756.       DestRect.Left := (DestRect.Left + Integer(FDDraw.DriverCaps.dwAlignBoundaryDest) div 2) div
  12757.         Integer(FDDraw.DriverCaps.dwAlignBoundaryDest) * Integer(FDDraw.DriverCaps.dwAlignBoundaryDest);
  12758.     end;
  12759.  
  12760.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNSIZEDEST <> 0) and (FDDraw.DriverCaps.dwAlignSizeDest <> 0) then
  12761.     begin
  12762.       DestRect.Right := DestRect.Left + (DestRect.Right - DestRect.Left) div
  12763.         Integer(FDDraw.DriverCaps.dwAlignSizeDest) * Integer(FDDraw.DriverCaps.dwAlignSizeDest);
  12764.     end;
  12765.  
  12766.     {  Color key setting  }
  12767.     if FDDraw.DriverCaps.dwCKeyCaps and DDCKEYCAPS_DESTOVERLAY <> 0 then
  12768.     begin
  12769.       OverlayFX.dckDestColorkey.dwColorSpaceLowValue := FTargetSurface.ColorMatch(FOverlayColorKey);
  12770.       OverlayFX.dckDestColorkey.dwColorSpaceHighValue := OverlayFX.dckDestColorkey.dwColorSpaceLowValue;
  12771.  
  12772.       OverlayFlags := OverlayFlags or (DDOVER_KEYDESTOVERRIDE or DDOVER_DDFX);
  12773.     end;
  12774.  
  12775.     FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.UpdateOverlay(@SrcRect, FTargetSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, @DestRect, OverlayFlags, @OverlayFX);
  12776.   end;
  12777. end;
  12778.  
  12779. procedure TDirectDrawOverlay.SetVisible(Value: Boolean);
  12780. begin
  12781.   FVisible := False;
  12782.   if FSurface <> nil then
  12783.   begin
  12784.     if FVisible then
  12785.       SetOverlayRect(FOverlayRect)
  12786.     else
  12787.       FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.UpdateOverlay(PRect(nil), FTargetSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, PRect(nil), DDOVER_HIDE, PDDOverlayFX(nil));
  12788.   end;
  12789. end;
  12790.  
  12791. { TDXFont }
  12792.  
  12793. constructor TDXFont.Create(AOwner: TComponent);
  12794. begin
  12795.   inherited Create(AOwner);
  12796. end;
  12797.  
  12798. destructor TDXFont.Destroy;
  12799. begin
  12800.   inherited Destroy;
  12801. end;
  12802.  
  12803. procedure TDXFont.Notification(AComponent: TComponent; Operation: TOperation);
  12804. begin
  12805.   inherited Notification(AComponent, Operation);
  12806.   if (Operation = opRemove) and (AComponent = FDXImageList) then
  12807.   begin
  12808.     FDXImageList := nil;
  12809.   end;
  12810. end; {Notification}
  12811.  
  12812. procedure TDXFont.SetFont(const Value: string);
  12813. begin
  12814.   FFont := Value;
  12815.   if assigned(FDXImageList) then
  12816.   begin
  12817.     FFontIndex := FDXImageList.items.IndexOf(FFont); { find font once }
  12818.     fOffset := FDXImageList.Items[FFontIndex].PatternWidth;
  12819.   end;
  12820. end;
  12821.  
  12822. procedure TDXFont.SetFontIndex(const Value: Integer);
  12823. begin
  12824.   FFontIndex := Value;
  12825.   if assigned(FDXImageList) then
  12826.   begin
  12827.     FFont := FDXImageList.Items[FFontIndex].Name;
  12828.     fOffset := FDXImageList.Items[FFontIndex].PatternWidth;
  12829.   end;
  12830. end;
  12831.  
  12832. procedure TDXFont.TextOut(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string);
  12833. var
  12834.   loop, letter: Integer;
  12835.   UpperText: string;
  12836. begin
  12837.   if not assigned(FDXImageList) then
  12838.     exit;
  12839.   Offset := FDXImageList.Items[FFontIndex].PatternWidth;
  12840.   UpperText := AnsiUppercase(text);
  12841.   for loop := 1 to Length(UpperText) do
  12842.   begin
  12843.     letter := AnsiPos(UpperText[loop], Alphabet) - 1;
  12844.     if letter < 0 then letter := 30;
  12845.     FDXImageList.items[FFontIndex].Draw(DirectDrawSurface, x + Offset * loop, y, letter);
  12846.   end; { loop }
  12847. end;
  12848.  
  12849. { TDXPowerFontEffectsParameters }
  12850.  
  12851. procedure TDXPowerFontEffectsParameters.SetAlphaValue(
  12852.   const Value: Integer);
  12853. begin
  12854.   FAlphaValue := Value;
  12855. end;
  12856.  
  12857. procedure TDXPowerFontEffectsParameters.SetAngle(const Value: Integer);
  12858. begin
  12859.   FAngle := Value;
  12860. end;
  12861.  
  12862. procedure TDXPowerFontEffectsParameters.SetCenterX(const Value: Integer);
  12863. begin
  12864.   FCenterX := Value;
  12865. end;
  12866.  
  12867. procedure TDXPowerFontEffectsParameters.SetCenterY(const Value: Integer);
  12868. begin
  12869.   FCenterY := Value;
  12870. end;
  12871.  
  12872. procedure TDXPowerFontEffectsParameters.SetHeight(const Value: Integer);
  12873. begin
  12874.   FHeight := Value;
  12875. end;
  12876.  
  12877. procedure TDXPowerFontEffectsParameters.SetWAmplitude(
  12878.   const Value: Integer);
  12879. begin
  12880.   FWAmplitude := Value;
  12881. end;
  12882.  
  12883. procedure TDXPowerFontEffectsParameters.SetWidth(const Value: Integer);
  12884. begin
  12885.   FWidth := Value;
  12886. end;
  12887.  
  12888. procedure TDXPowerFontEffectsParameters.SetWLenght(const Value: Integer);
  12889. begin
  12890.   FWLenght := Value;
  12891. end;
  12892.  
  12893. procedure TDXPowerFontEffectsParameters.SetWPhase(const Value: Integer);
  12894. begin
  12895.   FWPhase := Value;
  12896. end;
  12897.  
  12898. { TDXPowerFont }
  12899.  
  12900. constructor TDXPowerFont.Create(AOwner: TComponent);
  12901. begin
  12902.   inherited Create(AOwner);
  12903.   FUseEnterChar := True;
  12904.   FEnterCharacter := '|<';
  12905.   FAlphabets := PowerAlphaBet;
  12906.   FTextOutType := ttNormal;
  12907.   FTextOutEffect := teNormal;
  12908.   FEffectsParameters := TDXPowerFontEffectsParameters.Create;
  12909. end;
  12910.  
  12911. destructor TDXPowerFont.Destroy;
  12912. begin
  12913.   inherited Destroy;
  12914. end;
  12915.  
  12916. procedure TDXPowerFont.SetAlphabets(const Value: string);
  12917. begin
  12918.   if FDXImageList <> nil then
  12919.     if Length(Value) > FDXImageList.Items[FFontIndex].PatternCount - 1 then Exit;
  12920.   FAlphabets := Value;
  12921. end;
  12922.  
  12923. procedure TDXPowerFont.SetEnterCharacter(const Value: string);
  12924. begin
  12925.   if Length(Value) >= 2 then Exit;
  12926.   FEnterCharacter := Value;
  12927. end;
  12928.  
  12929. procedure TDXPowerFont.SetFont(const Value: string);
  12930. begin
  12931.   FFont := Value;
  12932.   if FDXImageList <> nil then
  12933.   begin
  12934.     FFontIndex := FDXImageList.Items.IndexOf(FFont); // Find font once...
  12935.     Offset := FDXImageList.Items[FFontIndex].PatternWidth;
  12936.  
  12937.     FEffectsParameters.Width := FDXImageList.Items[FFontIndex].PatternWidth;
  12938.     FEffectsParameters.Height := FDXImageList.Items[FFontIndex].PatternHeight;
  12939.   end;
  12940. end;
  12941.  
  12942. procedure TDXPowerFont.SetFontIndex(const Value: Integer);
  12943. begin
  12944.   FFontIndex := Value;
  12945.   if FDXImageList <> nil then
  12946.   begin
  12947.     FFont := FDXImageList.Items[FFontIndex].Name;
  12948.     Offset := FDXImageList.Items[FFontIndex].PatternWidth;
  12949.  
  12950.     FEffectsParameters.Width := FDXImageList.Items[FFontIndex].PatternWidth;
  12951.     FEffectsParameters.Height := FDXImageList.Items[FFontIndex].PatternHeight;
  12952.   end;
  12953. end;
  12954.  
  12955. procedure TDXPowerFont.SetEffectsParameters(const Value: TDXPowerFontEffectsParameters);
  12956. begin
  12957.   FEffectsParameters := Value;
  12958. end;
  12959.  
  12960. procedure TDXPowerFont.SetTextOutEffect(const Value: TDXPowerFontTextOutEffect);
  12961. begin
  12962.   FTextOutEffect := Value;
  12963. end;
  12964.  
  12965. procedure TDXPowerFont.SetTextOutType(const Value: TDXPowerFontTextOutType);
  12966. begin
  12967.   FTextOutType := Value;
  12968. end;
  12969.  
  12970. procedure TDXPowerFont.SetUseEnterChar(const Value: Boolean);
  12971. begin
  12972.   FUseEnterChar := Value;
  12973. end;
  12974.  
  12975. function TDXPowerFont.TextOutFast(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string): Boolean;
  12976. var
  12977.   Loop, Letter: Integer;
  12978.   txt: string;
  12979. begin
  12980.   Result := False;
  12981.   if FDXImageList = nil then Exit;
  12982.         // modified
  12983.   case FTextOutType of
  12984.     ttNormal: Txt := Text;
  12985.     ttUpperCase: Txt := AnsiUpperCase(Text);
  12986.     ttLowerCase: Txt := AnsiLowerCase(Text);
  12987.   end;
  12988.   Offset := FDXImageList.Items[FFontIndex].PatternWidth;
  12989.   Loop := 1;
  12990.   while (Loop <= Length(Text)) do
  12991.   begin
  12992.     Letter := AnsiPos(txt[Loop], FAlphabets); // modified
  12993.     if (Letter > 0) and (Letter < FDXImageList.Items[FFontIndex].PatternCount - 1) then
  12994.       FDXImageList.Items[FFontIndex].Draw(DirectDrawSurface, X + (Offset * Loop), Y, Letter - 1);
  12995.     Inc(Loop);
  12996.   end;
  12997.   Result := True;
  12998. end;
  12999.  
  13000. function TDXPowerFont.TextOut(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string): Boolean;
  13001. var
  13002.   Loop, Letter: Integer;
  13003.   FCalculatedEnters, EnterHeghit, XLoop: Integer;
  13004.   DoTextOut: Boolean;
  13005.   Txt: string;
  13006.   Rect: TRect;
  13007. begin
  13008.   Result := False;
  13009.   if FDXImageList = nil then Exit;
  13010.   Txt := Text;
  13011.   DoTextOut := True;
  13012.   if Assigned(FBeforeTextOut) then FBeforeTextOut(Self, Txt, DoTextOut);
  13013.   if not DoTextOut then Exit;
  13014.   // modified
  13015.   case FTextOutType of
  13016.     ttNormal: Txt := Text;
  13017.     ttUpperCase: Txt := AnsiUpperCase(Text);
  13018.     ttLowerCase: Txt := AnsiLowerCase(Text);
  13019.   end;
  13020.   Offset := FDXImageList.Items[FFontIndex].PatternWidth;
  13021.   FCalculatedEnters := 0;
  13022.   EnterHeghit := FDXImageList.Items[FFontIndex].PatternHeight;
  13023.   XLoop := 0;
  13024.   Loop := 1;
  13025.   while (Loop <= Length(Txt)) do
  13026.   begin
  13027.     if FUseEnterChar then
  13028.     begin
  13029.       if Txt[Loop] = FEnterCharacter[1] then begin Inc(FCalculatedEnters); Inc(Loop); end;
  13030.       if Txt[Loop] = FEnterCharacter[2] then begin Inc(FCalculatedEnters); XLoop := 0; {-FCalculatedEnters;} Inc(Loop); end;
  13031.     end;
  13032.     Letter := AnsiPos(Txt[Loop], FAlphabets); // modified
  13033.  
  13034.     if (Letter > 0) and (Letter < FDXImageList.Items[FFontIndex].PatternCount - 1) then
  13035.       case FTextOutEffect of
  13036.         teNormal: FDXImageList.Items[FFontIndex].Draw(DirectDrawSurface, X + (Offset * XLoop), Y + (FCalculatedEnters * EnterHeghit), Letter - 1);
  13037.         teRotat: FDXImageList.Items[FFontIndex].DrawRotate(DirectDrawSurface, X + (Offset * XLoop), Y + (FCalculatedEnters * EnterHeghit), FEffectsParameters.Width, FEffectsParameters.Height, Letter - 1, FEffectsParameters.CenterX, FEffectsParameters.CenterY, FEffectsParameters.Angle);
  13038.         teAlphaBlend:
  13039.           begin
  13040.             Rect.Left := X + (Offset * XLoop);
  13041.             Rect.Top := Y + (FCalculatedEnters * EnterHeghit);
  13042.             Rect.Right := Rect.Left + FEffectsParameters.Width;
  13043.             Rect.Bottom := Rect.Top + FEffectsParameters.Height;
  13044.  
  13045.             FDXImageList.Items[FFontIndex].DrawAlpha(DirectDrawSurface, Rect, Letter - 1, FEffectsParameters.AlphaValue);
  13046.           end;
  13047.         teWaveX: FDXImageList.Items[FFontIndex].DrawWaveX(DirectDrawSurface, X + (Offset * XLoop), Y + (FCalculatedEnters * EnterHeghit), FEffectsParameters.Width, FEffectsParameters.Height, Letter - 1, FEffectsParameters.WAmplitude, FEffectsParameters.WLenght, FEffectsParameters.WPhase);
  13048.       end;
  13049.     Inc(Loop);
  13050.     Inc(XLoop);
  13051.   end;
  13052.   if Assigned(FAfterTextOut) then FAfterTextOut(Self, Txt);
  13053.   Result := True;
  13054. end;
  13055.  
  13056. //---------------------------------------------------------------------------
  13057. {
  13058. Main code supported hardware acceleration by videoadapteur
  13059.  *  Copyright (c) 2004-2010 Jaro Benes
  13060.  *  All Rights Reserved
  13061.  *  Version 1.09
  13062.  *  D2D Hardware module - main implementation part
  13063.  *  web site: www.micrel.cz/Dx
  13064.  *  e-mail: delphix_d2d@micrel.cz
  13065. }
  13066.  
  13067. constructor TD2DTextures.Create(DDraw: TCustomDXDraw);
  13068. begin
  13069.   //inherited;
  13070.   FDDraw := DDraw; //reload DDraw
  13071. {$IFNDEF VER4UP}
  13072.   TexLen := 0;
  13073.   Texture := nil;
  13074. {$ELSE}
  13075.   SetLength(Texture, 0);
  13076. {$ENDIF}
  13077. end;
  13078.  
  13079. destructor TD2DTextures.Destroy;
  13080. var
  13081.   I: Integer;
  13082. begin
  13083.   if Assigned(Texture) then
  13084.     {$IFDEF VER4UP}
  13085.     for I := Low(Texture) to High(Texture) do
  13086.     begin
  13087.       Texture[I].D2DTexture.Free;
  13088.       {$IFDEF VIDEOTEX}
  13089.       if Assigned(Texture[I].VDIB) then
  13090.         Texture[I].VDIB.Free;
  13091.       {$ENDIF}
  13092.     end;
  13093.     {$ELSE}
  13094.     for I := 0 to TexLen - 1 do
  13095.     begin
  13096.       Texture[I].D2DTexture.Free;
  13097.       {$IFDEF VIDEOTEX}
  13098.       if Assigned(Texture[I].VDIB) then
  13099.         Texture[I].VDIB.Free;
  13100.       {$ENDIF}
  13101.     end;
  13102.     {$ENDIF}
  13103.   inherited;
  13104. end;
  13105.  
  13106. function TD2DTextures.GetD2DMaxTextures: Integer;
  13107. begin
  13108.   Result := {$IFDEF VER4UP}Length(Texture){$ELSE}TexLen{$ENDIF};
  13109. end;
  13110.  
  13111. procedure TD2DTextures.SaveTextures(path: string);
  13112. var I: Integer;
  13113. begin
  13114.   if Texture <> nil then
  13115.     {$IFDEF VER4UP}
  13116.     if Length(Texture) > 0 then
  13117.       for I := Low(Texture) to High(Texture) do
  13118.     {$ELSE}
  13119.     if TexLen > 0 then
  13120.       for I := 0 to TexLen - 1 do
  13121.     {$ENDIF}
  13122.         Texture[I].D2DTexture.FImage.SaveToFile(path + Texture[I].Name + '.dxt');
  13123. end;
  13124.  
  13125. procedure TD2DTextures.SetD2DMaxTextures(const Value: Integer);
  13126. begin
  13127.   if Value > 0 then
  13128.   {$IFDEF VER4UP}
  13129.     SetLength(Texture, Value)
  13130.   {$ELSE}
  13131.     Inc(TexLen);
  13132.   if Texture = nil then
  13133.     Texture := AllocMem(SizeOf(TTextureRec))
  13134.   else begin
  13135.       {alokuj pamet}
  13136.     ReallocMem(Texture, TexLen * SizeOf(TTextureRec));
  13137.   end;
  13138.   {$ENDIF}
  13139. end;
  13140.  
  13141. function TD2DTextures.Find(byName: string): Integer;
  13142. var I: Integer;
  13143. begin
  13144.   Result := -1;
  13145.   if Texture <> nil then
  13146.     {$IFDEF VER4UP}
  13147.     if Length(Texture) > 0 then
  13148.       for I := Low(Texture) to High(Texture) do
  13149.         if AnsiUpperCase(Texture[I].Name) = AnsiUpperCase(byName) then
  13150.         begin
  13151.           Result := I;
  13152.           Exit;
  13153.         end;
  13154.     {$ELSE}
  13155.     if TexLen > 0 then
  13156.       for I := 0 to TexLen - 1 do
  13157.         if AnsiUpperCase(Texture[I].Name) = AnsiUpperCase(byName) then
  13158.         begin
  13159.           Result := I;
  13160.           Exit;
  13161.         end;
  13162.     {$ENDIF}
  13163. end;
  13164.  
  13165. function TD2DTextures.GetTextureByName(const byName: string): TDirect3DTexture2;
  13166. begin
  13167.   Result := nil;
  13168.   if Assigned(Texture) then
  13169.     Result := Texture[Find(byName)].D2DTexture;
  13170. end;
  13171.  
  13172. function TD2DTextures.GetTextureByIndex(const byIndex: Integer): TDirect3DTexture2;
  13173. begin
  13174.   Result := nil;
  13175.   {$IFNDEF VER4UP}
  13176.   if Assigned(Texture) and (byIndex >= 0) and (byIndex <= (TexLen - 1)) then
  13177.     Result := Texture[byIndex].D2DTexture;
  13178.   {$ELSE}
  13179.   if Assigned(Texture) and (byIndex in [0..High(Texture)]) then
  13180.     Result := Texture[byIndex].D2DTexture;
  13181.   {$ENDIF}
  13182. end;
  13183.  
  13184. function TD2DTextures.GetTextureNameByIndex(const byIndex: Integer): string;
  13185. begin
  13186.   Result := '';
  13187.   {$IFNDEF VER4UP}
  13188.   if Assigned(Texture) and (byIndex >= 0) and (byIndex <= (TexLen - 1)) then
  13189.     Result := Texture[byIndex].Name;
  13190.   {$ELSE}
  13191.   if Assigned(Texture) and (byIndex in [0..High(Texture)]) then
  13192.     Result := Texture[byIndex].Name;
  13193.   {$ENDIF}
  13194. end;
  13195.  
  13196. function TD2DTextures.Count: Integer;
  13197. begin
  13198.   Result := 0;
  13199.   if Assigned(Texture) then
  13200.   {$IFNDEF VER4UP}
  13201.     Result := TexLen;
  13202.   {$ELSE}
  13203.     Result := High(Texture) + 1;
  13204.   {$ENDIF}
  13205. end;
  13206.  
  13207. procedure TD2DTextures.D2DPruneAllTextures;
  13208. var I: Integer;
  13209. begin
  13210.   if not Assigned(Texture) then Exit;
  13211.   {$IFDEF VER4UP}
  13212.   for I := Low(Texture) to High(Texture) do
  13213.   {$ELSE}
  13214.   for I := 0 to TexLen - 1 do
  13215.   {$ENDIF}
  13216.   begin
  13217.     Texture[I].D2DTexture.Free;
  13218.     {$IFDEF VIDEOTEX}
  13219.     if Assigned(Texture[I].VDIB) then
  13220.       Texture[I].VDIB.Free;
  13221.     {$ENDIF}
  13222.   end;
  13223.   {$IFDEF VER4UP}
  13224.   SetLength(Texture, 0);
  13225.   {$ELSE}
  13226.   TexLen := 0;
  13227.   {$ENDIF}
  13228. end;
  13229.  
  13230. procedure TD2DTextures.D2DFreeTextures;
  13231. var I: Integer;
  13232. begin
  13233.   if not Assigned(Texture) then Exit;
  13234.   {$IFDEF VER4UP}
  13235.   for I := Low(Texture) to High(Texture) do
  13236.   {$ELSE}
  13237.   for I := 0 to TexLen - 1 do
  13238.   {$ENDIF}
  13239.   begin
  13240.     Texture[I].D2DTexture.Free;
  13241.     {$IFDEF VIDEOTEX}
  13242.     if Assigned(Texture[I].VDIB) then
  13243.       Texture[I].VDIB.Free;
  13244.     {$ENDIF}  
  13245.   end;
  13246.   {$IFNDEF VER4UP}
  13247.   FreeMem(Texture, TexLen * SizeOf(TTextureRec));
  13248.   Texture := nil;
  13249.   {$ENDIF}
  13250. end;
  13251.  
  13252. procedure TD2DTextures.D2DPruneTextures;
  13253. begin
  13254.   if {$IFDEF VER4UP}Length(Texture){$ELSE}TexLen{$ENDIF} > maxTexBlock then
  13255.   begin
  13256.     D2DPruneAllTextures
  13257.   end;
  13258. end;
  13259.  
  13260. procedure TD2DTextures.SizeAdjust(var DIB: TDIB; var FloatX1, FloatY1, FloatX2, FloatY2: Double);
  13261. var
  13262.   X, Y: Integer;
  13263.   tempDIB: TDIB;
  13264. begin {auto-adjust size n^2 for accelerator compatibility}
  13265.   X := 1;
  13266.   repeat
  13267.     X := X * 2;
  13268.   until DIB.Width <= X;
  13269.   Y := 1;
  13270.   repeat
  13271.     Y := Y * 2
  13272.   until DIB.Height <= Y;
  13273.   {$IFDEF FORCE_SQUARE}
  13274.   X := Max(X, Y);
  13275.   Y := X;
  13276.   {$ENDIF}
  13277.   if (X = DIB.Width) and (Y = DIB.Height) then
  13278.   begin
  13279.     if DIB.BitCount = 32 then Exit; {do not touch}
  13280.     {code for correction a DIB.BitCount to 24 bit only}
  13281.     tempDIB := TDIB.Create;
  13282.     try
  13283.       tempDIB.SetSize(X, Y, 24);
  13284.       FillChar(tempDIB.PBits^, tempDIB.Size, 0);
  13285.       tempDIB.Canvas.Draw(0, 0, DIB);
  13286.       DIB.Assign(tempDIB);
  13287.     finally
  13288.       tempDIB.Free;
  13289.     end;
  13290.     Exit;
  13291.   end;
  13292.   tempDIB := TDIB.Create;
  13293.   try
  13294.     if DIB.BitCount = 32 then
  13295.     begin
  13296.       tempDIB.SetSize(X, Y, 32);
  13297.       FillChar(tempDIB.PBits^, tempDIB.Size, 0);
  13298.       //tempDIB.Canvas.Brush.Color := clBlack;
  13299.       //tempDIB.Canvas.FillRect(Bounds(0, 0, X, Y));
  13300.       tempDIB.Canvas.Draw(0, 0, DIB);
  13301. //      if DIB.HasAlphaChannel then
  13302. //        tempDIB.AssignAlphaChannel(DIB);
  13303.     end
  13304.     else
  13305.     begin
  13306.       tempDIB.SetSize(X, Y, 24 {DIB.BitCount}); {bad value for some 16}
  13307.       FillChar(tempDIB.PBits^, tempDIB.Size, 0);
  13308.       //tempDIB.Canvas.Brush.Color := clBlack;
  13309.       //tempDIB.Canvas.FillRect(Bounds(0, 0, X, Y));
  13310.       tempDIB.Canvas.Draw(0, 0, DIB);
  13311.     end;
  13312.     FloatX2 := (1 / tempDIB.Width) * DIB.Width;
  13313.     FloatY2 := (1 / tempDIB.Height) * DIB.Height;
  13314.     DIB.Assign(tempDIB);
  13315.   finally
  13316.     tempDIB.Free;
  13317.   end
  13318. end;
  13319.  
  13320. function TD2DTextures.CanFindTexture(aImage: TPictureCollectionItem): Boolean;
  13321. var I: Integer;
  13322. begin
  13323.   Result := True;
  13324.   {$IFDEF VER4UP}
  13325.   if Length(Texture) > 0 then
  13326.   {$ELSE}
  13327.   if TexLen > 0 then
  13328.   {$ENDIF}
  13329.     for I := 0 to D2DMaxTextures - 1 do
  13330.       if Texture[I].Name = aImage.Name then Exit;
  13331.   Result := False;
  13332. end;
  13333.  
  13334. function TD2DTextures.LoadTextures(aImage: TPictureCollectionItem): Boolean;
  13335. var
  13336.   {$IFNDEF VIDEOTEX}
  13337.   VDIB: TDIB;
  13338.   {$ENDIF}
  13339.   T: TDXTextureImage;
  13340. begin
  13341.   Result := True;
  13342.   try
  13343.     D2DPruneTextures; {up to maxTexBlock textures only}
  13344.     D2DMaxTextures := D2DMaxTextures + 1;
  13345.     if aImage.Name = '' then // FIX: OPTIMIZED
  13346.       aImage.Name := aImage.GetNamePath; {this name is supplement name, when wasn't aImage.Name fill}
  13347.     {$IFDEF VIDEOTEX}Texture[D2DMaxTextures - 1].{$ENDIF}VDIB := TDIB.Create;
  13348.     try
  13349.     with Texture[D2DMaxTextures - 1] do
  13350.     begin
  13351.       VDIB.Assign(aImage.Picture.Graphic);
  13352.       VDIB.Transparent := aImage.Transparent;
  13353.       FloatX1 := 0; FloatY1 := 0; FloatX2 := 1; FloatY2 := 1;
  13354.       SizeAdjust(VDIB, FloatX1, FloatY1, FloatX2, FloatY2);
  13355.       Name := aImage.Name;
  13356.       Width := VDIB.Width;
  13357.       Height := VDIB.Height;
  13358.       if VDIB.HasAlphaChannel then
  13359.       begin
  13360.         DIB2DXT(VDIB, T);
  13361.         T.ImageName := aImage.Name;
  13362.         T.Transparent := aImage.Transparent;
  13363.         D2DTexture := TDirect3DTexture2.Create(FDDraw, T, False);
  13364.         D2DTexture.Transparent := aImage.Transparent;
  13365.         AlphaChannel := True;
  13366.         //**T.Free; DO NOT FREE - surface is lost ** FIX by JB.
  13367.       end
  13368.       else
  13369.       begin
  13370.         D2DTexture := TDirect3DTexture2.Create(FDDraw, VDIB, False);
  13371.         D2DTexture.TransparentColor := DWORD(aImage.TransparentColor);
  13372.         D2DTexture.Surface.TransparentColor := DWORD(aImage.TransparentColor);
  13373.         D2DTexture.Transparent := aImage.Transparent;
  13374.         AlphaChannel := False;
  13375.       end;
  13376.     end;
  13377.     finally
  13378.       {$IFNDEF VIDEOTEX}
  13379.       VDIB.Free;
  13380.       {$ENDIF}
  13381.     end;
  13382.   except
  13383.     D2DMaxTextures := D2DMaxTextures - 1;
  13384.     Result := False;
  13385.   end;
  13386. end;
  13387.  
  13388. {$IFDEF VER4UP}
  13389. function TD2DTextures.CanFindTexture(const TexName: string): Boolean;
  13390. {$ELSE}
  13391. function TD2DTextures.CanFindTexture2(const TexName: string): Boolean;
  13392. {$ENDIF}
  13393. var I: Integer;
  13394. begin
  13395.   Result := True;
  13396. {$IFDEF VER4UP}
  13397.   if Length(Texture) > 0 then
  13398. {$ELSE}
  13399.   if TexLen > 0 then
  13400. {$ENDIF}
  13401.     for I := 0 to D2DMaxTextures - 1 do
  13402.       if Texture[I].Name = TexName then Exit;
  13403.   Result := False;
  13404. end;
  13405.  
  13406. function TD2DTextures.SetTransparentColor(dds: TDirectDrawSurface; PixelColor: Integer; Transparent: Boolean): Integer;
  13407. {Give a speculative transparent color value from DDS}
  13408. var
  13409.   ddck: TDDColorKey;
  13410.   CLL: Integer;
  13411. begin
  13412.   Result := 0;
  13413.   if dds.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  13414.     if dds.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetColorKey(DDCKEY_SRCBLT, ddck) = DD_OK then
  13415.       Result := ddck.dwColorSpaceLowValue;
  13416.   CLL := PixelColor; {have to pick up color from 0,0 pix of DIB}
  13417.   if Transparent then {and must be transparent}
  13418.     if (CLL <> Result) then {when different}
  13419.       Result := CLL; {use our TransparentColor}
  13420. end;
  13421.  
  13422. {$IFDEF VER4UP}
  13423. function TD2DTextures.LoadTextures(dds: TDirectDrawSurface; Transparent: Boolean; asTexName: string): Boolean;
  13424. {$ELSE}
  13425. function TD2DTextures.LoadTextures2(dds: TDirectDrawSurface; Transparent: Boolean; asTexName: string): Boolean;
  13426. {$ENDIF}
  13427. var
  13428.   {$IFNDEF VIDEOTEX}
  13429.   VDIB: TDIB;
  13430.   {$ENDIF}
  13431.   Col: Integer;
  13432.   T: PTextureRec;
  13433. begin
  13434.   Result := True;
  13435.   T := nil;
  13436.   try
  13437.     if dds.Modified then
  13438.     begin
  13439.       {search existing texture and return the pointer}
  13440.       T := Addr(Texture[Find(asTexName)]);
  13441.       {$IFNDEF VIDEOTEX}VDIB := TDIB.Create;{$ENDIF}
  13442.     end
  13443.     else
  13444.     begin
  13445.       D2DPruneTextures; {up to maxTexBlock textures only}
  13446.       D2DMaxTextures := D2DMaxTextures + 1; {next to new space}
  13447.       T := Addr(Texture[D2DMaxTextures - 1]); {is new place}
  13448.       {set name}
  13449.       T.Name := asTexName;
  13450.       {and create video-dib object for store the picture periodically changed}
  13451.       {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB := TDIB.Create;
  13452.       //T.VDIB.PixelFormat := MakeDIBPixelFormat(8, 8, 8);
  13453.     end;
  13454.     try
  13455.       {the dds assigned here}
  13456.       {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Assign(dds);
  13457.       {with full adjustation}
  13458.       T.FloatX1 := 0; T.FloatY1 := 0; T.FloatX2 := 1; T.FloatY2 := 1;
  13459.       SizeAdjust({$IFDEF VIDEOTEX}T.{$ENDIF}VDIB, T.FloatX1, T.FloatY1, T.FloatX2, T.FloatY2);
  13460.       {and store 'changed' values of size here}
  13461.       T.Width := {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Width;
  13462.       T.Height := {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Height;
  13463.       {and it have to set by dds as transparent, when it set up}
  13464.       {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Transparent := Transparent;
  13465.       {get up transparent color}
  13466.       Col := SetTransparentColor(dds, {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Pixels[0, 0], Transparent);
  13467.       if dds.Modified then
  13468.         T.D2DTexture.Load {for minimize time only load as videotexture}
  13469.       else
  13470.         T.D2DTexture := TDirect3DTexture2.Create(FDDraw, {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB, False); {create it}
  13471.       {don't forget set transparent values on texture!}
  13472.       T.D2DTexture.TransparentColor := DWORD(COL);
  13473.       T.D2DTexture.Surface.TransparentColor := DWORD(COL);
  13474.       T.D2DTexture.Transparent := Transparent;
  13475.     finally
  13476.      {$IFNDEF VIDEOTEX}
  13477.       if Assigned(VDIB) then VDIB.Free;
  13478.      {$ENDIF}
  13479.     end;
  13480.   except
  13481.     {eh, sorry, when is not the dds modified, roll back and release last the VDIB}
  13482.     if not dds.Modified then
  13483.       if T <> nil then
  13484.       begin
  13485.         if Assigned({$IFDEF VIDEOTEX}T.{$ENDIF}VDIB) then
  13486.         {$IFNDEF D5UP}
  13487.         begin {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Free; {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB := nil; end;
  13488.         {$ELSE}
  13489.           FreeAndNil({$IFDEF VIDEOTEX}T.{$ENDIF}VDIB);
  13490.         {$ENDIF}
  13491.         if Assigned(T.D2DTexture) then
  13492.         {$IFNDEF D5UP}
  13493.         begin T.D2DTexture.Free; T.D2DTexture := nil; end;
  13494.         {$ELSE}
  13495.           FreeAndNil(T.D2DTexture);
  13496.         {$ENDIF}
  13497.  
  13498.         D2DMaxTextures := D2DMaxTextures - 1; //go back
  13499.       end;
  13500.     Result := False;
  13501.   end;
  13502.   dds.Modified := False; {this flag turn off always}
  13503. end;
  13504.  
  13505. {$IFDEF VER4UP}
  13506. function TD2DTextures.LoadTextures(dds: TDirectDrawSurface; Transparent: Boolean;
  13507.   TransparentColor: Integer; asTexName: string): Boolean;
  13508. {$ELSE}
  13509. function TD2DTextures.LoadTextures3(dds: TDirectDrawSurface; Transparent: Boolean;
  13510.   TransparentColor: Integer; asTexName: string): Boolean;
  13511. {$ENDIF}
  13512.   function getDDSTransparentColor(DIB: TDIB; dds: TDirectDrawSurface): Integer;
  13513.   var CLL: Integer; ddck: TDDColorKey;
  13514.   begin
  13515.     Result := 0;
  13516.     if dds.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  13517.       if dds.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetColorKey(DDCKEY_SRCBLT, ddck) = DD_OK then
  13518.         Result := ddck.dwColorSpaceLowValue;
  13519.     CLL := TransparentColor;
  13520.     if (CLL = -1) or (cardinal(CLL) <> DIB.Pixels[0, 0]) then //when is DDS
  13521.       CLL := DIB.Pixels[0, 0]; //have to pick up color from 0,0 pix of DIB
  13522.     if Transparent then //and must be transparent
  13523.       if CLL <> Result then //when different
  13524.         Result := CLL; //use TransparentColor
  13525.   end;
  13526. var
  13527.   {$IFNDEF VIDEOTEX}
  13528.   VDIB: TDIB;
  13529.   {$ENDIF}
  13530.   COL: Integer;
  13531.   T: TDXTextureImage;
  13532. begin
  13533.   Result := True;
  13534.   try
  13535.     D2DPruneTextures; {up to maxTexBlock textures only}
  13536.     D2DMaxTextures := D2DMaxTextures + 1;
  13537.     Texture[D2DMaxTextures - 1].Name := asTexName;
  13538.     {$IFDEF VIDEOTEX}Texture[D2DMaxTextures - 1].{$ENDIF}VDIB := TDIB.Create;
  13539.     try
  13540.     with Texture[D2DMaxTextures - 1] do
  13541.     begin
  13542.       VDIB.AsSign(dds);
  13543.       VDIB.Transparent := Transparent;
  13544.       FloatX1 := 0; FloatY1 := 0; FloatX2 := 1; FloatY2 := 1;
  13545.       SizeAdjust(VDIB, FloatX1, FloatY1, FloatX2, FloatY2);
  13546.       Width := VDIB.Width;
  13547.       Height := VDIB.Height;
  13548.       if VDIB.HasAlphaChannel then
  13549.       begin
  13550.         DIB2DXT(VDIB, T);
  13551.         T.ImageName := asTexName;
  13552.         T.Transparent := Transparent;
  13553.         D2DTexture := TDirect3DTexture2.Create(FDDraw, T, False);
  13554.         D2DTexture.Transparent := Transparent;
  13555.         AlphaChannel := True;
  13556.         //**T.Free; DO NOT FREE - surface is lost ** FIX by JB.
  13557.       end
  13558.       else
  13559.       begin
  13560.         D2DTexture := TDirect3DTexture2.Create(FDDraw, VDIB, False);
  13561.         if transparentcolor = -1 then
  13562.           COL := getDDSTransparentColor(VDIB, DDS)
  13563.         else
  13564.           COL := D2DTexture.Surface.ColorMatch(transparentcolor);
  13565.           D2DTexture.TransparentColor := DWORD(COL); //**
  13566.           D2DTexture.Surface.TransparentColor := DWORD(COL); //**
  13567.           D2DTexture.Transparent := Transparent;
  13568.           AlphaChannel := False;
  13569.       end;
  13570.     end
  13571.     finally
  13572.       {$IFNDEF VIDEOTEX}
  13573.       VDIB.Free;
  13574.       {$ENDIF}
  13575.     end;
  13576.   except
  13577.     D2DMaxTextures := D2DMaxTextures - 1;
  13578.     Result := False;
  13579.   end;
  13580. end;
  13581.  
  13582. {$IFDEF VER4UP}
  13583. function TD2DTextures.CanFindTexture(const Color: LongInt): Boolean;
  13584. {$ELSE}
  13585. function TD2DTextures.CanFindTexture3(const Color: LongInt): Boolean;
  13586. {$ENDIF}
  13587. var I: Integer;
  13588. begin
  13589.   Result := True;
  13590.   {$IFDEF VER4UP}
  13591.   if Length(Texture) > 0 then
  13592.   {$ELSE}
  13593.   if TexLen > 0 then
  13594.   {$ENDIF}
  13595.     for I := 0 to D2DMaxTextures - 1 do
  13596.       if Texture[I].Name = '$' + IntToStr(Color) then Exit;
  13597.   Result := False;
  13598. end;
  13599.  
  13600. {$IFDEF VER4UP}
  13601. function TD2DTextures.LoadTextures(Color: LongInt): Boolean;
  13602. {$ELSE}
  13603. function TD2DTextures.LoadTextures4(Color: LongInt): Boolean;
  13604. {$ENDIF}
  13605. var
  13606.   S: string;
  13607.   {$IFNDEF VIDEOTEX}
  13608.   VDIB: TDIB;
  13609.   {$ENDIF}
  13610. begin
  13611.   Result := True;
  13612.   try
  13613.     D2DPruneTextures; {up to maxTexBlock textures only}
  13614.     D2DMaxTextures := D2DMaxTextures + 1;
  13615.     S := '$' + IntToStr(Color); {this name is supplement name}
  13616.     {$IFDEF VIDEOTEX}Texture[D2DMaxTextures - 1].{$ENDIF}VDIB := TDIB.Create;
  13617.     try
  13618.     with Texture[D2DMaxTextures - 1] do
  13619.     begin
  13620.       VDIB.SetSize(16, 16, 24); {16x16 good size}
  13621.       VDIB.Canvas.Brush.Color := Color;
  13622.       VDIB.Canvas.FillRect(Bounds(0, 0, 16, 16));
  13623.  
  13624.       FloatX1 := 0;
  13625.       FloatY1 := 0;
  13626.       FloatX2 := 1;
  13627.       FloatY2 := 1;
  13628.       Name := S;
  13629.       D2DTexture := TDirect3DTexture2.Create(FDDraw, VDIB, False);
  13630.       D2DTexture.Transparent := False; //cannot be transparent
  13631.     end;
  13632.     finally
  13633.       {$IFNDEF VIDEOTEX}
  13634.       VDIB.Free;
  13635.       {$ENDIF}
  13636.     end;
  13637.   except
  13638.     D2DMaxTextures := D2DMaxTextures - 1;
  13639.     Result := False;
  13640.   end;
  13641. end;
  13642.  
  13643. {$IFDEF VIDEOTEX}
  13644. function TD2DTextures.GetTexLayoutByName(name: string): TDIB;
  13645. var
  13646.   I: Integer;
  13647. begin
  13648.   Result := nil;
  13649.   I := Find(name);
  13650.   {$IFDEF VER4UP}
  13651.   if (I >= Low(Texture)) and (I <= High(Texture)) then
  13652.   {$ELSE}
  13653.   if I <> -1 then
  13654.   {$ENDIF}
  13655.     Result := Texture[I].VDIB
  13656. end;
  13657. {$ENDIF}
  13658.  
  13659. //---------------------------------------------------------------------------
  13660.  
  13661. constructor TD2D.Create(DDraw: TCustomDXDraw);
  13662. begin
  13663.   inherited Create;
  13664.   //after inheritance
  13665.   FDDraw := DDraw;
  13666.   FD2DTextureFilter := D2D_POINT {D2D_LINEAR};
  13667.   {$IFNDEF D3D_deprecated}
  13668.   FD2DTexture := TD2DTextures.Create(FDDraw);
  13669.   {$ENDIF}
  13670.   InitVertex;
  13671.   {internal allocation of texture}
  13672.   CanUseD2D := {$IFDEF D3D_deprecated}(do3D in FDDraw.Options) and
  13673.     (doDirectX7Mode in FDDraw.Options) and
  13674.     (doHardware in FDDraw.Options){$ELSE}True{$ENDIF};
  13675.   FDIB := TDIB.Create;
  13676.   FInitialized := False;
  13677. end;
  13678.  
  13679. destructor TD2D.Destroy;
  13680. begin
  13681.   {freeing texture and stop using it}
  13682.   CanUseD2D := False;
  13683.   if AsSigned(FD2DTexture) then
  13684.   begin
  13685.     FD2DTexture.Free; {add 29.5.2005 Takanori Kawasaki}
  13686.     FD2DTexture := nil;
  13687.   end;
  13688.   FDIB.Free;
  13689.   inherited Destroy;
  13690. end;
  13691.  
  13692. procedure TD2D.InitVertex;
  13693. var i: Integer;
  13694. begin
  13695.   Fillchar(FVertex, SizeOf(FVertex), 0);
  13696.   for i := 0 to 3 do
  13697.   begin
  13698.     FVertex[i].Specular := D3DRGB(1.0, 1.0, 1.0);
  13699.     FVertex[i].rhw := 1.0;
  13700.   end;
  13701. end;
  13702.  
  13703. //---------------------------------------------------------------------------
  13704.  
  13705. procedure TD2D.BeginScene();
  13706. begin
  13707.   asm
  13708.     FINIT
  13709.   end;
  13710.   FDDraw.D3DDevice7.BeginScene();
  13711.   asm
  13712.     FINIT
  13713.   end;
  13714.   FDDraw.D3DDevice7.Clear(0, nil, D3DCLEAR_TARGET, 0, 0, 0);
  13715. end;
  13716.  
  13717. //---------------------------------------------------------------------------
  13718.  
  13719. procedure TD2D.EndScene();
  13720. begin
  13721.   asm
  13722.     FINIT
  13723.   end;
  13724.   FDDraw.D3DDevice7.EndScene();
  13725.   asm
  13726.     FINIT
  13727.   end;
  13728. end;
  13729.  
  13730. function TD2D.D2DTexturedOn(Image: TPictureCollectionItem; Pattern: Integer; SubPatternRect: TRect; RenderType: TRenderType; Alpha: Byte): Boolean;
  13731. var I: Integer;
  13732.   SrcX, SrcY, diffX: Double;
  13733.   R: TRect;
  13734.   Q: TTextureRec;
  13735. begin
  13736.   Result := False;
  13737.   FDDraw.D3DDevice7.SetTexture(0, nil);
  13738.   if not FD2DTexture.CanFindTexture(Image) then {when no texture in list try load it}
  13739.     if not FD2DTexture.LoadTextures(Image) then {loading is here}
  13740.       Exit; {on error occurr out}
  13741.   I := FD2DTexture.Find(Image.Name);
  13742.   if I = -1 then Exit;
  13743.   {set pattern as texture}
  13744. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
  13745. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
  13746.   try
  13747.     RenderError := FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7) <> DD_OK;
  13748.     case RenderType of
  13749.       rtDraw: begin D2DEffectSolid; D2DWhite; end;
  13750.       rtBlend: begin D2DEffectBlend; D2DAlphaVertex(Alpha); end;
  13751.       rtAdd: begin D2DEffectAdd; D2DFade(Alpha); end;
  13752.       rtSub: begin D2DEffectSub; D2DFade(Alpha); end;
  13753.     end;
  13754.   except
  13755.     RenderError := True;
  13756.     FD2DTexture.D2DPruneAllTextures;
  13757.     Image.Restore;
  13758.     SetD2DTextureFilter(D2D_LINEAR);
  13759.     Exit;
  13760.   end;
  13761.   {set transparent area}
  13762.   RenderError := FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Ord(FD2DTexture.Texture[I].D2DTexture.Transparent)) <> DD_OK;
  13763.   {except for Draw when alphachannel exists}
  13764.   {change for blend drawing but save transparent area still}
  13765.   if FD2DTexture.Texture[I].AlphaChannel then
  13766.     {when is Draw selected then}
  13767.     if RenderType = rtDraw then
  13768.     begin
  13769.       D2DEffectBlend;
  13770.       D2DAlphaVertex($FF);
  13771.     end;
  13772.   {pokud je obrazek rozdeleny, nastav oka site}
  13773.   if (Image.PatternHeight <> 0) or (Image.PatternWidth <> 0) then
  13774.   begin
  13775.     {vezmi rect jenom dilku}
  13776.     R := Image.PatternRects[Pattern];
  13777.     SrcX := 1 / FD2DTexture.Texture[I].Width;
  13778.     SrcY := 1 / FD2DTexture.Texture[I].Height;
  13779.     //namapovani vertexu na texturu
  13780.     FD2DTexture.Texture[I].FloatX1 := SrcX * R.Left;
  13781.     FD2DTexture.Texture[I].FloatY1 := SrcY * R.Top;
  13782.     {for meshed subimage contain one image only can be problem there}
  13783.     diffX := 0.5; if Image.PatternCount = 1 then diffX := 0;
  13784.     FD2DTexture.Texture[I].FloatX2 := SrcX * (R.Right - diffX);
  13785.     FD2DTexture.Texture[I].FloatY2 := SrcY * (R.Bottom - diffX);
  13786.     if not (
  13787.       (SubPatternRect.Left = Image.PatternRects[Pattern].Left) and
  13788.       (SubPatternRect.Top = Image.PatternRects[Pattern].Top) and
  13789.       (SubPatternRect.Right = Image.PatternRects[Pattern].Right) and
  13790.       (SubPatternRect.Bottom = Image.PatternRects[Pattern].Bottom))
  13791.     then
  13792.     begin
  13793.       {remaping subtexture via subpattern}
  13794.       Q.FloatX1 := SrcX * SubPatternRect.Left;
  13795.       Q.FloatY1 := SrcY * SubPatternRect.Top;
  13796.       Q.FloatX2 := SrcX * (SubPatternRect.Right - diffX);
  13797.       Q.FloatY2 := SrcY * (SubPatternRect.Bottom - diffX);
  13798.       D2DTU(Q); {with mirroring/flipping}
  13799.       Result := not RenderError;
  13800.       Exit;
  13801.     end;
  13802.   end; {jinak celeho obrazku}
  13803.  
  13804.   {  X1,Y1             X2,Y1
  13805.   0  +-----------------+  1
  13806.      |                 |
  13807.      |                 |
  13808.      |                 |
  13809.      |                 |
  13810.   2  +-----------------+  3
  13811.      X1,Y2             X2,Y2  }
  13812.   D2DTU(FD2DTexture.Texture[I]);
  13813.   Result := not RenderError;
  13814. end;
  13815.  
  13816. function TD2D.D2DTexturedOnDDSTex(dds: TDirectDrawSurface; SubPatternRect: TRect; Transparent: Boolean): Integer;
  13817. {special version of map for TDirectDrawSurface only}
  13818. {set up transparent color from this surface}
  13819. var
  13820.   TexName: string;
  13821. begin
  13822.   Result := -1;
  13823.   {pokud je seznam prazdny, nahrej texturu}
  13824.   if dds.Caption <> '' then TexName := dds.Caption
  13825.   else TexName := IntToStr(Integer(dds)); {simple but stupid}
  13826.   if not FD2DTexture.{$IFDEF VER4UP}CanFindTexture{$ELSE}CanFindTexture2{$ENDIF}(TexName) then
  13827.   begin
  13828.     {when texture doesn't exists, has to the Modified flag turn off}
  13829.     if dds.Modified then
  13830.       dds.Modified := not dds.Modified;
  13831.     if not FD2DTexture.{$IFDEF VER4UP}LoadTextures{$ELSE}LoadTextures2{$ENDIF}(dds, Transparent, TexName) then
  13832.       Exit; {nepovede-li se to, pak ven}
  13833.   end
  13834.   else
  13835.     if dds.Modified then
  13836.     begin {when modifying, load texture allways}
  13837.       if not FD2DTexture.{$IFDEF VER4UP}LoadTextures{$ELSE}LoadTextures2{$ENDIF}(dds, Transparent, TexName) then
  13838.         Exit; {nepovede-li se to, pak ven}
  13839.     end;
  13840.   Result := FD2DTexture.Find(TexName);
  13841. end;
  13842.  
  13843. function IsNotZero(Z: TRect): Boolean;
  13844. begin
  13845.   Result := ((Z.Right - Z.Left) > 0) and ((Z.Bottom - Z.Top) > 0)
  13846. end;
  13847.  
  13848. function TD2D.D2DTexturedOnDDS(dds: TDirectDrawSurface; SubPatternRect: TRect; Transparent: Boolean; RenderType: TRenderType; Alpha: Byte): Boolean;
  13849. var I: Integer;
  13850.   SrcX, SrcY: Double;
  13851. begin
  13852.   Result := False;
  13853.   FDDraw.D3DDevice7.SetTexture(0, nil);
  13854.   {call a low level routine for load DDS texture}
  13855.   I := D2DTexturedOnDDSTex(dds, SubPatternRect, Transparent);
  13856.   if I = -1 then Exit;
  13857.   {set pattern as texture}
  13858. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
  13859. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
  13860.   try
  13861.     RenderError := FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7) <> DD_OK;
  13862.     case RenderType of
  13863.       rtDraw: begin D2DEffectSolid; D2DWhite; end;
  13864.       rtBlend: begin D2DEffectBlend; D2DAlphaVertex(Alpha); end;
  13865.       rtAdd: begin D2DEffectAdd; D2DFade(Alpha); end;
  13866.       rtSub: begin D2DEffectSub; D2DFade(Alpha); end;
  13867.     end;
  13868.   except
  13869.     RenderError := True;
  13870.     FD2DTexture.D2DPruneAllTextures;
  13871.     SetD2DTextureFilter(D2D_LINEAR); //default
  13872.     Exit;
  13873.   end;
  13874.   {set transparent area}
  13875.   RenderError := FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Ord(FD2DTexture.Texture[I].D2DTexture.Transparent)) <> DD_OK;
  13876.   if IsNotZero(SubPatternRect) then
  13877.   begin
  13878.     {Set Texture Coordinates}
  13879.     SrcX := 1 / FD2DTexture.Texture[I].D2DTexture.FImage.Width;
  13880.     SrcY := 1 / FD2DTexture.Texture[I].D2DTexture.FImage.Height;
  13881.     //namapovani vertexu na texturu
  13882.     FD2DTexture.Texture[I].FloatX1 := SrcX * SubPatternRect.Left;
  13883.     FD2DTexture.Texture[I].FloatY1 := SrcY * SubPatternRect.Top;
  13884.     FD2DTexture.Texture[I].FloatX2 := SrcX * (SubPatternRect.Right - 0.5 { - 1}); //by Speeeder
  13885.     FD2DTexture.Texture[I].FloatY2 := SrcY * (SubPatternRect.Bottom - 0.5 { - 1}); //by Speeeder
  13886.   end;
  13887.   D2DTU(FD2DTexture.Texture[I]);
  13888.   Result := not RenderError;
  13889. end;
  13890.  
  13891. //---------------------------------------------------------------------------
  13892.  
  13893. procedure TD2D.SaveTextures(path: string);
  13894. begin
  13895.   FD2DTexture.SaveTextures(path);
  13896. end;
  13897.  
  13898. procedure TD2D.SetCanUseD2D(const Value: Boolean);
  13899. begin
  13900.   case Value of
  13901.     False: {prestava se uzivat}
  13902.       if AsSigned(FD2DTexture) and (Value <> FCanUseD2D) then
  13903.       begin
  13904.         FInitialized := False;
  13905.       end;
  13906.     True:
  13907.       if Value <> FCanUseD2D then
  13908.       begin
  13909.         {$IFDEF D3D_deprecated}
  13910.         FD2DTexture := TD2DTextures.Create(FDDraw);
  13911.         TextureFilter := D2D_LINEAR;
  13912.         {$ENDIF}
  13913.       end
  13914.   end;
  13915.   FCanUseD2D := Value;
  13916. end;
  13917.  
  13918. function TD2D.GetCanUseD2D: Boolean;
  13919. begin
  13920.   {$IFDEF D3D_deprecated}
  13921.   {Mode has to do3D, doDirectX7Mode and doHardware}
  13922.   if (do3D in FDDraw.Options) and
  13923.     (doDirectX7Mode in FDDraw.Options) and
  13924.     (doHardware in FDDraw.Options)
  13925.   then
  13926.   begin
  13927.     if not FCanUseD2D then CanUseD2D := True;
  13928.   end
  13929.   else
  13930.     if not (do3D in FDDraw.Options) or
  13931.       not (doDirectX7Mode in FDDraw.Options) or
  13932.       not (doHardware in FDDraw.Options)
  13933.       then
  13934.       if FCanUseD2D then FCanUseD2D := False; // CanUseD2D -> FCanUseD2D
  13935.   {$ELSE}
  13936.   FCanUseD2D := (doHardware in FDDraw.Options);
  13937.   {$ENDIF}
  13938.   FBitCount := FDDraw.Surface.SurfaceDesc.ddpfPixelFormat.dwRGBBitCount;
  13939.   {supported 16 or 32 bitcount deepth only}
  13940.   {$IFDEF D3D_deprecated}
  13941.   if not (FBitCount in [16, 32]) then FCanUseD2D := False;
  13942.   {$ENDIF}
  13943.   if not FInitialized then
  13944.     if FCanUseD2D and Assigned(FDDraw.D3DDevice7) then
  13945.     begin
  13946.       FDDraw.D3DDevice7.GetCaps(FD3DDevDesc7);
  13947.       FInitialized := True;
  13948.     end;
  13949.  
  13950.   Result := FCanUseD2D;
  13951. end;
  13952.  
  13953. procedure TD2D.SetD2DTextureFilter(const Value: TD2DTextureFilter);
  13954. begin
  13955.   FD2DTextureFilter := Value;
  13956.   if {$IFDEF D3D_deprecated}(do3D in FDDraw.Options) and{$ENDIF} AsSigned(FDDraw.D3DDevice7) then
  13957.   begin
  13958.     FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter) + 1));
  13959.     FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter) + 1));
  13960.   end;
  13961. end;
  13962.  
  13963. procedure TD2D.SetD2DAntialiasFilter(const Value: TD3DAntialiasMode);
  13964. begin
  13965.   FD2DAntialiasFilter := Value;
  13966.   if {$IFDEF D3D_deprecated}(do3D in FDDraw.Options) and{$ENDIF} AsSigned(FDDraw.D3DDevice7) then
  13967.   begin
  13968.     FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_ANTIALIAS, Ord(Value));
  13969.   end;
  13970. end;
  13971.  
  13972. procedure TD2D.D2DRect(R: TRect);
  13973. begin
  13974.   FVertex[0].sx := R.Left - 0.5;
  13975.   FVertex[0].sy := R.Top - 0.5;
  13976.   FVertex[1].sx := R.Right - 0.5;
  13977.   FVertex[1].sy := R.Top - 0.5;
  13978.   FVertex[2].sx := R.Left - 0.5;
  13979.   FVertex[2].sy := R.Bottom - 0.5;
  13980.   FVertex[3].sx := R.Right - 0.5;
  13981.   FVertex[3].sy := R.Bottom - 0.5;
  13982. end;
  13983.  
  13984. procedure TD2D.D2DTU(T: TTextureRec);
  13985. begin
  13986.   if FMirrorFlipSet = [rmfMirror] then
  13987.   begin
  13988.     {  X1,Y1             X2,Y1
  13989.     0  +-----------------+  1
  13990.        |                 |
  13991.        |                 |
  13992.        |                 |
  13993.        |                 |
  13994.     2  +-----------------+  3
  13995.        X1,Y2             X2,Y2  }
  13996.     FVertex[1].tu := T.FloatX1;
  13997.     FVertex[1].tv := T.FloatY1;
  13998.     FVertex[0].tu := T.FloatX2;
  13999.     FVertex[0].tv := T.FloatY1;
  14000.     FVertex[3].tu := T.FloatX1;
  14001.     FVertex[3].tv := T.FloatY2;
  14002.     FVertex[2].tu := T.FloatX2;
  14003.     FVertex[2].tv := T.FloatY2;
  14004.   end
  14005.   else
  14006.   if FMirrorFlipSet = [rmfFlip] then
  14007.   begin
  14008.     {  X1,Y1             X2,Y1
  14009.     0  +-----------------+  1
  14010.        |                 |
  14011.        |                 |
  14012.        |                 |
  14013.        |                 |
  14014.     2  +-----------------+  3
  14015.        X1,Y2             X2,Y2  }
  14016.     FVertex[2].tu := T.FloatX1;
  14017.     FVertex[2].tv := T.FloatY1;
  14018.     FVertex[3].tu := T.FloatX2;
  14019.     FVertex[3].tv := T.FloatY1;
  14020.     FVertex[0].tu := T.FloatX1;
  14021.     FVertex[0].tv := T.FloatY2;
  14022.     FVertex[1].tu := T.FloatX2;
  14023.     FVertex[1].tv := T.FloatY2;
  14024.   end
  14025.   else
  14026.   if FMirrorFlipSet = [rmfMirror, rmfFlip] then
  14027.   begin
  14028.     {  X1,Y1             X2,Y1
  14029.     0  +-----------------+  1
  14030.        |                 |
  14031.        |                 |
  14032.        |                 |
  14033.        |                 |
  14034.     2  +-----------------+  3
  14035.        X1,Y2             X2,Y2  }
  14036.     FVertex[3].tu := T.FloatX1;
  14037.     FVertex[3].tv := T.FloatY1;
  14038.     FVertex[2].tu := T.FloatX2;
  14039.     FVertex[2].tv := T.FloatY1;
  14040.     FVertex[1].tu := T.FloatX1;
  14041.     FVertex[1].tv := T.FloatY2;
  14042.     FVertex[0].tu := T.FloatX2;
  14043.     FVertex[0].tv := T.FloatY2;
  14044.   end
  14045.   else
  14046.   begin
  14047.     {  X1,Y1             X2,Y1
  14048.     0  +-----------------+  1
  14049.        |                 |
  14050.        |                 |
  14051.        |                 |
  14052.        |                 |
  14053.     2  +-----------------+  3
  14054.        X1,Y2             X2,Y2  }
  14055.     FVertex[0].tu := T.FloatX1;
  14056.     FVertex[0].tv := T.FloatY1;
  14057.     FVertex[1].tu := T.FloatX2;
  14058.     FVertex[1].tv := T.FloatY1;
  14059.     FVertex[2].tu := T.FloatX1;
  14060.     FVertex[2].tv := T.FloatY2;
  14061.     FVertex[3].tu := T.FloatX2;
  14062.     FVertex[3].tv := T.FloatY2;
  14063.   end;
  14064. end;
  14065.  
  14066. {Final public routines}
  14067.  
  14068. function TD2D.D2DRender(Image: TPictureCollectionItem; DestRect: TRect;
  14069.   Pattern: Integer; SourceRect: TRect; RenderType: TRenderType; Alpha: Byte): Boolean;
  14070. begin
  14071.   Result := False; if not CanUseD2D then Exit;
  14072.   if D2DTexturedOnSubRect(Image, Pattern, Image.PatternRects[Pattern], SourceRect, RenderType, Alpha) then
  14073.   begin
  14074.     D2DRect(DestRect);
  14075.     Result := RenderQuad;
  14076.   end;
  14077. end;
  14078.  
  14079. function TD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Image: TPictureCollectionItem; R: TRect;
  14080.   Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14081. begin
  14082.   Result := False; if not CanUseD2D then Exit;
  14083.   if D2DTexturedOn(Image, Pattern, Image.PatternRects[Pattern], RenderType, Alpha) then
  14084.   begin
  14085.     D2DRect(R);
  14086.     Result := RenderQuad;
  14087.   end;
  14088. end;
  14089.  
  14090. function TD2D.D2DRenderDDS(Source: TDirectDrawSurface; SourceRect, DestRect: TRect;
  14091.   Transparent: Boolean; Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14092. begin
  14093.   Result := False; if not CanUseD2D then Exit;
  14094.   if D2DTexturedOnDDS(Source, SourceRect, Transparent, RenderType, Alpha) then
  14095.   begin
  14096.     D2DRect(DestRect);
  14097.     Result := RenderQuad;
  14098.   end;
  14099. end;
  14100.  
  14101. function TD2D.D2DRenderCol(Image: TPictureCollectionItem; R: TRect;
  14102.   Pattern, Color: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14103. begin
  14104.   Result := False; if not CanUseD2D then Exit;
  14105.   if D2DTexturedOn(Image, Pattern, Image.PatternRects[Pattern], RenderType, Alpha) then
  14106.   begin
  14107.     D2DRect(R);
  14108.     Result := RenderQuad;
  14109.   end;
  14110. end;
  14111.  
  14112. function TD2D.D2DRenderColDDS(Source: TDirectDrawSurface; SourceRect, DestRect: TRect;
  14113.   Transparent: Boolean; Pattern, Color: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14114. begin
  14115.   Result := False; if not CanUseD2D then Exit;
  14116.   {Add}
  14117.   if D2DTexturedOnDDS(Source, SourceRect, Transparent, RenderType, Alpha) then
  14118.   begin
  14119.     D2DRect(DestRect);
  14120.     Result := RenderQuad;
  14121.   end;
  14122. end;
  14123.  
  14124. function TD2D.D2DRenderDrawXY(Image: TPictureCollectionItem; X, Y: Integer;
  14125.   Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14126. var PWidth, PHeight: Integer;
  14127. begin
  14128.   Result := False; if not CanUseD2D then Exit;
  14129.   {Draw}
  14130.   if D2DTexturedOn(Image, Pattern, Image.PatternRects[Pattern], RenderType, Alpha) then
  14131.   begin
  14132.     PWidth := Image.PatternWidth; if PWidth = 0 then PWidth := Image.Width;
  14133.     PHeight := Image.PatternHeight; if PHeight = 0 then PHeight := Image.Height;
  14134.     D2DRect(Bounds(X, Y, PWidth, PHeight));
  14135.     Result := RenderQuad;
  14136.   end;
  14137. end;
  14138.  
  14139. function TD2D.D2DRenderDrawDDSXY(Source: TDirectDrawSurface; X, Y: Integer;
  14140.   Transparent: Boolean; Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14141. begin
  14142.   Result := False; if not CanUseD2D then Exit;
  14143.   {Draw}
  14144.   if D2DTexturedOnDDS(Source, ZeroRect, Transparent, RenderType, Alpha) then
  14145.   begin
  14146.     D2DRect(Bounds(X, Y, Source.Width, Source.Height));
  14147.     Result := RenderQuad;
  14148.   end;
  14149. end;
  14150.  
  14151. {$IFDEF VER4UP}
  14152. function TD2D.D2DRenderDrawDDSXY(Source: TDirectDrawSurface; X, Y: Integer;
  14153.   SrcRect: TRect; Transparent: Boolean; Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14154. begin
  14155.   Result := False; if not CanUseD2D then Exit;
  14156.   {Draw}
  14157.   if D2DTexturedOnDDS(Source, SrcRect, Transparent, RenderType, Alpha) then
  14158.   begin
  14159.     D2DRect(Bounds(X, Y, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top));
  14160.     Result := RenderQuad;
  14161.   end;
  14162. end;
  14163. {$ENDIF}
  14164.  
  14165. {Rotate functions}
  14166.  
  14167. procedure TD2D.D2DRotate(X, Y, W, H: Integer; Px, Py: Double; Angle: Single);
  14168.   procedure SinCosS(const Theta: Single; var Sin, Cos: Single); register;
  14169.   { EAX contains address of Sin}
  14170.   { EDX contains address of Cos}
  14171.   { Theta is passed over the stack}
  14172.   asm
  14173.     FLD  Theta
  14174.     FSINCOS
  14175.     FSTP DWORD PTR [EDX]    // cosine
  14176.     FSTP DWORD PTR [EAX]    // sine
  14177.   end;
  14178. const PI256 = 2 * PI / 256;
  14179. var x1, y1, up, s_angle, c_angle, s_up, c_up: Single;
  14180. begin
  14181.   angle := angle * PI256; up := angle + PI / 2;
  14182.   x1 := w * px; y1 := h * py;
  14183.   SinCosS(angle, s_angle, c_angle);
  14184.   SinCosS(up, s_up, c_up);
  14185.   FVertex[0].sx := X - x1 * c_angle - y1 * c_up;
  14186.   FVertex[0].sy := Y - x1 * s_angle - y1 * s_up;
  14187.   FVertex[1].sx := FVertex[0].sx + W * c_angle;
  14188.   FVertex[1].sy := FVertex[0].sy + W * s_angle;
  14189.   FVertex[2].sx := FVertex[0].sx + H * c_up;
  14190.   FVertex[2].sy := FVertex[0].sy + H * s_up;
  14191.   FVertex[3].sx := FVertex[2].sx + W * c_angle;
  14192.   FVertex[3].sy := FVertex[2].sy + W * s_angle;
  14193. end;
  14194.  
  14195. function TD2D.D2DRenderRotate(Image: TPictureCollectionItem; RotX, RotY,
  14196.   PictWidth, PictHeight, PatternIndex: Integer; RenderType: TRenderType;
  14197.   CenterX, CenterY: Double;
  14198.   Angle: single; Alpha: Byte): Boolean;
  14199. begin
  14200.   Result := False; if not CanUseD2D then Exit;
  14201.   {load textures and map it, set of effect}
  14202.   if D2DTexturedOn(Image, PatternIndex, Image.PatternRects[PatternIndex], RenderType, Alpha) then
  14203.   begin
  14204.     {do rotate mesh}
  14205.     D2DRotate(RotX, RotY, PictWidth, PictHeight, CenterX, CenterY, Angle);
  14206.     {render it}
  14207.     Result := RenderQuad;
  14208.   end;
  14209. end;
  14210.  
  14211. function TD2D.D2DRenderRotateDDS(Image: TDirectDrawSurface; SourceRect: TRect; RotX, RotY,
  14212.   PictWidth, PictHeight: Integer; RenderType: TRenderType;
  14213.   CenterX, CenterY: Double; Angle: single; Alpha: Byte;
  14214.   Transparent: Boolean): Boolean;
  14215. begin
  14216.   Result := False; if not CanUseD2D then Exit;
  14217.   {load textures and map it, set of effect}
  14218.   if D2DTexturedOnDDS(Image, SourceRect, Transparent, RenderType, Alpha) then
  14219.   begin
  14220.     {do rotate mesh}
  14221.     D2DRotate(RotX, RotY, PictWidth, PictHeight, CenterX, CenterY, Angle);
  14222.     {render it}
  14223.     Result := RenderQuad;
  14224.   end;
  14225. end;
  14226.  
  14227. {------------------------------------------------------------------------------}
  14228. {created 31.1.2005 JB.}
  14229. {replacement original Hori's functionality}
  14230. {24.4.2006 create WaveY as supplement like WaveX functions}
  14231. {14.5.2006 added functionality for tile drawing through PatternIndex}
  14232.  
  14233. function TD2D.D2DMeshMapToWave(dds: TDirectDrawSurface; Transparent: Boolean;
  14234.   TransparentColor: Integer; X, Y, iWidth, iHeight, PatternIndex: Integer;
  14235.   PatternRect: TRect;
  14236.   Amp, Len, Ph, Alpha: Integer; effect: TRenderType; DoY: Boolean): Boolean;
  14237.   function D2DTexturedOn(dds: TDirectDrawSurface; Transparent: Boolean; var TexNo: Integer): Boolean;
  14238.   {special version of mapping for TDirectDrawSurface only}
  14239.   {set up transparent color from this surface}
  14240.   var I: Integer;
  14241.     TexName: string;
  14242.   begin
  14243.     Result := False;
  14244.     TexNo := -1;
  14245.     RenderError := FDDraw.D3DDevice7.SetTexture(0, nil) <> DD_OK;
  14246.     {pokud je seznam prazdny, nahrej texturu}
  14247.     if dds.Caption <> '' then TexName := dds.Caption
  14248.     else TexName := IntToStr(Integer(dds));
  14249.     if not FD2DTexture.{$IFDEF VER4UP}CanFindTexture{$ELSE}CanFindTexture2{$ENDIF}(TexName) then
  14250.       {nepovede-li se to, pak ven}
  14251.       if not FD2DTexture.{$IFDEF VER4UP}LoadTextures{$ELSE}LoadTextures3{$ENDIF}(dds, Transparent, TransparentColor, TexName) then Exit;
  14252.     I := FD2DTexture.Find(TexName);
  14253.     if I = -1 then Exit;
  14254.     TexNo := I;
  14255.     {set pattern as texture}
  14256. //    FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
  14257. //    FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
  14258.     try
  14259.       RenderError := FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7) <> DD_OK;
  14260.       //Result := True; {not RetderError}
  14261.     except
  14262.       RenderError := True;
  14263.       Result := False;
  14264.       FD2DTexture.D2DPruneAllTextures;
  14265.       Exit;
  14266.     end;
  14267.     {set transparent area}
  14268.     RenderError := FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Ord(FD2DTexture.Texture[I].D2DTexture.Transparent)) <> DD_OK;
  14269.     Result := not RenderError;
  14270.   end;
  14271. type
  14272.   TVertexArray = array{$IFNDEF VER4UP} [0..0]{$ENDIF} of TD3DTLVERTEX;
  14273.   {$IFNDEF VER4UP}
  14274.   PVertexArray = ^TVertexArray;
  14275.   {$ENDIF}
  14276. var
  14277.   SVertex: {$IFDEF VER4UP}TVertexArray{$ELSE}PVertexArray{$ENDIF};
  14278.   I, maxVertex, maxPix, VStepVx, TexNo, Width, Height: Integer;
  14279.   VStep, VStepTo, D, Z, FX1, FX2, FY1, FY2, SX, SY, X1, Y1, X2, Y2: Extended;
  14280.   R: TRect;
  14281.   clr: DWORD;
  14282. begin
  14283.   Result := False;
  14284.   {zde uschovano maximum [0..1] po adjustaci textury, ktera nemela nektery rozmer 2^n}
  14285.   {FD2DTexture.Texture[I].FloatX2;}
  14286.   {FD2DTexture.Texture[I].FloatY2;}
  14287.   {napr. pokud byl rozmer 0.7 pak je nutno prepocitat tento interval [0..0.7] na height}
  14288.   if not D2DTexturedOn(dds, Transparent, TexNo) then Exit;
  14289.   {musi se prenastavit velikost pokud je PatternIndex <> -1}
  14290.   Width := iWidth;
  14291.   Height := iHeight;
  14292.   {remove into local variabled for multi-picture adjustation}
  14293.   FX1 := FD2DTexture.Texture[TexNo].FloatX1;
  14294.   FX2 := FD2DTexture.Texture[TexNo].FloatX2;
  14295.   FY1 := FD2DTexture.Texture[TexNo].FloatY1;
  14296.   FY2 := FD2DTexture.Texture[TexNo].FloatY2;
  14297.   {when pattertindex selected, get real value of subtexture}
  14298.   if (PatternIndex <> -1) {and (PatternRect <> ZeroRect)} then
  14299.   begin
  14300.     R := PatternRect;
  14301.     Width := R.Right - R.Left;
  14302.     Height := R.Bottom - R.Top;
  14303.     {scale unit of full new width and height}
  14304.     SX := 1 / FD2DTexture.Texture[TexNo].Width;
  14305.     SY := 1 / FD2DTexture.Texture[TexNo].Height;
  14306.     {remap there}
  14307.     FX1 := R.Left * SX;
  14308.     FX2 := R.Right * SX;
  14309.     FY1 := R.Top * SY;
  14310.     FY2 := R.Bottom * SY;
  14311.   end;
  14312.   {nastavuje se tolik vertexu, kolik je potreba}
  14313.   {speculative set up of rows for better look how needed}
  14314.   if not DoY then
  14315.   begin
  14316.     maxVertex := 2 * Trunc(Height / Len * 8);
  14317.     if (maxVertex mod 2) > 0 then {top to limits}
  14318.       Inc(maxVertex, 2);
  14319.     if (maxVertex div 2) > Height then {correct to Height}
  14320.       maxVertex := 2 * Height;
  14321.   end
  14322.   else
  14323.   begin
  14324.     maxVertex := 2 * Trunc(Width / Len * 8);
  14325.     if (maxVertex mod 2) > 0 then {top to limits}
  14326.       Inc(maxVertex, 2);
  14327.     if (maxVertex div 2) > Width then {correct to Width}
  14328.       maxVertex := 2 * Width;
  14329.   end;
  14330.  
  14331.   {pocet pixlu mezi ploskami}
  14332.   if not DoY then
  14333.   begin
  14334.     repeat
  14335.       if (Height mod (maxVertex div 2)) <> 0 then
  14336.         Inc(maxVertex, 2);
  14337.       maxPix := Height div (maxVertex div 2);
  14338.     until (Height mod (maxVertex div 2)) = 0;
  14339.     {krok k nastaveni vertexu}
  14340.     VStep := (FY2 - FY1) / (maxVertex div 2);
  14341.   end
  14342.   else
  14343.   begin
  14344.     repeat
  14345.       if (Width mod (maxVertex div 2)) <> 0 then
  14346.         Inc(maxVertex, 2);
  14347.       maxPix := Width div (maxVertex div 2);
  14348.     until (Width mod (maxVertex div 2)) = 0;
  14349.     {krok k nastaveni vertexu}
  14350.     VStep := (FX2 - FX1) / (maxVertex div 2);
  14351.   end;
  14352.   //prostor
  14353.   {$IFDEF VER4UP}
  14354.   SetLength(SVertex, maxVertex);
  14355.   {$ELSE}
  14356.   SVertex := AllocMem(maxVertex * SizeOf(TD3DTLVERTEX));
  14357.   try
  14358.   {$ENDIF}
  14359.     //inicializace
  14360.     VStepVx := 0;
  14361.     VStepTo := 0;
  14362.     D := ph / (128 / PI); {shift wave}
  14363.     Z := (Len / 2) / PI; {wave length to radians}
  14364.     clr := D2DVertColor(Effect, Alpha); //effect cumulate to one param and one line of code
  14365.     {vlastni nastaveni vertexu v pasu vertexu}
  14366.     for I := 0 to maxVertex - 1 do
  14367.     begin
  14368.       SVertex[I].Specular := D3DRGB(1.0, 1.0, 1.0);
  14369.       SVertex[I].rhw := 1.0;
  14370.       SVertex[I].color := clr;
  14371.       if not DoY then
  14372.         case (I + 1) mod 2 of //triangle driver
  14373.           1: begin
  14374.               if I <> 0 then Inc(VStepVx, maxPix);
  14375.               SVertex[I].sx := X + Trunc(amp * Sin((Y + VStepVx) / Z + D)) - 0.5; //levy
  14376.               SVertex[I].sy := Y + VStepVx - 0.5;
  14377.               if FMirrorFlipSet = [rmfMirror] then
  14378.               begin
  14379.                 X1 := FX2; if I <> 0 then VStepTo := VStepTo + VStep;
  14380.                 Y1 := FY1 + VStepTo;
  14381.               end
  14382.               else
  14383.                 if FMirrorFlipSet = [rmfFlip] then
  14384.                 begin
  14385.                   X1 := FX1;
  14386.                   Y1 := FY2 - VStepTo;
  14387.                 end
  14388.                 else
  14389.                   if FMirrorFlipSet = [rmfMirror, rmfFlip] then
  14390.                   begin
  14391.                     X1 := FX2;
  14392.                     Y1 := FY2 - VStepTo;
  14393.                   end
  14394.                   else
  14395.                   begin
  14396.                     X1 := FX1; if I <> 0 then VStepTo := VStepTo + VStep;
  14397.                     Y1 := FY1 + VStepTo;
  14398.                   end;
  14399.               SVertex[I].tu := X1;
  14400.               SVertex[I].tv := Y1;
  14401.             end;
  14402.           0: begin
  14403.               SVertex[I].sx := X + Width + Trunc(amp * Sin((Y + VStepVx) / Z + D)) - 1; //pravy
  14404.               SVertex[I].sy := Y + VStepVx;
  14405.               if FMirrorFlipSet = [rmfMirror] then
  14406.               begin
  14407.                 X2 := FX1;
  14408.                 Y2 := FY1 + VStepTo;
  14409.               end
  14410.               else
  14411.                 if FMirrorFlipSet = [rmfFlip] then
  14412.                 begin
  14413.                   X2 := FX2;
  14414.                   Y2 := FY2 - VStepTo; if I <> 0 then VStepTo := VStepTo + VStep;
  14415.                 end
  14416.                 else
  14417.                   if FMirrorFlipSet = [rmfMirror, rmfFlip] then
  14418.                   begin
  14419.                     X2 := FX1;
  14420.                     Y2 := FY2 - VStepTo; if I <> 0 then VStepTo := VStepTo + VStep;
  14421.                   end
  14422.                   else
  14423.                   begin
  14424.                     X2 := FX2;
  14425.                     Y2 := FY1 + VStepTo;
  14426.                   end;
  14427.               SVertex[I].tu := X2;
  14428.               SVertex[I].tv := Y2;
  14429.             end;
  14430.         end {case}
  14431.       else
  14432.         case (I + 1) mod 2 of //triangle driver
  14433.           0: begin
  14434.               if I <> 0 then Inc(VStepVx, maxPix);
  14435.               SVertex[I].sy := Y + Trunc(amp * Sin((X + VStepVx) / Z + D)) - 0.5; //hore
  14436.               SVertex[I].sx := X + VStepVx - 0.5;
  14437.               if FMirrorFlipSet = [rmfMirror] then
  14438.               begin
  14439.                 Y1 := FY1; if I <> 0 then VStepTo := VStepTo + VStep;
  14440.                 X1 := FX2 - VStepTo;
  14441.               end
  14442.               else
  14443.                 if FMirrorFlipSet = [rmfFlip] then
  14444.                 begin
  14445.                   Y1 := FY2; if I <> 0 then VStepTo := VStepTo + VStep;
  14446.                   X1 := FX1 + VStepTo;
  14447.                 end
  14448.                 else
  14449.                   if FMirrorFlipSet = [rmfMirror, rmfFlip] then
  14450.                   begin
  14451.                     Y1 := FY2; if I <> 0 then VStepTo := VStepTo + VStep;
  14452.                     X1 := FX2 - VStepTo;
  14453.                   end
  14454.                   else
  14455.                   begin
  14456.                     Y1 := FY1; if I <> 0 then VStepTo := VStepTo + VStep;
  14457.                     X1 := FX1 + VStepTo;
  14458.                   end;
  14459.               SVertex[I].tu := X1;
  14460.               SVertex[I].tv := Y1;
  14461.             end;
  14462.           1: begin
  14463.               SVertex[I].sy := Y + Height + Trunc(amp * Sin((X + VStepVx) / Z + D)) - 1; //dole
  14464.               SVertex[I].sx := X + VStepVx;
  14465.               if FMirrorFlipSet = [rmfMirror] then
  14466.               begin
  14467.                 Y2 := FY2;
  14468.                 X2 := FX2 - VStepTo;
  14469.               end
  14470.               else
  14471.                 if FMirrorFlipSet = [rmfFlip] then
  14472.                 begin
  14473.                   Y2 := FY1;
  14474.                   X2 := FX1 + VStepTo;
  14475.                 end
  14476.                 else
  14477.                   if FMirrorFlipSet = [rmfMirror, rmfFlip] then
  14478.                   begin
  14479.                     Y2 := FY1;
  14480.                     X2 := FX2 - VStepTo;
  14481.                   end
  14482.                   else
  14483.                   begin
  14484.                     Y2 := FY2;
  14485.                     X2 := FX1 + VStepTo;
  14486.                   end;
  14487.               SVertex[I].tu := X2;
  14488.               SVertex[I].tv := Y2;
  14489.             end;
  14490.         end;
  14491.     end;
  14492.     {set of effect}
  14493.     case Effect of
  14494.       rtDraw: D2DEffectSolid;
  14495.       rtBlend: D2DEffectBlend;
  14496.       rtAdd: D2DEffectAdd;
  14497.       rtSub: D2DEffectSub;
  14498.     end;
  14499.     with FDDraw.D3DDevice7 do
  14500.     begin
  14501.       {kreslime hned zde}//render now and here
  14502.       Result := DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, SVertex[0], maxVertex, D3DDP_WAIT) = DD_OK;
  14503.       //zpet hodnoty
  14504.       //FIX InitVertex;
  14505.       FMirrorFlipSet := []; {only for one operation, back to normal position}
  14506.       {restore device status}
  14507.       RenderError := SetTextureStageState(1, D3DTSS_COLOROP, Ord(D3DTOP_DISABLE)) <> DD_OK;
  14508.       RenderError := SetTextureStageState(1, D3DTSS_ALPHAOP, Ord(D3DTOP_DISABLE)) <> DD_OK;
  14509.       RenderError := SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 0) <> DD_OK;
  14510.     end;
  14511.   {$IFNDEF VER4UP}
  14512.   finally
  14513.     FreeMem(SVertex, maxVertex * SizeOf(TD3DTLVERTEX));
  14514.   end;
  14515.   {$ENDIF}
  14516. end;
  14517.  
  14518. function TD2D.D2DRenderWaveX(Image: TPictureCollectionItem; X, Y, Width,
  14519.   Height, PatternIndex: Integer; RenderType: TRenderType; transparent: Boolean;
  14520.   amp, Len, ph, Alpha: Integer): Boolean;
  14521. begin
  14522.   Result := False; if not CanUseD2D then Exit;
  14523.   {load textures and map, do make wave mesh and render it}
  14524.   Result := D2DMeshMapToWave(Image.PatternSurfaces[PatternIndex], transparent,
  14525.     Image.FTransparentColor, X, Y, Width, Height, PatternIndex,
  14526.     Image.PatternRects[PatternIndex],
  14527.     amp, Len, ph, Alpha, RenderType{$IFNDEF VER4UP}, False{$ENDIF});
  14528. end;
  14529.  
  14530. function TD2D.D2DRenderWaveXDDS(Source: TDirectDrawSurface; X, Y, Width,
  14531.   Height: Integer; RenderType: TRenderType; Transparent: Boolean; Amp, Len, Ph, Alpha: Integer): Boolean;
  14532. begin
  14533.   Result := False; if not CanUseD2D then Exit;
  14534.   {load textures and map, do make wave mesh and render it}
  14535.   Result := D2DMeshMapToWave(Source, transparent, -1, X, Y, Width, Height, -1,
  14536.     ZeroRect,
  14537.     amp, Len, ph, Alpha, RenderType{$IFNDEF VER4UP}, False{$ENDIF});
  14538. end;
  14539.  
  14540. function TD2D.D2DRenderWaveY(Image: TPictureCollectionItem; X, Y, Width,
  14541.   Height, PatternIndex: Integer; RenderType: TRenderType; Transparent: Boolean;
  14542.   Amp, Len, Ph, Alpha: Integer): Boolean;
  14543. begin
  14544.   Result := False; if not CanUseD2D then Exit;
  14545.   {load textures and map, do make wave mesh and render it}
  14546.   Result := D2DMeshMapToWave(Image.PatternSurfaces[PatternIndex], transparent,
  14547.     Image.FTransparentColor, X, Y, Width, Height, PatternIndex,
  14548.     Image.PatternRects[PatternIndex],
  14549.     amp, Len, ph, Alpha, RenderType, True);
  14550. end;
  14551.  
  14552. function TD2D.D2DRenderWaveYDDS(Source: TDirectDrawSurface; X, Y, Width,
  14553.   Height: Integer; RenderType: TRenderType; Transparent: Boolean;
  14554.   Amp, Len, Ph, Alpha: Integer): Boolean;
  14555. begin
  14556.   Result := False; if not CanUseD2D then Exit;
  14557.   {load textures and map, do make wave mesh and render it}
  14558.   Result := D2DMeshMapToWave(Source, transparent, -1, X, Y, Width, Height, -1,
  14559.     ZeroRect,
  14560.     amp, Len, ph, Alpha, RenderType, True);
  14561. end;
  14562.  
  14563. function TD2D.D2DTexturedOnRect(Rect: TRect; Color: LongInt): Boolean;
  14564. var I: Integer;
  14565. begin
  14566.   Result := False;
  14567.   FDDraw.D3DDevice7.SetTexture(0, nil);
  14568.   if not FD2DTexture.{$IFDEF VER4UP}CanFindTexture{$ELSE}CanFindTexture3{$ENDIF}(Color) then {when no texture in list try load it}
  14569.     if not FD2DTexture.{$IFDEF VER4UP}LoadTextures{$ELSE}LoadTextures4{$ENDIF}(Color) then Exit; {on error occurr go out}
  14570.   I := FD2DTexture.Find('$' + IntToStr(Color)); //simply .. but stupid
  14571.   if I = -1 then Exit;
  14572.   {set pattern as texture}
  14573. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
  14574. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
  14575.   try
  14576.     RenderError := FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7) <> DD_OK;
  14577.   except
  14578.     RenderError := True;
  14579.     FD2DTexture.D2DPruneAllTextures;
  14580.     exit;
  14581.   end;
  14582.   {set transparent part}
  14583.   FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, 0); //no transparency
  14584.  
  14585.   D2DTU(FD2DTexture.Texture[I]);
  14586.   Result := not RenderError;
  14587. end;
  14588.  
  14589. function TD2D.D2DTexturedOnSubRect(Image: TPictureCollectionItem;
  14590.   Pattern: Integer; SubPatternRect, SubRect: TRect; RenderType: TRenderType;
  14591.   Alpha: Byte): Boolean;
  14592. label
  14593.   lblHop;  
  14594. var
  14595.   I, W, H: Integer;
  14596.   SrcX, SrcY, diffX: Double;
  14597.   R, tmpSubRect: TRect;
  14598.   Q: TTextureRec;
  14599.   qFloatX1, qFloatX2, qFloatY1, qFloatY2: Double;
  14600. begin
  14601.   Result := False;
  14602.   FDDraw.D3DDevice7.SetTexture(0, nil);
  14603.   if not FD2DTexture.CanFindTexture(Image) then {when no texture in list try load it}
  14604.     if not FD2DTexture.LoadTextures(Image) then {loading is here}
  14605.       Exit; {on error occurr out}
  14606.   I := FD2DTexture.Find(Image.Name);
  14607.   if I = -1 then Exit;
  14608.   {set pattern as texture}
  14609. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
  14610. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
  14611.   try
  14612.     FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7);
  14613.     case RenderType of
  14614.       rtDraw: begin D2DEffectSolid; D2DWhite; end;
  14615.       rtBlend: begin D2DEffectBlend; D2DAlphaVertex(Alpha); end;
  14616.       rtAdd: begin D2DEffectAdd; D2DFade(Alpha); end;
  14617.       rtSub: begin D2DEffectSub; D2DFade(Alpha); end;
  14618.     end;
  14619.   except
  14620.     RenderError := true;
  14621.     FD2DTexture.D2DPruneAllTextures;
  14622.     Image.Restore;
  14623.     SetD2DTextureFilter(D2D_LINEAR);
  14624.     Exit;
  14625.   end;
  14626.   {set transparent part}
  14627.   FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Ord(FD2DTexture.Texture[I].D2DTexture.Transparent));
  14628.   {except for Draw when alphachannel exists}
  14629.   {change for blend drawing but save transparent area still}
  14630.   if FD2DTexture.Texture[I].AlphaChannel then
  14631.     {when is Draw selected then}
  14632.     if RenderType = rtDraw then
  14633.     begin
  14634.       D2DEffectBlend; D2DAlphaVertex($FF);
  14635.     end;
  14636.   {pokud je obrazek rozdeleny, nastav oka site}
  14637.   if (Image.PatternHeight <> 0) or (Image.PatternWidth <> 0) then
  14638.   begin
  14639.     {vezmi rect jenom dilku}
  14640.     R := Image.PatternRects[Pattern];
  14641.  
  14642.     if not CompareMem(@SubRect, @ZeroRect, SizeOf(SubRect)) then
  14643.     begin
  14644.       {ktere oko site to je?}
  14645.       W := SubRect.Right - SubRect.Left; {takhle je siroky}
  14646.       H := SubRect.Bottom - SubRect.Top; {takhle je vysoky}
  14647.       tmpSubRect := Bounds(R.Left + SubRect.Left, R.Top + SubRect.Top, W, H);
  14648.       if RectInRect(tmpSubRect, R) then
  14649.       begin
  14650.         {pokud je subrect jeste v ramci patternu, musi se posouvat podle patternindex}
  14651.         Inc(R.Left, SubRect.Left);
  14652.         Inc(R.Top, SubRect.Top);
  14653.         if (R.Left + W) < R.Right then R.Right := R.Left + W;
  14654.         if (R.Top + H) < R.Bottom then R.Bottom := R.Top + H;
  14655.         goto lblHop;
  14656.       end;
  14657.     end;
  14658.     SrcX := 1 / FD2DTexture.Texture[I].Width;
  14659.     SrcY := 1 / FD2DTexture.Texture[I].Height;
  14660.     //namapovani vertexu na texturu
  14661.     FD2DTexture.Texture[I].FloatX1 := SrcX * R.Left;
  14662.     FD2DTexture.Texture[I].FloatY1 := SrcY * R.Top;
  14663.     {for meshed subimage contain one image only can be problem there}
  14664.     diffX := 0.5; if Image.PatternCount = 1 then diffX := 0;
  14665.     FD2DTexture.Texture[I].FloatX2 := SrcX * (R.Right - diffX);
  14666.     FD2DTexture.Texture[I].FloatY2 := SrcY * (R.Bottom - diffX);
  14667.     if not (
  14668.       (SubPatternRect.Left = Image.PatternRects[Pattern].Left) and
  14669.       (SubPatternRect.Top = Image.PatternRects[Pattern].Top) and
  14670.       (SubPatternRect.Right = Image.PatternRects[Pattern].Right) and
  14671.       (SubPatternRect.Bottom = Image.PatternRects[Pattern].Bottom))
  14672.     then
  14673.     begin
  14674.       {remaping subtexture via subpattern}
  14675.       Q.FloatX1 := SrcX * SubPatternRect.Left;
  14676.       Q.FloatY1 := SrcY * SubPatternRect.Top;
  14677.       Q.FloatX2 := SrcX * (SubPatternRect.Right - diffX);
  14678.       Q.FloatY2 := SrcY * (SubPatternRect.Bottom - diffX);
  14679.       D2DTU(Q); {with mirroring/flipping}
  14680.       Result := True;
  14681.       Exit;
  14682.     end;
  14683.   end; {jinak celeho obrazku}
  14684.  
  14685.   if not CompareMem(@SubRect, @ZeroRect, SizeOf(SubRect)) then
  14686.     if RectInRect(SubRect, Bounds(0,0, FD2DTexture.Texture[I].Width, FD2DTexture.Texture[I].Height)) then
  14687.     begin
  14688.       R := SubRect;
  14689.      lblHop:
  14690.       SrcX := 1 / FD2DTexture.Texture[I].Width;
  14691.       SrcY := 1 / FD2DTexture.Texture[I].Height;
  14692.       //namapovani vertexu na texturu
  14693.       qFloatX1 := FD2DTexture.Texture[I].FloatX1;
  14694.       qFloatY1 := FD2DTexture.Texture[I].FloatY1;
  14695.       qFloatX2 := FD2DTexture.Texture[I].FloatX2;
  14696.       qFloatY2 := FD2DTexture.Texture[I].FloatY2;
  14697.       try
  14698.         FD2DTexture.Texture[I].FloatX1 := SrcX * R.Left;
  14699.         FD2DTexture.Texture[I].FloatY1 := SrcY * R.Top;
  14700.         {for meshed subimage contain one image only can be problem there}
  14701.         diffX := 0.5; if Image.PatternCount = 1 then diffX := 0;
  14702.         FD2DTexture.Texture[I].FloatX2 := SrcX * (R.Right - diffX);
  14703.         FD2DTexture.Texture[I].FloatY2 := SrcY * (R.Bottom - diffX);
  14704.         {remaping subtexture via subpattern}
  14705.         D2DTU(FD2DTexture.Texture[I]); {with mirroring/flipping}
  14706.         Result := True;
  14707.         Exit;
  14708.       finally
  14709.         FD2DTexture.Texture[I].FloatX1 := qFloatX1;
  14710.         FD2DTexture.Texture[I].FloatY1 := qFloatY1;
  14711.         FD2DTexture.Texture[I].FloatX2 := qFloatX2;
  14712.         FD2DTexture.Texture[I].FloatY2 := qFloatY2;
  14713.       end;
  14714.     end;
  14715.  
  14716.   {  X1,Y1             X2,Y1
  14717.   0  +-----------------+  1
  14718.      |                 |
  14719.      |                 |
  14720.      |                 |
  14721.      |                 |
  14722.   2  +-----------------+  3
  14723.      X1,Y2             X2,Y2  }
  14724.   D2DTU(FD2DTexture.Texture[I]);
  14725.   Result := True;
  14726. end;
  14727.  
  14728. function TD2D.D2DRenderColoredPartition(Image: TPictureCollectionItem;
  14729.   DestRect: TRect;
  14730.   PatternIndex, Color, Specular: Integer;
  14731.   Faded: Boolean;
  14732.   SourceRect: TRect;
  14733.   RenderType: TRenderType;
  14734.   Alpha: Byte): Boolean;
  14735. begin
  14736.   Result := False; if not CanUseD2D then Exit;
  14737.   {set of effect before fade}
  14738.   case RenderType of
  14739.     rtDraw: D2DEffectSolid;
  14740.     rtBlend: D2DEffectBlend;
  14741.     rtAdd: D2DEffectAdd;
  14742.     rtSub: D2DEffectSub;
  14743.   end;
  14744.   if Faded then D2DFade(Alpha);
  14745.  
  14746.   D2DColoredVertex(Color);
  14747.   if Specular <> Round(D3DRGB(1.0, 1.0, 1.0)) then
  14748.     D2DSpecularVertex(Specular);
  14749.   {load textures and map it}
  14750.   if D2DTexturedOn(Image, PatternIndex, SourceRect, RenderType, Alpha) then
  14751.   begin
  14752.     D2DRect(DestRect);
  14753.     {render it}
  14754.     Result := RenderQuad;
  14755.   end;
  14756. end;
  14757.  
  14758. function TD2D.D2DRenderFillRect(Rect: TRect; RGBColor: LongInt;
  14759.   RenderType: TRenderType; Alpha: Byte): Boolean;
  14760. begin
  14761.   Result := False; if not CanUseD2D then Exit;
  14762.   case RenderType of
  14763.     rtDraw: begin D2DEffectSolid; D2DColoredVertex(RGBColor); end;
  14764.     rtBlend: begin D2DEffectBlend; D2DAlphaVertex(Alpha); end;
  14765.     rtAdd: begin D2DEffectAdd; D2DFade(Alpha); end;
  14766.     rtSub: begin D2DEffectSub; D2DFade(Alpha); end;
  14767.   end;
  14768.   if D2DTexturedOnRect(Rect, RGBColor) then
  14769.   begin
  14770.     D2DRect(Rect);
  14771.     Result := RenderQuad;
  14772.   end;
  14773. end;
  14774.  
  14775. function TD2D.D2DRenderRotateModeCol(Image: TPictureCollectionItem;
  14776.   RenderType: TRenderType;
  14777.   RotX, RotY, PictWidth, PictHeight, PatternIndex: Integer; CenterX,
  14778.   CenterY: Double; Angle: single; Color: Integer; Alpha: Byte): Boolean;
  14779. begin
  14780.   Result := False; if not CanUseD2D then Exit;
  14781.   {set of effect before colored}
  14782.   case RenderType of
  14783.     rtDraw: D2DEffectSolid;
  14784.     rtAdd: D2DEffectAdd;
  14785.     rtSub: D2DEffectSub;
  14786.     rtBlend: D2DEffectBlend;
  14787.   end;
  14788.   D2DFadeColored(Color, Alpha);
  14789.   {load textures and map it}
  14790.   if D2DTexturedOn(Image, PatternIndex, Image.PatternRects[PatternIndex], RenderType, Alpha) then
  14791.   begin
  14792.     {do rotate mesh}
  14793.     D2DRotate(RotX, RotY, PictWidth, PictHeight, CenterX, CenterY, Angle);
  14794.     {render it}
  14795.     Result := RenderQuad;
  14796.   end;
  14797. end;
  14798.  
  14799. function TD2D.D2DRenderRotateModeColDDS(Image: TDirectDrawSurface;
  14800.   RotX, RotY, PictWidth, PictHeight: Integer; RenderType: TRenderType;
  14801.   CenterX, CenterY: Double; Angle: Single; Color: Integer; Alpha: Byte;
  14802.   Transparent: Boolean): Boolean;
  14803. begin
  14804.   Result := False; if not CanUseD2D then Exit;
  14805.   {set of effect}
  14806.   D2DFadeColored(Color, Alpha);
  14807.   {load textures and map it}
  14808.   if D2DTexturedOnDDS(Image, ZeroRect, Transparent, RenderType, Alpha) then
  14809.   begin
  14810.     {do rotate mesh}
  14811.     D2DRotate(RotX, RotY, PictWidth, PictHeight, CenterX, CenterY, Angle);
  14812.     {render it}
  14813.     Result := RenderQuad;
  14814.   end;
  14815. end;
  14816.  
  14817. procedure TD2D.D2DEffectSolid;
  14818. begin
  14819.   with FDDraw.D3DDevice7 do
  14820.   begin
  14821.     SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 0);
  14822.     //SetRenderState(D3DRENDERSTATE_FILLMODE, Integer(D3DFILL_SOLID));
  14823.     SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Integer(True));
  14824.     SetRenderState(D3DRENDERSTATE_SRCBLEND, Integer(D3DBLEND_ONE));
  14825.   end;
  14826. end;
  14827.  
  14828. procedure TD2D.D2DEffectBlend;
  14829. begin
  14830.   with FDDraw.D3DDevice7 do
  14831.   begin
  14832.     SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 1);
  14833.     SetRenderState(D3DRENDERSTATE_SRCBLEND, Integer(D3DBLEND_SRCALPHA));
  14834.     SetRenderState(D3DRENDERSTATE_DESTBLEND, Integer(D3DBLEND_INVSRCALPHA));
  14835.  
  14836.     SetTextureStageState(0, D3DTSS_COLOROP, Integer(D3DTOP_MODULATE));
  14837.     SetTextureStageState(0, D3DTSS_COLORARG1, Integer(D3DTA_TEXTURE));
  14838.     SetTextureStageState(0, D3DTSS_COLORARG2, Integer(D3DTA_CURRENT));
  14839.  
  14840.     SetTextureStageState(0, D3DTSS_ALPHAOP, Integer(D3DTOP_BLENDDIFFUSEALPHA));
  14841.     SetTextureStageState(0, D3DTSS_ALPHAARG1, Integer(D3DTA_TEXTURE));
  14842.     SetTextureStageState(0, D3DTSS_ALPHAARG2, Integer(D3DTA_CURRENT));
  14843.  
  14844.     SetTextureStageState(0, D3DTSS_ALPHAOP, Integer(D3DTOP_MODULATE));
  14845.   end;
  14846. end;
  14847.  
  14848. procedure TD2D.D2DEffectAdd;
  14849. begin
  14850.   with FDDraw.D3DDevice7 do
  14851.   begin
  14852.     SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 1);
  14853.     SetRenderState(D3DRENDERSTATE_SRCBLEND, Integer(D3DBLEND_ONE));
  14854.     SetRenderState(D3DRENDERSTATE_DESTBLEND, Integer(D3DBLEND_ONE));
  14855.     SetTextureStageState(0, D3DTSS_ALPHAOP, Ord(D3DTOP_SELECTARG1));
  14856.     SetTextureStageState(0, D3DTSS_ALPHAARG1,  D3DTA_CURRENT);
  14857.     SetTextureStageState(0, D3DTSS_ALPHAOP, Integer(D3DTOP_MODULATE));
  14858.   end;
  14859. end;
  14860.  
  14861. procedure TD2D.D2DEffectSub;
  14862. begin
  14863.   with FDDraw.D3DDevice7 do
  14864.   begin
  14865.     SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 1);
  14866.     SetRenderState(D3DRENDERSTATE_SRCBLEND, Integer(D3DBLEND_ZERO));
  14867.     SetRenderState(D3DRENDERSTATE_DESTBLEND, Integer(D3DBLEND_INVSRCCOLOR));
  14868.     SetTextureStageState(0, D3DTSS_ALPHAOP, Ord(D3DTOP_SELECTARG1));
  14869.     SetTextureStageState(0, D3DTSS_ALPHAARG1,  D3DTA_CURRENT);
  14870.     SetTextureStageState(0, D3DTSS_ALPHAOP, Integer(D3DTOP_MODULATE));
  14871.   end;
  14872. end;
  14873.  
  14874. function TD2D.D2DAlphaVertex(Alpha: Integer): Integer;
  14875. begin
  14876.   Result := RGBA_MAKE($FF, $FF, $FF, Alpha);
  14877.   FVertex[0].Color := Result;
  14878.   FVertex[1].Color := Result;
  14879.   FVertex[2].Color := Result;
  14880.   FVertex[3].Color := Result;
  14881. end;
  14882.  
  14883. procedure TD2D.D2DColoredVertex(C: Integer);
  14884. begin
  14885.   C := D3DRGB(C and $FF / 255, (C shr 8) and $FF / 255, (C shr 16) and $FF / 255);
  14886.   FVertex[0].Color := C;
  14887.   FVertex[1].Color := C;
  14888.   FVertex[2].Color := C;
  14889.   FVertex[3].Color := C;
  14890. end;
  14891.  
  14892. procedure TD2D.D2DColAlpha(C, Alpha: Integer);
  14893. begin
  14894.   C := D3DRGBA(C and $FF / 255, (C shr 8) and $FF / 255, (C shr 16) and $FF / 255, Alpha / 255);
  14895.   FVertex[0].Color := C;
  14896.   FVertex[1].Color := C;
  14897.   FVertex[2].Color := C;
  14898.   FVertex[3].Color := C;
  14899. end;
  14900.  
  14901. procedure TD2D.D2DSpecularVertex(C: Integer);
  14902. begin
  14903.   C := D3DRGB(C and $FF / 255, (C shr 8) and $FF / 255, (C shr 16) and $FF / 255);
  14904.   FVertex[0].Specular := C;
  14905.   FVertex[1].Specular := C;
  14906.   FVertex[2].Specular := C;
  14907.   FVertex[3].Specular := C;
  14908. end;
  14909.  
  14910. procedure TD2D.D2DCol4Alpha(C1, C2, C3, C4, Alpha: Integer);
  14911. begin
  14912.   FVertex[0].Color := D3DRGBA(C1 and $FF / 255, (C1 shr 8) and $FF / 255,
  14913.     (C1 shr 16) and $FF / 255, Alpha / 255);
  14914.   FVertex[1].Color := D3DRGBA(C2 and $FF / 255, (C2 shr 8) and $FF / 255,
  14915.     (C2 shr 16) and $FF / 255, Alpha / 255);
  14916.   FVertex[2].Color := D3DRGBA(C3 and $FF / 255, (C3 shr 8) and $FF / 255,
  14917.     (C3 shr 16) and $FF / 255, Alpha / 255);
  14918.   FVertex[3].Color := D3DRGBA(C4 and $FF / 255, (C4 shr 8) and $FF / 255,
  14919.     (C4 shr 16) and $FF / 255, Alpha / 255);
  14920. end;
  14921.  
  14922. function TD2D.D2DVertColor(RenderType: TRenderType; Alpha: Byte): DWORD;
  14923. begin
  14924.   case RenderType of //effect cumulate to one param and four line of code
  14925.     rtDraw: Result := RGB_MAKE($FF, $FF, $FF);
  14926.     rtBlend: Result := RGBA_MAKE($FF, $FF, $FF, Alpha);
  14927.     rtAdd: Result := RGB_MAKE(Alpha, Alpha, Alpha);
  14928.     rtSub: Result := RGB_MAKE(Alpha, Alpha, Alpha);
  14929.   else
  14930.     Result := RGB_MAKE($FF, $FF, $FF);
  14931.   end;
  14932. end;
  14933.  
  14934. function TD2D.D2DWhite: Integer;
  14935. begin
  14936.   Result := RGB_MAKE($FF, $FF, $FF);
  14937.   FVertex[0].Color := Result;
  14938.   FVertex[1].Color := Result;
  14939.   FVertex[2].Color := Result;
  14940.   FVertex[3].Color := Result;
  14941. end;
  14942.  
  14943. function TD2D.D2DFade(Alpha: Integer): Integer;
  14944. begin
  14945.   Result := RGB_MAKE(Alpha, Alpha, Alpha);
  14946.   FVertex[0].Color := Result;
  14947.   FVertex[1].Color := Result;
  14948.   FVertex[2].Color := Result;
  14949.   FVertex[3].Color := Result;
  14950. end;
  14951.  
  14952. procedure TD2D.D2DFadeColored(C, Alpha: Integer);
  14953. var mult: single;
  14954. begin
  14955.   mult := Alpha / 65025; //Alpha/255/255;
  14956.   C := D3DRGB((C and $FF) * mult, ((C shr 8) and $FF) * mult, ((C shr 16) and $FF) * mult);
  14957.   FVertex[0].Color := C;
  14958.   FVertex[1].Color := C;
  14959.   FVertex[2].Color := C;
  14960.   FVertex[3].Color := C;
  14961. end;
  14962.  
  14963. procedure TD2D.D2DFade4Colored(C1, C2, C3, C4, Alpha: Integer);
  14964. var mult: single;
  14965. begin
  14966.   mult := Alpha / 65025; //Alpha/255/255;
  14967.   FVertex[0].Color := D3DRGB((C1 and $FF) * mult, ((C1 shr 8) and $FF) * mult,
  14968.     ((C1 shr 16) and $FF) * mult);
  14969.   FVertex[1].Color := D3DRGB((C2 and $FF) * mult, ((C2 shr 8) and $FF) * mult,
  14970.     ((C2 shr 16) and $FF) * mult);
  14971.   FVertex[2].Color := D3DRGB((C3 and $FF) * mult, ((C3 shr 8) and $FF) * mult,
  14972.     ((C3 shr 16) and $FF) * mult);
  14973.   FVertex[3].Color := D3DRGB((C4 and $FF) * mult, ((C4 shr 8) and $FF) * mult,
  14974.     ((C4 shr 16) and $FF) * mult);
  14975. end;
  14976.  
  14977. function TD2D.RenderQuad: Boolean;
  14978. begin
  14979.   Result := FDDraw.D3DDevice7.DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, FVertex, 4, D3DDP_WAIT) <> DD_OK;
  14980.   InitVertex;
  14981.   FMirrorFlipSet := []; {only for one operation, back to normal position}
  14982.   {restore device status}
  14983.   with FDDraw.D3DDevice7 do
  14984.   begin
  14985.     SetTextureStageState(1, D3DTSS_COLOROP, Ord(D3DTOP_DISABLE));
  14986.     SetTextureStageState(1, D3DTSS_ALPHAOP, Ord(D3DTOP_DISABLE));
  14987.     SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 0);
  14988.   end;
  14989. end;
  14990.  
  14991. function TD2D.RenderTri: Boolean;
  14992. begin
  14993.   Result := FDDraw.D3DDevice7.DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, FVertex, 3, D3DDP_WAIT) <> DD_OK;
  14994.   InitVertex;
  14995.   FMirrorFlipSet := []; {only for one operation, back to normal position}
  14996.   {restore device status}
  14997.   with FDDraw.D3DDevice7 do
  14998.   begin
  14999.     SetTextureStageState(1, D3DTSS_COLOROP, Ord(D3DTOP_DISABLE));
  15000.     SetTextureStageState(1, D3DTSS_ALPHAOP, Ord(D3DTOP_DISABLE));
  15001.     SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 0);
  15002.   end;
  15003. end;
  15004.  
  15005. procedure TD2D.D2DMeshMapToRect(R: TRect);
  15006. begin
  15007.   FVertex[0].sx := R.Left - 0.5;
  15008.   FVertex[0].sy := R.Top - 0.5;
  15009.   FVertex[1].sx := R.Right - 0.5;
  15010.   FVertex[1].sy := R.Top - 0.5;
  15011.   FVertex[2].sx := R.Left - 0.5;
  15012.   FVertex[2].sy := R.Bottom - 0.5;
  15013.   FVertex[3].sx := R.Right - 0.5;
  15014.   FVertex[3].sy := R.Bottom - 0.5;
  15015. end;
  15016.  
  15017. function TD2D.D2DInitializeSurface: Boolean;
  15018. begin
  15019.   Result := False;
  15020.   if Assigned(FDDraw.D3DDevice7) then
  15021.     Result := FDDraw.D3DDevice7.SetRenderTarget(FDDraw.Surface.IDDSurface7, 0) = DD_OK;
  15022. end;
  15023.  
  15024. procedure TD2D.D2DUpdateTextures;
  15025. var I: Integer;
  15026. begin
  15027.   {$IFDEF VER4UP}
  15028.   for I := Low(FD2DTexture.Texture) to High(FD2DTexture.Texture) do
  15029.   {$ELSE}
  15030.   for I := 0 to FD2DTexture.TexLen - 1 do
  15031.   {$ENDIF}
  15032.   begin
  15033.     FD2DTexture.Texture[I].Width := FD2DTexture.Texture[I].D2DTexture.Surface.Width;
  15034.     FD2DTexture.Texture[I].Height := FD2DTexture.Texture[I].D2DTexture.Surface.Height;
  15035. //    FD2DTexture.Texture[I].AlphaChannel := ?
  15036.   end;
  15037. end;
  15038.  
  15039. {  TTrace  }
  15040.  
  15041. constructor TTrace.Create(Collection: TCollection);
  15042. begin
  15043.   inherited Create(Collection);
  15044.   FBlit := TBlit.Create(Self);
  15045.   FBlit.FEngine := TCustomDXDraw(Traces.FOwner);
  15046. end;
  15047.  
  15048. destructor TTrace.Destroy;
  15049. begin
  15050.   FBlit.Free;
  15051.   inherited Destroy;
  15052. end;
  15053.  
  15054. function TTrace.GetDisplayName: string;
  15055. begin
  15056.   Result := inherited GetDisplayName
  15057. end;
  15058.  
  15059. procedure TTrace.SetDisplayName(const Value: string);
  15060. begin
  15061.   if (Value <> '') and (AnsiCompareText(Value, GetDisplayName) <> 0) and
  15062.     (Collection is TTraces) and (TTraces(Collection).IndexOf(Value) >= 0) then
  15063.     raise Exception.Create(Format('Item duplicate name "%s" error', [Value]));
  15064.   inherited SetDisplayName(Value);
  15065. end;
  15066.  
  15067. function TTrace.GetTraces: TTraces;
  15068. begin
  15069.   if Collection is TTraces then
  15070.     Result := TTraces(Collection)
  15071.   else
  15072.     Result := nil;
  15073. end;
  15074.  
  15075. procedure TTrace.Render(const LagCount: Integer);
  15076. begin
  15077.   FBlit.DoMove(LagCount);
  15078.   FBlit.DoCollision;
  15079.   FBlit.DoDraw;
  15080.   if Assigned(FBlit.FOnRender) then
  15081.     FBlit.FOnRender(FBlit);
  15082. end;
  15083.  
  15084. function TTrace.IsActualized: Boolean;
  15085. begin
  15086.   Result := FActualized;
  15087. end;
  15088.  
  15089. procedure TTrace.Assign(Source: TPersistent);
  15090. begin
  15091.   if Source is TTrace then begin
  15092.     //FTracePoints.Assign(TTrace(Source).FTracePoints);
  15093.     FBlit.Assign(TTrace(Source).FBlit);
  15094.     FTag := TTrace(Source).FTag;
  15095.   end
  15096.   else
  15097.     inherited Assign(Source);
  15098. end;
  15099.  
  15100. function TTrace.GetActive: Boolean;
  15101. begin
  15102.   Result := FBlit.FActive;
  15103. end;
  15104.  
  15105. procedure TTrace.SetActive(const Value: Boolean);
  15106. begin
  15107.   FBlit.FActive := Value;
  15108. end;
  15109.  
  15110. function TTrace.GetOnCollision: TNotifyEvent;
  15111. begin
  15112.   Result := FBlit.FOnCollision;
  15113. end;
  15114.  
  15115. procedure TTrace.SetOnCollision(const Value: TNotifyEvent);
  15116. begin
  15117.   FBlit.FOnCollision := Value;
  15118. end;
  15119.  
  15120. function TTrace.GetOnGetImage: TNotifyEvent;
  15121. begin
  15122.   Result := FBlit.FOnGetImage;
  15123. end;
  15124.  
  15125. procedure TTrace.SetOnGetImage(const Value: TNotifyEvent);
  15126. begin
  15127.   FBlit.FOnGetImage := Value;
  15128. end;
  15129.  
  15130. function TTrace.GetOnDraw: TNotifyEvent;
  15131. begin
  15132.   Result := FBlit.FOnDraw;
  15133. end;
  15134.  
  15135. procedure TTrace.SetOnDraw(const Value: TNotifyEvent);
  15136. begin
  15137.   FBlit.FOnDraw := Value;
  15138. end;
  15139.  
  15140. function TTrace.GetOnMove: TBlitMoveEvent;
  15141. begin
  15142.   Result := FBlit.FOnMove;
  15143. end;
  15144.  
  15145. procedure TTrace.SetOnMove(const Value: TBlitMoveEvent);
  15146. begin
  15147.   FBlit.FOnMove := Value;
  15148. end;
  15149.  
  15150. function TTrace.Clone(NewName: string; OffsetX, OffsetY: Integer;
  15151.   Angle: Single): TTrace;
  15152. var
  15153.   NewItem: TTrace;
  15154.   I: Integer;
  15155. begin
  15156.   NewItem := GetTraces.Add;
  15157.   NewItem.Assign(Self);
  15158.   NewItem.Name := NewName;
  15159.   for I := 0 to NewItem.Blit.GetPathCount - 1 do begin
  15160.     NewItem.Blit.FPathArr[I].X := NewItem.Blit.FPathArr[I].X + OffsetX;
  15161.     NewItem.Blit.FPathArr[I].Y := NewItem.Blit.FPathArr[I].Y + OffsetY;
  15162.   end;
  15163.   Result := NewItem
  15164. end;
  15165.  
  15166. function TTrace.GetOnRender: TOnRender;
  15167. begin
  15168.   Result := FBlit.FOnRender;
  15169. end;
  15170.  
  15171. procedure TTrace.SetOnRender(const Value: TOnRender);
  15172. begin
  15173.   FBlit.FOnRender := Value;
  15174. end;
  15175.  
  15176. {  TTraces  }
  15177.  
  15178. constructor TTraces.Create(AOwner: TComponent);
  15179. begin
  15180.   inherited Create(TTrace);
  15181.   FOwner := AOwner;
  15182. end;
  15183.  
  15184. destructor TTraces.Destroy;
  15185. begin
  15186.   inherited Destroy;
  15187. end;
  15188.  
  15189. function TTraces.Add: TTrace;
  15190. begin
  15191.   Result := TTrace(inherited Add);
  15192. end;
  15193.  
  15194. function TTraces.Find(const Name: string): TTrace;
  15195. var
  15196.   i: Integer;
  15197. begin
  15198.   i := IndexOf(Name);
  15199.   if i = -1 then
  15200.     raise EDXTracerError.CreateFmt('Tracer item named %s not found', [Name]);
  15201.   Result := Items[i];
  15202. end;
  15203.  
  15204. function TTraces.GetItem(Index: Integer): TTrace;
  15205. begin
  15206.   Result := TTrace(inherited GetItem(Index));
  15207. end;
  15208.  
  15209. procedure TTraces.SetItem(Index: Integer;
  15210.   Value: TTrace);
  15211. begin
  15212.   inherited SetItem(Index, Value);
  15213. end;
  15214.  
  15215. procedure TTraces.Update(Item: TCollectionItem);
  15216. begin
  15217.   inherited Update(Item);
  15218. end;
  15219.  
  15220. {$IFDEF VER4UP}
  15221. function TTraces.Insert(Index: Integer): TTrace;
  15222. begin
  15223.   Result := TTrace(inherited Insert(Index));
  15224. end;
  15225. {$ENDIF}
  15226.  
  15227. function TTraces.GetOwner: TPersistent;
  15228. begin
  15229.   Result := FOwner;
  15230. end;
  15231.  
  15232. {  TBlit  }
  15233.  
  15234. function TBlit.GetWorldX: Double;
  15235. begin
  15236.   if Parent <> nil then
  15237.     Result := Parent.WorldX + FBlitRec.FX
  15238.   else
  15239.     Result := FBlitRec.FX;
  15240. end;
  15241.  
  15242. function TBlit.GetWorldY: Double;
  15243. begin
  15244.   if Parent <> nil then
  15245.     Result := Parent.WorldY + FBlitRec.FY
  15246.   else
  15247.     Result := FBlitRec.FY;
  15248. end;
  15249.  
  15250. procedure TBlit.DoMove(LagCount: Integer);
  15251. var
  15252.   MoveIt: Boolean;
  15253. begin
  15254.   if not FBlitRec.FMoved then Exit;
  15255.   if AsSigned(FOnMove) then begin
  15256.     MoveIt := True; {if nothing then reanimate will force}
  15257.     FOnMove(Self, LagCount, MoveIt); {when returned MoveIt = true still that do not move}
  15258.     if MoveIt then
  15259.       ReAnimate(LagCount); //for reanimation
  15260.   end
  15261.   else begin
  15262.     ReAnimate(LagCount);
  15263.   end;
  15264.   {there is moving to next foot of the path}
  15265.   if Active then
  15266.     if GetPathCount > 0 then begin
  15267.       Dec(FCurrentTime, LagCount);
  15268.       if FCurrentTime < 0 then begin
  15269.         if FBustrofedon then begin
  15270.           case FCurrentDirection of
  15271.             True: begin
  15272.                 Inc(FCurrentPosition); //go forward
  15273.                 if FCurrentPosition = (GetPathCount - 1) then
  15274.                   FCurrentDirection := not FCurrentDirection //change direction
  15275.               end;
  15276.             False: begin
  15277.                 Dec(FCurrentPosition); //go backward
  15278.                 if FCurrentPosition = 0 then
  15279.                   FCurrentDirection := not FCurrentDirection //change direction
  15280.               end;
  15281.           end;
  15282.         end
  15283.         else
  15284.           if FCurrentPosition < (GetPathCount - 1) then begin
  15285.             Inc(FCurrentPosition) //go forward only
  15286.           end
  15287.           else
  15288.             if FMovingRepeatly then
  15289.               FCurrentPosition := 0; {return to start}
  15290.         {get actual new value for showing time}
  15291.         {must be pick-up there, after change of the current position}
  15292.         FCurrentTime := Path[FCurrentPosition].StayOn; {cas mezi pohyby}
  15293.       end;
  15294.       X := Path[FCurrentPosition].X;
  15295.       Y := Path[FCurrentPosition].Y;
  15296.     end;
  15297.   {}
  15298. end;
  15299.  
  15300. function TBlit.GetDrawImageIndex: Integer;
  15301. begin
  15302.   Result := FBlitRec.FAnimStart + Trunc(FBlitRec.FAnimPos);
  15303. end;
  15304.  
  15305. procedure TBlit.DoDraw;
  15306. var
  15307.   f: TRenderMirrorFlipSet;
  15308.   r: TRect;
  15309. begin
  15310.   with FBlitRec do begin
  15311.     if not FVisible then Exit;
  15312.     if FImage = nil then DoGetImage;
  15313.     if FImage = nil then Exit;
  15314.     {owner draw called here}
  15315.     if AsSigned(FOnDraw) then
  15316.       FOnDraw(Self)
  15317.     else
  15318.     {when is not owner draw then go here}
  15319.     begin
  15320.       f := [];
  15321.       if FMirror then f := f + [rmfMirror];
  15322.       if FFlip then f := f + [rmfFlip];
  15323.       r := Bounds(Round(FX), Round(FY), FImage.Width, FImage.Height);
  15324.       DXDraw_Render(FEngine, FImage, r,
  15325.         GetDrawImageIndex, FBlurImageArr, FBlurImage, FTextureFilter, f, FBlendMode, FAngle,
  15326.         FAlpha, FCenterX, FCenterY, FScale, FWaveType, FAmplitude, FAmpLength, FPhase);
  15327.     end;
  15328.   end
  15329. end;
  15330.  
  15331. function Mod2f(i: Double; i2: Integer): Double;
  15332. begin
  15333.   if i2 = 0 then
  15334.     Result := i
  15335.   else
  15336.   begin
  15337.     Result := i - Round(i / i2) * i2;
  15338.     if Result < 0 then
  15339.       Result := i2 + Result;
  15340.   end;
  15341. end;
  15342.  
  15343. procedure TBlit.ReAnimate(MoveCount: Integer);
  15344. var I: Integer;
  15345. begin
  15346.   with FBlitRec do begin
  15347.     FAnimPos := FAnimPos + FAnimSpeed * MoveCount;
  15348.  
  15349.     if FAnimLooped then
  15350.     begin
  15351.       if FAnimCount > 0 then
  15352.         FAnimPos := Mod2f(FAnimPos, FAnimCount)
  15353.       else
  15354.         FAnimPos := 0;
  15355.     end
  15356.     else
  15357.     begin
  15358.       if Round(FAnimPos) >= FAnimCount then
  15359.       begin
  15360.         FAnimPos := FAnimCount - 1;
  15361.         FAnimSpeed := 0;
  15362.       end;
  15363.       if FAnimPos < 0 then
  15364.       begin
  15365.         FAnimPos := 0;
  15366.         FAnimSpeed := 0;
  15367.       end;
  15368.     end;
  15369.     {incerease or decrease speed}
  15370.     if (FEnergy <> 0) then begin
  15371.       FSpeedX := FSpeedX + FSpeedX * FEnergy;
  15372.       FSpeedY := FSpeedY + FSpeedY * FEnergy;
  15373.     end;
  15374.     {adjust with speed}
  15375.     if (FSpeedX > 0) or (FSpeedY > 0) then begin
  15376.       FX := FX + FSpeedX * MoveCount;
  15377.       FY := FY + FSpeedY * MoveCount;
  15378.     end;
  15379.     {and gravity aplicable}
  15380.     if (FGravityX > 0) or (FGravityY > 0) then begin
  15381.       FX := FX + FGravityX * MoveCount;
  15382.       FY := FY + FGravityY * MoveCount;
  15383.     end;
  15384.     if FBlurImage then begin
  15385.       {ale jen jsou-li jine souradnice}
  15386.       if (FBlurImageArr[High(FBlurImageArr)].eX <> Round(WorldX)) or
  15387.       (FBlurImageArr[High(FBlurImageArr)].eY <> Round(WorldY)) then begin
  15388.         for i := Low(FBlurImageArr) + 1 to High(FBlurImageArr) do begin
  15389.           FBlurImageArr[i - 1] := FBlurImageArr[i];
  15390.           {adjust the blur intensity}
  15391.           FBlurImageArr[i - 1].eIntensity := Round(FAlpha / (High(FBlurImageArr) + 1)) * (i - 1);
  15392.         end;
  15393.         with FBlurImageArr[High(FBlurImageArr)] do begin
  15394.           eX := Round(WorldX);
  15395.           eY := Round(WorldY);
  15396.           ePatternIndex := GetDrawImageIndex;
  15397.           eIntensity := Round(FAlpha / (High(FBlurImageArr) + 1)) * High(FBlurImageArr);
  15398.           eBlendMode := FBlendMode;
  15399.           eActive := True;
  15400.         end;
  15401.       end;
  15402.     end;
  15403.   end;
  15404. end;
  15405.  
  15406. function TBlit.DoCollision: TBlit;
  15407. var
  15408.   i, maxzaxis: Integer;
  15409. begin
  15410.   Result := nil;
  15411.   if not FBlitRec.FCollisioned then Exit;
  15412.   if AsSigned(FOnCollision) then
  15413.     FOnCollision(Self)
  15414.   else begin
  15415.     {over z axis}
  15416.     maxzaxis := 0;
  15417.     for i := 0 to FEngine.Traces.Count - 1 do
  15418.       maxzaxis := Max(maxzaxis, FEngine.Traces.Items[i].FBlit.Z);
  15419.     {for all items}
  15420.     for i := 0 to FEngine.Traces.Count - 1 do
  15421.       {no self item}
  15422.       if FEngine.Traces.Items[i].FBlit <> Self then
  15423.         {through engine}
  15424.         with FEngine.Traces.Items[i] do
  15425.           {test overlap}
  15426.           if OverlapRect(Bounds(Round(FBlit.WorldX), Round(FBlit.WorldY),
  15427.             FBlit.Width, FBlit.Height), Bounds(Round(WorldX), Round(WorldY), Width, Height)) then
  15428.           begin
  15429.             {if any, then return first blit}
  15430.             Result := FBlit;
  15431.             {and go out}
  15432.             Break;
  15433.           end;
  15434.   end;
  15435. end;
  15436.  
  15437. procedure TBlit.DoGetImage;
  15438. begin
  15439.   {init image when object come from form}
  15440.   if FImage = nil then
  15441.     if AsSigned(FOnGetImage) then begin
  15442.       FOnGetImage(Self);
  15443.       if FImage = nil then
  15444.         raise EDXBlitError.Create('Undefined image file!');
  15445.       FBlitRec.FWidth := FImage.Width;
  15446.       FBlitRec.FHeight := FImage.Height;
  15447.     end;
  15448. end;
  15449.  
  15450. constructor TBlit.Create(AParent: TObject);
  15451. begin
  15452.   inherited Create;
  15453.   FParent := nil;
  15454.   if AParent is TBlit then
  15455.     FParent := TBlit(AParent);
  15456.   FillChar(FBlitRec, SizeOf(FBlitRec), 0);
  15457.   with FBlitRec do begin
  15458.     FCollisioned := True; {can be collisioned}
  15459.     FMoved := True; {can be moved}
  15460.     FVisible := True; {can be rendered}
  15461.     FAnimCount := 0;
  15462.     FAnimLooped := False;
  15463.     FAnimPos := 0;
  15464.     FAnimSpeed := 0;
  15465.     FAnimStart := 0;
  15466.     FAngle := 0;
  15467.     FAlpha := $FF;
  15468.     FCenterX := 0.5;
  15469.     FCenterY := 0.5;
  15470.     FScale := 1;
  15471.     FBlendMode := rtDraw;
  15472.     FAmplitude := 0;
  15473.     FAmpLength := 0;
  15474.     FPhase := 0;
  15475.     FWaveType := wtWaveNone;
  15476.     FSpeedX := 0;
  15477.     FSpeedY := 0;
  15478.     FGravityX := 0;
  15479.     FGravityY := 0;
  15480.     FEnergy := 0;
  15481.     FBlurImage := False;
  15482.     FMirror := False;
  15483.     FFlip := False;
  15484.   end;
  15485.   FillChar(FBlurImageArr, SizeOf(FBlitRec), 0);
  15486.   FActive := True; {active on}
  15487.   FMovingRepeatly := True;
  15488.   {super private}
  15489.   FCurrentTime := 0;
  15490.   FCurrentPosition := 0;
  15491.   FCurrentDirection := True;
  15492. end;
  15493.  
  15494. destructor TBlit.Destroy;
  15495. begin
  15496.   {$IFDEF VER4UP}
  15497.   SetLength(FPathArr, 0);
  15498.   {$ELSE}
  15499.   SetPathLen(0);
  15500.   {$ENDIF}
  15501.   inherited;
  15502. end;
  15503.  
  15504. function TBlit.GetMoved: Boolean;
  15505. begin
  15506.   Result := FBlitRec.FMoved;
  15507. end;
  15508.  
  15509. procedure TBlit.SetMoved(const Value: Boolean);
  15510. begin
  15511.   FBlitRec.FMoved := Value;
  15512. end;
  15513.  
  15514. function TBlit.GetWaveType: TWaveType;
  15515. begin
  15516.   Result := FBlitRec.FWaveType;
  15517. end;
  15518.  
  15519. procedure TBlit.SetWaveType(const Value: TWaveType);
  15520. begin
  15521.   FBlitRec.FWaveType := Value;
  15522. end;
  15523.  
  15524. function TBlit.GetAmplitude: Integer;
  15525. begin
  15526.   Result := FBlitRec.FAmplitude;
  15527. end;
  15528.  
  15529. procedure TBlit.SetAmplitude(const Value: Integer);
  15530. begin
  15531.   FBlitRec.FAmplitude := Value;
  15532. end;
  15533.  
  15534. function TBlit.GetAnimStart: Integer;
  15535. begin
  15536.   Result := FBlitRec.FAnimStart;
  15537. end;
  15538.  
  15539. procedure TBlit.SetAnimStart(const Value: Integer);
  15540. begin
  15541.   FBlitRec.FAnimStart := Value;
  15542. end;
  15543.  
  15544. function TBlit.GetAmpLength: Integer;
  15545. begin
  15546.   Result := FBlitRec.FAmpLength;
  15547. end;
  15548.  
  15549. procedure TBlit.SetAmpLength(const Value: Integer);
  15550. begin
  15551.   FBlitRec.FAmpLength := Value;
  15552. end;
  15553.  
  15554. function TBlit.GetWidth: Integer;
  15555. begin
  15556.   Result := FBlitRec.FWidth;
  15557. end;
  15558.  
  15559. procedure TBlit.SetWidth(const Value: Integer);
  15560. begin
  15561.   FBlitRec.FWidth := Value;
  15562. end;
  15563.  
  15564. function TBlit.GetGravityX: Single;
  15565. begin
  15566.   Result := FBlitRec.FGravityX;
  15567. end;
  15568.  
  15569. procedure TBlit.SetGravityX(const Value: Single);
  15570. begin
  15571.   FBlitRec.FGravityX := Value;
  15572. end;
  15573.  
  15574. function TBlit.StoreGravityX: Boolean;
  15575. begin
  15576.   Result := FBlitRec.FGravityX <> 1.0;
  15577. end;
  15578.  
  15579. function TBlit.GetPhase: Integer;
  15580. begin
  15581.   Result := FBlitRec.FPhase;
  15582. end;
  15583.  
  15584. procedure TBlit.SetPhase(const Value: Integer);
  15585. begin
  15586.   FBlitRec.FPhase := Value;
  15587. end;
  15588.  
  15589. function TBlit.GetAnimPos: Double;
  15590. begin
  15591.   Result := FBlitRec.FAnimPos;
  15592. end;
  15593.  
  15594. procedure TBlit.SetAnimPos(const Value: Double);
  15595. begin
  15596.   FBlitRec.FAnimPos := Value;
  15597. end;
  15598.  
  15599. function TBlit.StoreAnimPos: Boolean;
  15600. begin
  15601.   Result := FBlitRec.FAnimPos <> 0;
  15602. end;
  15603.  
  15604. function TBlit.GetFlip: Boolean;
  15605. begin
  15606.   Result := FBlitRec.FFlip;
  15607. end;
  15608.  
  15609. procedure TBlit.SetFlip(const Value: Boolean);
  15610. begin
  15611.   FBlitRec.FFlip := Value;
  15612. end;
  15613.  
  15614. function TBlit.GetGravityY: Single;
  15615. begin
  15616.   Result := FBlitRec.FGravityY;
  15617. end;
  15618.  
  15619. procedure TBlit.SetGravityY(const Value: Single);
  15620. begin
  15621.   FBlitRec.FGravityY := Value;
  15622. end;
  15623.  
  15624. function TBlit.StoreGravityY: Boolean;
  15625. begin
  15626.   Result := FBlitRec.FGravityY <> 1.0;
  15627. end;
  15628.  
  15629. function TBlit.GetSpeedX: Single;
  15630. begin
  15631.   Result := FBlitRec.FSpeedX;
  15632. end;
  15633.  
  15634. procedure TBlit.SetSpeedX(const Value: Single);
  15635. begin
  15636.   FBlitRec.FSpeedX := Value;
  15637. end;
  15638.  
  15639. function TBlit.StoreSpeedX: Boolean;
  15640. begin
  15641.   Result := FBlitRec.FSpeedX <> 0;
  15642. end;
  15643.  
  15644. function TBlit.GetSpeedY: Single;
  15645. begin
  15646.   Result := FBlitRec.FSpeedY;
  15647. end;
  15648.  
  15649. procedure TBlit.SetSpeedY(const Value: Single);
  15650. begin
  15651.   FBlitRec.FSpeedY := Value;
  15652. end;
  15653.  
  15654. function TBlit.StoreSpeedY: Boolean;
  15655. begin
  15656.   Result := FBlitRec.FSpeedY <> 0;
  15657. end;
  15658.  
  15659. function TBlit.GetCenterX: Double;
  15660. begin
  15661.   Result := FBlitRec.FCenterX;
  15662. end;
  15663.  
  15664. procedure TBlit.SetCenterX(const Value: Double);
  15665. begin
  15666.   FBlitRec.FCenterX := Value;
  15667. end;
  15668.  
  15669. function TBlit.StoreCenterX: Boolean;
  15670. begin
  15671.   Result := FBlitRec.FCenterX <> 0.5;
  15672. end;
  15673.  
  15674. function TBlit.GetAngle: Single;
  15675. begin
  15676.   Result := FBlitRec.FAngle;
  15677. end;
  15678.  
  15679. procedure TBlit.SetAngle(const Value: Single);
  15680. begin
  15681.   FBlitRec.FAngle := Value;
  15682. end;
  15683.  
  15684. function TBlit.StoreAngle: Boolean;
  15685. begin
  15686.   Result := FBlitRec.FAngle <> 0;
  15687. end;
  15688.  
  15689. function TBlit.GetBlurImage: Boolean;
  15690. begin
  15691.   Result := FBlitRec.FBlurImage;
  15692. end;
  15693.  
  15694. procedure TBlit.SetBlurImage(const Value: Boolean);
  15695. begin
  15696.   FBlitRec.FBlurImage := Value;
  15697. end;
  15698.  
  15699. function TBlit.GetCenterY: Double;
  15700. begin
  15701.   Result := FBlitRec.FCenterY;
  15702. end;
  15703.  
  15704. procedure TBlit.SetCenterY(const Value: Double);
  15705. begin
  15706.   FBlitRec.FCenterY := Value;
  15707. end;
  15708.  
  15709. function TBlit.StoreCenterY: Boolean;
  15710. begin
  15711.   Result := FBlitRec.FCenterY <> 0.5;
  15712. end;
  15713.  
  15714. function TBlit.GetBlendMode: TRenderType;
  15715. begin
  15716.   Result := FBlitRec.FBlendMode;
  15717. end;
  15718.  
  15719. procedure TBlit.SetBlendMode(const Value: TRenderType);
  15720. begin
  15721.   FBlitRec.FBlendMode := Value;
  15722. end;
  15723.  
  15724. function TBlit.GetAnimSpeed: Double;
  15725. begin
  15726.   Result := FBlitRec.FAnimSpeed;
  15727. end;
  15728.  
  15729. procedure TBlit.SetAnimSpeed(const Value: Double);
  15730. begin
  15731.   FBlitRec.FAnimSpeed := Value;
  15732. end;
  15733.  
  15734. function TBlit.StoreAnimSpeed: Boolean;
  15735. begin
  15736.   Result := FBlitRec.FAnimSpeed <> 0;
  15737. end;
  15738.  
  15739. function TBlit.GetZ: Integer;
  15740. begin
  15741.   Result := FBlitRec.FZ;
  15742. end;
  15743.  
  15744. procedure TBlit.SetZ(const Value: Integer);
  15745. begin
  15746.   FBlitRec.FZ := Value;
  15747. end;
  15748.  
  15749. function TBlit.GetMirror: Boolean;
  15750. begin
  15751.   Result := FBlitRec.FMirror;
  15752. end;
  15753.  
  15754. procedure TBlit.SetMirror(const Value: Boolean);
  15755. begin
  15756.   FBlitRec.FMirror := Value;
  15757. end;
  15758.  
  15759. function TBlit.GetX: Double;
  15760. begin
  15761.   Result := FBlitRec.FX;
  15762. end;
  15763.  
  15764. procedure TBlit.SetX(const Value: Double);
  15765. begin
  15766.   FBlitRec.FX := Value;
  15767. end;
  15768.  
  15769. function TBlit.GetVisible: Boolean;
  15770. begin
  15771.   Result := FBlitRec.FVisible;
  15772. end;
  15773.  
  15774. procedure TBlit.SetVisible(const Value: Boolean);
  15775. begin
  15776.   FBlitRec.FVisible := Value;
  15777. end;
  15778.  
  15779. function TBlit.GetY: Double;
  15780. begin
  15781.   Result := FBlitRec.FY;
  15782. end;
  15783.  
  15784. procedure TBlit.SetY(const Value: Double);
  15785. begin
  15786.   FBlitRec.FY := Value;
  15787. end;
  15788.  
  15789. function TBlit.GetAlpha: Byte;
  15790. begin
  15791.   Result := FBlitRec.FAlpha;
  15792. end;
  15793.  
  15794. procedure TBlit.SetAlpha(const Value: Byte);
  15795. begin
  15796.   FBlitRec.FAlpha := Value;
  15797. end;
  15798.  
  15799. function TBlit.GetEnergy: Single;
  15800. begin
  15801.   Result := FBlitRec.FEnergy;
  15802. end;
  15803.  
  15804. procedure TBlit.SetEnergy(const Value: Single);
  15805. begin
  15806.   FBlitRec.FEnergy := Value;
  15807. end;
  15808.  
  15809. function TBlit.StoreEnergy: Boolean;
  15810. begin
  15811.   Result := FBlitRec.FEnergy <> 0;
  15812. end;
  15813.  
  15814. function TBlit.GetCollisioned: Boolean;
  15815. begin
  15816.   Result := FBlitRec.FCollisioned;
  15817. end;
  15818.  
  15819. procedure TBlit.SetCollisioned(const Value: Boolean);
  15820. begin
  15821.   FBlitRec.FCollisioned := Value;
  15822. end;
  15823.  
  15824. function TBlit.GetAnimLooped: Boolean;
  15825. begin
  15826.   Result := FBlitRec.FAnimLooped;
  15827. end;
  15828.  
  15829. procedure TBlit.SetAnimLooped(const Value: Boolean);
  15830. begin
  15831.   FBlitRec.FAnimLooped := Value;
  15832. end;
  15833.  
  15834. function TBlit.GetHeight: Integer;
  15835. begin
  15836.   Result := FBlitRec.FHeight;
  15837. end;
  15838.  
  15839. procedure TBlit.SetHeight(const Value: Integer);
  15840. begin
  15841.   FBlitRec.FHeight := Value;
  15842. end;
  15843.  
  15844. function TBlit.GetScale: Double;
  15845. begin
  15846.   Result := FBlitRec.FScale;
  15847. end;
  15848.  
  15849. procedure TBlit.SetScale(const Value: Double);
  15850. begin
  15851.   FBlitRec.FScale := Value;
  15852. end;
  15853.  
  15854. function TBlit.StoreScale: Boolean;
  15855. begin
  15856.   Result := FBlitRec.FScale <> 1.0;
  15857. end;
  15858.  
  15859. function TBlit.GetAnimCount: Integer;
  15860. begin
  15861.   Result := FBlitRec.FAnimCount;
  15862. end;
  15863.  
  15864. procedure TBlit.SetAnimCount(const Value: Integer);
  15865. begin
  15866.   FBlitRec.FAnimCount := Value;
  15867. end;
  15868.  
  15869. function TBlit.GetTextureFilter: TD2DTextureFilter;
  15870. begin
  15871.   Result := FBlitRec.FTextureFilter;
  15872. end;
  15873.  
  15874. procedure TBlit.SetTextureFilter(const Value: TD2DTextureFilter);
  15875. begin
  15876.   FBlitRec.FTextureFilter := Value;
  15877. end;
  15878.  
  15879. function TBlit.GetBoundsRect: TRect;
  15880. begin
  15881.   Result := Bounds(Round(WorldX), Round(WorldY), Width, Height);
  15882. end;
  15883.  
  15884. function TBlit.GetClientRect: TRect;
  15885. begin
  15886.   Result := Bounds(0, 0, Width, Height);
  15887. end;
  15888.  
  15889. function TBlit.GetBlitAt(X, Y: Integer): TBlit;
  15890.  
  15891.   procedure BlitAt(X, Y: Double; Blit: TBlit);
  15892.   var
  15893.     i: Integer;
  15894.     X2, Y2: Double;
  15895.   begin
  15896.     if Blit.Visible and PointInRect(Point(Round(X), Round(Y)),
  15897.       Bounds(Round(Blit.X), Round(Blit.Y), Blit.Width, Blit.Width)) then
  15898.     begin
  15899.       if (Result = nil) or (Blit.Z > Result.Z) then
  15900.         Result := Blit; {uniquelly - where will be store last blit}
  15901.     end;
  15902.  
  15903.     X2 := X - Blit.X;
  15904.     Y2 := Y - Blit.Y;
  15905.     for i := 0 to Blit.Engine.FTraces.Count - 1 do
  15906.       BlitAt(X2, Y2, Blit.Engine.FTraces.Items[i].FBlit);
  15907.   end;
  15908.  
  15909. var
  15910.   i: Integer;
  15911.   X2, Y2: Double;
  15912. begin
  15913.   Result := nil;
  15914.  
  15915.   X2 := X - Self.X;
  15916.   Y2 := Y - Self.Y;
  15917.   for i := 0 to Engine.FTraces.Count - 1 do
  15918.     BlitAt(X2, Y2, Engine.FTraces.Items[i].FBlit);
  15919. end;
  15920.  
  15921. procedure TBlit.SetPathLen(Len: Integer);
  15922. var I, L: Integer;
  15923. begin
  15924.   {$IFDEF VER4UP}
  15925.   if Length(FPathArr) <> Len then
  15926.   {$ELSE}
  15927.   if FPathLen <> Len then
  15928.   {$ENDIF}
  15929.   begin
  15930.     L := Len;
  15931.     if Len <= 0 then L := 0;
  15932.     {$IFDEF VER4UP}
  15933.     SetLength(FPathArr, L);
  15934.     for I := Low(FPathArr) to High(FPathArr) do begin
  15935.       FillChar(FPathArr[i], SizeOf(FPathArr), 0);
  15936.       FPathArr[i].StayOn := 25;
  15937.     end;
  15938.     {$ELSE}
  15939.     FPathLen := L;
  15940.     if FPathArr = nil then
  15941.       FPAthArr := AllocMem(FPathLen * SizeOf(TPath))
  15942.     else
  15943.       {alokuj pamet}
  15944.       ReallocMem(FPathArr, FPathLen * SizeOf(TPath));
  15945.     if Assigned(FPathArr) then begin
  15946.       FillChar(FPathArr^, FPathLen * SizeOf(TPath), 0);
  15947.       for I := 0 to FPathLen do
  15948.         FPathArr[i].StayOn := 25;
  15949.     end
  15950.     {$ENDIF}
  15951.   end;
  15952. end;
  15953.  
  15954. function TBlit.IsPathEmpty: Boolean;
  15955. begin
  15956.   {$IFNDEF VER4UP}
  15957.   Result := FPathLen = 0;
  15958.   {$ELSE}
  15959.   Result := Length(FPathArr) = 0;
  15960.   {$ENDIF}
  15961. end;
  15962.  
  15963. function TBlit.GetPathCount: Integer;
  15964. begin
  15965.   {$IFNDEF VER4UP}
  15966.   Result := FPathLen;
  15967.   {$ELSE}
  15968.   Result := Length(FPathArr);
  15969.   {$ENDIF}
  15970. end;
  15971.  
  15972. function TBlit.GetPath(index: Integer): TPath;
  15973. begin
  15974.   {$IFDEF VER4UP}
  15975.   if (index >= Low(FPathArr)) and (index <= High(FPathArr)) then
  15976.   {$ELSE}
  15977.   if (index >= 0) and (index < FPathLen) then
  15978.   {$ENDIF}
  15979.     Result := FPathArr[index]
  15980.   else
  15981.     raise Exception.Create('Bad path index!');
  15982. end;
  15983.  
  15984. procedure TBlit.SetPath(index: Integer; const Value: TPath);
  15985. begin
  15986.   {$IFDEF VER4UP}
  15987.   if (index >= Low(FPathArr)) and (index <= High(FPathArr)) then
  15988.   {$ELSE}
  15989.   if (index >= 0) and (index < FPathLen) then
  15990.   {$ENDIF}
  15991.     FPathArr[index] := Value
  15992.   else
  15993.     raise Exception.Create('Bad path index!');
  15994. end;
  15995.  
  15996. procedure TBlit.ReadPaths(Stream: TStream);
  15997. var
  15998.   PathLen: Integer;
  15999. begin
  16000.   {nacti delku}
  16001.   Stream.ReadBuffer(PathLen, SizeOf(PathLen));
  16002.   SetPathLen(PathLen);
  16003.   Stream.ReadBuffer(FPathArr[0], PathLen * SizeOf(TPath));
  16004. end;
  16005.  
  16006. procedure TBlit.WritePaths(Stream: TStream);
  16007. var
  16008.   PathLen: Integer;
  16009. begin
  16010.   PathLen := GetPathCount;
  16011.   Stream.WriteBuffer(PathLen, SizeOf(PathLen));
  16012.   Stream.WriteBuffer(FPathArr[0], PathLen * SizeOf(TPath));
  16013. end;
  16014.  
  16015. procedure TBlit.DefineProperties(Filer: TFiler);
  16016. begin
  16017.   inherited DefineProperties(Filer);
  16018.   Filer.DefineBinaryProperty('Paths', ReadPaths, WritePaths, not IsPathEmpty);
  16019. end;
  16020.  
  16021. procedure TBlit.Assign(Source: TPersistent);
  16022. var I: Integer;
  16023. begin
  16024.   if Source is TBlit then
  16025.   begin
  16026.     {$IFDEF VER4UP}
  16027.     I := Length(TBlit(Source).FPathArr);
  16028.     {$ELSE}
  16029.     I := FPathLen;
  16030.     {$ENDIF}
  16031.     SetPathLen(I);
  16032.     if I > 0 then
  16033.       Move(TBlit(Source).FPathArr[0], FPathArr[0], I * SizeOf(TPath));
  16034.     FBlitRec := TBlit(Source).FBlitRec;
  16035.     FillChar(FBlurImageArr, SizeOf(FBlurImageArr), 0);
  16036.     FActive := TBlit(Source).FActive;
  16037.     FMovingRepeatly := TBlit(Source).FMovingRepeatly;
  16038.     FImage := nil;
  16039.     FOnMove := TBlit(Source).FOnMove;
  16040.     FOnDraw := TBlit(Source).FOnDraw;
  16041.     FOnCollision := TBlit(Source).FOnCollision;
  16042.     FOnGetImage := TBlit(Source).FOnGetImage;
  16043.     FEngine := TBlit(Source).FEngine;
  16044.   end
  16045.   else
  16046.     inherited Assign(Source);
  16047. end;
  16048.  
  16049. function TBlit.GetMovingRepeatly: Boolean;
  16050. begin
  16051.   Result := FMovingRepeatly;
  16052. end;
  16053.  
  16054. procedure TBlit.SetMovingRepeatly(const Value: Boolean);
  16055. begin
  16056.   FMovingRepeatly := Value;
  16057. end;
  16058.  
  16059. function TBlit.GetBustrofedon: Boolean;
  16060. begin
  16061.   Result := FBustrofedon;
  16062. end;
  16063.  
  16064. procedure TBlit.SetBustrofedon(const Value: Boolean);
  16065. begin
  16066.   FBustrofedon := Value;
  16067. end;
  16068.  
  16069. {  utility draw  }
  16070.  
  16071. procedure DXDraw_Draw(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
  16072.   Rect: TRect; Pattern: Integer; TextureFilter: TD2DTextureFilter;
  16073.   MirrorFlip: TRenderMirrorFlipSet;
  16074.   BlendMode: TRenderType; Angle: Single; Alpha: Byte;
  16075.   CenterX: Double; CenterY: Double;
  16076.   Scale: Single); {$IFDEF VER9UP}inline;{$ENDIF}
  16077. var
  16078. //  r: TRect;
  16079.   width, height: Integer;
  16080. begin
  16081.   if not Assigned(DXDraw.Surface) then Exit;
  16082.   if not Assigned(Image) then Exit;
  16083.   if Scale <> 1.0 then begin
  16084.     width := Round(Scale * Image.Width);
  16085.     height := Round(Scale * Image.Height);
  16086.   end
  16087.   else begin
  16088.     width := Image.Width;
  16089.     height := Image.Height;
  16090.   end;
  16091.   //r := Bounds(X, Y, width, height);
  16092.   DXDraw.TextureFilter(TextureFilter);
  16093.   DXDraw.MirrorFlip(MirrorFlip);
  16094.   case BlendMode of
  16095.     rtDraw: begin
  16096.         if Angle = 0 then
  16097.           Image.StretchDraw(DXDraw.Surface, Rect, Pattern)
  16098.         else
  16099.           Image.DrawRotate(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16100.             (Rect.Top + Rect.Bottom) div 2,
  16101.             Width, Height, Pattern, CenterX, CenterY, Angle);
  16102.       end;
  16103.     rtBlend: begin
  16104.         if Angle = 0 then
  16105.           Image.DrawAlpha(DXDraw.Surface, Rect, Pattern, Alpha)
  16106.         else
  16107.           Image.DrawRotateAlpha(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16108.             (Rect.Top + Rect.Bottom) div 2,
  16109.             Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16110.       end;
  16111.     rtAdd: begin
  16112.         if Angle = 0 then
  16113.           Image.DrawAdd(DXDraw.Surface, Rect, Pattern, Alpha)
  16114.         else
  16115.           Image.DrawRotateAdd(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16116.             (Rect.Top + Rect.Bottom) div 2,
  16117.             Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16118.       end;
  16119.     rtSub: begin
  16120.         if Angle = 0 then
  16121.           Image.DrawSub(DXDraw.Surface, Rect, Pattern, Alpha)
  16122.         else
  16123.           Image.DrawRotateSub(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16124.             (Rect.Top + Rect.Bottom) div 2,
  16125.             Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16126.       end;
  16127.   end; {case}
  16128. end;
  16129.  
  16130. procedure DXDraw_Paint(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
  16131.   Rect: TRect; Pattern: Integer; var BlurImageArr: TBlurImageArr; BlurImage: Boolean;
  16132.   TextureFilter: TD2DTextureFilter;
  16133.   MirrorFlip: TRenderMirrorFlipSet;
  16134.   BlendMode: TRenderType;
  16135.   Angle: Single;
  16136.   Alpha: Byte;
  16137.   CenterX: Double; CenterY: Double); {$IFDEF VER9UP}inline;{$ENDIF}
  16138. var
  16139.   rr: TRect;
  16140.   i, width, height: Integer;
  16141. begin
  16142.   if not Assigned(DXDraw.Surface) then Exit;
  16143.   if not Assigned(Image) then Exit;
  16144.   width := Image.Width;
  16145.   height := Image.Height;
  16146.   //rr := Bounds(X, Y, width, height);
  16147.   //DXDraw.MirrorFlip(MirrorFlip);
  16148.   DXDraw.TextureFilter(TextureFilter);
  16149.   case BlendMode of
  16150.     rtDraw: begin
  16151.         if BlurImage then begin
  16152.           for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16153.               DXDraw.MirrorFlip(MirrorFlip);
  16154.               rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Width, Height);
  16155.               if Angle = 0 then
  16156.                 Image.DrawAlpha(DXDraw.Surface, rr, BlurImageArr[i].ePatternIndex, BlurImageArr[i].eIntensity)
  16157.               else
  16158.                 Image.DrawRotateAlpha(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16159.                   (rr.Top + rr.Bottom) div 2,
  16160.                   Width, Height, BlurImageArr[i].ePatternIndex, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16161.               if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16162.             end;
  16163.         end;
  16164.         DXDraw.MirrorFlip(MirrorFlip);
  16165.         if Angle = 0 then
  16166.           Image.StretchDraw(DXDraw.Surface, Rect, Pattern)
  16167.         else
  16168.           Image.DrawRotate(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16169.             (Rect.Top + Rect.Bottom) div 2,
  16170.             Width, Height, Pattern, CenterX, CenterY, Angle);
  16171.       end;
  16172.     rtBlend: begin
  16173.         if BlurImage then begin
  16174.           for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16175.               DXDraw.MirrorFlip(MirrorFlip);
  16176.               rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Width, Height);
  16177.               if Angle = 0 then
  16178.                 Image.DrawAlpha(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
  16179.               else
  16180.                 Image.DrawRotateAlpha(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16181.                   (rr.Top + rr.Bottom) div 2,
  16182.                   Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16183.               if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16184.             end;
  16185.         end;
  16186.         DXDraw.MirrorFlip(MirrorFlip);
  16187.         if Angle = 0 then
  16188.           Image.DrawAlpha(DXDraw.Surface, Rect, Pattern, Alpha)
  16189.         else
  16190.           Image.DrawRotateAlpha(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16191.             (Rect.Top + Rect.Bottom) div 2,
  16192.             Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16193.       end;
  16194.     rtAdd: begin
  16195.         if BlurImage then begin
  16196.           for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16197.               DXDraw.MirrorFlip(MirrorFlip);
  16198.               rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Width, Height);
  16199.               if Angle = 0 then
  16200.                 Image.DrawAdd(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
  16201.               else
  16202.                 Image.DrawRotateAdd(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16203.                   (rr.Top + rr.Bottom) div 2,
  16204.                   Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16205.               if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16206.             end;
  16207.         end;
  16208.         DXDraw.MirrorFlip(MirrorFlip);
  16209.         if Angle = 0 then
  16210.           Image.DrawAdd(DXDraw.Surface, Rect, Pattern, Alpha)
  16211.         else
  16212.           Image.DrawRotateAdd(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16213.             (Rect.Top + Rect.Bottom) div 2,
  16214.             Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16215.       end;
  16216.     rtSub: begin
  16217.         if BlurImage then begin
  16218.           for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16219.               DXDraw.MirrorFlip(MirrorFlip);
  16220.               rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Width, Height);
  16221.               if Angle = 0 then
  16222.                 Image.DrawSub(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
  16223.               else
  16224.                 Image.DrawRotateSub(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16225.                   (rr.Top + rr.Bottom) div 2,
  16226.                   Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16227.               if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16228.             end;
  16229.         end;
  16230.         DXDraw.MirrorFlip(MirrorFlip);
  16231.         if Angle = 0 then
  16232.           Image.DrawSub(DXDraw.Surface, Rect, Pattern, Alpha)
  16233.         else
  16234.           Image.DrawRotateSub(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16235.             (Rect.Top + Rect.Bottom) div 2,
  16236.             Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16237.       end;
  16238.   end; {case}
  16239. end;
  16240.  
  16241. procedure DXDraw_Render(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
  16242.   Rect: TRect; Pattern: Integer; var BlurImageArr: TBlurImageArr; BlurImage: Boolean;
  16243.   TextureFilter: TD2DTextureFilter; MirrorFlip: TRenderMirrorFlipSet;
  16244.   BlendMode: TRenderType;
  16245.   Angle: Single;
  16246.   Alpha: Byte;
  16247.   CenterX: Double; CenterY: Double;
  16248.   Scale: Single;
  16249.   WaveType: TWaveType;
  16250.   Amplitude: Integer; AmpLength: Integer; Phase: Integer); {$IFDEF VER9UP}inline;{$ENDIF}
  16251. var
  16252.   rr: TRect;
  16253.   i, width, height: Integer;
  16254. begin
  16255.   if not Assigned(DXDraw.Surface) then Exit;
  16256.   if not Assigned(Image) then Exit;
  16257.   if Scale <> 1.0 then begin
  16258.     width := Round(Scale * Image.Width);
  16259.     height := Round(Scale * Image.Height);
  16260.   end
  16261.   else begin
  16262.     width := Image.Width;
  16263.     height := Image.Height;
  16264.   end;
  16265.   //r := Bounds(X, Y, width, height);
  16266.   DXDraw.TextureFilter(TextureFilter);
  16267.   DXDraw.MirrorFlip(MirrorFlip);
  16268.   case BlendMode of
  16269.     rtDraw:
  16270.       begin
  16271.         case WaveType of
  16272.           wtWaveNone:
  16273.             begin
  16274.               if BlurImage then begin
  16275.                 for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16276.                     DXDraw.MirrorFlip(MirrorFlip);
  16277.                     rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Round(Scale * Width), Round(Scale * Height));
  16278.                     if Angle = 0 then
  16279.                       Image.DrawAlpha(DXDraw.Surface, rr, BlurImageArr[i].ePatternIndex, BlurImageArr[i].eIntensity)
  16280.                     else
  16281.                       Image.DrawRotateAlpha(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16282.                         (rr.Top + rr.Bottom) div 2,
  16283.                         Width, Height, BlurImageArr[i].ePatternIndex, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16284.                     if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16285.                   end;
  16286.               end;
  16287.               DXDraw.MirrorFlip(MirrorFlip);
  16288.               if Angle = 0 then
  16289.                 Image.StretchDraw(DXDraw.Surface, Rect, Pattern)
  16290.               else
  16291.                 Image.DrawRotate(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16292.                   (Rect.Top + Rect.Bottom) div 2,
  16293.                   Width, Height, Pattern, CenterX, CenterY, Angle);
  16294.             end;
  16295.           wtWaveX: Image.DrawWaveX(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase);
  16296.           wtWaveY: Image.DrawWaveY(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase);
  16297.         end;
  16298.       end;
  16299.     rtBlend: begin
  16300.         case WaveType of
  16301.           wtWaveNone: begin
  16302.               if BlurImage then begin
  16303.                 for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16304.                     DXDraw.MirrorFlip(MirrorFlip);
  16305.                     rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Round(Scale * Width), Round(Scale * Height));
  16306.                     if Angle = 0 then
  16307.                       Image.DrawAlpha(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
  16308.                     else
  16309.                       Image.DrawRotateAlpha(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16310.                         (rr.Top + rr.Bottom) div 2,
  16311.                         Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16312.                     if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16313.                   end;
  16314.               end;
  16315.               DXDraw.MirrorFlip(MirrorFlip);
  16316.               if Angle = 0 then
  16317.                 Image.DrawAlpha(DXDraw.Surface, Rect, Pattern, Alpha)
  16318.               else
  16319.                 Image.DrawRotateAlpha(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16320.                   (Rect.Top + Rect.Bottom) div 2,
  16321.                   Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16322.             end;
  16323.           wtWaveX: Image.DrawWaveXAlpha(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
  16324.           wtWaveY: Image.DrawWaveYAlpha(DXDraw.Surface, Round(Rect.Top), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
  16325.         end;
  16326.       end;
  16327.     rtAdd: begin
  16328.         case WaveType of
  16329.           wtWaveNone: begin
  16330.               if BlurImage then begin
  16331.                 for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16332.                     DXDraw.MirrorFlip(MirrorFlip);
  16333.                     rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Round(Scale * Width), Round(Scale * Height));
  16334.                     if Angle = 0 then
  16335.                       Image.DrawAdd(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
  16336.                     else
  16337.                       Image.DrawRotateAdd(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16338.                         (rr.Top + rr.Bottom) div 2,
  16339.                         Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16340.                     if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16341.                   end;
  16342.               end;
  16343.               DXDraw.MirrorFlip(MirrorFlip);
  16344.               if Angle = 0 then
  16345.                 Image.DrawAdd(DXDraw.Surface, Rect, Pattern, Alpha)
  16346.               else
  16347.                 Image.DrawRotateAdd(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16348.                   (Rect.Top + Rect.Bottom) div 2,
  16349.                   Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16350.             end;
  16351.           wtWaveX: Image.DrawWaveXAdd(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
  16352.           wtWaveY: Image.DrawWaveYAdd(DXDraw.Surface, Round(Rect.Top), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
  16353.         end;
  16354.       end;
  16355.     rtSub: begin
  16356.         case WaveType of
  16357.           wtWaveNone: begin
  16358.               if BlurImage then begin
  16359.                 for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16360.                     DXDraw.MirrorFlip(MirrorFlip);
  16361.                     rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Round(Scale * Width), Round(Scale * Height));
  16362.                     if Angle = 0 then
  16363.                       Image.DrawSub(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
  16364.                     else
  16365.                       Image.DrawRotateSub(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16366.                         (rr.Top + rr.Bottom) div 2,
  16367.                         Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16368.                     if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16369.                   end;
  16370.               end;
  16371.               DXDraw.MirrorFlip(MirrorFlip);
  16372.               if Angle = 0 then
  16373.                 Image.DrawSub(DXDraw.Surface, Rect, Pattern, Alpha)
  16374.               else
  16375.                 Image.DrawRotateSub(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16376.                   (Rect.Top + Rect.Bottom) div 2,
  16377.                   Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16378.             end;
  16379.           wtWaveX: Image.DrawWaveXSub(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
  16380.           wtWaveY: Image.DrawWaveYSub(DXDraw.Surface, Round(Rect.Top), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
  16381.         end;
  16382.       end;
  16383.   end; {case}
  16384. end;
  16385.  
  16386. initialization
  16387.   _DXTextureImageLoadFuncList := TList.Create;
  16388.   TDXTextureImage.RegisterLoadFunc(DXTextureImage_LoadDXTextureImageFunc); //delete Mr.Kawasaki
  16389.   TDXTextureImage.RegisterLoadFunc(DXTextureImage_LoadBitmapFunc);
  16390. finalization
  16391.   TDXTextureImage.UnRegisterLoadFunc(DXTextureImage_LoadDXTextureImageFunc); //delete Mr.Kawasaki
  16392.   TDXTextureImage.UnRegisterLoadFunc(DXTextureImage_LoadBitmapFunc);
  16393.   _DXTextureImageLoadFuncList.Free;
  16394.   { driver free }
  16395.   DirectDrawDrivers.Free;
  16396.   {$IFDEF _DMO_}DirectDrawDriversEx.Free;{$ENDIF}
  16397. end.