Subversion Repositories spacemission

Rev

Rev 4 | 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. {
  4582. procedure TDirectDrawSurface.PutPixel8(x, y, color: Integer);
  4583. var
  4584.   SurfacePtr: PByte;
  4585.   PixelOffset: Integer;
  4586. begin
  4587.   SurfacePtr := FLockSurfaceDesc.lpSurface;
  4588.   PixelOffset := x + y * FLockSurfaceDesc.dwWidth;
  4589.   SurfacePtr[PixelOffset] := color and $FF; // set pixel (lo byte of color)
  4590. end;}
  4591.  
  4592. procedure TDirectDrawSurface.PutPixel8(x, y, color: Integer); assembler;
  4593. { on entry:  self = eax, x = edx,   y = ecx,   color = ? }
  4594. asm
  4595.   push esi                              // must maintain esi
  4596.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface// set to surface
  4597.   add esi,edx                           // add x
  4598.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.dwwidth]  // eax = pitch
  4599.   mul ecx                               // eax = pitch * y
  4600.   add esi,eax                           // esi = pixel offset
  4601.   mov ecx, color
  4602.   mov ds:[esi],cl                       // set pixel (lo byte of ecx)
  4603.   pop esi                               // restore esi
  4604.   //ret                                   // return
  4605. end;
  4606.  
  4607. {
  4608. procedure TDirectDrawSurface.PutPixel16(x, y, color: Integer);
  4609. var
  4610.   pPixel: PWord;
  4611. begin
  4612.   pPixel := PWord(Integer(TDirectDrawSurface(Self).FLockSurfaceDesc.lpSurface) +
  4613.              x * 2 + y * TDirectDrawSurface(Self).FLockSurfaceDesc.lPitch);
  4614.   pPixel^ := color;
  4615. end;
  4616. }
  4617.  
  4618. procedure TDirectDrawSurface.PutPixel16(x, y, color: Integer); assembler;
  4619. { on entry:  self = eax, x = edx,   y = ecx,   color = ? }
  4620. asm
  4621.   push esi
  4622.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
  4623.   shl edx,1
  4624.   add esi,edx
  4625.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
  4626.   mul ecx
  4627.   add esi,eax
  4628.   mov ecx, color
  4629.   mov ds:[esi],cx
  4630.   pop esi
  4631.   //ret
  4632. end;
  4633.  
  4634. {
  4635. procedure TDirectDrawSurface.PutPixel24(x, y, color: Integer);
  4636. var
  4637.   pPixel: PByte;
  4638.   dwPitch: DWORD;
  4639.   dwColor: DWORD;
  4640. begin
  4641.   pPixel := PByte(TDirectDrawSurface(Self).FLockSurfaceDesc.lpSurface);
  4642.   Inc(pPixel, x * 3);
  4643.   dwPitch := TDirectDrawSurface(Self).FLockSurfaceDesc.lPitch;
  4644.   Inc(pPixel, y * dwPitch);
  4645.   dwColor := color and $FFFFFF;
  4646.   pPixel[0] := Byte(dwColor);
  4647.   pPixel[1] := Byte(dwColor shr 8);
  4648.   pPixel[2] := Byte(dwColor shr 16);
  4649. end;
  4650. }
  4651.  
  4652. procedure TDirectDrawSurface.PutPixel24(x, y, color: Integer); assembler;
  4653. { on entry:  self = eax, x = edx,   y = ecx,   color = ? }
  4654. asm
  4655.   push esi
  4656.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
  4657.   imul edx,3
  4658.   add esi,edx
  4659.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
  4660.   mul ecx
  4661.   add esi,eax
  4662.   mov eax,ds:[esi]
  4663.   and eax,$FF000000
  4664.   mov ecx, color
  4665.   or  ecx,eax
  4666.   mov ds:[esi+1],ecx
  4667.   pop esi
  4668.   //ret
  4669. end;
  4670.  
  4671. {
  4672. procedure TDirectDrawSurface.PutPixel24(x, y, color: Integer);
  4673. var
  4674.   offset: Integer;
  4675.   pixelColor: LongInt;
  4676. begin
  4677.   offset := (y * TDirectDrawSurface(Self).FLockSurfaceDesc.lpitch) + (x * 3);
  4678.   pixelColor := color and $FFFFFF;
  4679.   Move(pixelColor, PByte(Integer(TDirectDrawSurface(Self).FLockSurfaceDesc.lpSurface) + offset)^, 3);
  4680. end;
  4681. }
  4682.  
  4683. procedure TDirectDrawSurface.PutPixel32(x, y, color: Integer); assembler;
  4684. { on entry:  self = eax, x = edx,   y = ecx,   color = ? }
  4685. asm
  4686.   push esi
  4687.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
  4688.   shl edx,2
  4689.   add esi,edx
  4690.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
  4691.   mul ecx
  4692.   add esi,eax
  4693.   mov ecx, color
  4694.   mov ds:[esi],ecx
  4695.   pop esi
  4696.   //ret
  4697. end;
  4698.  
  4699. procedure TDirectDrawSurface.Poke(X, Y: Integer; const Value: LongInt);
  4700. begin
  4701.   if (X < 0) or (X > (Width - 1)) or
  4702.     (Y < 0) or (Y > (Height - 1)) or not FIsLocked then Exit;
  4703.   case Bitcount of
  4704.     8: PutPixel8(x, y, value);
  4705.     16: PutPixel16(x, y, value);
  4706.     24: PutPixel24(x, y, value);
  4707.     32: PutPixel32(x, y, value);
  4708.   end;
  4709. end;
  4710.  
  4711. {
  4712. function TDirectDrawSurface.GetPixel8(x, y: Integer): Integer;
  4713. var
  4714.   Pixel: Byte;
  4715.   PixelPtr: PByte;
  4716. begin
  4717.   PixelPtr := PByte(TDirectDrawSurface(Self).FLockSurfaceDesc.lpSurface + x + (y * TDirectDrawSurface(Self).FLockSurfaceDesc.lpitch));
  4718.   Pixel := PixelPtr^;
  4719.   Result := Pixel;
  4720. end;
  4721.  
  4722. function TDirectDrawSurface.GetPixel16(x, y: Integer): Integer;
  4723. var
  4724.   Pixel: Word;
  4725.   PixelPtr: PWord;
  4726. begin
  4727.   PixelPtr := PWord(TDirectDrawSurface(Self).FLockSurfaceDesc.lpSurface + (x * 2) + (y * TDirectDrawSurface(Self).FLockSurfaceDesc.lpitch));
  4728.   Pixel := PixelPtr^;
  4729.   Result := Pixel;
  4730. end;
  4731.  
  4732. function TDirectDrawSurface.GetPixel24(x, y: Integer): Integer;
  4733. var
  4734.   Pixel: array[0..2] of Byte;
  4735.   PixelPtr: PByte;
  4736. begin
  4737.   PixelPtr := PByte(TDirectDrawSurface(Self).FLockSurfaceDesc.lpSurface + (x * 3) + (y * TDirectDrawSurface(Self).FLockSurfaceDesc.lpitch));
  4738.   Pixel[0] := PixelPtr^;
  4739.   Pixel[1] := (PixelPtr+1)^;
  4740.   Pixel[2] := (PixelPtr+2)^;
  4741.   Result := Pixel[0] or (Pixel[1] shl 8) or (Pixel[2] shl 16);
  4742. end;
  4743.  
  4744. function TDirectDrawSurface.GetPixel32(x, y: Integer): Integer;
  4745. var
  4746.   Pixel: Integer;
  4747.   PixelPtr: PInteger;
  4748. begin
  4749.   PixelPtr := PInteger(TDirectDrawSurface(Self).FLockSurfaceDesc.lpSurface + (x * 4) + (y * TDirectDrawSurface(Self).FLockSurfaceDesc.lpitch));
  4750.   Pixel := PixelPtr^;
  4751.   Result := Pixel;
  4752. end;
  4753. }
  4754.  
  4755. function TDirectDrawSurface.GetPixel8(x, y: Integer): Integer; assembler;
  4756. { on entry:  self = eax, x = edx,   y = ecx,   result = eax }
  4757. asm
  4758.   push esi                              // myst maintain esi
  4759.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface        // set to surface
  4760.   add esi,edx                           // add x
  4761.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]         // eax = pitch
  4762.   mul ecx                               // eax = pitch * y
  4763.   add esi,eax                           // esi = pixel offset
  4764.   mov eax,ds:[esi]                      // eax = color
  4765.   and eax,$FF                           // map into 8bit
  4766.   pop esi                               // restore esi
  4767.   //ret                                   // return
  4768. end;
  4769.  
  4770. function TDirectDrawSurface.GetPixel16(x, y: Integer): Integer; assembler;
  4771. { on entry:  self = eax, x = edx,   y = ecx,   result = eax }
  4772. asm
  4773.   push esi
  4774.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
  4775.   shl edx,1
  4776.   add esi,edx
  4777.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
  4778.   mul ecx
  4779.   add esi,eax
  4780.   mov eax,ds:[esi]
  4781.   and eax,$FFFF                         // map into 16bit
  4782.   pop esi
  4783.   //ret
  4784. end;
  4785.  
  4786. function TDirectDrawSurface.GetPixel24(x, y: Integer): Integer; assembler;
  4787. { on entry:  self = eax, x = edx,   y = ecx,   result = eax }
  4788. asm
  4789.   push esi
  4790.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
  4791.   imul edx,3
  4792.   add esi,edx
  4793.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
  4794.   mul ecx
  4795.   add esi,eax
  4796.   mov eax,ds:[esi]
  4797.   and eax,$FFFFFF                       // map into 24bit
  4798.   pop esi
  4799.   //ret
  4800. end;
  4801.  
  4802. function TDirectDrawSurface.GetPixel32(x, y: Integer): Integer; assembler;
  4803. { on entry:  self = eax, x = edx,   y = ecx,   result = eax }
  4804. asm
  4805.   push esi
  4806.   mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
  4807.   shl edx,2
  4808.   add esi,edx
  4809.   mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
  4810.   mul ecx
  4811.   add esi,eax
  4812.   mov eax,ds:[esi]
  4813.   pop esi
  4814.   //ret
  4815. end;
  4816.  
  4817. function TDirectDrawSurface.Peek(X, Y: Integer): LongInt;
  4818. begin
  4819.   Result := 0;
  4820.   if (X < 0) or (X > (Width - 1)) or
  4821.     (Y < 0) or (Y > (Height - 1)) or not FIsLocked then Exit;
  4822.   case Bitcount of
  4823.     8: Result := GetPixel8(x, y);
  4824.     16: Result := GetPixel16(x, y);
  4825.     24: Result := GetPixel24(x, y);
  4826.     32: Result := GetPixel32(x, y);
  4827.   end;
  4828. end;
  4829.  
  4830. procedure TDirectDrawSurface.PokeLine(X1, Y1, X2, Y2: Integer; Color: cardinal);
  4831. var
  4832.   i, deltax, deltay, numpixels,
  4833.     d, dinc1, dinc2,
  4834.     x, xinc1, xinc2,
  4835.     y, yinc1, yinc2: Integer;
  4836. begin
  4837.   if not FIsLocked then {$IFDEF VER4UP}Lock{$ELSE}LockSurface{$ENDIF}; //force lock the surface
  4838.   { Calculate deltax and deltay for initialisation }
  4839.   deltax := abs(x2 - x1);
  4840.   deltay := abs(y2 - y1);
  4841.  
  4842.   { Initialise all vars based on which is the independent variable }
  4843.   if deltax >= deltay then
  4844.   begin
  4845.     { x is independent variable }
  4846.     numpixels := deltax + 1;
  4847.     d := (2 * deltay) - deltax;
  4848.  
  4849.     dinc1 := deltay shl 1;
  4850.     dinc2 := (deltay - deltax) shl 1;
  4851.     xinc1 := 1;
  4852.     xinc2 := 1;
  4853.     yinc1 := 0;
  4854.     yinc2 := 1;
  4855.   end
  4856.   else
  4857.   begin
  4858.     { y is independent variable }
  4859.     numpixels := deltay + 1;
  4860.     d := (2 * deltax) - deltay;
  4861.     dinc1 := deltax shl 1;
  4862.     dinc2 := (deltax - deltay) shl 1;
  4863.     xinc1 := 0;
  4864.     xinc2 := 1;
  4865.     yinc1 := 1;
  4866.     yinc2 := 1;
  4867.   end;
  4868.   { Make sure x and y move in the right directions }
  4869.   if x1 > x2 then
  4870.   begin
  4871.     xinc1 := -xinc1;
  4872.     xinc2 := -xinc2;
  4873.   end;
  4874.   if y1 > y2 then
  4875.   begin
  4876.     yinc1 := -yinc1;
  4877.     yinc2 := -yinc2;
  4878.   end;
  4879.   x := x1;
  4880.   y := y1;
  4881.   { Draw the pixels }
  4882.   for i := 1 to numpixels do
  4883.   begin
  4884.     if (x > 0) and (x < (Width - 1)) and (y > 0) and (y < (Height - 1)) then
  4885.       Pixel[x, y] := Color;
  4886.     if d < 0 then
  4887.     begin
  4888.       Inc(d, dinc1);
  4889.       Inc(x, xinc1);
  4890.       Inc(y, yinc1);
  4891.     end
  4892.     else
  4893.     begin
  4894.       Inc(d, dinc2);
  4895.       Inc(x, xinc2);
  4896.       Inc(y, yinc2);
  4897.     end;
  4898.   end;
  4899. end;
  4900.  
  4901. procedure TDirectDrawSurface.PokeLinePolar(x, y: Integer; angle, length: extended; Color: cardinal);
  4902. var
  4903.   xp, yp: Integer;
  4904. begin
  4905.   xp := round(sin(angle * pi / 180) * length) + x;
  4906.   yp := round(cos(angle * pi / 180) * length) + y;
  4907.   PokeLine(x, y, xp, yp, Color);
  4908. end;
  4909.  
  4910. procedure TDirectDrawSurface.PokeBox(xs, ys, xd, yd: Integer; Color: cardinal);
  4911. begin
  4912.   pokeline(xs, ys, xd, ys, color);
  4913.   pokeline(xs, ys, xs, yd, color);
  4914.   pokeline(xd, ys, xd, yd, color);
  4915.   pokeline(xs, yd, xd, yd, color);
  4916. end;
  4917.  
  4918. procedure TDirectDrawSurface.PokeBlendPixel(const X, Y: Integer; aColor: cardinal; Alpha: byte);
  4919. var
  4920.   cr, cg, cb: byte;
  4921.   ar, ag, ab: byte;
  4922. begin
  4923.   LoadRGB(aColor, ar, ag, ab);
  4924.   LoadRGB(Pixel[x, y], cr, cg, cb);
  4925.   Pixel[x, y] := SaveRGB((Alpha * (aR - cr) shr 8) + cr, // R alpha
  4926.     (Alpha * (aG - cg) shr 8) + cg, // G alpha
  4927.     (Alpha * (aB - cb) shr 8) + cb); // B alpha
  4928. end;
  4929.  
  4930. {
  4931. function Conv24to16(Color: Integer): Word;
  4932. var
  4933.   r, g, b: Byte;
  4934. begin
  4935.   r := (Color shr 16) and $FF;
  4936.   g := (Color shr 8) and $FF;
  4937.   b := Color and $FF;
  4938.   Result := ((r shr 3) shl 11) or ((g shr 2) shl 5) or (b shr 3);
  4939. end;
  4940. }
  4941.  
  4942. function Conv24to16(Color: Integer): Word; register;
  4943. asm
  4944.   mov ecx,eax
  4945.   shl eax,24
  4946.   shr eax,27
  4947.   shl eax,11
  4948.   mov edx,ecx
  4949.   shl edx,16
  4950.   shr edx,26
  4951.   shl edx,5
  4952.   or eax,edx
  4953.   mov edx,ecx
  4954.   shl edx,8
  4955.   shr edx,27
  4956.   or eax,edx
  4957. end;
  4958.  
  4959. procedure TDirectDrawSurface.PokeWuLine(X1, Y1, X2, Y2, aColor: Integer);
  4960. var DeltaX, DeltaY, Loop, Start, Finish: Integer;
  4961.   Dx, Dy, DyDx: Single; // fractional parts
  4962.   Color16: DWord;
  4963. begin
  4964.   DeltaX := Abs(X2 - X1); // Calculate DeltaX and DeltaY for initialization
  4965.   DeltaY := Abs(Y2 - Y1);
  4966.   if (DeltaX = 0) or (DeltaY = 0) then
  4967.   begin // straight lines
  4968.     PokeLine(X1, Y1, X2, Y2, aColor);
  4969.     Exit;
  4970.   end;
  4971.   if BitCount = 16 then
  4972.     Color16 := Conv24to16(aColor)
  4973.   else
  4974.     Color16 := aColor;
  4975.   if DeltaX > DeltaY then // horizontal or vertical
  4976.   begin
  4977.   { determine rise and run }
  4978.     if Y2 > Y1 then DyDx := -(DeltaY / DeltaX)
  4979.     else DyDx := DeltaY / DeltaX;
  4980.     if X2 < X1 then
  4981.     begin
  4982.       Start := X2; // right to left
  4983.       Finish := X1;
  4984.       Dy := Y2;
  4985.     end else
  4986.     begin
  4987.       Start := X1; // left to right
  4988.       Finish := X2;
  4989.       Dy := Y1;
  4990.       DyDx := -DyDx; // inverse slope
  4991.     end;
  4992.     for Loop := Start to Finish do
  4993.     begin
  4994.       PokeBlendPixel(Loop, Trunc(Dy), Color16, Trunc((1 - Frac(Dy)) * 255));
  4995.       PokeBlendPixel(Loop, Trunc(Dy) + 1, Color16, Trunc(Frac(Dy) * 255));
  4996.       Dy := Dy + DyDx; // next point
  4997.     end;
  4998.   end else
  4999.   begin
  5000.    { determine rise and run }
  5001.     if X2 > X1 then DyDx := -(DeltaX / DeltaY)
  5002.     else DyDx := DeltaX / DeltaY;
  5003.     if Y2 < Y1 then
  5004.     begin
  5005.       Start := Y2; // right to left
  5006.       Finish := Y1;
  5007.       Dx := X2;
  5008.     end else
  5009.     begin
  5010.       Start := Y1; // left to right
  5011.       Finish := Y2;
  5012.       Dx := X1;
  5013.       DyDx := -DyDx; // inverse slope
  5014.     end;
  5015.     for Loop := Start to Finish do
  5016.     begin
  5017.       PokeBlendPixel(Trunc(Dx), Loop, Color16, Trunc((1 - Frac(Dx)) * 255));
  5018.       PokeBlendPixel(Trunc(Dx), Loop, Color16, Trunc(Frac(Dx) * 255));
  5019.       Dx := Dx + DyDx; // next point
  5020.     end;
  5021.   end;
  5022. end;
  5023.  
  5024. procedure TDirectDrawSurface.Noise(Oblast: TRect; Density: Byte);
  5025. var
  5026.   dx, dy: Integer;
  5027.   Dens: byte;
  5028. begin
  5029.   {noise}
  5030.   case Density of
  5031.     0..2: Dens := 3;
  5032.     255: Dens := 254;
  5033.   else
  5034.     Dens := Density;
  5035.   end;
  5036.   if Dens >= Oblast.Right then
  5037.     Dens := Oblast.Right div 3;
  5038.   dy := Oblast.Top;
  5039.   while dy <= Oblast.Bottom do begin
  5040.     dx := Oblast.Left;
  5041.     while dx <= Oblast.Right do begin
  5042.       inc(dx, random(dens));
  5043.       if dx <= Oblast.Right then
  5044.         Pixel[dx, dy] := not Pixel[dx, dy];
  5045.     end;
  5046.     inc(dy);
  5047.   end;
  5048. end;
  5049.  
  5050. {
  5051. function Conv16to24(Color: Word): Integer;
  5052. var
  5053.   r, g, b: Byte;
  5054. begin
  5055.   r := (Color shr 11) and $1F;
  5056.   g := (Color shr 5) and $3F;
  5057.   b := Color and $1F;
  5058.   Result := (r shl 19) or (g shl 10) or (b shl 3);
  5059. end;
  5060. }
  5061.  
  5062. function Conv16to24(Color: Word): Integer; register;
  5063. asm
  5064.  xor edx,edx
  5065.  mov dx,ax
  5066.  
  5067.  mov eax,edx
  5068.  shl eax,27
  5069.  shr eax,8
  5070.  
  5071.  mov ecx,edx
  5072.  shr ecx,5
  5073.  shl ecx,26
  5074.  shr ecx,16
  5075.  or eax,ecx
  5076.  
  5077.  mov ecx,edx
  5078.  shr ecx,11
  5079.  shl ecx,27
  5080.  shr ecx,24
  5081.  or eax,ecx
  5082. end;
  5083.  
  5084. procedure GetRGB(Color: cardinal; var R, G, B: Byte); {$IFDEF VER9UP}inline; {$ENDIF}
  5085. begin
  5086.   R := Color;
  5087.   G := Color shr 8;
  5088.   B := Color shr 16;
  5089. end;
  5090.  
  5091. procedure TDirectDrawSurface.LoadRGB(Color: cardinal; var R, G, B: Byte);
  5092. var grB: Byte;
  5093. begin
  5094.   grB := 1;
  5095.   if FLockSurfaceDesc.ddpfPixelFormat.dwGBitMask = 2016 then grB := 0; // 565
  5096.   case BitCount of
  5097.     15, 16: begin
  5098.         R := (color shr (11 - grB)) shl 3;
  5099.         if grB = 0 then
  5100.           G := ((color and 2016) shr 5) shl 2
  5101.         else
  5102.           G := ((color and 992) shr 5) shl 3;
  5103.         B := (color and 31) shl 3;
  5104.       end;
  5105.   else
  5106.     GetRGB(Color, R, G, B);
  5107.   end;
  5108. end;
  5109.  
  5110. function TDirectDrawSurface.SaveRGB(const R, G, B: Byte): cardinal;
  5111. begin
  5112.   case BitCount of
  5113.     15, 16: begin
  5114.         Result := Conv24to16(RGB(R, G, B));
  5115.       end;
  5116.   else
  5117.     Result := RGB(R, G, B);
  5118.   end;
  5119. end;
  5120.  
  5121. procedure TDirectDrawSurface.Blur;
  5122. var
  5123.   x, y, tr, tg, tb: Integer;
  5124.   r, g, b: byte;
  5125. begin
  5126.   for y := 1 to GetHeight - 1 do
  5127.     for x := 1 to GetWidth - 1 do begin
  5128.       LoadRGB(peek(x, y), r, g, b);
  5129.       tr := r;
  5130.       tg := g;
  5131.       tb := b;
  5132.       LoadRGB(peek(x, y + 1), r, g, b);
  5133.       Inc(tr, r);
  5134.       Inc(tg, g);
  5135.       Inc(tb, b);
  5136.       LoadRGB(peek(x, y - 1), r, g, b);
  5137.       Inc(tr, r);
  5138.       Inc(tg, g);
  5139.       Inc(tb, b);
  5140.       LoadRGB(peek(x - 1, y), r, g, b);
  5141.       Inc(tr, r);
  5142.       Inc(tg, g);
  5143.       Inc(tb, b);
  5144.       LoadRGB(peek(x + 1, y), r, g, b);
  5145.       Inc(tr, r);
  5146.       Inc(tg, g);
  5147.       Inc(tb, b);
  5148.       tr := tr shr 2;
  5149.       tg := tg shr 2;
  5150.       tb := tb shr 2;
  5151.       Poke(x, y, savergb(tr, tg, tb));
  5152.     end;
  5153. end;
  5154.  
  5155. procedure TDirectDrawSurface.PokeCircle(X, Y, Radius, Color: Integer);
  5156. var
  5157.   a, af, b, bf, c,
  5158.     target, r2: Integer;
  5159. begin
  5160.   Target := 0;
  5161.   A := Radius;
  5162.   B := 0;
  5163.   R2 := Sqr(Radius);
  5164.  
  5165.   while a >= B do
  5166.   begin
  5167.     b := Round(Sqrt(R2 - Sqr(A)));
  5168.     c := target; target := b; b := c;
  5169.     while B < Target do
  5170.     begin
  5171.       Af := (120 * a) div 100;
  5172.       Bf := (120 * b) div 100;
  5173.       pixel[x + af, y + b] := color;
  5174.       pixel[x + bf, y + a] := color;
  5175.       pixel[x - af, y + b] := color;
  5176.       pixel[x - bf, y + a] := color;
  5177.       pixel[x - af, y - b] := color;
  5178.       pixel[x - bf, y - a] := color;
  5179.       pixel[x + af, y - b] := color;
  5180.       pixel[x + bf, y - a] := color;
  5181.       B := B + 1;
  5182.     end;
  5183.     A := A - 1;
  5184.   end;
  5185. end;
  5186.  
  5187. function RGBToBGR(Color: cardinal): cardinal;
  5188. begin
  5189.   result := (LoByte(LoWord(Color)) shr 3 shl 11) or // Red
  5190.     (HiByte((Color)) shr 2 shl 5) or // Green
  5191.     (LoByte(HiWord(Color)) shr 3); // Blue
  5192. end;
  5193.  
  5194. procedure TDirectDrawSurface.PokeVLine(x, y1, y2: Integer; Color: cardinal);
  5195. var
  5196.   y: Integer;
  5197.   NColor: cardinal;
  5198.   r, g, b: byte;
  5199. begin
  5200.   if y1 < 0 then y1 := 0;
  5201.   if y2 >= Height then y2 := Height - 1;
  5202.   GetRGB(Color, r, g, b);
  5203.   NColor := RGBToBGR(rgb(r, g, b));
  5204.   for y := y1 to y2 do
  5205.   begin
  5206.     pixel[x, y] := NColor;
  5207.   end;
  5208. end;
  5209.  
  5210. procedure TDirectDrawSurface.PokeFilledEllipse(exc, eyc, ea, eb, color: Integer);
  5211. var x, y: Integer; aa, aa2, bb, bb2, d, dx, dy: LongInt;
  5212. begin
  5213.   x := 0;
  5214.   y := eb;
  5215.   aa := LongInt(ea) * ea;
  5216.   aa2 := 2 * aa;
  5217.   bb := LongInt(eb) * eb;
  5218.   bb2 := 2 * bb;
  5219.   d := bb - aa * eb + aa div 4;
  5220.   dx := 0;
  5221.   dy := aa2 * eb;
  5222.   PokevLine(exc, eyc - y, eyc + y, color);
  5223.   while (dx < dy) do begin
  5224.     if (d > 0) then begin
  5225.       dec(y); dec(dy, aa2); dec(d, dy);
  5226.     end;
  5227.     inc(x); inc(dx, bb2); inc(d, bb + dx);
  5228.     PokevLine(exc - x, eyc - y, eyc + y, color);
  5229.     PokevLine(exc + x, eyc - y, eyc + y, color);
  5230.   end;
  5231.   inc(d, (3 * (aa - bb) div 2 - (dx + dy)) div 2);
  5232.   while (y >= 0) do begin
  5233.     if (d < 0) then begin
  5234.       inc(x); inc(dx, bb2); inc(d, bb + dx);
  5235.       PokevLine(exc - x, eyc - y, eyc + y, color);
  5236.       PokevLine(exc + x, eyc - y, eyc + y, color);
  5237.     end;
  5238.     dec(y); dec(dy, aa2); inc(d, aa - dy);
  5239.   end;
  5240. end;
  5241.  
  5242. procedure TDirectDrawSurface.DoRotate(cent1, cent2, angle: Integer; coord1, coord2: Real; Color: word);
  5243. var coord1t, coord2t: Real;
  5244.   c1, c2: Integer;
  5245. begin
  5246.   coord1t := coord1 - cent1;
  5247.   coord2t := coord2 - cent2;
  5248.   coord1 := coord1t * cos(angle * pi / 180) - coord2t * sin(angle * pi / 180);
  5249.   coord2 := coord1t * sin(angle * pi / 180) + coord2t * cos(angle * pi / 180);
  5250.   coord1 := coord1 + cent1;
  5251.   coord2 := coord2 + cent2;
  5252.   c1 := round(coord1);
  5253.   c2 := round(coord2);
  5254.   pixel[c1, c2] := Color;
  5255. end;
  5256.  
  5257. procedure TDirectDrawSurface.PokeEllipse(exc, eyc, ea, eb, angle, Color: Integer);
  5258. var
  5259.   elx, ely: Integer;
  5260.   aa, aa2, bb, bb2, d, dx, dy: LongInt;
  5261.   x, y: real;
  5262. begin
  5263.   elx := 0;
  5264.   ely := eb;
  5265.   aa := LongInt(ea) * ea;
  5266.   aa2 := 2 * aa;
  5267.   bb := LongInt(eb) * eb;
  5268.   bb2 := 2 * bb;
  5269.   d := bb - aa * eb + aa div 4;
  5270.   dx := 0;
  5271.   dy := aa2 * eb;
  5272.   x := exc;
  5273.   y := eyc - ely;
  5274.   dorotate(exc, eyc, angle, x, y, Color);
  5275.   x := exc;
  5276.   y := eyc + ely;
  5277.   dorotate(exc, eyc, angle, x, y, Color);
  5278.   x := exc - ea;
  5279.   y := eyc;
  5280.   dorotate(exc, eyc, angle, x, y, Color);
  5281.   x := exc + ea;
  5282.   y := eyc;
  5283.   dorotate(exc, eyc, angle, x, y, Color);
  5284.   while (dx < dy) do begin
  5285.     if (d > 0) then begin Dec(ely); Dec(dy, aa2); Dec(d, dy); end;
  5286.     Inc(elx); Inc(dx, bb2); Inc(d, bb + dx);
  5287.     x := exc + elx; y := eyc + ely;
  5288.     dorotate(exc, eyc, angle, x, y, Color);
  5289.     x := exc - elx; y := eyc + ely;
  5290.     dorotate(exc, eyc, angle, x, y, Color);
  5291.     x := exc + elx; y := eyc - ely;
  5292.     dorotate(exc, eyc, angle, x, y, Color);
  5293.     x := exc - elx; y := eyc - ely;
  5294.     dorotate(exc, eyc, angle, x, y, Color);
  5295.   end;
  5296.   Inc(d, (3 * (aa - bb) div 2 - (dx + dy)) div 2);
  5297.   while (ely > 0) do begin
  5298.     if (d < 0) then begin Inc(elx); Inc(dx, bb2); Inc(d, bb + dx); end;
  5299.     Dec(ely); Dec(dy, aa2); Inc(d, aa - dy);
  5300.     x := exc + elx; y := eyc + ely;
  5301.     dorotate(exc, eyc, angle, x, y, Color);
  5302.     x := exc - elx; y := eyc + ely;
  5303.     dorotate(exc, eyc, angle, x, y, Color);
  5304.     x := exc + elx; y := eyc - ely;
  5305.     dorotate(exc, eyc, angle, x, y, Color);
  5306.     x := exc - elx; y := eyc - ely;
  5307.     dorotate(exc, eyc, angle, x, y, Color);
  5308.   end;
  5309. end;
  5310.  
  5311. procedure TDirectDrawSurface.MirrorFlip(Value: TRenderMirrorFlipSet);
  5312. begin
  5313.   if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then
  5314.     D2D.MirrorFlip := Value;
  5315. end;
  5316.  
  5317. {  TDXDrawDisplayMode  }
  5318.  
  5319. function TDXDrawDisplayMode.GetBitCount: Integer;
  5320. begin
  5321.   Result := FSurfaceDesc.ddpfPixelFormat.dwRGBBitCount;
  5322. end;
  5323.  
  5324. function TDXDrawDisplayMode.GetHeight: Integer;
  5325. begin
  5326.   Result := FSurfaceDesc.dwHeight;
  5327. end;
  5328.  
  5329. function TDXDrawDisplayMode.GetWidth: Integer;
  5330. begin
  5331.   Result := FSurfaceDesc.dwWidth;
  5332. end;
  5333.  
  5334. {  TDXDrawDisplay  }
  5335.  
  5336. constructor TDXDrawDisplay.Create(ADXDraw: TCustomDXDraw);
  5337. begin
  5338.   inherited Create;
  5339.   FDXDraw := ADXDraw;
  5340.   FModes := TCollection.Create(TDXDrawDisplayMode);
  5341.   FWidth := 640;
  5342.   FHeight := 480;
  5343.   FBitCount := 16;
  5344.   FFixedBitCount := False; //True;
  5345.   FFixedRatio := True;
  5346.   FFixedSize := True; //False;
  5347. end;
  5348.  
  5349. destructor TDXDrawDisplay.Destroy;
  5350. begin
  5351.   FModes.Free;
  5352.   inherited Destroy;
  5353. end;
  5354.  
  5355. procedure TDXDrawDisplay.Assign(Source: TPersistent);
  5356. begin
  5357.   if Source is TDXDrawDisplay then
  5358.   begin
  5359.     if Source <> Self then
  5360.     begin
  5361.       FBitCount := TDXDrawDisplay(Source).BitCount;
  5362.       FHeight := TDXDrawDisplay(Source).Height;
  5363.       FWidth := TDXDrawDisplay(Source).Width;
  5364.  
  5365.       FFixedBitCount := TDXDrawDisplay(Source).FFixedBitCount;
  5366.       FFixedRatio := TDXDrawDisplay(Source).FFixedRatio;
  5367.       FFixedSize := TDXDrawDisplay(Source).FFixedSize;
  5368.     end;
  5369.   end else
  5370.     inherited Assign(Source);
  5371. end;
  5372.  
  5373. function TDXDrawDisplay.GetCount: Integer;
  5374. begin
  5375.   if FModes.Count = 0 then
  5376.     LoadDisplayModes;
  5377.   Result := FModes.Count;
  5378. end;
  5379.  
  5380. function TDXDrawDisplay.GetMode: TDXDrawDisplayMode;
  5381. var
  5382.   i: Integer;
  5383.   ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  5384. begin
  5385.   Result := nil;
  5386.   if FDXDraw.DDraw <> nil then
  5387.   begin
  5388.     ddsd := FDXDraw.DDraw.DisplayMode;
  5389.     with ddsd do
  5390.       i := IndexOf(dwWidth, dwHeight, ddpfPixelFormat.dwRGBBitCount);
  5391.     if i <> -1 then
  5392.       Result := Modes[i];
  5393.   end;
  5394.   if Result = nil then
  5395.     raise EDirectDrawError.Create(SDisplayModeCannotAcquired);
  5396. end;
  5397.  
  5398. function TDXDrawDisplay.GetMode2(Index: Integer): TDXDrawDisplayMode;
  5399. begin
  5400.   if FModes.Count = 0 then
  5401.     LoadDisplayModes;
  5402.   Result := TDXDrawDisplayMode(FModes.Items[Index]);
  5403. end;
  5404.  
  5405. function TDXDrawDisplay.IndexOf(Width, Height, BitCount: Integer): Integer;
  5406. var
  5407.   i: Integer;
  5408. begin
  5409.   Result := -1;
  5410.   for i := 0 to Count - 1 do
  5411.     if (Modes[i].Width = Width) and (Modes[i].Height = Height) and (Modes[i].BitCount = BitCount) then
  5412.     begin
  5413.       Result := i;
  5414.       Exit;
  5415.     end;
  5416. end;
  5417.  
  5418. procedure TDXDrawDisplay.LoadDisplayModes;
  5419.  
  5420.   function EnumDisplayModesProc(const lpTDDSurfaceDesc: TDDSurfaceDesc;
  5421.     lpContext: Pointer): HRESULT; stdcall;
  5422.   begin
  5423.     with TDXDrawDisplayMode.Create(TCollection(lpContext)) do
  5424.       FSurfaceDesc := lpTDDSurfaceDesc;
  5425.     Result := DDENUMRET_OK;
  5426.   end;
  5427.  
  5428.   function Compare(Item1, Item2: TDXDrawDisplayMode): Integer;
  5429.   begin
  5430.     if Item1.Width <> Item2.Width then
  5431.       Result := Item1.Width - Item2.Width
  5432.     else if Item1.Height <> Item2.Height then
  5433.       Result := Item1.Height - Item2.Height
  5434.     else
  5435.       Result := Item1.BitCount - Item2.BitCount;
  5436.   end;
  5437.  
  5438. var
  5439.   DDraw: TDirectDraw;
  5440.   TempList: TList;
  5441.   i: Integer;
  5442. begin
  5443.   FModes.Clear;
  5444.  
  5445.   if FDXDraw.DDraw <> nil then
  5446.   begin
  5447.     FDXDraw.DDraw.DXResult := FDXDraw.DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}
  5448.       .EnumDisplayModes(0, {$IFDEF D3D_deprecated}PDDSurfaceDesc{$ELSE}PDDSurfaceDesc2{$ENDIF}(nil),
  5449.       FModes, @EnumDisplayModesProc);
  5450.   end else
  5451.   begin
  5452.     DDraw := TDirectDraw.Create(PGUID(FDXDraw.FDriver));
  5453.     try
  5454.       DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}
  5455.       .EnumDisplayModes(0, {$IFDEF D3D_deprecated}PDDSurfaceDesc{$ELSE}PDDSurfaceDesc2{$ENDIF}(nil),
  5456.       FModes, @EnumDisplayModesProc);
  5457.     finally
  5458.       DDraw.Free;
  5459.     end;
  5460.   end;
  5461.  
  5462.   TempList := TList.Create;
  5463.   try
  5464.     for i := 0 to FModes.Count - 1 do
  5465.       TempList.Add(FModes.Items[i]);
  5466.     TempList.Sort(@Compare);
  5467.  
  5468.     for i := FModes.Count - 1 downto 0 do
  5469.       TDXDrawDisplayMode(TempList[i]).Index := i;
  5470.   finally
  5471.     TempList.Free;
  5472.   end;
  5473. end;
  5474.  
  5475. function TDXDrawDisplay.SetSize(AWidth, AHeight, ABitCount{$IFNDEF D3D_deprecated}, ARefreshRate, AFlags{$ENDIF}: Integer): Boolean;
  5476. begin
  5477.   Result := False;
  5478.   if FDXDraw.DDraw <> nil then
  5479.   begin
  5480.     FDXDraw.DDraw.DXResult := FDXDraw.DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}
  5481.       .SetDisplayMode(AWidth, AHeight, ABitCount{$IFNDEF D3D_deprecated}, ARefreshRate, AFlags{$ENDIF});
  5482.     Result := FDXDraw.DDraw.DXResult = DD_OK;
  5483.  
  5484.     if Result then
  5485.     begin
  5486.       FWidth := AWidth;
  5487.       FHeight := AHeight;
  5488.       FBitCount := ABitCount;
  5489.     end;
  5490.   end;
  5491. end;
  5492.  
  5493. function TDXDrawDisplay.DynSetSize(AWidth, AHeight, ABitCount: Integer): Boolean;
  5494.  
  5495.   {$IFNDEF D3D_deprecated}
  5496.   function GetDefaultRefreshRate: Integer;
  5497.   begin
  5498.     Result := 60;
  5499.   end;
  5500.   {$ENDIF}
  5501.  
  5502.   function TestBitCount(BitCount, ABitCount: Integer): Boolean;
  5503.   begin
  5504.     if (BitCount > 8) and (ABitCount > 8) then
  5505.     begin
  5506.       Result := True;
  5507.     end else
  5508.     begin
  5509.       Result := BitCount >= ABitCount;
  5510.     end;
  5511.   end;
  5512.  
  5513.   function SetSize2(Ratio: Boolean): Boolean;
  5514.   var
  5515.     DWidth, DHeight, DBitCount{$IFNDEF D3D_deprecated}, DRRate, DFlags{$ENDIF}, i: Integer;
  5516.     Flag: Boolean;
  5517.   begin
  5518.     Result := False;
  5519.  
  5520.     DWidth := Maxint;
  5521.     DHeight := Maxint;
  5522.     DBitCount := ABitCount;
  5523.     {$IFNDEF D3D_deprecated}
  5524.     DRRate := GetDefaultRefreshRate;
  5525.     DFlags := 0;
  5526.     {$ENDIF}
  5527.     Flag := False;
  5528.     for i := 0 to Count - 1 do
  5529.       with Modes[i] do
  5530.       begin
  5531.         if ((DWidth >= Width) and (DHeight >= Width) and
  5532.           ((not Ratio) or (Width / Height = AWidth / AHeight)) and
  5533.           ((FFixedSize and (Width = AWidth) and (Height = Height)) or
  5534.           ((not FFixedSize) and (Width >= AWidth) and (Height >= AHeight))) and
  5535.  
  5536.           ((FFixedBitCount and (BitCount = ABitCount)) or
  5537.           ((not FFixedBitCount) and TestBitCount(BitCount, ABitCount)))) then
  5538.         begin
  5539.           DWidth := Width;
  5540.           DHeight := Height;
  5541.           DBitCount := BitCount;
  5542.           Flag := True;
  5543.         end;
  5544.       end;
  5545.  
  5546.     if Flag then
  5547.     begin
  5548.       if (DBitCount <> ABitCount) then
  5549.       begin
  5550.         if IndexOf(DWidth, DHEight, ABitCount) <> -1 then
  5551.           DBitCount := ABitCount;
  5552.       end;
  5553.  
  5554.       Result := SetSize(DWidth, DHeight, DBitCount{$IFNDEF D3D_deprecated}, DRRate, DFlags{$ENDIF});
  5555.     end;
  5556.   end;
  5557.  
  5558. begin
  5559.   Result := False;
  5560.  
  5561.   if (AWidth <= 0) or (AHeight <= 0) or (not (ABitCount in [8, 16, 24, 32])) then Exit;
  5562.  
  5563.   {  The change is attempted by the size of default.  }
  5564.   if SetSize(AWidth, AHeight, ABitCount{$IFNDEF D3D_deprecated}, GetDefaultRefreshRate, 0{$ENDIF}) then
  5565.   begin
  5566.     Result := True;
  5567.     Exit;
  5568.   end;
  5569.  
  5570.   {  The change is attempted by the screen ratio fixation.  }
  5571.   if FFixedRatio then
  5572.     if SetSize2(True) then
  5573.     begin
  5574.       Result := True;
  5575.       Exit;
  5576.     end;
  5577.  
  5578.   {  The change is unconditionally attempted.  }
  5579.   if SetSize2(False) then
  5580.   begin
  5581.     Result := True;
  5582.     Exit;
  5583.   end;
  5584. end;
  5585.  
  5586. procedure TDXDrawDisplay.SetBitCount(Value: Integer);
  5587. begin
  5588.   if not (Value in [8, 16, 24, 32]) then
  5589.     raise EDirectDrawError.Create(SInvalidDisplayBitCount);
  5590.   FBitCount := Value;
  5591. end;
  5592.  
  5593. procedure TDXDrawDisplay.SetHeight(Value: Integer);
  5594. begin
  5595.   FHeight := Max(Value, 0);
  5596. end;
  5597.  
  5598. procedure TDXDrawDisplay.SetWidth(Value: Integer);
  5599. begin
  5600.   FWidth := Max(Value, 0);
  5601. end;
  5602.  
  5603. {  TCustomDXDraw  }
  5604.  
  5605. function BPPToDDBD(BPP: DWORD): DWORD;
  5606. begin
  5607.   case BPP of
  5608.     1: Result := DDBD_1;
  5609.     2: Result := DDBD_2;
  5610.     4: Result := DDBD_4;
  5611.     8: Result := DDBD_8;
  5612.     16: Result := DDBD_16;
  5613.     24: Result := DDBD_24;
  5614.     32: Result := DDBD_32;
  5615.   else
  5616.     Result := 0;
  5617.   end;
  5618. end;
  5619.  
  5620. procedure FreeZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface);
  5621. begin
  5622.   if ZBuffer <> nil then
  5623.   begin
  5624.     if (Surface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) and (ZBuffer.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) then
  5625.       Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.DeleteAttachedSurface(0, ZBuffer.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF});
  5626.     ZBuffer.Free; ZBuffer := nil;
  5627.   end;
  5628. end;
  5629.  
  5630. type
  5631.   TInitializeDirect3DOption = (idoSelectDriver, idoOptimizeDisplayMode,
  5632.     idoHardware, {$IFDEF D3DRM}idoRetainedMode,{$ENDIF} idoZBuffer);
  5633.  
  5634.   TInitializeDirect3DOptions = set of TInitializeDirect3DOption;
  5635.  
  5636. procedure Direct3DInitializing(Options: TInitializeDirect3DOptions;
  5637.   var BitCount: Integer; var Driver: PGUID; var DriverGUID: TGUID{$IFNDEF D3D_deprecated}; var D3DDeviceTypeSet: TD3DDeviceTypeSet{$ENDIF});
  5638. type
  5639.   PDirect3DInitializingRecord = ^TDirect3DInitializingRecord;
  5640.   TDirect3DInitializingRecord = record
  5641.     Options: TInitializeDirect3DOptions;
  5642.     Driver: ^PGUID;
  5643.     DriverGUID: PGUID;
  5644.     BitCount: Integer;
  5645.  
  5646.     Flag: Boolean;
  5647.     DriverCaps: TDDCaps;
  5648.     HELCaps: TDDCaps;
  5649.     {$IFDEF D3D_deprecated}
  5650.     HWDeviceDesc: TD3DDeviceDesc;
  5651.     HELDeviceDesc: TD3DDeviceDesc;
  5652.     DeviceDesc: TD3DDeviceDesc;
  5653.     {$ELSE}
  5654.     DeviceDesc: TD3DDeviceDesc7;
  5655.     {$ENDIF}
  5656.     D3DFlag: Boolean;
  5657.     {$IFDEF D3D_deprecated}
  5658.     HWDeviceDesc2: TD3DDeviceDesc;
  5659.     HELDeviceDesc2: TD3DDeviceDesc;
  5660.     DeviceDesc2: TD3DDeviceDesc;
  5661.     {$ELSE}
  5662.     DeviceDesc2: TD3DDeviceDesc7;
  5663.     {$ENDIF}
  5664.   end;
  5665.  
  5666.   {$IFDEF D3D_deprecated}
  5667.   function EnumDeviceCallBack(lpGuid: PGUID; // nil for the default device
  5668.       lpDeviceDescription: PAnsiChar; lpDeviceName: PAnsiChar;
  5669.       var lpD3DHWDeviceDesc: TD3DDeviceDesc;
  5670.       var lpD3DHELDeviceDesc: TD3DDeviceDesc;
  5671.       rec: PDirect3DInitializingRecord) : HResult; stdcall;
  5672.  
  5673.     procedure UseThisDevice;
  5674.     begin
  5675.       rec.D3DFlag := True;
  5676.       rec.HWDeviceDesc2 := lpD3DHWDeviceDesc;
  5677.       rec.HELDeviceDesc2 := lpD3DHELDeviceDesc;
  5678.       rec.DeviceDesc2 := lpD3DHWDeviceDesc;
  5679.     end;
  5680.  
  5681.   begin
  5682.     Result := D3DENUMRET_OK;
  5683.  
  5684.     if lpD3DHWDeviceDesc.dcmColorModel = 0 then Exit;
  5685.  
  5686.     if idoOptimizeDisplayMode in rec.Options then
  5687.     begin
  5688.       if (lpD3DHWDeviceDesc.dwDeviceRenderBitDepth and (DDBD_16 or DDBD_24 or DDBD_32)) = 0 then Exit;
  5689.     end
  5690.     else
  5691.     begin
  5692.       if (lpD3DHWDeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then Exit;
  5693.     end;
  5694.  
  5695.     UseThisDevice;
  5696.   end;
  5697.   {$ELSE}
  5698.   function EnumDeviceCallBack(lpDeviceDescription: PAnsiChar; lpDeviceName: PAnsiChar;
  5699.       const lpD3DDeviceDesc: TD3DDeviceDesc7; rec: PDirect3DInitializingRecord) : HResult; stdcall;
  5700.   begin
  5701.     Result := D3DENUMRET_OK;
  5702.  
  5703.     maxVideoBlockSize := Min(lpD3DDeviceDesc.dwMaxTextureWidth, lpD3DDeviceDesc.dwMaxTextureHeight);
  5704.     SurfaceDivWidth := lpD3DDeviceDesc.dwMaxTextureWidth;
  5705.     SurfaceDivHeight := lpD3DDeviceDesc.dwMaxTextureHeight;
  5706.  
  5707.     //if lpD3DHWDeviceDesc.dcmColorModel = 0 then Exit;
  5708.     if idoOptimizeDisplayMode in rec.Options then
  5709.     begin
  5710.       if (lpD3DDeviceDesc.dwDeviceRenderBitDepth and (DDBD_16 or DDBD_24 or DDBD_32)) = 0 then Exit;
  5711.     end
  5712.     else
  5713.     begin
  5714.       if (lpD3DDeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then Exit;
  5715.     end;
  5716.  
  5717.     rec.D3DFlag := True;
  5718.     rec.DeviceDesc2 := lpD3DDeviceDesc;
  5719.   end;
  5720.   {$ENDIF}
  5721.  
  5722.   function EnumDirectDrawDriverCallback(lpGUID: PGUID; lpDriverDescription: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF};
  5723.     lpDriverName: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF}; rec: PDirect3DInitializingRecord): HRESULT; stdcall;
  5724.   var
  5725.     DDraw: TDirectDraw;
  5726.     {$IFDEF D3D_deprecated}
  5727.     Direct3D: IDirect3D;
  5728.     {$ENDIF}
  5729.     Direct3D7: IDirect3D7;
  5730.  
  5731.     function CountBitMask(i: DWORD; const Bits: array of DWORD): DWORD;
  5732.     var
  5733.       j: Integer;
  5734.     begin
  5735.       Result := 0;
  5736.  
  5737.       for j := Low(Bits) to High(Bits) do
  5738.       begin
  5739.         if i and Bits[j] <> 0 then
  5740.           Inc(Result);
  5741.       end;
  5742.     end;
  5743.  
  5744.     function CompareCountBitMask(i, i2: DWORD; const Bits: array of DWORD): Integer;
  5745.     var
  5746.       j, j2: DWORD;
  5747.     begin
  5748.       j := CountBitMask(i, Bits);
  5749.       j2 := CountBitMask(i2, Bits);
  5750.  
  5751.       if j < j2 then
  5752.         Result := -1
  5753.       else if i > j2 then
  5754.         Result := 1
  5755.       else
  5756.         Result := 0;
  5757.     end;
  5758.  
  5759.     function CountBit(i: DWORD): DWORD;
  5760.     var
  5761.       j: Integer;
  5762.     begin
  5763.       Result := 0;
  5764.  
  5765.       for j := 0 to 31 do
  5766.         if i and (1 shl j) <> 0 then
  5767.           Inc(Result);
  5768.     end;
  5769.  
  5770.     function CompareCountBit(i, i2: DWORD): Integer;
  5771.     begin
  5772.       Result := CountBit(i) - CountBit(i2);
  5773.       if Result < 0 then Result := -1;
  5774.       if Result > 0 then Result := 1;
  5775.     end;
  5776.  
  5777.     function FindDevice: Boolean;
  5778.     begin
  5779.       {  The Direct3D driver is examined.  }
  5780.       rec.D3DFlag := False;
  5781.       try
  5782.         {$IFDEF D3D_deprecated}Direct3D{$ELSE}Direct3D7{$ENDIF}.EnumDevices(@EnumDeviceCallBack, rec) {= DD_OK}
  5783.       except
  5784.         on E: Exception do
  5785.         begin
  5786.           rec.D3DFlag := False;
  5787.           // eventually catch  exception to automatic log
  5788.           Log(E.Message {$IFNDEF VER4UP}, ChangefileExt(ParamStr(0), '.log'){$ENDIF});
  5789.           //and cannot continue !!!
  5790.           Result := False;
  5791.           Exit;
  5792.         end;
  5793.       end;
  5794.       Result := rec.D3DFlag;
  5795.  
  5796.       if not Result then Exit;
  5797.  
  5798.       {  Comparison of DirectDraw driver.  }
  5799.       if not rec.Flag then
  5800.       begin
  5801.         {$IFDEF D3D_deprecated}
  5802.         rec.HWDeviceDesc := rec.HWDeviceDesc2;
  5803.         rec.HELDeviceDesc := rec.HELDeviceDesc2;
  5804.         rec.DeviceDesc := rec.DeviceDesc2;
  5805.         {$ENDIF}
  5806.         rec.Flag := True;
  5807.       end
  5808.       else
  5809.       begin
  5810.         {  Comparison of hardware. (One with large number of functions to support is chosen.  }
  5811.         Result := False;
  5812.  
  5813.         if DDraw.DriverCaps.dwVidMemTotal < rec.DriverCaps.dwVidMemTotal then Exit;
  5814.         {$IFDEF D3D_deprecated}
  5815.         if CompareCountBitMask(DDraw.DriverCaps.ddscaps.dwCaps, rec.DriverCaps.ddscaps.dwCaps, [DDSCAPS_TEXTURE, DDSCAPS_ZBUFFER, DDSCAPS_MIPMAP]) +
  5816.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwMiscCaps, rec.HWDeviceDesc2.dpcLineCaps.dwMiscCaps) +
  5817.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwRasterCaps, rec.HWDeviceDesc2.dpcLineCaps.dwRasterCaps) +
  5818.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwAlphaCmpCaps, rec.HWDeviceDesc2.dpcLineCaps.dwAlphaCmpCaps) +
  5819.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwSrcBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwSrcBlendCaps) +
  5820.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwDestBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwDestBlendCaps) +
  5821.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwShadeCaps, rec.HWDeviceDesc2.dpcLineCaps.dwShadeCaps) +
  5822.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureCaps) +
  5823.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureFilterCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureFilterCaps) +
  5824.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureBlendCaps) +
  5825.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureAddressCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureAddressCaps) < 0 then Exit;
  5826.         {$ENDIF}
  5827.         Result := True;
  5828.       end;
  5829.     end;
  5830.  
  5831.   begin
  5832.     Result := DDENUMRET_OK;
  5833.  
  5834.     DDraw := TDirectDraw.Create(lpGUID);
  5835.     try
  5836.       if (DDraw.DriverCaps.dwCaps and DDCAPS_3D <> 0) and
  5837.         (DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE <> 0) then
  5838.       begin
  5839.         try
  5840.         if DDraw.IDDraw7 <> nil then
  5841.           Direct3D7 := DDraw.IDraw7 as IDirect3D7
  5842.         {$IFDEF D3D_deprecated}
  5843.         else
  5844.           Direct3D := DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF} as IDirect3D
  5845.         {$ENDIF};
  5846.         except
  5847.           on E: Exception do
  5848.             log(E.Message {$IFNDEF VER4UP}, ChangefileExt(ParamStr(0), '.log'){$ENDIF});
  5849.         end;
  5850.         try
  5851.           if FindDevice then
  5852.           begin
  5853.             rec.DriverCaps := DDraw.DriverCaps;
  5854.             rec.HELCaps := DDraw.HELCaps;
  5855.  
  5856.             if lpGUID = nil then
  5857.               rec.Driver := nil
  5858.             else
  5859.             begin
  5860.               rec.DriverGUID^ := lpGUID^;
  5861.               rec.Driver^ := @rec.DriverGUID;
  5862.             end;
  5863.           end;
  5864.         finally
  5865.           {$IFDEF D3D_deprecated}
  5866.           Direct3D := nil;
  5867.           {$ENDIF}
  5868.           Direct3D7 := nil;
  5869.         end;
  5870.       end;
  5871.     finally
  5872.       DDraw.Free;
  5873.     end;
  5874.   end;
  5875.  
  5876. var
  5877.   rec: TDirect3DInitializingRecord;
  5878.   DDraw: TDirectDraw;
  5879.   {$IFNDEF D3D_deprecated}
  5880.   devGUID: Tguid;
  5881.   {$ENDIF}
  5882. begin
  5883.   FillChar(rec, SizeOf(rec), 0);
  5884.   rec.BitCount := BitCount;
  5885.   rec.Options := Options;
  5886.  
  5887.   {  Driver selection   }
  5888.   if idoSelectDriver in Options then
  5889.   begin
  5890.     rec.Flag := False;
  5891.     rec.Options := Options;
  5892.     rec.Driver := @Driver;
  5893.     rec.DriverGUID := @DriverGUID;
  5894.     DXDirectDrawEnumerate(@EnumDirectDrawDriverCallback, @rec);
  5895.   end
  5896.   else
  5897.   begin
  5898.     DDraw := TDirectDraw.Create(Driver);
  5899.     try
  5900.       rec.DriverCaps := DDraw.DriverCaps;
  5901.       rec.HELCaps := DDraw.HELCaps;
  5902.  
  5903.       rec.D3DFlag := False;
  5904.       (DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF} as IDirect3D).EnumDevices(@EnumDeviceCallBack, @rec);
  5905.       if rec.D3DFlag then
  5906.         {$IFDEF D3D_deprecated}
  5907.         rec.DeviceDesc := rec.DeviceDesc2;
  5908.         {$ELSE}
  5909.         rec.DeviceDesc := rec.DeviceDesc2;
  5910.         {$ENDIF}
  5911.     finally
  5912.       DDraw.Free;
  5913.     end;
  5914.     rec.Flag := True;
  5915.   end;
  5916.  
  5917.   {  Display mode optimization  }
  5918.   if rec.Flag and (idoOptimizeDisplayMode in Options) then
  5919.   begin
  5920.     if (rec.DeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then
  5921.     begin
  5922.       if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_16 <> 0 then
  5923.         rec.BitCount := 16
  5924.       else
  5925.       if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_24 <> 0 then
  5926.         rec.BitCount := 24
  5927.       else if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_32 <> 0 then
  5928.         rec.BitCount := 32;
  5929.     end;
  5930.   end;
  5931.  
  5932.   {test type of device}
  5933.   {$IFNDEF D3D_deprecated}
  5934.   D3DDeviceTypeSet := [];
  5935.  
  5936.   Move(rec.DeviceDesc2.deviceGUID, devGUID, Sizeof(TGUID) );
  5937.  
  5938.   if CompareMem(@devGUID, @IID_IDirect3DTnLHalDevice, Sizeof(TGUID)) then
  5939.     D3DDeviceTypeSet := D3DDeviceTypeSet + [dtTnLHAL];
  5940.  
  5941.   if CompareMem(@devGUID, @IID_IDirect3DHALDEVICE, Sizeof(TGUID)) then
  5942.     D3DDeviceTypeSet := D3DDeviceTypeSet + [dtHAL];
  5943.  
  5944.   if CompareMem(@devGUID, @IID_IDirect3DMMXDevice, Sizeof(TGUID)) then
  5945.     D3DDeviceTypeSet := D3DDeviceTypeSet + [dtMMX];
  5946.  
  5947.   if CompareMem(@devGUID, @IID_IDirect3DRGBDevice, Sizeof(TGUID)) then
  5948.     D3DDeviceTypeSet := D3DDeviceTypeSet + [dtRGB];
  5949.  
  5950.   if CompareMem(@devGUID, @IID_IDirect3DRampDevice, Sizeof(TGUID)) then
  5951.     D3DDeviceTypeSet := D3DDeviceTypeSet + [dtRamp];
  5952.  
  5953.   if CompareMem(@devGUID, @IID_IDirect3DRefDevice, Sizeof(TGUID)) then
  5954.     D3DDeviceTypeSet := D3DDeviceTypeSet + [dtRef];
  5955.   {$ENDIF}
  5956.   BitCount := rec.BitCount;
  5957. end;
  5958.  
  5959. procedure Direct3DInitializing_DXDraw(Options: TInitializeDirect3DOptions;
  5960.   DXDraw: TCustomDXDraw);
  5961. var
  5962.   BitCount: Integer;
  5963.   Driver: PGUID;
  5964.   DriverGUID: TGUID;
  5965.   {$IFNDEF D3D_deprecated}
  5966.   D3DDeviceTypeSet: TD3DDeviceTypeSet;
  5967.   {$ENDIF}
  5968. begin
  5969.   BitCount := DXDraw.Display.BitCount;
  5970.   Driver := DXDraw.Driver;
  5971.   Direct3DInitializing(Options, BitCount, Driver, DriverGUID{$IFNDEF D3D_deprecated}, D3DDeviceTypeSet{$ENDIF});
  5972.   DXDraw.Driver := Driver;
  5973.   DXDraw.Display.BitCount := BitCount;
  5974.   {$IFNDEF D3D_deprecated}
  5975.   DXDraw.FDeviceTypeSet := D3DDeviceTypeSet;
  5976.   {$ENDIF}
  5977. end;
  5978.  
  5979. {$IFDEF D3D_deprecated}
  5980. procedure InitializeDirect3D(Surface: TDirectDrawSurface;
  5981.   var ZBuffer: TDirectDrawSurface;
  5982.   out D3D: IDirect3D;
  5983.   out D3D2: IDirect3D2;
  5984.   out D3D3: IDirect3D3;
  5985.   out D3DDevice: IDirect3DDevice;
  5986.   out D3DDevice2: IDirect3DDevice2;
  5987.   out D3DDevice3: IDirect3DDevice3;
  5988. {$IFDEF D3DRM}
  5989.   var D3DRM: IDirect3DRM;
  5990.   var D3DRM2: IDirect3DRM2;
  5991.   var D3DRM3: IDirect3DRM3;
  5992.   out D3DRMDevice: IDirect3DRMDevice;
  5993.   out D3DRMDevice2: IDirect3DRMDevice2;
  5994.   out D3DRMDevice3: IDirect3DRMDevice3;
  5995.   out Viewport: IDirect3DRMViewport;
  5996.   var Scene: IDirect3DRMFrame;
  5997.   var Camera: IDirect3DRMFrame;
  5998. {$ENDIF}
  5999.   var NowOptions: TInitializeDirect3DOptions);
  6000. type
  6001.   TInitializeDirect3DRecord = record
  6002.     Flag: Boolean;
  6003.     BitCount: Integer;
  6004.     HWDeviceDesc: TD3DDeviceDesc;
  6005.     HELDeviceDesc: TD3DDeviceDesc;
  6006.     DeviceDesc: TD3DDeviceDesc;
  6007.     Hardware: Boolean;
  6008.     Options: TInitializeDirect3DOptions;
  6009.     GUID: TGUID;
  6010.     SupportHardware: Boolean;
  6011.   end;
  6012.  
  6013.   function CreateZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface;
  6014.     const DeviceDesc: TD3DDeviceDesc; Hardware: Boolean): Boolean;
  6015.   const
  6016.     MemPosition: array[Boolean] of Integer = (DDSCAPS_SYSTEMMEMORY, DDSCAPS_VIDEOMEMORY);
  6017.   var
  6018.     ZBufferBitDepth: Integer;
  6019.     ddsd: TDDSurfaceDesc;
  6020.   begin
  6021.     Result := False;
  6022.     FreeZBufferSurface(Surface, ZBuffer);
  6023.  
  6024.     if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_16 <> 0 then
  6025.       ZBufferBitDepth := 16
  6026.     else
  6027.     if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_24 <> 0 then
  6028.       ZBufferBitDepth := 24
  6029.     else
  6030.     if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_32 <> 0 then
  6031.       ZBufferBitDepth := 32
  6032.     else
  6033.       ZBufferBitDepth := 0;
  6034.  
  6035.     if ZBufferBitDepth <> 0 then
  6036.     begin
  6037.       with ddsd do
  6038.       begin
  6039.         dwSize := SizeOf(ddsd);
  6040.         Surface.ISurface.GetSurfaceDesc(ddsd);
  6041.         dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT or DDSD_ZBUFFERBITDEPTH;
  6042.         ddsCaps.dwCaps := DDSCAPS_ZBUFFER or MemPosition[Hardware];
  6043.         dwHeight := Surface.Height;
  6044.         dwWidth := Surface.Width;
  6045.         dwZBufferBitDepth := ZBufferBitDepth;
  6046.       end;
  6047.  
  6048.       ZBuffer := TDirectDrawSurface.Create(Surface.DDraw);
  6049.       if ZBuffer.CreateSurface(ddsd) then
  6050.       begin
  6051.         if Surface.ISurface.AddAttachedSurface(ZBuffer.ISurface) <> DD_OK then
  6052.         begin
  6053.           ZBuffer.Free; ZBuffer := nil;
  6054.           Exit;
  6055.         end;
  6056.         Result := True;
  6057.       end else
  6058.       begin
  6059.         ZBuffer.Free; ZBuffer := nil;
  6060.         Exit;
  6061.       end;
  6062.     end;
  6063.   end;
  6064.  
  6065.   function EnumDeviceCallBack(const lpGuid: TGUID; lpDeviceDescription, lpDeviceName: PChar;
  6066.     const lpD3DHWDeviceDesc, lpD3DHELDeviceDesc: TD3DDeviceDesc;
  6067.     lpUserArg: Pointer): HRESULT; stdcall;
  6068.   var
  6069.     dev: ^TD3DDeviceDesc;
  6070.     Hardware: Boolean;
  6071.     rec: ^TInitializeDirect3DRecord;
  6072.  
  6073.     procedure UseThisDevice;
  6074.     begin
  6075.       rec.Flag := True;
  6076.       rec.GUID := lpGUID;
  6077.       rec.HWDeviceDesc := lpD3DHWDeviceDesc;
  6078.       rec.HELDeviceDesc := lpD3DHELDeviceDesc;
  6079.       rec.DeviceDesc := dev^;
  6080.       rec.Hardware := Hardware;
  6081.     end;
  6082.  
  6083.   begin
  6084.     Result := D3DENUMRET_OK;
  6085.     rec := lpUserArg;
  6086.  
  6087.     Hardware := lpD3DHWDeviceDesc.dcmColorModel <> 0;
  6088.     if Hardware then
  6089.       dev := @lpD3DHWDeviceDesc
  6090.     else
  6091.       dev := @lpD3DHELDeviceDesc;
  6092.  
  6093.     if (Hardware) and (not rec.SupportHardware) then Exit;
  6094.     if dev.dcmColorModel <> D3DCOLOR_RGB then Exit;
  6095.     if CompareMem(@lpGUID, @IID_IDirect3DRefDevice, SizeOf(TGUID)) then Exit;
  6096.  
  6097.     {  Bit depth test.  }
  6098.     if (dev.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then Exit;
  6099.  
  6100.     if Hardware then
  6101.     begin
  6102.       {  Hardware  }
  6103.       UseThisDevice;
  6104.     end else
  6105.     begin
  6106.       {  Software  }
  6107.       if not rec.Hardware then
  6108.         UseThisDevice;
  6109.     end;
  6110.   end;
  6111.  
  6112. var
  6113.   Hardware: Boolean;
  6114.   SupportHardware: Boolean;
  6115.   D3DDeviceGUID: TGUID;
  6116.   Options: TInitializeDirect3DOptions;
  6117.  
  6118.   procedure InitDevice;
  6119.   var
  6120.     rec: TInitializeDirect3DRecord;
  6121.   begin
  6122.     {  Device search  }
  6123.     rec.Flag := False;
  6124.     rec.BitCount := Surface.BitCount;
  6125.     rec.Hardware := False;
  6126.     rec.Options := Options;
  6127.     rec.SupportHardware := SupportHardware;
  6128.  
  6129.     D3D3.EnumDevices(@EnumDeviceCallBack, @rec);
  6130.     if not rec.Flag then
  6131.       raise EDXDrawError.Create(S3DDeviceNotFound);
  6132.  
  6133.     Hardware := rec.Hardware;
  6134.     D3DDeviceGUID := rec.GUID;
  6135.  
  6136.     if Hardware then
  6137.       NowOptions := NowOptions + [idoHardware];
  6138.  
  6139.     {  Z buffer making  }
  6140.     NowOptions := NowOptions - [idoZBuffer];
  6141.     if idoZBuffer in Options then
  6142.     begin
  6143.       if CreateZBufferSurface(Surface, ZBuffer, rec.DeviceDesc, Hardware) then
  6144.         NowOptions := NowOptions + [idoZBuffer];
  6145.     end;
  6146.   end;
  6147. {$IFDEF D3DRM}
  6148. type
  6149.   TDirect3DRMCreate = function(out lplpDirect3DRM: IDirect3DRM): HRESULT; stdcall;
  6150. {$ENDIF}
  6151. begin
  6152.   try
  6153.     Options := NowOptions;
  6154.     NowOptions := [];
  6155.  
  6156.     D3D3 := Surface.DDraw.IDraw as IDirect3D3;
  6157.     D3D2 := D3D3 as IDirect3D2;
  6158.     D3D := D3D3 as IDirect3D;
  6159.  
  6160.     {  Whether hardware can be used is tested.  }
  6161.     SupportHardware := (Surface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_VIDEOMEMORY <> 0) and
  6162.       (idoHardware in Options) and (Surface.DDraw.DriverCaps.dwCaps and DDCAPS_3D <> 0);
  6163.  
  6164.     if Surface.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE = 0 then
  6165.       SupportHardware := False;
  6166.  
  6167.     {  Direct3D  }
  6168.     InitDevice;
  6169.  
  6170.     if D3D3.CreateDevice(D3DDeviceGUID, Surface.ISurface4, D3DDevice3, nil) <> D3D_OK then
  6171.     begin
  6172.       SupportHardware := False;
  6173.       InitDevice;
  6174.       if D3D3.CreateDevice(D3DDeviceGUID, Surface.ISurface4, D3DDevice3, nil) <> D3D_OK then
  6175.         raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DDevice3']);
  6176.     end;
  6177.  
  6178.     if SupportHardware then NowOptions := NowOptions + [idoHardware];
  6179.  
  6180.     D3DDevice2 := D3DDevice3 as IDirect3DDevice2;
  6181.     D3DDevice := D3DDevice3 as IDirect3DDevice;
  6182.  
  6183.     with D3DDevice3 do
  6184.     begin
  6185.       SetRenderState(TD3DRenderStateType(D3DRENDERSTATE_DITHERENABLE), 1);
  6186.       SetRenderState(TD3DRenderStateType(D3DRENDERSTATE_ZENABLE), Ord(ZBuffer <> nil));
  6187.       SetRenderState(TD3DRenderStateType(D3DRENDERSTATE_ZWRITEENABLE), Ord(ZBuffer <> nil));
  6188.     end;
  6189. {$IFDEF D3DRM}
  6190.     {  Direct3D Retained Mode}
  6191.     if idoRetainedMode in Options then
  6192.     begin
  6193.       NowOptions := NowOptions + [idoRetainedMode];
  6194.       if D3DRM = nil then
  6195.       begin
  6196.         if TDirect3DRMCreate(DXLoadLibrary('D3DRM.dll', 'Direct3DRMCreate'))(D3DRM) <> D3DRM_OK then
  6197.           raise EDXDrawError.CreateFmt(SCannotInitialized, [SDirect3DRM]);
  6198.         D3DRM2 := D3DRM as IDirect3DRM2;
  6199.         D3DRM3 := D3DRM as IDirect3DRM3;
  6200.       end;
  6201.  
  6202.       if D3DRM3.CreateDeviceFromD3D(D3D2, D3DDevice2, D3DRMDevice3) <> D3DRM_OK then
  6203.         raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DRMDevice2']);
  6204.  
  6205.       D3DRMDevice3.SetBufferCount(2);
  6206.       D3DRMDevice := D3DRMDevice3 as IDirect3DRMDevice;
  6207.       D3DRMDevice2 := D3DRMDevice3 as IDirect3DRMDevice2;
  6208.  
  6209.       {  Rendering state setting  }
  6210.       D3DRMDevice.SetQuality(D3DRMLIGHT_ON or D3DRMFILL_SOLID or D3DRMSHADE_GOURAUD);
  6211.       D3DRMDevice.SetTextureQuality(D3DRMTEXTURE_NEAREST);
  6212.       D3DRMDevice.SetDither(True);
  6213.  
  6214.       if Surface.BitCount = 8 then
  6215.       begin
  6216.         D3DRMDevice.SetShades(8);
  6217.         D3DRM.SetDefaultTextureColors(64);
  6218.         D3DRM.SetDefaultTextureShades(32);
  6219.       end else
  6220.       begin
  6221.         D3DRM.SetDefaultTextureColors(64);
  6222.         D3DRM.SetDefaultTextureShades(32);
  6223.       end;
  6224.  
  6225.       {  Frame making  }
  6226.       if Scene = nil then
  6227.       begin
  6228.         D3DRM.CreateFrame(nil, Scene);
  6229.         D3DRM.CreateFrame(Scene, Camera);
  6230.         Camera.SetPosition(Camera, 0, 0, 0);
  6231.       end;
  6232.  
  6233.       {  Viewport making  }
  6234.       D3DRM.CreateViewport(D3DRMDevice, Camera, 0, 0,
  6235.         Surface.Width, Surface.Height, Viewport);
  6236.       Viewport.SetBack(5000.0);
  6237.     end;
  6238. {$ENDIF}
  6239.    except
  6240.     FreeZBufferSurface(Surface, ZBuffer);
  6241.     D3D := nil;
  6242.     D3D2 := nil;
  6243.     D3D3 := nil;
  6244.     D3DDevice := nil;
  6245.     D3DDevice2 := nil;
  6246.     D3DDevice3 := nil;
  6247. {$IFDEF D3DRM}
  6248.     D3DRM := nil;
  6249.     D3DRM2 := nil;
  6250.     D3DRMDevice := nil;
  6251.     D3DRMDevice2 := nil;
  6252.     Viewport := nil;
  6253.     Scene := nil;
  6254.     Camera := nil;
  6255. {$ENDIF}
  6256.     raise;
  6257.   end;
  6258. end;
  6259. {$ENDIF}
  6260.  
  6261. procedure InitializeDirect3D7(Surface: TDirectDrawSurface;
  6262.   var ZBuffer: TDirectDrawSurface;
  6263.   out D3D7: IDirect3D7;
  6264.   out D3DDevice7: IDirect3DDevice7;
  6265.   var NowOptions: TInitializeDirect3DOptions);
  6266. type
  6267.   TInitializeDirect3DRecord = record
  6268.     Flag: Boolean;
  6269.     BitCount: Integer;
  6270.     DeviceDesc: TD3DDeviceDesc7;
  6271.     Hardware: Boolean;
  6272.     Options: TInitializeDirect3DOptions;
  6273.     SupportHardware: Boolean;
  6274.   end;
  6275.  
  6276.   function CreateZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface;
  6277.     const DeviceDesc: TD3DDeviceDesc7; Hardware: Boolean): Boolean;
  6278.   const
  6279.     MemPosition: array[Boolean] of Integer = (DDSCAPS_SYSTEMMEMORY, DDSCAPS_VIDEOMEMORY);
  6280.   var
  6281.     ZBufferBitDepth: Integer;
  6282.     ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  6283.   begin
  6284.     Result := False;
  6285.     FreeZBufferSurface(Surface, ZBuffer);
  6286.  
  6287.     if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_16 <> 0 then
  6288.       ZBufferBitDepth := 16
  6289.     else if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_24 <> 0 then
  6290.       ZBufferBitDepth := 24
  6291.     else if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_32 <> 0 then
  6292.       ZBufferBitDepth := 32
  6293.     else
  6294.       ZBufferBitDepth := 0;
  6295.  
  6296.     if ZBufferBitDepth <> 0 then
  6297.     begin
  6298.       with ddsd do
  6299.       begin
  6300.         dwSize := SizeOf(ddsd);
  6301.         Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetSurfaceDesc(ddsd);
  6302.         dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT or DDSD_ZBUFFERBITDEPTH;
  6303.         ddsCaps.dwCaps := DDSCAPS_ZBUFFER or MemPosition[Hardware];
  6304.         dwHeight := Surface.Height;
  6305.         dwWidth := Surface.Width;
  6306.         {$IFDEF D3D_deprecated}
  6307.         dwZBufferBitDepth := ZBufferBitDepth;
  6308.         {$ELSE}
  6309.         ddpfPixelFormat.dwFlags := DDPF_ZBUFFER;
  6310.         ddpfPixelFormat.dwZBufferBitDepth := ZBufferBitDepth;
  6311.         ddpfPixelFormat.dwStencilBitDepth := 0;
  6312.         ddpfPixelFormat.dwZBitMask := (1 shl ZBufferBitDepth) - 1;
  6313.         ddpfPixelFormat.dwStencilBitMask := 0;
  6314.         ddpfPixelFormat.dwLuminanceAlphaBitMask := 0;
  6315.         {$ENDIF}
  6316.       end;
  6317.  
  6318.       ZBuffer := TDirectDrawSurface.Create(Surface.DDraw);
  6319.       if ZBuffer.CreateSurface(ddsd) then
  6320.       begin
  6321.         if Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.AddAttachedSurface(ZBuffer.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}) <> DD_OK then
  6322.         begin
  6323.           ZBuffer.Free; ZBuffer := nil;
  6324.           Exit;
  6325.         end;
  6326.         Result := True;
  6327.       end else
  6328.       begin
  6329.         ZBuffer.Free; ZBuffer := nil;
  6330.         Exit;
  6331.       end;
  6332.     end;
  6333.   end;
  6334.  
  6335.   function EnumDeviceCallBack(lpDeviceDescription, lpDeviceName: PChar;
  6336.     const lpTD3DDeviceDesc: TD3DDeviceDesc7; lpUserArg: Pointer): HRESULT; stdcall;
  6337.   var
  6338.     Hardware: Boolean;
  6339.     rec: ^TInitializeDirect3DRecord;
  6340.  
  6341.     procedure UseThisDevice;
  6342.     begin
  6343.       rec.Flag := True;
  6344.       rec.DeviceDesc := lpTD3DDeviceDesc;
  6345.       rec.Hardware := Hardware;
  6346.     end;
  6347.  
  6348.   begin
  6349.     Result := D3DENUMRET_OK;
  6350.     rec := lpUserArg;
  6351.  
  6352.     Hardware := lpTD3DDeviceDesc.dwDevCaps and D3DDEVCAPS_HWRASTERIZATION <> 0;
  6353.  
  6354.     if Hardware and (not rec.SupportHardware) then Exit;
  6355.     if CompareMem(@lpTD3DDeviceDesc.deviceGUID, @IID_IDirect3DRefDevice, SizeOf(TGUID)) then Exit;
  6356.  
  6357.     {  Bit depth test.  }
  6358.     if (lpTD3DDeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then Exit;
  6359.  
  6360.     if Hardware then
  6361.     begin
  6362.       {  Hardware  }
  6363.       UseThisDevice;
  6364.     end else
  6365.     begin
  6366.       {  Software  }
  6367.       if not rec.Hardware then
  6368.         UseThisDevice;
  6369.     end;
  6370.   end;
  6371.  
  6372. var
  6373.   Hardware: Boolean;
  6374.   SupportHardware: Boolean;
  6375.   D3DDeviceGUID: TGUID;
  6376.   Options: TInitializeDirect3DOptions;
  6377.  
  6378.   procedure InitDevice;
  6379.   var
  6380.     rec: TInitializeDirect3DRecord;
  6381.   begin
  6382.     {  Device search  }
  6383.     rec.Flag := False;
  6384.     rec.BitCount := Surface.BitCount;
  6385.     rec.Hardware := False;
  6386.     rec.Options := Options;
  6387.     rec.SupportHardware := SupportHardware;
  6388.  
  6389.     D3D7.EnumDevices(@EnumDeviceCallBack, @rec);
  6390.     if not rec.Flag then
  6391.       raise EDXDrawError.Create(S3DDeviceNotFound);
  6392.  
  6393.     Hardware := rec.Hardware;
  6394.     D3DDeviceGUID := rec.DeviceDesc.deviceGUID;
  6395.  
  6396.     if Hardware then
  6397.       NowOptions := NowOptions + [idoHardware];
  6398.  
  6399.     {  Z buffer making  }
  6400.     NowOptions := NowOptions - [idoZBuffer];
  6401.     if idoZBuffer in Options then
  6402.     begin
  6403.       if CreateZBufferSurface(Surface, ZBuffer, rec.DeviceDesc, Hardware) then
  6404.         NowOptions := NowOptions + [idoZBuffer];
  6405.     end;
  6406.   end;
  6407.  
  6408. begin
  6409.  
  6410.   try
  6411.     Options := NowOptions {$IFDEF D3DRM}- [idoRetainedMode]{$ENDIF};
  6412.     NowOptions := [];
  6413.  
  6414.     D3D7 := Surface.DDraw.IDraw7 as IDirect3D7;
  6415.  
  6416.     {  Whether hardware can be used is tested.  }
  6417.     SupportHardware := (Surface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_VIDEOMEMORY <> 0) and
  6418.       (idoHardware in Options) and (Surface.DDraw.DriverCaps.dwCaps and DDCAPS_3D <> 0) and
  6419.       (Surface.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE <> 0);
  6420.  
  6421.     {  Direct3D  }
  6422.     InitDevice;
  6423.  
  6424.     if D3D7.CreateDevice(D3DDeviceGUID, Surface.ISurface7, D3DDevice7) <> D3D_OK then
  6425.     begin
  6426.       SupportHardware := False;
  6427.       InitDevice;
  6428.       if D3D7.CreateDevice(D3DDeviceGUID, Surface.ISurface7, D3DDevice7) <> D3D_OK then
  6429.         raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DDevice7']);
  6430.     end;
  6431.  
  6432.     if SupportHardware then NowOptions := NowOptions + [idoHardware];
  6433.   except
  6434.     FreeZBufferSurface(Surface, ZBuffer);
  6435.     D3D7 := nil;
  6436.     D3DDevice7 := nil;
  6437.     raise;
  6438.   end;
  6439. end;
  6440. type
  6441.  
  6442. {  TDXDrawDriver  }
  6443.  
  6444.   TDXDrawDriver = class
  6445.   private
  6446.     FDXDraw: TCustomDXDraw;
  6447.     constructor Create(ADXDraw: TCustomDXDraw); virtual;
  6448.     destructor Destroy; override;
  6449.     procedure Finalize; virtual;
  6450.     procedure Flip; virtual; abstract;
  6451.     procedure Initialize; virtual; abstract;
  6452.     procedure Initialize3D;
  6453.     function SetSize(AWidth, AHeight: Integer): Boolean; virtual;
  6454.     function Restore: Boolean;
  6455.   end;
  6456.  
  6457.   TDXDrawDriverBlt = class(TDXDrawDriver)
  6458.   private
  6459.     procedure Flip; override;
  6460.     procedure Initialize; override;
  6461.     procedure InitializeSurface;
  6462.     function SetSize(AWidth, AHeight: Integer): Boolean; override;
  6463.   end;
  6464.  
  6465.   TDXDrawDriverFlip = class(TDXDrawDriver)
  6466.   private
  6467.     procedure Flip; override;
  6468.     procedure Initialize; override;
  6469.   end;
  6470.  
  6471. procedure TCustomDXDraw.MirrorFlip(Value: TRenderMirrorFlipSet);
  6472. begin
  6473.   if CheckD3 then
  6474.     FD2D.MirrorFlip := Value;
  6475. end;
  6476.  
  6477. procedure TCustomDXDraw.SaveTextures(path: string);
  6478. begin
  6479.   if CheckD3 then
  6480.     FD2D.SaveTextures(path)
  6481. end;
  6482. {  TDXDrawDriver  }
  6483.  
  6484. constructor TDXDrawDriver.Create(ADXDraw: TCustomDXDraw);
  6485. var
  6486.   AOptions: TInitializeDirect3DOptions;
  6487. begin
  6488.   inherited Create;
  6489.   FDXDraw := ADXDraw;
  6490.  
  6491.   {  Driver selection and Display mode optimizationn }
  6492.   if FDXDraw.FOptions * [doFullScreen, doSystemMemory, {$IFDEF D3D_deprecated}do3D,{$ENDIF} doHardware] =
  6493.     [doFullScreen, {$IFDEF D3D_deprecated}do3D,{$ENDIF} doHardware] then
  6494.   begin
  6495.     AOptions := [];
  6496.     with FDXDraw do
  6497.     begin
  6498.       if doSelectDriver in Options then AOptions := AOptions + [idoSelectDriver];
  6499.       if not FDXDraw.Display.FixedBitCount then AOptions := AOptions + [idoOptimizeDisplayMode];
  6500.  
  6501.       if doHardware in Options then AOptions := AOptions + [idoHardware];
  6502.       {$IFDEF D3DRM}if doRetainedMode in Options then AOptions := AOptions + [idoRetainedMode];{$ENDIF}
  6503.       if doZBuffer in Options then AOptions := AOptions + [idoZBuffer];
  6504.     end;
  6505.  
  6506.     Direct3DInitializing_DXDraw(AOptions, FDXDraw);
  6507.   end;
  6508.  
  6509.   if FDXDraw.Options * [doFullScreen, doHardware, doSystemMemory] = [doFullScreen, doHardware] then
  6510.     FDXDraw.FDDraw := TDirectDraw.CreateEx(PGUID(FDXDraw.FDriver), {$IFDEF D3D_deprecated}doDirectX7Mode in FDXDraw.Options{$ELSE}True{$ENDIF})
  6511.   else
  6512.     FDXDraw.FDDraw := TDirectDraw.CreateEx(nil, {$IFDEF D3D_deprecated}doDirectX7Mode in FDXDraw.Options{$ELSE}True{$ENDIF});
  6513. end;
  6514.  
  6515. procedure TDXDrawDriver.Initialize3D;
  6516. const
  6517.   DXDrawOptions3D = [doHardware, {$IFDEF D3DRM}doRetainedMode,{$ENDIF} doSelectDriver, doZBuffer];
  6518. var
  6519.   AOptions: TInitializeDirect3DOptions;
  6520. begin
  6521.   AOptions := [];
  6522.   with FDXDraw do
  6523.   begin
  6524.     if doHardware in FOptions then AOptions := AOptions + [idoHardware];
  6525.     {$IFDEF D3DRM}if doRetainedMode in FNowOptions then AOptions := AOptions + [idoRetainedMode];{$ENDIF}
  6526.     if doSelectDriver in FOptions then AOptions := AOptions + [idoSelectDriver];
  6527.     if doZBuffer in FOptions then AOptions := AOptions + [idoZBuffer];
  6528.     {$IFDEF D3D_deprecated}
  6529.     if doDirectX7Mode in FOptions then
  6530.     begin
  6531.       InitializeDirect3D7(FSurface, FZBuffer, FD3D7, FD3DDevice7, AOptions);
  6532.     end else
  6533.     begin
  6534.       InitializeDirect3D(FSurface, FZBuffer, FD3D, FD3D2, FD3D3, FD3DDevice, FD3DDevice2, FD3DDevice3,
  6535.         {$IFDEF D3DRM}
  6536.         FD3DRM, FD3DRM2, FD3DRM3, FD3DRMDevice, FD3DRMDevice2, FD3DRMDevice3, FViewport, FScene, FCamera,
  6537.         {$ENDIF}
  6538.         AOptions);
  6539.     end;
  6540.     {$ELSE}
  6541.     InitializeDirect3D7(FSurface, FZBuffer, FD3D7, FD3DDevice7, AOptions);
  6542.     {$ENDIF}
  6543.     FNowOptions := FNowOptions - DXDrawOptions3D;
  6544.     if idoHardware in AOptions then FNowOptions := FNowOptions + [doHardware];
  6545.     {$IFDEF D3DRM}if idoRetainedMode in AOptions then FNowOptions := FNowOptions + [doRetainedMode];{$ENDIF}
  6546.     if idoSelectDriver in AOptions then FNowOptions := FNowOptions + [doSelectDriver];
  6547.     if idoZBuffer in AOptions then FNowOptions := FNowOptions + [doZBuffer];
  6548.   end;
  6549. end;
  6550.  
  6551. destructor TDXDrawDriver.Destroy;
  6552. begin
  6553.   Finalize;
  6554.   FDXDraw.FDDraw.Free;
  6555.   inherited Destroy;
  6556. end;
  6557.  
  6558. procedure TDXDrawDriver.Finalize;
  6559. begin
  6560.   with FDXDraw do
  6561.   begin
  6562.     {$IFDEF D3DRM}
  6563.     FViewport := nil;
  6564.     FCamera := nil;
  6565.     FScene := nil;
  6566.  
  6567.     FD3DRMDevice := nil;
  6568.     FD3DRMDevice2 := nil;
  6569.     FD3DRMDevice3 := nil;
  6570.     FD3DRM3 := nil;
  6571.     FD3DRM2 := nil;
  6572.     FD3DRM := nil;
  6573.     {$ENDIF}
  6574.     {$IFDEF D3D_deprecated}
  6575.     FD3DDevice := nil;
  6576.     FD3DDevice2 := nil;
  6577.     FD3DDevice3 := nil;
  6578.     {$ENDIF}
  6579.     FD3DDevice7 := nil;
  6580.     {$IFDEF D3D_deprecated}
  6581.     FD3D := nil;
  6582.     FD3D2 := nil;
  6583.     FD3D3 := nil;
  6584.     {$ENDIF}
  6585.     FD3D7 := nil;
  6586.  
  6587.     FreeZBufferSurface(FSurface, FZBuffer);
  6588.  
  6589.     FClipper.Free; FClipper := nil;
  6590.     FPalette.Free; FPalette := nil;
  6591.     FSurface.Free; FSurface := nil;
  6592.     FPrimary.Free; FPrimary := nil;
  6593.  
  6594.   end;
  6595. end;
  6596.  
  6597. function TDXDrawDriver.Restore: Boolean;
  6598. begin
  6599.   Result := FDXDraw.FPrimary.Restore and FDXDraw.FSurface.Restore;
  6600.   if Result then
  6601.   begin
  6602.     FDXDraw.FPrimary.Fill(0);
  6603.     FDXDraw.FSurface.Fill(0);
  6604.   end;
  6605. end;
  6606.  
  6607. function TDXDrawDriver.SetSize(AWidth, AHeight: Integer): Boolean;
  6608. begin
  6609.   Result := False;
  6610. end;
  6611.  
  6612. {  TDXDrawDriverBlt  }
  6613.  
  6614. function TDXDrawRGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads;
  6615.   AllowPalette256: Boolean): TPaletteEntries;
  6616. var
  6617.   Entries: TPaletteEntries;
  6618.   dc: THandle;
  6619.   i: Integer;
  6620. begin
  6621.   Result := RGBQuadsToPaletteEntries(RGBQuads);
  6622.  
  6623.   if not AllowPalette256 then
  6624.   begin
  6625.     dc := GetDC(0);
  6626.     try
  6627.       GetSystemPaletteEntries(dc, 0, 256, Entries);
  6628.     finally
  6629.       ReleaseDC(0, dc);
  6630.     end;
  6631.  
  6632.     for i := 0 to 9 do
  6633.       Result[i] := Entries[i];
  6634.  
  6635.     for i := 256 - 10 to 255 do
  6636.       Result[i] := Entries[i];
  6637.   end;
  6638.  
  6639.   for i := 0 to 255 do
  6640.     Result[i].peFlags := D3DPAL_READONLY;
  6641. end;
  6642.  
  6643. procedure TDXDrawDriverBlt.Flip;
  6644. var
  6645.   pt: TPoint;
  6646.   Dest: TRect;
  6647.   DF: TDDBltFX;
  6648. begin
  6649.   pt := FDXDraw.ClientToScreen(Point(0, 0));
  6650.  
  6651.   if doStretch in FDXDraw.NowOptions then
  6652.   begin
  6653.     Dest := Bounds(pt.x, pt.y, FDXDraw.Width, FDXDraw.Height);
  6654.   end else
  6655.   begin
  6656.     if doCenter in FDXDraw.NowOptions then
  6657.     begin
  6658.       Inc(pt.x, (FDXDraw.Width - FDXDraw.FSurface.Width) div 2);
  6659.       Inc(pt.y, (FDXDraw.Height - FDXDraw.FSurface.Height) div 2);
  6660.     end;
  6661.  
  6662.     Dest := Bounds(pt.x, pt.y, FDXDraw.FSurface.Width, FDXDraw.FSurface.Height);
  6663.   end;
  6664.  
  6665.   if doWaitVBlank in FDXDraw.NowOptions then
  6666.     FDXDraw.FDDraw.DXResult := FDXDraw.FDDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.WaitForVerticalBlank(DDWAITVB_BLOCKBEGIN, 0);
  6667.  
  6668.   FillChar(DF, SizeOf(DF), 0);
  6669.   DF.dwsize := SizeOf(DF);
  6670.   DF.dwDDFX := 0;
  6671.  
  6672.   FDXDraw.FPrimary.Blt(Dest, FDXDraw.FSurface.ClientRect, DDBLT_WAIT, df, FDXDraw.FSurface);
  6673. end;
  6674.  
  6675. procedure TDXDrawDriverBlt.Initialize;
  6676. {$IFDEF D3D_deprecated}
  6677. const
  6678.   PrimaryDesc: TDDSurfaceDesc = (
  6679.     dwSize: SizeOf(PrimaryDesc);
  6680.     dwFlags: DDSD_CAPS;
  6681.     ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE)
  6682.     );
  6683. {$ENDIF}
  6684. var
  6685.   Entries: TPaletteEntries;
  6686.   PaletteCaps: Integer;
  6687.   {$IFNDEF D3D_deprecated}
  6688.   PrimaryDesc: TDDSurfaceDesc2;
  6689.   {$ENDIF}
  6690. begin
  6691.   {$IFNDEF D3D_deprecated}
  6692.   FillChar(PrimaryDesc, SizeOf(PrimaryDesc), 0);
  6693.   PrimaryDesc.dwSize := SizeOf(PrimaryDesc);
  6694.   PrimaryDesc.dwFlags := DDSD_CAPS;
  6695.   PrimaryDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
  6696.   {$ENDIF}
  6697.   {  Surface making  }
  6698.   FDXDraw.FPrimary := TDirectDrawSurface.Create(FDXDraw.FDDraw);
  6699.   if not FDXDraw.FPrimary.CreateSurface(PrimaryDesc) then
  6700.     raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawPrimarySurface]);
  6701.  
  6702.   FDXDraw.FSurface := TDirectDrawSurface.Create(FDXDraw.FDDraw);
  6703.  
  6704.   {  Clipper making  }
  6705.   FDXDraw.FClipper := TDirectDrawClipper.Create(FDXDraw.FDDraw);
  6706.   FDXDraw.FClipper.Handle := FDXDraw.Handle;
  6707.   FDXDraw.FPrimary.Clipper := FDXDraw.FClipper;
  6708.  
  6709.   {  Palette making  }
  6710.   PaletteCaps := DDPCAPS_8BIT or DDPCAPS_INITIALIZE;
  6711.   if doAllowPalette256 in FDXDraw.NowOptions then
  6712.     PaletteCaps := PaletteCaps or DDPCAPS_ALLOW256;
  6713.  
  6714.   FDXDraw.FPalette := TDirectDrawPalette.Create(FDXDraw.FDDraw);
  6715.   Entries := TDXDrawRGBQuadsToPaletteEntries(FDXDraw.ColorTable,
  6716.     doAllowPalette256 in FDXDraw.NowOptions);
  6717.   FDXDraw.FPalette.CreatePalette(PaletteCaps, Entries);
  6718.  
  6719.   FDXDraw.FPrimary.Palette := FDXDraw.Palette;
  6720.  
  6721.   InitializeSurface;
  6722. end;
  6723.  
  6724. procedure TDXDrawDriverBlt.InitializeSurface;
  6725. var
  6726.   ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  6727. begin
  6728.   FDXDraw.FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil;
  6729.  
  6730.   {  Surface making  }
  6731.   FDXDraw.FNowOptions := FDXDraw.FNowOptions - [doSystemMemory];
  6732.  
  6733.   FillChar(ddsd, SizeOf(ddsd), 0);
  6734.   with ddsd do
  6735.   begin
  6736.     dwSize := SizeOf(ddsd);
  6737.     dwFlags := DDSD_WIDTH or DDSD_HEIGHT or DDSD_CAPS;
  6738.     dwWidth := Max(FDXDraw.FSurfaceWidth, 1);
  6739.     dwHeight := Max(FDXDraw.FSurfaceHeight, 1);
  6740.     ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
  6741.     if doSystemMemory in FDXDraw.Options then
  6742.       ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
  6743.     {$IFDEF D3D_deprecated}if do3D in FDXDraw.FNowOptions then{$ENDIF}
  6744.       ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_3DDEVICE;
  6745.   end;
  6746.  
  6747.   if not FDXDraw.FSurface.CreateSurface(ddsd) then
  6748.   begin
  6749.     ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
  6750.     if not FDXDraw.FSurface.CreateSurface(ddsd) then
  6751.       raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
  6752.   end;
  6753.  
  6754.   if FDXDraw.FSurface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_VIDEOMEMORY = 0 then
  6755.     FDXDraw.FNowOptions := FDXDraw.FNowOptions + [doSystemMemory];
  6756.  
  6757.   FDXDraw.FSurface.Palette := FDXDraw.Palette;
  6758.   FDXDraw.FSurface.Fill(0);
  6759.  
  6760.   {$IFDEF D3D_deprecated}if do3D in FDXDraw.FNowOptions then{$ENDIF}
  6761.     Initialize3D;
  6762. end;
  6763.  
  6764. function TDXDrawDriverBlt.SetSize(AWidth, AHeight: Integer): Boolean;
  6765. begin
  6766.   Result := True;
  6767.  
  6768.   FDXDraw.FSurfaceWidth := Max(AWidth, 1);
  6769.   FDXDraw.FSurfaceHeight := Max(AHeight, 1);
  6770.  
  6771.   Inc(FDXDraw.FOffNotifyRestore);
  6772.   try
  6773.     FDXDraw.NotifyEventList(dxntFinalizeSurface);
  6774.  
  6775.     if FDXDraw.FCalledDoInitializeSurface then
  6776.     begin
  6777.       FDXDraw.FCalledDoInitializeSurface := False;
  6778.       FDXDraw.DoFinalizeSurface;
  6779.     end;
  6780.  
  6781.     InitializeSurface;
  6782.  
  6783.     FDXDraw.NotifyEventList(dxntInitializeSurface);
  6784.     FDXDraw.FCalledDoInitializeSurface := True; FDXDraw.DoInitializeSurface;
  6785.   finally
  6786.     Dec(FDXDraw.FOffNotifyRestore);
  6787.   end;
  6788. end;
  6789.  
  6790. {  TDXDrawDriverFlip  }
  6791.  
  6792. procedure TDXDrawDriverFlip.Flip;
  6793. begin
  6794.   if (FDXDraw.FForm <> nil) and (FDXDraw.FForm.Active) then
  6795.     FDXDraw.FPrimary.DXResult := FDXDraw.FPrimary.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.Flip(nil, DDFLIP_WAIT)
  6796.   else
  6797.     FDXDraw.FPrimary.DXResult := 0;
  6798. end;
  6799.  
  6800. procedure TDXDrawDriverFlip.Initialize;
  6801. {$IFDEF D3D_deprecated}
  6802. const
  6803.   DefPrimaryDesc: TDDSurfaceDesc = (
  6804.     dwSize: SizeOf(DefPrimaryDesc);
  6805.     dwFlags: DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
  6806.     dwBackBufferCount: 1;
  6807.     ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX)
  6808.     );
  6809.   BackBufferCaps: TDDSCaps = (dwCaps: DDSCAPS_BACKBUFFER);
  6810. {$ENDIF}
  6811. var
  6812.   PrimaryDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  6813.   PaletteCaps: Integer;
  6814.   Entries: TPaletteEntries;
  6815.   DDSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface{$ELSE}IDirectDrawSurface7{$ENDIF};
  6816.   {$IFNDEF D3D_deprecated}
  6817.   BackBufferCaps: TDDSCaps2;
  6818.   {$ENDIF}
  6819. begin
  6820.   {  Surface making  }
  6821.   {$IFDEF D3D_deprecated}
  6822.   PrimaryDesc := DefPrimaryDesc;
  6823.   {$ELSE}
  6824.   FillChar(PrimaryDesc, SizeOf(PrimaryDesc), 0);
  6825.   PrimaryDesc.dwSize := SizeOf(PrimaryDesc);
  6826.   PrimaryDesc.dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
  6827.   PrimaryDesc.dwBackBufferCount := 1;
  6828.   PrimaryDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX;
  6829.   FillChar(BackBufferCaps, SizeOf(BackBufferCaps), 0);
  6830.   BackBufferCaps.dwCaps := DDSCAPS_BACKBUFFER;
  6831.   {$ENDIF}
  6832.   {$IFDEF D3D_deprecated}if do3D in FDXDraw.FNowOptions then{$ENDIF}
  6833.     PrimaryDesc.ddsCaps.dwCaps := PrimaryDesc.ddsCaps.dwCaps or DDSCAPS_3DDEVICE;
  6834.  
  6835.   FDXDraw.FPrimary := TDirectDrawSurface.Create(FDXDraw.FDDraw);
  6836.   if not FDXDraw.FPrimary.CreateSurface(PrimaryDesc) then
  6837.     raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawPrimarySurface]);
  6838.  
  6839.   FDXDraw.FSurface := TDirectDrawSurface.Create(FDXDraw.FDDraw);
  6840.   if FDXDraw.FPrimary.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetAttachedSurface(BackBufferCaps, DDSurface) = DD_OK then
  6841.     FDXDraw.FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := DDSurface;
  6842.  
  6843.   FDXDraw.FNowOptions := FDXDraw.FNowOptions - [doSystemMemory];
  6844.   if FDXDraw.FSurface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_SYSTEMMEMORY <> 0 then
  6845.     FDXDraw.FNowOptions := FDXDraw.FNowOptions + [doSystemMemory];
  6846.  
  6847.   {  Clipper making of dummy  }
  6848.   FDXDraw.FClipper := TDirectDrawClipper.Create(FDXDraw.FDDraw);
  6849.  
  6850.   {  Palette making  }
  6851.   PaletteCaps := DDPCAPS_8BIT;
  6852.   if doAllowPalette256 in FDXDraw.Options then
  6853.     PaletteCaps := PaletteCaps or DDPCAPS_ALLOW256;
  6854.  
  6855.   FDXDraw.FPalette := TDirectDrawPalette.Create(FDXDraw.FDDraw);
  6856.   Entries := TDXDrawRGBQuadsToPaletteEntries(FDXDraw.ColorTable,
  6857.     doAllowPalette256 in FDXDraw.NowOptions);
  6858.   FDXDraw.FPalette.CreatePalette(PaletteCaps, Entries);
  6859.  
  6860.   FDXDraw.FPrimary.Palette := FDXDraw.Palette;
  6861.   FDXDraw.FSurface.Palette := FDXDraw.Palette;
  6862.  
  6863.   {$IFDEF D3D_deprecated}if do3D in FDXDraw.FNowOptions then{$ENDIF}
  6864.     Initialize3D;
  6865.  
  6866. end;
  6867.  
  6868. constructor TCustomDXDraw.Create(AOwner: TComponent);
  6869. var
  6870.   Entries: TPaletteEntries;
  6871.   dc: THandle;
  6872. begin
  6873.   FNotifyEventList := TList.Create;
  6874.   inherited Create(AOwner);
  6875.   FAutoInitialize := True;
  6876.   FDisplay := TDXDrawDisplay.Create(Self);
  6877.   {$IFDEF _DMO_}FAdapters := EnumDirectDrawDriversEx;{$ENDIF}
  6878.   Options := [doAllowReboot, doWaitVBlank, doCenter, {$IFDEF D3D_deprecated}doDirectX7Mode, do3D,{$ENDIF}
  6879.     doHardware, doSelectDriver];
  6880.  
  6881.   FAutoSize := True;
  6882.  
  6883.   dc := GetDC(0);
  6884.   try
  6885.     GetSystemPaletteEntries(dc, 0, 256, Entries);
  6886.   finally
  6887.     ReleaseDC(0, dc);
  6888.   end;
  6889.  
  6890.   ColorTable := PaletteEntriesToRGBQuads(Entries);
  6891.   DefColorTable := ColorTable;
  6892.  
  6893.   Width := 100;
  6894.   Height := 100;
  6895.   ParentColor := False;
  6896.   Color := clBlack; //clBtnFace; // FIX
  6897.  
  6898.   FD2D := TD2D.Create(Self);
  6899.   D2D := FD2D; {as loopback}
  6900.   FTraces := TTraces.Create(Self);
  6901. end;
  6902.  
  6903. destructor TCustomDXDraw.Destroy;
  6904. begin
  6905.   Finalize;
  6906.   NotifyEventList(dxntDestroying);
  6907.   FDisplay.Free;
  6908.   {$IFDEF _DMO_}FAdapters := nil;{$ENDIF}
  6909.   FSubClass.Free; FSubClass := nil;
  6910.   FNotifyEventList.Free;
  6911.   FD2D.Free;
  6912.   FD2D := nil;
  6913.   D2D := nil;
  6914.   FTraces.Free;
  6915.   inherited Destroy;
  6916. end;
  6917.  
  6918. class function TCustomDXDraw.Drivers: TDirectXDrivers;
  6919. begin
  6920.   Result := EnumDirectDrawDrivers;
  6921. end;
  6922.  
  6923. {$IFDEF _DMO_}
  6924. class function TCustomDXDraw.DriversEx: TDirectXDriversEx;
  6925. begin
  6926.   Result := EnumDirectDrawDriversEx;
  6927. end;
  6928. {$ENDIF}
  6929.  
  6930. type
  6931.   PDXDrawNotifyEvent = ^TDXDrawNotifyEvent;
  6932.  
  6933. procedure TCustomDXDraw.RegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
  6934. var
  6935.   Event: PDXDrawNotifyEvent;
  6936. begin
  6937.   UnRegisterNotifyEvent(NotifyEvent);
  6938.  
  6939.   New(Event);
  6940.   Event^ := NotifyEvent;
  6941.   FNotifyEventList.Add(Event);
  6942.  
  6943.   NotifyEvent(Self, dxntSetSurfaceSize);
  6944.  
  6945.   if Initialized then
  6946.   begin
  6947.     NotifyEvent(Self, dxntInitialize);
  6948.     if FCalledDoInitializeSurface then
  6949.       NotifyEvent(Self, dxntInitializeSurface);
  6950.     if FOffNotifyRestore = 0 then
  6951.       NotifyEvent(Self, dxntRestore);
  6952.   end;
  6953. end;
  6954.  
  6955. procedure TCustomDXDraw.UnRegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
  6956. var
  6957.   Event: PDXDrawNotifyEvent;
  6958.   i: Integer;
  6959. begin
  6960.   for i := 0 to FNotifyEventList.Count - 1 do
  6961.   begin
  6962.     Event := FNotifyEventList[i];
  6963.     if (TMethod(Event^).Code = TMethod(NotifyEvent).Code) and
  6964.       (TMethod(Event^).Data = TMethod(NotifyEvent).Data) then
  6965.     begin
  6966.       FreeMem(Event);
  6967.       FNotifyEventList.Delete(i);
  6968.  
  6969.       if FCalledDoInitializeSurface then
  6970.         NotifyEvent(Self, dxntFinalizeSurface);
  6971.       if Initialized then
  6972.         NotifyEvent(Self, dxntFinalize);
  6973.  
  6974.       Break;
  6975.     end;
  6976.   end;
  6977. end;
  6978.  
  6979. procedure TCustomDXDraw.NotifyEventList(NotifyType: TDXDrawNotifyType);
  6980. var
  6981.   i: Integer;
  6982. begin
  6983.   for i := FNotifyEventList.Count - 1 downto 0 do
  6984.     PDXDrawNotifyEvent(FNotifyEventList[i])^(Self, NotifyType);
  6985. end;
  6986.  
  6987. procedure TCustomDXDraw.FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
  6988.  
  6989.   procedure FlipToGDISurface;
  6990.   begin
  6991.     if Initialized and (FNowOptions * [doFullScreen, doFlip] = [doFullScreen, doFlip]) then
  6992.       DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.FlipToGDISurface;
  6993.   end;
  6994.  
  6995. begin
  6996.   case Message.Msg of
  6997.     {CM_ACTIVATE:
  6998.         begin
  6999.           DefWindowProc(Message);
  7000.           if AutoInitialize and (not FInitalized2) then
  7001.             Initialize;
  7002.           Exit;
  7003.         end;   }
  7004.     WM_WINDOWPOSCHANGED:
  7005.       begin
  7006.         if TWMWindowPosChanged(Message).WindowPos^.flags and SWP_SHOWWINDOW <> 0 then
  7007.         begin
  7008.           DefWindowProc(Message);
  7009.           if AutoInitialize and (not FInitialized2) then
  7010.             Initialize;
  7011.           Exit;
  7012.         end;
  7013.       end;
  7014. (*
  7015.     WM_ACTIVATEAPP:
  7016.       begin
  7017.         if TWMActivateApp(Message).Active then
  7018.         begin
  7019.           FActive := True;
  7020.           DoActivate;
  7021. //          PostMessage(FHandle, CM_ACTIVATE, 0, 0)
  7022.         end
  7023.         else
  7024.         begin
  7025.           FActive := False;
  7026.           DoDeactivate;
  7027. //          PostMessage(FHandle, CM_DEACTIVATE, 0, 0);
  7028.         end;
  7029.       end;
  7030. *)
  7031.     WM_ACTIVATE:
  7032.       begin
  7033.         if TWMActivate(Message).Active = WA_INACTIVE then
  7034.           FlipToGDISurface;
  7035.       end;
  7036.     WM_INITMENU:
  7037.       begin
  7038.         FlipToGDISurface;
  7039.       end;
  7040.     WM_DESTROY:
  7041.       begin
  7042.         Finalize;
  7043.       end;
  7044.     WM_ENTERSIZEMOVE:
  7045.       begin
  7046.         if not (csLoading in ComponentState) then
  7047.           Finalize;
  7048.       end;
  7049.     WM_EXITSIZEMOVE:
  7050.       begin
  7051.         if not (csLoading in ComponentState) then
  7052.           Initialize;
  7053.       end;
  7054. //    SW_RESTORE, SW_MAXIMIZE:
  7055. //        begin
  7056. //          {force finalize/initialize loop}
  7057. //          if not AutoInitialize or not (csLoading in ComponentState) then begin
  7058. //            Finalize;
  7059. //            Initialize;
  7060. //          end;
  7061. //        end;
  7062.   end;
  7063.   DefWindowProc(Message);
  7064. end;
  7065.  
  7066. procedure TCustomDXDraw.DoFinalize;
  7067. begin
  7068.   if Assigned(FOnFinalize) then FOnFinalize(Self);
  7069. end;
  7070.  
  7071. procedure TCustomDXDraw.DoFinalizeSurface;
  7072. begin
  7073.   if Assigned(FOnFinalizeSurface) then FOnFinalizeSurface(Self);
  7074. end;
  7075.  
  7076. procedure TCustomDXDraw.DoInitialize;
  7077. begin
  7078.   {$IFDEF _DMO_}
  7079.   {erase items for following refresh}
  7080.   if Assigned(FAdapters) then FAdapters.Clear;
  7081.   EnumDirectDrawDriversEx;
  7082.   {$ENDIF}
  7083.   if Assigned(FOnInitialize) then FOnInitialize(Self);
  7084.   {$IFNDEF DXR_deprecated}
  7085.    {$IFDEF D3D_deprecated}
  7086.     if not (do3D in Options) then
  7087.       Options := Options + [do3D];
  7088.    {$ENDIF}
  7089.   {$ENDIF}
  7090. end;
  7091.  
  7092. procedure TCustomDXDraw.DoInitializeSurface;
  7093. begin
  7094.   {.06 added for better initialization}
  7095.   if Assigned(FD2D) then
  7096.     RenderError := FD2D.D2DInitializeSurface;
  7097.  
  7098.   if Assigned(FOnInitializeSurface) then FOnInitializeSurface(Self);
  7099. end;
  7100.  
  7101. procedure TCustomDXDraw.DoInitializing;
  7102. begin
  7103.   if Assigned(FOnInitializing) then FOnInitializing(Self);
  7104. end;
  7105.  
  7106. procedure TCustomDXDraw.DoRestoreSurface;
  7107. begin
  7108.   if Assigned(FOnRestoreSurface) then FOnRestoreSurface(Self);
  7109. end;
  7110.  
  7111. procedure TCustomDXDraw.Finalize;
  7112. begin
  7113.   if FInternalInitialized then
  7114.   begin
  7115.     FSurfaceWidth := SurfaceWidth;
  7116.     FSurfaceHeight := SurfaceHeight;
  7117.  
  7118.     FDisplay.FModes.Clear;
  7119.  
  7120.     FUpdating := True;
  7121.     try
  7122.       try
  7123.         try
  7124.           if FCalledDoInitializeSurface then
  7125.           begin
  7126.             FCalledDoInitializeSurface := False;
  7127.             DoFinalizeSurface;
  7128.           end;
  7129.         finally
  7130.           NotifyEventList(dxntFinalizeSurface);
  7131.         end;
  7132.       finally
  7133.         try
  7134.           if FCalledDoInitialize then
  7135.           begin
  7136.             FCalledDoInitialize := False;
  7137.             DoFinalize;
  7138.           end;
  7139.         finally
  7140.           NotifyEventList(dxntFinalize);
  7141.         end;
  7142.       end;
  7143.     finally
  7144.       FInternalInitialized := False;
  7145.       FInitialized := False;
  7146.  
  7147.       SetOptions(FOptions);
  7148.  
  7149.       FDXDrawDriver.Free; FDXDrawDriver := nil;
  7150.       FUpdating := False;
  7151.     end;
  7152.   end;
  7153.   if AsSigned(FD2D) then
  7154.     FD2D.Free;
  7155.   FD2D := nil;
  7156.   D2D := nil
  7157. end;
  7158.  
  7159. procedure TCustomDXDraw.Flip;
  7160. begin
  7161.   if Initialized and (not FUpdating) then
  7162.   begin
  7163.     if TryRestore and (not RenderError) then
  7164.       TDXDrawDriver(FDXDrawDriver).Flip;
  7165.   end;
  7166.   RenderError := false;
  7167. end;
  7168.  
  7169. function TCustomDXDraw.GetCanDraw: Boolean;
  7170. begin
  7171.   {$IFNDEF DXR_deprecated}
  7172.   {$IFDEF D3D_deprecated}
  7173.   if not (do3D in Options) then
  7174.     Options := Options + [do3D];
  7175.   {$ENDIF}
  7176.   {$ENDIF}
  7177.   Result := Initialized and (not FUpdating) and (Surface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) and
  7178.     TryRestore;
  7179. end;
  7180.  
  7181. function TCustomDXDraw.GetCanPaletteAnimation: Boolean;
  7182. begin
  7183.   Result := Initialized and (not FUpdating) and (doFullScreen in FNowOptions)
  7184.     and (DDraw.DisplayMode.ddpfPixelFormat.dwRGBBitCount <= 8);
  7185. end;
  7186.  
  7187. function TCustomDXDraw.GetSurfaceHeight: Integer;
  7188. begin
  7189.   if Surface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  7190.     Result := Surface.Height
  7191.   else
  7192.     Result := FSurfaceHeight;
  7193. end;
  7194.  
  7195. function TCustomDXDraw.GetSurfaceWidth: Integer;
  7196. begin
  7197.   if Surface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  7198.     Result := Surface.Width
  7199.   else
  7200.     Result := FSurfaceWidth;
  7201. end;
  7202.  
  7203. procedure TCustomDXDraw.Loaded;
  7204. begin
  7205.   inherited Loaded;
  7206.  
  7207.   if AutoSize then
  7208.   begin
  7209.     FSurfaceWidth := Width;
  7210.     FSurfaceHeight := Height;
  7211.   end;
  7212.  
  7213.   NotifyEventList(dxntSetSurfaceSize);
  7214.  
  7215.   if FAutoInitialize and (not (csDesigning in ComponentState)) then
  7216.   begin
  7217.     if {(not (doFullScreen in FOptions)) or }(FSubClass = nil) then
  7218.       Initialize;
  7219.   end;
  7220. end;
  7221.  
  7222. procedure TCustomDXDraw.Initialize;
  7223. begin
  7224.   FInitialized2 := True;
  7225.  
  7226.   Finalize;
  7227.  
  7228.   if FForm = nil then
  7229.     raise EDXDrawError.Create(SNoForm);
  7230.  
  7231.   try
  7232.     DoInitializing;
  7233.  
  7234.     {  Initialization.  }
  7235.     FUpdating := True;
  7236.     try
  7237.       FInternalInitialized := True;
  7238.  
  7239.       NotifyEventList(dxntInitializing);
  7240.  
  7241.       {  DirectDraw initialization.  }
  7242.       if doFlip in FNowOptions then
  7243.         FDXDrawDriver := TDXDrawDriverFlip.Create(Self)
  7244.       else
  7245.         FDXDrawDriver := TDXDrawDriverBlt.Create(Self);
  7246.  
  7247.       {  Window handle setting.  }
  7248.       SetCooperativeLevel;
  7249.  
  7250.       {  Set display mode.  }
  7251.       if doFullScreen in FNowOptions then
  7252.       begin
  7253.         if not Display.DynSetSize(Display.Width, Display.Height, Display.BitCount) then
  7254.           raise EDXDrawError.CreateFmt(SDisplaymodeChange, [Display.Width, Display.Height, Display.BitCount]);
  7255.       end;
  7256.  
  7257.       {  Resource initialization.  }
  7258.       if AutoSize then
  7259.       begin
  7260.         FSurfaceWidth := Width;
  7261.         FSurfaceHeight := Height;
  7262.       end;
  7263.  
  7264.       TDXDrawDriver(FDXDrawDriver).Initialize;
  7265.     finally
  7266.       FUpdating := False;
  7267.     end;
  7268.   except
  7269.     Finalize;
  7270.     raise;
  7271.   end;
  7272.  
  7273.   FInitialized := True;
  7274.  
  7275.   Inc(FOffNotifyRestore);
  7276.   try
  7277.     NotifyEventList(dxntSetSurfaceSize);
  7278.     NotifyEventList(dxntInitialize);
  7279.     FCalledDoInitialize := True; DoInitialize;
  7280.  
  7281.     NotifyEventList(dxntInitializeSurface);
  7282.     FCalledDoInitializeSurface := True; DoInitializeSurface;
  7283.   finally
  7284.     Dec(FOffNotifyRestore);
  7285.   end;
  7286.  
  7287.   if not Assigned(FD2D) then begin
  7288.     FD2D := TD2D.Create(Self);
  7289.     D2D := FD2D; {as loopback}
  7290.   end;
  7291.  
  7292.   Restore;
  7293. end;
  7294.  
  7295. procedure TCustomDXDraw.Paint;
  7296. var
  7297.   Old: TDXDrawOptions;
  7298.   w, h: Integer;
  7299.   s: string;
  7300. begin
  7301.   inherited Paint;
  7302.   if (csDesigning in ComponentState) then
  7303.   begin
  7304.     Canvas.Brush.Style := bsClear;
  7305.     Canvas.Pen.Color := clBlack;
  7306.     Canvas.Pen.Style := psDash;
  7307.     Canvas.Rectangle(0, 0, Width, Height);
  7308.  
  7309.     Canvas.Pen.Style := psSolid;
  7310.     Canvas.Pen.Color := clGray;
  7311.     Canvas.MoveTo(0, 0);
  7312.     Canvas.LineTo(Width, Height);
  7313.  
  7314.     Canvas.MoveTo(0, Height);
  7315.     Canvas.LineTo(Width, 0);
  7316.  
  7317.     s := Format('(%s)', [ClassName]);
  7318.  
  7319.     w := Canvas.TextWidth(s);
  7320.     h := Canvas.TextHeight(s);
  7321.  
  7322.     Canvas.Brush.Style := bsSolid;
  7323.     Canvas.Brush.Color := clBtnFace;
  7324.     Canvas.TextOut(Width div 2 - w div 2, Height div 2 - h div 2, s);
  7325.   end else
  7326.   begin
  7327.     Old := FNowOptions;
  7328.     try
  7329.       FNowOptions := FNowOptions - [doWaitVBlank];
  7330.       Flip;
  7331.     finally
  7332.       FNowOptions := Old;
  7333.     end;
  7334.     if (Parent <> nil) and (Initialized) and (Surface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_VIDEOMEMORY <> 0) then
  7335.       Parent.Invalidate;
  7336.   end;
  7337. end;
  7338.  
  7339. function TCustomDXDraw.PaletteChanged(Foreground: Boolean): Boolean;
  7340. begin
  7341.   if Foreground then
  7342.   begin
  7343.     Restore;
  7344.     Result := True;
  7345.   end else
  7346.     Result := False;
  7347. end;
  7348.  
  7349. procedure TCustomDXDraw.Render(LagCount: Integer{$IFDEF VER4UP} = 0{$ENDIF});
  7350. var I: Integer;
  7351. begin
  7352. {$IFDEF D3DRM}
  7353.   if FInitialized and {$IFDEF D3D_deprecated}(do3D in FNowOptions) and{$ENDIF} (doRetainedMode in FNowOptions) then
  7354.   begin
  7355.     asm FInit end;
  7356.     FViewport.Clear;
  7357.     FViewport.Render(FScene);
  7358.     FD3DRMDevice.Update;
  7359.     asm FInit end;
  7360.   end;
  7361. {$ENDIF}
  7362.   {traces}
  7363.   if FTraces.Count > 0 then
  7364.     for I := 0 to FTraces.Count - 1 do
  7365.       if FTraces.Items[I].Active then
  7366.         FTraces.Items[I].Render(LagCount);
  7367.   {own rendering event}
  7368.   if Assigned(FOnRender) then
  7369.     FOnRender(Self);
  7370. end;
  7371.  
  7372. procedure TCustomDXDraw.Restore;
  7373. begin
  7374.   if Initialized and (not FUpdating) then
  7375.   begin
  7376.     FUpdating := True;
  7377.     try
  7378.       if TDXDrawDriver(FDXDrawDriver).Restore then
  7379.       begin
  7380.         Primary.Palette := Palette;
  7381.         Surface.Palette := Palette;
  7382.  
  7383.         SetColorTable(DefColorTable);
  7384.         NotifyEventList(dxntRestore);
  7385.         DoRestoreSurface;
  7386.         SetColorTable(ColorTable);
  7387.       end;
  7388.     finally
  7389.       FUpdating := False;
  7390.     end;
  7391.   end;
  7392. end;
  7393.  
  7394. procedure TCustomDXDraw.SetAutoSize(Value: Boolean);
  7395. begin
  7396.   if FAutoSize <> Value then
  7397.   begin
  7398.     FAutoSize := Value;
  7399.     if FAutoSize then
  7400.       SetSize(Width, Height);
  7401.   end;
  7402. end;
  7403.  
  7404. procedure TCustomDXDraw.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  7405. begin
  7406.   inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  7407.   if FAutoSize and (not FUpdating) then
  7408.     SetSize(AWidth, AHeight);
  7409. end;
  7410.  
  7411. procedure TCustomDXDraw.BeginScene;
  7412. begin
  7413.   if CheckD3 then
  7414.     FD2D.BeginScene
  7415. end;
  7416.  
  7417. procedure TCustomDXDraw.EndScene;
  7418. begin
  7419.   if CheckD3 then
  7420.     FD2D.EndScene
  7421. end;
  7422.  
  7423. function TCustomDXDraw.CheckD3: Boolean;
  7424. begin
  7425.   Result := {$IFDEF D3D_deprecated}(do3D in Options) and{$ENDIF} (doHardware in Options) and AsSigned(FD2D);
  7426. end;
  7427.  
  7428. function TCustomDXDraw.CheckD3D(Dest: TDirectDrawSurface): Boolean;
  7429. begin
  7430.   Result := CheckD3 and (FD2D.FDDraw.FSurface = Dest)
  7431. end;
  7432.  
  7433. procedure TCustomDXDraw.ClearStack;
  7434. begin
  7435.   if CheckD3 then
  7436.     FD2D.D2DTextures.D2DPruneAllTextures;
  7437. end;
  7438.  
  7439. procedure TCustomDXDraw.UpdateTextures;
  7440. var Changed: Boolean;
  7441. begin
  7442.   if CheckD3 then begin
  7443.     if Assigned(FOnUpdateTextures) then begin
  7444.       Changed := False;
  7445.       FOnUpdateTextures(FD2D.FD2DTexture, Changed);
  7446.       if Changed then FD2D.D2DUpdateTextures;
  7447.     end
  7448.   end;
  7449. end;
  7450.  
  7451. procedure TCustomDXDraw.TextureFilter(Grade: TD2DTextureFilter);
  7452. begin
  7453.   if CheckD3 then
  7454.     FD2D.TextureFilter := Grade;
  7455. end;
  7456.  
  7457. procedure TCustomDXDraw.AntialiasFilter(Grade: TD3DAntialiasMode);
  7458. begin
  7459.   if CheckD3 then
  7460.     FD2D.AntialiasFilter := Grade;
  7461. end;
  7462.  
  7463. // ***** fade effects
  7464. // do not use in dxtimer cycle
  7465.  
  7466. function TCustomDXDraw.Fade2Color(colorfrom, colorto: LongInt): LongInt;
  7467. var i, r1, r2, g1, g2, b1, b2: Integer;
  7468. begin
  7469.   r1 := GetRValue(colorfrom);
  7470.   r2 := GetRValue(colorto);
  7471.   g1 := GetGValue(colorfrom);
  7472.   g2 := GetGValue(colorto);
  7473.   b1 := GetBValue(colorfrom);
  7474.   b2 := GetBValue(colorto);
  7475.   if r1 < r2 then
  7476.   begin
  7477.     for i := r1 to r2 do
  7478.     begin
  7479.       Surface.Fill(RGB(i, g1, b1));
  7480.       Flip;
  7481.     end;
  7482.   end
  7483.   else
  7484.   begin
  7485.     for i := r1 downto r2 do
  7486.     begin
  7487.       Surface.Fill(RGB(i, g1, b1));
  7488.       Flip;
  7489.     end;
  7490.   end;
  7491.  
  7492.   if g1 < g2 then
  7493.   begin
  7494.     for i := g1 to g2 do
  7495.     begin
  7496.       Surface.Fill(RGB(r2, i, b1));
  7497.       Flip;
  7498.     end;
  7499.   end
  7500.   else
  7501.   begin
  7502.     for i := g1 downto g2 do
  7503.     begin
  7504.       Surface.Fill(RGB(r2, i, b1));
  7505.       Flip;
  7506.     end;
  7507.   end;
  7508.   if b1 < b2 then
  7509.   begin
  7510.     for i := b1 to b2 do
  7511.     begin
  7512.       Surface.Fill(RGB(r2, g2, i));
  7513.       Flip;
  7514.     end;
  7515.   end
  7516.   else
  7517.   begin
  7518.     for i := b1 downto b2 do
  7519.     begin
  7520.       Surface.Fill(RGB(r2, g2, i));
  7521.       Flip;
  7522.     end;
  7523.   end;
  7524.   Result := colorto;
  7525. end;
  7526.  
  7527. function TCustomDXDraw.Fade2Black(colorfrom: LongInt): LongInt;
  7528. var i, r, g, b: Integer;
  7529. begin
  7530.   r := GetRValue(colorfrom);
  7531.   g := GetGValue(colorfrom);
  7532.   b := GetBValue(colorfrom);
  7533.   for i := r downto 0 do
  7534.   begin
  7535.     Surface.Fill(RGB(i, g, b));
  7536.     Flip;
  7537.   end;
  7538.   for i := g downto 0 do
  7539.   begin
  7540.     Surface.Fill(RGB(0, i, b));
  7541.     Flip;
  7542.   end;
  7543.   for i := g downto 0 do
  7544.   begin
  7545.     Surface.Fill(RGB(0, 0, i));
  7546.     Flip;
  7547.   end;
  7548.   Result := 0;
  7549. end;
  7550.  
  7551. function TCustomDXDraw.Fade2White(colorfrom: LongInt): LongInt;
  7552. var i, r, g, b: Integer;
  7553. begin
  7554.   r := GetRValue(colorfrom);
  7555.   g := GetGValue(colorfrom);
  7556.   b := GetBValue(colorfrom);
  7557.   for i := r to 255 do
  7558.   begin
  7559.     Surface.Fill(RGB(i, g, b));
  7560.     Flip;
  7561.   end;
  7562.   for i := g to 255 do
  7563.   begin
  7564.     Surface.Fill(RGB(255, i, b));
  7565.     Flip;
  7566.   end;
  7567.   for i := b to 255 do
  7568.   begin
  7569.     Surface.Fill(RGB(255, 255, i));
  7570.     Flip;
  7571.   end;
  7572.   Result := RGB(255, 255, 255);
  7573. end;
  7574.  
  7575. function TCustomDXDraw.Grey2Fade(shadefrom, shadeto: Integer): Integer;
  7576. var i: Integer;
  7577. begin
  7578.   if shadefrom < shadeto then
  7579.   begin
  7580.     for i := shadefrom to shadeto do
  7581.     begin
  7582.       Surface.Fill(RGB(i, i, i));
  7583.       Flip;
  7584.     end;
  7585.   end
  7586.   else
  7587.   begin
  7588.     for i := shadefrom downto shadeto do
  7589.     begin
  7590.       Surface.Fill(RGB(i, i, i));
  7591.       Flip;
  7592.     end;
  7593.   end;
  7594.   Result := shadeto;
  7595. end;
  7596.  
  7597. function TCustomDXDraw.FadeGrey2Screen(oldcolor, newcolour: LongInt): LongInt;
  7598. begin
  7599.   result := Grey2Fade(oldcolor, newcolour);
  7600. end;
  7601.  
  7602. function TCustomDXDraw.Fade2Screen(oldcolor, newcolour: LongInt): LongInt;
  7603. begin
  7604.   result := Fade2Color(oldcolor, newcolour);
  7605. end;
  7606.  
  7607. function TCustomDXDraw.White2Screen(oldcolor: Integer): LongInt;
  7608. begin
  7609.   result := Fade2Color(oldcolor, RGB(255, 255, 255));
  7610. end;
  7611.  
  7612. function TCustomDXDraw.Black2Screen(oldcolor: Integer): LongInt;
  7613. begin
  7614.   result := Fade2Color(oldcolor, RGB(0, 0, 0));
  7615. end;
  7616.  
  7617. procedure TCustomDXDraw.GrabImage(iX, iY, iWidth, iHeight: Integer; ddib: TDIB);
  7618. var ts, td: trect;
  7619. begin
  7620.   ddib.SetSize(iWidth, iHeight, 24);
  7621.   ts.left := iX;
  7622.   ts.top := iY;
  7623.   ts.right := iX + iWidth - 1;
  7624.   ts.bottom := iY + iHeight - 1;
  7625.   td.left := 0;
  7626.   td.top := 0;
  7627.   td.right := iWidth;
  7628.   td.bottom := iHeight;
  7629.   with Surface.Canvas do
  7630.   begin
  7631.     ddib.Canvas.CopyRect(td, Surface.Canvas, ts);
  7632.     Release;
  7633.   end;
  7634. end;
  7635.  
  7636. procedure TCustomDXDraw.PasteImage(sdib: TDIB; x, y: Integer);
  7637. var
  7638.   ts, td: trect;
  7639.   w, h: Integer;
  7640. begin
  7641.   w := sdib.width - 1;
  7642.   h := sdib.height - 1;
  7643.   ts.left := 0;
  7644.   ts.top := 0;
  7645.   ts.right := w;
  7646.   ts.bottom := h;
  7647.   td.left := x;
  7648.   td.top := y;
  7649.   td.right := x + w;
  7650.   td.bottom := y + h;
  7651.   with Surface.Canvas do
  7652.   begin
  7653.     CopyRect(td, sdib.Canvas, ts);
  7654.     release;
  7655.   end;
  7656. end;
  7657.  
  7658. // *****
  7659.  
  7660. procedure TCustomDXDraw.SetColorTable(const ColorTable: TRGBQuads);
  7661. var
  7662.   Entries: TPaletteEntries;
  7663. begin
  7664.   if Initialized and (Palette <> nil) then
  7665.   begin
  7666.     Entries := TDXDrawRGBQuadsToPaletteEntries(ColorTable,
  7667.       doAllowPalette256 in FNowOptions);
  7668.     Palette.SetEntries(0, 256, Entries);
  7669.   end;
  7670. end;
  7671.  
  7672. procedure TCustomDXDraw.SetCooperativeLevel;
  7673. var
  7674.   Flags: Integer;
  7675.   Control: TWinControl;
  7676. begin
  7677.   Control := FForm;
  7678.   if Control = nil then
  7679.     Control := Self;
  7680.  
  7681.   if doFullScreen in FNowOptions then
  7682.   begin
  7683.     Flags := DDSCL_FULLSCREEN or DDSCL_EXCLUSIVE or DDSCL_ALLOWMODEX{$IFDEF DXDOUBLEPRECISION} or DDSCL_FPUPRESERVE{$ENDIF};
  7684.     if doNoWindowChange in FNowOptions then
  7685.       Flags := Flags or DDSCL_NOWINDOWCHANGES;
  7686.     if doAllowReboot in FNowOptions then
  7687.       Flags := Flags or DDSCL_ALLOWREBOOT;
  7688.   end else
  7689.     Flags := DDSCL_NORMAL{$IFDEF DXDOUBLEPRECISION} or DDSCL_FPUPRESERVE{$ENDIF};
  7690.  
  7691.   DDraw.DXResult := DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.SetCooperativeLevel(Control.Handle, Flags);
  7692. end;
  7693.  
  7694. procedure TCustomDXDraw.SetDisplay(Value: TDXDrawDisplay);
  7695. begin
  7696.   FDisplay.Assign(Value);
  7697. end;
  7698.  
  7699. procedure TCustomDXDraw.SetDriver(Value: PGUID);
  7700. begin
  7701.   if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
  7702.   begin
  7703.     FDriverGUID := Value^;
  7704.     FDriver := @FDriverGUID;
  7705.   end else
  7706.     FDriver := Value;
  7707. end;
  7708.  
  7709. procedure TCustomDXDraw.SetOptions(Value: TDXDrawOptions);
  7710. const
  7711.   InitOptions = [doFullScreen, doNoWindowChange, doAllowReboot,
  7712.     doAllowPalette256, doSystemMemory, doFlip,
  7713.     {$IFDEF D3D_deprecated}doDirectX7Mode, do3D,{$ENDIF}{$IFDEF D3DRM} doRetainedMode, {$ENDIF}
  7714.     doHardware, doSelectDriver, doZBuffer];
  7715. var
  7716.   OldOptions: TDXDrawOptions;
  7717. begin
  7718.   FOptions := Value;
  7719.  
  7720.   if Initialized then
  7721.   begin
  7722.     OldOptions := FNowOptions;
  7723.     FNowOptions := FNowOptions * InitOptions + (FOptions - InitOptions);
  7724.     {$IFDEF D3D_deprecated}
  7725.     if not (do3D in FNowOptions) then
  7726.       FNowOptions := FNowOptions - [doHardware, {$IFDEF D3DRM}doRetainedMode,{$ENDIF} doSelectDriver, doZBuffer];
  7727.     {$ENDIF}
  7728.   end else
  7729.   begin
  7730.     FNowOptions := FOptions;
  7731.  
  7732.     if not (doFullScreen in FNowOptions) then
  7733.       FNowOptions := FNowOptions - [doNoWindowChange, doAllowReBoot, doAllowPalette256, doFlip];
  7734.     {$IFDEF D3D_deprecated}
  7735.     if not (do3D in FNowOptions) then
  7736.       FNowOptions := FNowOptions - [doDirectX7Mode, {$IFDEF D3DRM}doRetainedMode,{$ENDIF} doHardware, doSelectDriver, doZBuffer];
  7737.     {$ENDIF}
  7738.     if doSystemMemory in FNowOptions then
  7739.       FNowOptions := FNowOptions - [doFlip];
  7740.     {$IFDEF D3DRM}
  7741.     if doDirectX7Mode in FNowOptions then
  7742.       FNowOptions := FNowOptions - [doRetainedMode];
  7743.     {$ENDIF}
  7744.     FNowOptions := FNowOptions - [doHardware];
  7745.   end;
  7746. end;
  7747.  
  7748. procedure TCustomDXDraw.SetParent(AParent: TWinControl);
  7749. var
  7750.   Control: TWinControl;
  7751. begin
  7752.   inherited SetParent(AParent);
  7753.  
  7754.   FForm := nil;
  7755.   FSubClass.Free; FSubClass := nil;
  7756.  
  7757.   if not (csDesigning in ComponentState) then
  7758.   begin
  7759.     Control := Parent;
  7760.     while (Control <> nil) and (not (Control is TCustomForm)) do
  7761.       Control := Control.Parent;
  7762.     if Control <> nil then
  7763.     begin
  7764.       FForm := TCustomForm(Control);
  7765.       FSubClass := TControlSubClass.Create(Control, FormWndProc);
  7766.     end;
  7767.   end;
  7768. end;
  7769.  
  7770. procedure TCustomDXDraw.SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
  7771. begin
  7772.   if ((ASurfaceWidth <> SurfaceWidth) or (ASurfaceHeight <> SurfaceHeight)) and
  7773.     (not FUpdating) then
  7774.   begin
  7775.     if Initialized then
  7776.     begin
  7777.       try
  7778.         if not TDXDrawDriver(FDXDrawDriver).SetSize(ASurfaceWidth, ASurfaceHeight) then
  7779.           Exit;
  7780.       except
  7781.         Finalize;
  7782.         raise;
  7783.       end;
  7784.     end else
  7785.     begin
  7786.       FSurfaceWidth := ASurfaceWidth;
  7787.       FSurfaceHeight := ASurfaceHeight;
  7788.     end;
  7789.  
  7790.     NotifyEventList(dxntSetSurfaceSize);
  7791.   end;
  7792. end;
  7793.  
  7794. procedure TCustomDXDraw.SetSurfaceHeight(Value: Integer);
  7795. begin
  7796.   if ComponentState * [csReading, csLoading] = [] then
  7797.     SetSize(SurfaceWidth, Value)
  7798.   else
  7799.     FSurfaceHeight := Value;
  7800. end;
  7801.  
  7802. procedure TCustomDXDraw.SetSurfaceWidth(Value: Integer);
  7803. begin
  7804.   if ComponentState * [csReading, csLoading] = [] then
  7805.     SetSize(Value, SurfaceHeight)
  7806.   else
  7807.     FSurfaceWidth := Value;
  7808. end;
  7809.  
  7810. function TCustomDXDraw.TryRestore: Boolean;
  7811. begin
  7812.   Result := False;
  7813.  
  7814.   if Initialized and (not FUpdating) and (Primary.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) then
  7815.   begin
  7816.     if (Primary.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DDERR_SURFACELOST) or
  7817.       (Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DDERR_SURFACELOST) then
  7818.     begin
  7819.       if Assigned(FD2D) and Assigned(FD2D.FD2DTexture) then FD2D.FD2DTexture.D2DPruneAllTextures;//<-Add Mr.Kawasaki
  7820.       Restore;
  7821.       Result := (Primary.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DD_OK) and (Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DD_OK);
  7822.     end else
  7823.       Result := True;
  7824.   end;
  7825. end;
  7826.  
  7827. procedure TCustomDXDraw.SetTraces(const Value: TTraces);
  7828. begin
  7829.   FTraces.Assign(Value);
  7830. end;
  7831.  
  7832. procedure TCustomDXDraw.UpdatePalette;
  7833. begin
  7834.   if Initialized and (doWaitVBlank in FNowOptions) then
  7835.   begin
  7836.     if FDDraw.FDriverCaps.dwPalCaps and DDPCAPS_VSYNC = 0 then
  7837.       FDDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.WaitForVerticalBlank(DDWAITVB_BLOCKBEGIN, 0);
  7838.   end;
  7839.  
  7840.   SetColorTable(ColorTable);
  7841. end;
  7842.  
  7843. procedure TCustomDXDraw.WMCreate(var Message: TMessage);
  7844. begin
  7845.   inherited;
  7846.   if Initialized and (not FUpdating) then
  7847.   begin
  7848.     if Clipper <> nil then
  7849.       Clipper.Handle := Handle;
  7850.     SetCooperativeLevel;
  7851.   end;
  7852. end;
  7853.  
  7854. {$IFDEF DX3D_deprecated}
  7855.  
  7856. {  TCustomDX3D  }
  7857.  
  7858. constructor TCustomDX3D.Create(AOwner: TComponent);
  7859. begin
  7860.   inherited Create(AOwner);
  7861.   Options := [toHardware, toRetainedMode, toSelectDriver];
  7862.   FSurfaceWidth := 320;
  7863.   FSurfaceHeight := 240;
  7864. end;
  7865.  
  7866. destructor TCustomDX3D.Destroy;
  7867. begin
  7868.   DXDraw := nil;
  7869.   inherited Destroy;
  7870. end;
  7871.  
  7872. procedure TCustomDX3D.DoFinalize;
  7873. begin
  7874.   if Assigned(FOnFinalize) then FOnFinalize(Self);
  7875. end;
  7876.  
  7877. procedure TCustomDX3D.DoInitialize;
  7878. begin
  7879.   if Assigned(FOnInitialize) then FOnInitialize(Self);
  7880. end;
  7881.  
  7882. procedure TCustomDX3D.Finalize;
  7883. begin
  7884.   if FInitialized then
  7885.   begin
  7886.     try
  7887.       if FInitFlag then
  7888.       begin
  7889.         FInitFlag := False;
  7890.         DoFinalize;
  7891.       end;
  7892.     finally
  7893.       FInitialized := False;
  7894.  
  7895.       SetOptions(FOptions);
  7896.       {$IFDEF D3DRM}
  7897.       FViewport := nil;
  7898.       FCamera := nil;
  7899.       FScene := nil;
  7900.  
  7901.       FD3DRMDevice := nil;
  7902.       FD3DRMDevice2 := nil;
  7903.       FD3DRMDevice3 := nil;
  7904.       {$ENDIF}
  7905.       {$IFDEF D3D_deprecated}
  7906.       FD3DDevice := nil;
  7907.       FD3DDevice2 := nil;
  7908.       FD3DDevice3 := nil;
  7909.       {$ENDIF}
  7910.       FD3DDevice7 := nil;
  7911.       {$IFDEF D3D_deprecated}
  7912.       FD3D := nil;
  7913.       FD3D2 := nil;
  7914.       FD3D3 := nil;
  7915.       {$ENDIF}
  7916.       FD3D7 := nil;
  7917.  
  7918.       FreeZBufferSurface(FSurface, FZBuffer);
  7919.  
  7920.       FSurface.Free; FSurface := nil;
  7921.       {$IFDEF D3DRM}
  7922.       FD3DRM3 := nil;
  7923.       FD3DRM2 := nil;
  7924.       FD3DRM := nil;
  7925.       {$ENDIF}
  7926.     end;
  7927.   end;
  7928. end;
  7929.  
  7930. procedure TCustomDX3D.Initialize;
  7931. var
  7932.   ddsd: TDDSurfaceDesc;
  7933.   AOptions: TInitializeDirect3DOptions;
  7934. begin
  7935.   Finalize;
  7936.   try
  7937.     FInitialized := True;
  7938.  
  7939.     {  Make surface.  }
  7940.     FillChar(ddsd, SizeOf(ddsd), 0);
  7941.     ddsd.dwSize := SizeOf(ddsd);
  7942.     ddsd.dwFlags := DDSD_WIDTH or DDSD_HEIGHT or DDSD_CAPS;
  7943.     ddsd.dwWidth := Max(FSurfaceWidth, 1);
  7944.     ddsd.dwHeight := Max(FSurfaceHeight, 1);
  7945.     ddsd.ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN or DDSCAPS_3DDEVICE;
  7946.     if toSystemMemory in FNowOptions then
  7947.       ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY
  7948.     else
  7949.       ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_VIDEOMEMORY;
  7950.  
  7951.     FSurface := TDirectDrawSurface.Create(FDXDraw.DDraw);
  7952.     if not FSurface.CreateSurface(ddsd) then
  7953.     begin
  7954.       ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps and (not DDSCAPS_VIDEOMEMORY) or DDSCAPS_SYSTEMMEMORY;
  7955.       if not FSurface.CreateSurface(ddsd) then
  7956.         raise EDX3DError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
  7957.     end;
  7958.  
  7959.     AOptions := [];
  7960.  
  7961.     if toHardware in FNowOptions then AOptions := AOptions + [idoHardware];
  7962.     if toRetainedMode in FNowOptions then AOptions := AOptions + [idoRetainedMode];
  7963.     if toSelectDriver in FNowOptions then AOptions := AOptions + [idoSelectDriver];
  7964.     if toZBuffer in FNowOptions then AOptions := AOptions + [idoZBuffer];
  7965.  
  7966.     if doDirectX7Mode in FDXDraw.NowOptions then
  7967.     begin
  7968.       InitializeDirect3D7(FSurface, FZBuffer, FD3D7, FD3DDevice7, AOptions);
  7969.     end else
  7970.     begin
  7971.       InitializeDirect3D(FSurface, FZBuffer, FD3D, FD3D2, FD3D3, FD3DDevice, FD3DDevice2, FD3DDevice3,
  7972. {$IFDEF D3DRM}FD3DRM, FD3DRM2, FD3DRM3, FD3DRMDevice, FD3DRMDevice2, FD3DRMDevice3, FViewport, FScene, FCamera, {$ENDIF}
  7973.         AOptions);
  7974.     end;
  7975.  
  7976.     FNowOptions := [];
  7977.  
  7978.     if idoHardware in AOptions then FNowOptions := FNowOptions + [toHardware];
  7979.     if idoRetainedMode in AOptions then FNowOptions := FNowOptions + [toRetainedMode];
  7980.     if idoSelectDriver in AOptions then FNowOptions := FNowOptions + [toSelectDriver];
  7981.     if idoZBuffer in AOptions then FNowOptions := FNowOptions + [toZBuffer];
  7982.   except
  7983.     Finalize;
  7984.     raise;
  7985.   end;
  7986.  
  7987.   FInitFlag := True; DoInitialize;
  7988. end;
  7989.  
  7990. procedure TCustomDX3D.Render;
  7991. begin
  7992. {$IFDEF D3DRM}
  7993.   if FInitialized and (toRetainedMode in FNowOptions) then
  7994.   begin
  7995.     asm FInit end;
  7996.     FViewport.Clear;
  7997.     FViewport.Render(FScene);
  7998.     FD3DRMDevice.Update;
  7999.     asm FInit end;
  8000.   end;
  8001. {$ENDIF}
  8002. end;
  8003.  
  8004. function TCustomDX3D.GetCanDraw: Boolean;
  8005. begin
  8006.   Result := Initialized and (Surface.IDDSurface <> nil) and
  8007.     (Surface.ISurface.IsLost = DD_OK);
  8008. end;
  8009.  
  8010. function TCustomDX3D.GetSurfaceHeight: Integer;
  8011. begin
  8012.   if FSurface.IDDSurface <> nil then
  8013.     Result := FSurface.Height
  8014.   else
  8015.     Result := FSurfaceHeight;
  8016. end;
  8017.  
  8018. function TCustomDX3D.GetSurfaceWidth: Integer;
  8019. begin
  8020.   if FSurface.IDDSurface <> nil then
  8021.     Result := FSurface.Width
  8022.   else
  8023.     Result := FSurfaceWidth;
  8024. end;
  8025.  
  8026. procedure TCustomDX3D.SetAutoSize(Value: Boolean);
  8027. begin
  8028.   if FAutoSize <> Value then
  8029.   begin
  8030.     FAutoSize := Value;
  8031.     if FAutoSize and (DXDraw <> nil) then
  8032.       SetSize(DXDraw.SurfaceWidth, DXDraw.SurfaceHeight);
  8033.   end;
  8034. end;
  8035.  
  8036. procedure TCustomDX3D.SetOptions(Value: TDX3DOptions);
  8037. const
  8038.   DX3DOptions = [toRetainedMode, toSystemMemory, toHardware, toSelectDriver, toZBuffer];
  8039.   InitOptions = [toSystemMemory, toHardware, toSelectDriver, toZBuffer];
  8040. var
  8041.   OldOptions: TDX3DOptions;
  8042. begin
  8043.   FOptions := Value;
  8044.  
  8045.   if Initialized then
  8046.   begin
  8047.     OldOptions := FNowOptions;
  8048.     FNowOptions := FNowOptions * InitOptions + FOptions * (DX3DOptions - InitOptions);
  8049.   end else
  8050.   begin
  8051.     FNowOptions := FOptions;
  8052.  
  8053.     if (FDXDraw <> nil) and (doDirectX7Mode in FDXDraw.FNowOptions) then
  8054.       FNowOptions := FNowOptions - [toRetainedMode];
  8055.   end;
  8056. end;
  8057.  
  8058. procedure TCustomDX3D.SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
  8059. begin
  8060.   if (ASurfaceWidth <> SurfaceWidth) or (ASurfaceHeight <> SurfaceHeight) then
  8061.   begin
  8062.     FSurfaceWidth := ASurfaceWidth;
  8063.     FSurfaceHeight := ASurfaceHeight;
  8064.  
  8065.     if Initialized then
  8066.       Initialize;
  8067.   end;
  8068. end;
  8069.  
  8070. procedure TCustomDX3D.SetSurfaceHeight(Value: Integer);
  8071. begin
  8072.   if ComponentState * [csReading, csLoading] = [] then
  8073.     SetSize(SurfaceWidth, Value)
  8074.   else
  8075.     FSurfaceHeight := Value;
  8076. end;
  8077.  
  8078. procedure TCustomDX3D.SetSurfaceWidth(Value: Integer);
  8079. begin
  8080.   if ComponentState * [csReading, csLoading] = [] then
  8081.     SetSize(Value, SurfaceHeight)
  8082.   else
  8083.     FSurfaceWidth := Value;
  8084. end;
  8085.  
  8086. procedure TCustomDX3D.Notification(AComponent: TComponent;
  8087.   Operation: TOperation);
  8088. begin
  8089.   inherited Notification(AComponent, Operation);
  8090.   if (Operation = opRemove) and (FDXDraw = AComponent) then
  8091.     DXDraw := nil;
  8092. end;
  8093.  
  8094. procedure TCustomDX3D.DXDrawNotifyEvent(Sender: TCustomDXDraw;
  8095.   NotifyType: TDXDrawNotifyType);
  8096. var
  8097.   AOptions: TInitializeDirect3DOptions;
  8098. begin
  8099.   case NotifyType of
  8100.     dxntDestroying:
  8101.       begin
  8102.         DXDraw := nil;
  8103.       end;
  8104.     dxntInitializing:
  8105.       begin
  8106.         if (FDXDraw.FOptions * [do3D, doFullScreen] = [doFullScreen])
  8107.           and (FOptions * [toSystemMemory, toSelectDriver] = [toSelectDriver]) then
  8108.         begin
  8109.           AOptions := [];
  8110.           with FDXDraw do
  8111.           begin
  8112.             if doHardware in Options then AOptions := AOptions + [idoHardware];
  8113.             if doRetainedMode in Options then AOptions := AOptions + [idoRetainedMode];
  8114.             if doSelectDriver in Options then AOptions := AOptions + [idoSelectDriver];
  8115.             if doZBuffer in Options then AOptions := AOptions + [idoZBuffer];
  8116.           end;
  8117.  
  8118.           Direct3DInitializing_DXDraw(AOptions, FDXDraw);
  8119.         end;
  8120.       end;
  8121.     dxntInitialize:
  8122.       begin
  8123.         Initialize;
  8124.       end;
  8125.     dxntFinalize:
  8126.       begin
  8127.         Finalize;
  8128.       end;
  8129.     dxntRestore:
  8130.       begin
  8131.         FSurface.Restore;
  8132.         if FZBuffer <> nil then
  8133.           FZBuffer.Restore;
  8134.         FSurface.Palette := FDXDraw.Palette;
  8135.       end;
  8136.     dxntSetSurfaceSize:
  8137.       begin
  8138.         if AutoSize then
  8139.           SetSize(Sender.SurfaceWidth, Sender.SurfaceHeight);
  8140.       end;
  8141.   end;
  8142. end;
  8143.  
  8144. procedure TCustomDX3D.SetDXDraw(Value: TCustomDXDraw);
  8145. begin
  8146.   if FDXDraw <> Value then
  8147.   begin
  8148.     if FDXDraw <> nil then
  8149.       FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
  8150.  
  8151.     FDXDraw := Value;
  8152.  
  8153.     if FDXDraw <> nil then
  8154.       FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
  8155.   end;
  8156. end;
  8157.  
  8158. {$ENDIF}
  8159.  
  8160. {  TDirect3DTexture  }
  8161.  
  8162. constructor TDirect3DTexture.Create(Graphic: TGraphic; DXDraw: TComponent);
  8163. var
  8164.   i: Integer;
  8165. begin
  8166.   inherited Create;
  8167.   FDXDraw := DXDraw;
  8168.   FGraphic := Graphic;
  8169.  
  8170.   {  The palette is acquired.  }
  8171.   i := GetPaletteEntries(FGraphic.Palette, 0, 256, FPaletteEntries);
  8172.   case i of
  8173.     1..2: FBitCount := 1;
  8174.     3..16: FBitCount := 4;
  8175.     17..256: FBitCount := 8;
  8176.   else
  8177.     FBitCount := 24;
  8178.   end;
  8179.  
  8180.   if FDXDraw is TCustomDXDraw then
  8181.   begin
  8182.     with (FDXDraw as TCustomDXDraw) do
  8183.     begin
  8184.       if (not Initialized) {$IFDEF D3D_deprecated}or (not (do3D in NowOptions)){$ENDIF} then
  8185.         raise EDirect3DTextureError.CreateFmt(SNotMade, [FDXDraw.ClassName]);
  8186.     end;
  8187.     FSurface := TDirectDrawSurface.Create((FDXDraw as TCustomDXDraw).Surface.DDraw);
  8188.     (FDXDraw as TCustomDXDraw).RegisterNotifyEvent(DXDrawNotifyEvent);
  8189.   end
  8190.   else
  8191. {$IFDEF DX3D_deprecated}
  8192.     if FDXDraw is TCustomDX3D then
  8193.     begin
  8194.       with (FDXDraw as TDX3D) do
  8195.       begin
  8196.         if not Initialized then
  8197.           raise EDirect3DTextureError.CreateFmt(SNotMade, [FDXDraw.ClassName]);
  8198.       end;
  8199.  
  8200.       FSurface := TDirectDrawSurface.Create((FDXDraw as TCustomDX3D).Surface.DDraw);
  8201.       (FDXDraw as TCustomDX3D).FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
  8202.     end else
  8203. {$ENDIF}
  8204.       raise EDirect3DTextureError.CreateFmt(SNotSupported, [FDXDraw.ClassName]);
  8205. end;
  8206.  
  8207. destructor TDirect3DTexture.Destroy;
  8208. begin
  8209.   if FDXDraw is TCustomDXDraw then
  8210.   begin
  8211.     (FDXDraw as TCustomDXDraw).UnRegisterNotifyEvent(DXDrawNotifyEvent);
  8212.   end
  8213. {$IFDEF DX3D_deprecated}
  8214.   else if FDXDraw is TCustomDX3D then
  8215.   begin
  8216.     (FDXDraw as TCustomDX3D).FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
  8217.   end
  8218. {$ENDIF};
  8219.   Clear;
  8220.   FSurface.Free;
  8221.   inherited Destroy;
  8222. end;
  8223.  
  8224. procedure TDirect3DTexture.Clear;
  8225. begin
  8226.   FHandle := 0;
  8227.   FTexture := nil;
  8228.   FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil;
  8229. end;
  8230.  
  8231. function TDirect3DTexture.GetHandle: TD3DTextureHandle;
  8232. begin
  8233.   if FTexture = nil then
  8234.     Restore;
  8235.   Result := FHandle;
  8236. end;
  8237.  
  8238. function TDirect3DTexture.GetSurface: TDirectDrawSurface;
  8239. begin
  8240.   if FTexture = nil then
  8241.     Restore;
  8242.   Result := FSurface;
  8243. end;
  8244.  
  8245. function TDirect3DTexture.GetTexture: {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF};
  8246. begin
  8247.   if FTexture = nil then
  8248.     Restore;
  8249.   Result := FTexture;
  8250. end;
  8251.  
  8252. procedure TDirect3DTexture.SetTransparentColor(Value: TColor);
  8253. begin
  8254.   if FTransparentColor <> Value then
  8255.   begin
  8256.     FTransparentColor := Value;
  8257.  
  8258.     if FSurface <> nil then
  8259.       FSurface.TransparentColor := FSurface.ColorMatch(Value);
  8260.   end;
  8261. end;
  8262.  
  8263. procedure TDirect3DTexture.Restore;
  8264.  
  8265.   function EnumTextureFormatCallback(const ddsd: TDDSurfaceDesc;
  8266.     lParam: Pointer): HRESULT; stdcall;
  8267.   var
  8268.     tex: TDirect3DTexture;
  8269.  
  8270.     procedure UseThisFormat;
  8271.     begin
  8272.       tex.FFormat := ddsd;
  8273.       tex.FEnumFormatFlag := True;
  8274.     end;
  8275.  
  8276.   begin
  8277.     Result := DDENUMRET_OK;
  8278.     tex := lParam;
  8279.  
  8280.     if ddsd.ddpfPixelFormat.dwFlags and (DDPF_ALPHA or DDPF_ALPHAPIXELS) <> 0 then
  8281.       Exit;
  8282.  
  8283.     if not tex.FEnumFormatFlag then
  8284.     begin
  8285.       {  When called first,  this format is unconditionally selected.  }
  8286.       UseThisFormat;
  8287.     end else
  8288.     begin
  8289.       if (tex.FBitCount <= 8) and (ddsd.ddpfPixelFormat.dwRGBBitCount >= tex.FBitCount) and
  8290.         (ddsd.ddpfPixelFormat.dwRGBBitCount >= 8) and
  8291.         (ddsd.ddpfPixelFormat.dwFlags and DDPF_RGB <> 0) then
  8292.       begin
  8293.         if tex.FFormat.ddpfPixelFormat.dwRGBBitCount > ddsd.ddpfPixelFormat.dwRGBBitCount then
  8294.           UseThisFormat;
  8295.       end else
  8296.       begin
  8297.         if (tex.FFormat.ddpfPixelFormat.dwRGBBitCount > ddsd.ddpfPixelFormat.dwRGBBitCount) and
  8298.           (ddsd.ddpfPixelFormat.dwRGBBitCount > 8) and
  8299.           (ddsd.ddpfPixelFormat.dwFlags and DDPF_RGB <> 0) then
  8300.           UseThisFormat;
  8301.       end;
  8302.     end;
  8303.   end;
  8304.  
  8305.   function GetBitCount(i: Integer): Integer;
  8306.   var
  8307.     j: Integer;
  8308.   begin
  8309.     for j := 32 downto 1 do
  8310.       if (1 shl j) and i <> 0 then
  8311.       begin
  8312.         Result := j;
  8313.         if 1 shl j <> i then
  8314.           Dec(Result);
  8315.         Exit;
  8316.       end;
  8317.     Result := 0;
  8318.   end;
  8319.  
  8320.   function CreateHalftonePalette(R, G, B: Integer): TPaletteEntries;
  8321.   var
  8322.     i: Integer;
  8323.   begin
  8324.     for i := 0 to 255 do
  8325.       with Result[i] do
  8326.       begin
  8327.         peRed := ((i shr (G + B - 1)) and (1 shl R - 1)) * 255 div (1 shl R - 1);
  8328.         peGreen := ((i shr (B - 1)) and (1 shl G - 1)) * 255 div (1 shl G - 1);
  8329.         peBlue := ((i shr 0) and (1 shl B - 1)) * 255 div (1 shl B - 1);
  8330.         peFlags := 0;
  8331.       end;
  8332.   end;
  8333.  
  8334. var
  8335.   ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
  8336.   Palette: TDirectDrawPalette;
  8337.   PaletteCaps: Integer;
  8338.   TempSurface: TDirectDrawSurface;
  8339.   Width2, Height2: Integer;
  8340.   D3DDevice: {$IFDEF D3D_deprecated}IDirect3DDevice{$ELSE}IDirect3DDevice7{$ENDIF};
  8341.   Hardware: Boolean;
  8342.   DDraw: TDirectDraw;
  8343. begin
  8344.   Clear;
  8345.   try
  8346.     DDraw := nil;
  8347.     Hardware := False;
  8348.     if FDXDraw is TCustomDXDraw then
  8349.     begin
  8350.       DDraw := (FDXDraw as TCustomDXDraw).DDraw;
  8351.       D3DDevice := (FDXDraw as TCustomDXDraw).{$IFDEF D3D_deprecated}D3DDevice{$ELSE}D3DDevice7{$ENDIF};
  8352.       Hardware := doHardware in (FDXDraw as TCustomDXDraw).NowOptions;
  8353.     end
  8354.     {$IFDEF DX3D_deprecated}
  8355.     else if FDXDraw is TCustomDX3D then
  8356.     begin
  8357.       DDraw := (FDXDraw as TCustomDX3D).Surface.DDraw;
  8358.       D3DDevice := (FDXDraw as TCustomDX3D).D3DDevice;
  8359.       Hardware := toHardware in (FDXDraw as TCustomDX3D).NowOptions;
  8360.     end
  8361.     {$ENDIF};
  8362.  
  8363.     if (DDraw = nil) or (D3DDevice = nil) then Exit;
  8364.  
  8365.     {  The size of texture is arranged in the size of the square of two.  }
  8366.     Width2 := Max(1 shl GetBitCount(FGraphic.Width), 1);
  8367.     Height2 := Max(1 shl GetBitCount(FGraphic.Height), 1);
  8368.  
  8369.     {  Selection of format of texture.  }
  8370.     FEnumFormatFlag := False;
  8371.     D3DDevice.EnumTextureFormats(@EnumTextureFormatCallback, Self);
  8372.  
  8373.     TempSurface := TDirectDrawSurface.Create(FSurface.DDraw);
  8374.     try
  8375.       {  Make source surface.  }
  8376.       with ddsd do
  8377.       begin
  8378.         dwSize := SizeOf(ddsd);
  8379.         dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
  8380.         ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_SYSTEMMEMORY;
  8381.         dwWidth := Width2;
  8382.         dwHeight := Height2;
  8383.         ddpfPixelFormat := FFormat.ddpfPixelFormat;
  8384.       end;
  8385.  
  8386.       if not TempSurface.CreateSurface(ddsd) then
  8387.         raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
  8388.  
  8389.       {  Make surface.  }
  8390.       with ddsd do
  8391.       begin
  8392.         dwSize := SizeOf(ddsd);
  8393.         dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
  8394.         if Hardware then
  8395.           ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_VIDEOMEMORY
  8396.         else
  8397.           ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_SYSTEMMEMORY;
  8398.         ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_ALLOCONLOAD;
  8399.         dwWidth := Width2;
  8400.         dwHeight := Height2;
  8401.         ddpfPixelFormat := FFormat.ddpfPixelFormat;
  8402.       end;
  8403.  
  8404.       if not FSurface.CreateSurface(ddsd) then
  8405.         raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
  8406.  
  8407.       {  Make palette.  }
  8408.       if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8 <> 0 then
  8409.       begin
  8410.         PaletteCaps := DDPCAPS_8BIT or DDPCAPS_ALLOW256;
  8411.         if FBitCount = 24 then
  8412.           CreateHalftonePalette(3, 3, 2);
  8413.       end else if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4 <> 0 then
  8414.       begin
  8415.         PaletteCaps := DDPCAPS_4BIT;
  8416.         if FBitCount = 24 then
  8417.           CreateHalftonePalette(1, 2, 1);
  8418.       end else if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1 <> 0 then
  8419.       begin
  8420.         PaletteCaps := DDPCAPS_1BIT;
  8421.         if FBitCount = 24 then
  8422.         begin
  8423.           FPaletteEntries[0] := RGBQuadToPaletteEntry(RGBQuad(0, 0, 0));
  8424.           FPaletteEntries[1] := RGBQuadToPaletteEntry(RGBQuad(255, 255, 255));
  8425.         end;
  8426.       end else
  8427.         PaletteCaps := 0;
  8428.  
  8429.       if PaletteCaps <> 0 then
  8430.       begin
  8431.         Palette := TDirectDrawPalette.Create(DDraw);
  8432.         try
  8433.           Palette.CreatePalette(PaletteCaps, FPaletteEntries);
  8434.           TempSurface.Palette := Palette;
  8435.           FSurface.Palette := Palette;
  8436.         finally
  8437.           Palette.Free;
  8438.         end;
  8439.       end;
  8440.  
  8441.       {  The image is loaded into source surface.  }
  8442.       with TempSurface.Canvas do
  8443.       begin
  8444.         StretchDraw(TempSurface.ClientRect, FGraphic);
  8445.         Release;
  8446.       end;
  8447.  
  8448.       {  Source surface is loaded into surface.  }
  8449.       FTexture := FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF} as {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF};
  8450.       FTexture.Load(TempSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF} as {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF});
  8451.     finally
  8452.       TempSurface.Free;
  8453.     end;
  8454.  
  8455.     if FTexture.GetHandle(D3DDevice as {$IFDEF D3D_deprecated}IDirect3DDevice{$ELSE}IDirect3DDevice2{$ENDIF}, FHandle) <> D3D_OK then
  8456.       raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
  8457.  
  8458.     FSurface.TransparentColor := FSurface.ColorMatch(FTransparentColor);
  8459.   except
  8460.     Clear;
  8461.     raise;
  8462.   end;
  8463. end;
  8464.  
  8465. procedure TDirect3DTexture.DXDrawNotifyEvent(Sender: TCustomDXDraw;
  8466.   NotifyType: TDXDrawNotifyType);
  8467. begin
  8468.   case NotifyType of
  8469.     dxntInitializeSurface:
  8470.       begin
  8471.         Restore;
  8472.       end;
  8473.     dxntRestore:
  8474.       begin
  8475.         Restore;
  8476.       end;
  8477.   end;
  8478. end;
  8479.  
  8480. {  TDirect3DTexture2  }
  8481.  
  8482. constructor TDirect3DTexture2.Create(ADXDraw: TCustomDXDraw; Graphic: TObject;
  8483.   AutoFreeGraphic: Boolean);
  8484. begin
  8485.   inherited Create;
  8486.   FSrcImage := Graphic;
  8487.   FAutoFreeGraphic := AutoFreeGraphic;
  8488.   FNeedLoadTexture := True;
  8489.  
  8490.   if FSrcImage is TDXTextureImage then
  8491.     FImage := TDXTextureImage(FSrcImage)
  8492.   else
  8493.   if FSrcImage is TDIB then
  8494.     SetDIB(TDIB(FSrcImage))
  8495.   else
  8496.   if FSrcImage is TGraphic then
  8497.   begin
  8498.     FSrcImage := TDIB.Create;
  8499.     try
  8500.       TDIB(FSrcImage).Assign(TGraphic(Graphic));
  8501.       SetDIB(TDIB(FSrcImage));
  8502.     finally
  8503.       if FAutoFreeGraphic then
  8504.         Graphic.Free;
  8505.       FAutoFreeGraphic := True;
  8506.     end;
  8507.   end
  8508.   else
  8509.     if FSrcImage is TPicture then
  8510.     begin
  8511.       FSrcImage := TDIB.Create;
  8512.       try
  8513.         TDIB(FSrcImage).Assign(TPicture(Graphic).Graphic);
  8514.         SetDIB(TDIB(FSrcImage));
  8515.       finally
  8516.         if FAutoFreeGraphic then
  8517.           Graphic.Free;
  8518.         FAutoFreeGraphic := True;
  8519.       end;
  8520.     end
  8521.     else
  8522.       raise Exception.CreateFmt(SCannotLoadGraphic, [Graphic.ClassName]);
  8523.  
  8524.   FMipmap := FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap] > 0;
  8525.  
  8526.   FTransparent := FImage.Transparent;
  8527.   case FImage.ImageType of
  8528.     DXTextureImageType_PaletteIndexedColor:
  8529.       begin
  8530.         FTransparentColor := PaletteIndex(dxtDecodeChannel(FImage.idx_index, FImage.TransparentColor));
  8531.       end;
  8532.     DXTextureImageType_RGBColor:
  8533.       begin
  8534.         FTransparentColor := RGB(dxtDecodeChannel(FImage.rgb_red, FImage.TransparentColor),
  8535.           dxtDecodeChannel(FImage.rgb_green, FImage.TransparentColor),
  8536.           dxtDecodeChannel(FImage.rgb_blue, FImage.TransparentColor));
  8537.       end;
  8538.   end;
  8539.  
  8540.   SetDXDraw(ADXDraw);
  8541. end;
  8542.  
  8543. constructor TDirect3DTexture2.CreateFromFile(ADXDraw: TCustomDXDraw; const FileName: string);
  8544. var
  8545.   Image: TObject;
  8546. begin
  8547.   Image := nil;
  8548.   try
  8549.     {  TDXTextureImage  }
  8550.     Image := TDXTextureImage.Create;
  8551.     try
  8552.       TDXTextureImage(Image).LoadFromFile(FileName);
  8553.     except
  8554.       Image.Free;
  8555.       Image := nil;
  8556.     end;
  8557.  
  8558.     {  TDIB  }
  8559.     if Image = nil then
  8560.     begin
  8561.       Image := TDIB.Create;
  8562.       try
  8563.         TDIB(Image).LoadFromFile(FileName);
  8564.       except
  8565.         Image.Free;
  8566.         Image := nil;
  8567.       end;
  8568.     end;
  8569.  
  8570.     {  TPicture  }
  8571.     if Image = nil then
  8572.     begin
  8573.       Image := TPicture.Create;
  8574.       try
  8575.         TPicture(Image).LoadFromFile(FileName);
  8576.       except
  8577.         Image.Free;
  8578.         Image := nil;
  8579.         raise;
  8580.       end;
  8581.     end;
  8582.   except
  8583.     Image.Free;
  8584.     raise;
  8585.   end;
  8586.  
  8587.   Create(ADXDraw, Image, True);
  8588. end;
  8589.  
  8590. constructor TDirect3DTexture2.CreateVideoTexture(ADXDraw: TCustomDXDraw);
  8591. begin
  8592.   inherited Create;
  8593.   SetDXDraw(ADXDraw);
  8594. end;
  8595.  
  8596. destructor TDirect3DTexture2.Destroy;
  8597. begin
  8598.   Finalize;
  8599.  
  8600.   SetDXDraw(nil);
  8601.  
  8602.   if FAutoFreeGraphic then
  8603.     FSrcImage.Free;
  8604.   FImage2.Free;
  8605.   inherited Destroy;
  8606. end;
  8607.  
  8608. procedure TDirect3DTexture2.DXDrawNotifyEvent(Sender: TCustomDXDraw;
  8609.   NotifyType: TDXDrawNotifyType);
  8610. begin
  8611.   case NotifyType of
  8612.     dxntDestroying:
  8613.       begin
  8614.         SetDXDraw(nil);
  8615.       end;
  8616.     dxntInitializeSurface:
  8617.       begin
  8618.         Initialize;
  8619.       end;
  8620.     dxntFinalizeSurface:
  8621.       begin
  8622.         Finalize;
  8623.       end;
  8624.     dxntRestore:
  8625.       begin
  8626.         Load;
  8627.       end;
  8628.   end;
  8629. end;
  8630.  
  8631. procedure TDirect3DTexture2.SetDXDraw(ADXDraw: TCustomDXDraw);
  8632. begin
  8633.   if FDXDraw <> ADXDraw then
  8634.   begin
  8635.     if FDXDraw <> nil then
  8636.       FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
  8637.  
  8638.     FDXDraw := ADXDraw;
  8639.  
  8640.     if FDXDraw <> nil then
  8641.       FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
  8642.   end;
  8643. end;
  8644.  
  8645. procedure TDirect3DTexture2.DoRestoreSurface;
  8646. begin
  8647.   if Assigned(FOnRestoreSurface) then
  8648.     FOnRestoreSurface(Self);
  8649. end;
  8650.  
  8651. procedure TDirect3DTexture2.SetDIB(DIB: TDIB);
  8652. var
  8653.   i: Integer;
  8654. begin
  8655.   if FImage2 = nil then
  8656.     FImage2 := TDXTextureImage.Create;
  8657.  
  8658.   if DIB.BitCount <= 8 then
  8659.   begin
  8660.     FImage2.SetImage(DXTextureImageType_PaletteIndexedColor, DIB.Width, DIB.Height, DIB.BitCount,
  8661.       DIB.WidthBytes, DIB.NextLine, DIB.PBits, DIB.TopPBits, DIB.Size, False);
  8662.  
  8663.     FImage2.idx_index := dxtMakeChannel((1 shl DIB.BitCount) - 1, True);
  8664.     for i := 0 to 255 do
  8665.       FImage2.idx_palette[i] := RGBQuadToPaletteEntry(DIB.ColorTable[i]);
  8666.   end else
  8667.   begin
  8668.     FImage2.SetImage(DXTextureImageType_RGBColor, DIB.Width, DIB.Height, DIB.BitCount,
  8669.       DIB.WidthBytes, DIB.NextLine, DIB.PBits, DIB.TopPBits, DIB.Size, False);
  8670.  
  8671.     FImage2.rgb_red := dxtMakeChannel(DIB.NowPixelFormat.RBitMask, False);
  8672.     FImage2.rgb_green := dxtMakeChannel(DIB.NowPixelFormat.GBitMask, False);
  8673.     FImage2.rgb_blue := dxtMakeChannel(DIB.NowPixelFormat.BBitMask, False);
  8674.  
  8675.     i := DIB.NowPixelFormat.RBitCount + DIB.NowPixelFormat.GBitCount + DIB.NowPixelFormat.BBitCount;
  8676.     if i < DIB.BitCount then
  8677.       FImage2.rgb_alpha := dxtMakeChannel(((1 shl (DIB.BitCount - i)) - 1) shl i, False);
  8678.   end;
  8679.  
  8680.   FImage := FImage2;
  8681. end;
  8682.  
  8683. function TDirect3DTexture2.GetHeight: Integer;
  8684. begin
  8685.   if Assigned(FImage) then
  8686.     Result := FImage.Height
  8687.   else
  8688.     if Assigned(FImage2) then
  8689.       Result := FImage2.Height
  8690.     else
  8691.       Result := 0;
  8692. end;
  8693.  
  8694. function TDirect3DTexture2.GetIsMipmap: Boolean;
  8695. begin
  8696.   if FSurface <> nil then
  8697.     Result := FUseMipmap
  8698.   else
  8699.     Result := FMipmap;
  8700. end;
  8701.  
  8702. function TDirect3DTexture2.GetSurface: TDirectDrawSurface;
  8703. begin
  8704.   Result := FSurface;
  8705.   if (Result <> nil) and FNeedLoadTexture then
  8706.     Load;
  8707. end;
  8708.  
  8709. function TDirect3DTexture2.GetTransparent: Boolean;
  8710. begin
  8711.   if FSurface <> nil then
  8712.     Result := FUseColorKey
  8713.   else
  8714.     Result := FTransparent;
  8715. end;
  8716.  
  8717. function TDirect3DTexture2.GetWidth: Integer;
  8718. begin
  8719.   if Assigned(FImage) then
  8720.     Result := FImage.Width
  8721.   else
  8722.     if Assigned(FImage2) then
  8723.       Result := FImage2.Width
  8724.     else
  8725.       Result := 0;
  8726. end;
  8727.  
  8728. procedure TDirect3DTexture2.SetTransparent(Value: Boolean);
  8729. begin
  8730.   if FTransparent <> Value then
  8731.   begin
  8732.     FTransparent := Value;
  8733.     if FSurface <> nil then
  8734.       SetColorKey;
  8735.   end;
  8736. end;
  8737.  
  8738. procedure TDirect3DTexture2.SetTransparentColor(Value: TColorRef);
  8739. begin
  8740.   if FTransparentColor <> Value then
  8741.   begin
  8742.     FTransparentColor := Value;
  8743.     if (FSurface <> nil) and FTransparent then
  8744.       SetColorKey;
  8745.   end;
  8746. end;
  8747.  
  8748. procedure TDirect3DTexture2.Finalize;
  8749. begin
  8750.   FSurface.Free; FSurface := nil;
  8751.  
  8752.   FUseColorKey := False;
  8753.   FUseMipmap := False;
  8754.   FNeedLoadTexture := False;
  8755. end;
  8756.  
  8757. const
  8758.   DDPF_PALETTEINDEXED = DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
  8759.     DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8;
  8760.  
  8761. procedure TDirect3DTexture2.Initialize;
  8762.  
  8763.   function GetBitCount(i: Integer): Integer;
  8764.   begin
  8765.     Result := 31;
  8766.     while (i >= 0) and (((1 shl Result) and i) = 0) do Dec(Result);
  8767.   end;
  8768.  
  8769.   function GetMaskBitCount(b: Integer): Integer;
  8770.   var
  8771.     i: Integer;
  8772.   begin
  8773.     i := 0;
  8774.     while (i < 31) and (((1 shl i) and b) = 0) do Inc(i);
  8775.  
  8776.     Result := 0;
  8777.     while ((1 shl i) and b) <> 0 do
  8778.     begin
  8779.       Inc(i);
  8780.       Inc(Result);
  8781.     end;
  8782.   end;
  8783.  
  8784.   function GetPaletteBitCount(const ddpfPixelFormat: TDDPixelFormat): Integer;
  8785.   begin
  8786.     if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8 <> 0 then
  8787.       Result := 8
  8788.     else if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4 <> 0 then
  8789.       Result := 4
  8790.     else if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED2 <> 0 then
  8791.       Result := 2
  8792.     else if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1 <> 0 then
  8793.       Result := 1
  8794.     else
  8795.       Result := 0;
  8796.   end;
  8797.  
  8798.   function EnumTextureFormatCallback(const lpDDPixFmt: TDDPixelFormat;
  8799.     lParam: Pointer): HRESULT; stdcall;
  8800.   var
  8801.     tex: TDirect3DTexture2;
  8802.  
  8803.     procedure UseThisFormat;
  8804.     begin
  8805.       tex.FTextureFormat.ddpfPixelFormat := lpDDPixFmt;
  8806.       tex.FEnumTextureFormatFlag := True;
  8807.     end;
  8808.  
  8809.   var
  8810.     rgb_red, rgb_green, rgb_blue, rgb_alpha, idx_index: Integer;
  8811.     sum1, sum2: Integer;
  8812.   begin
  8813.     Result := DDENUMRET_OK;
  8814.     tex := lParam;
  8815.  
  8816.     {  Form acquisition of source image  }
  8817.     rgb_red := 0;
  8818.     rgb_green := 0;
  8819.     rgb_blue := 0;
  8820.     rgb_alpha := 0;
  8821.     idx_index := 0;
  8822.  
  8823.     case tex.FImage.ImageType of
  8824.       DXTextureImageType_RGBColor:
  8825.         begin
  8826.           {  RGB Color  }
  8827.           rgb_red := tex.FImage.rgb_red.bitcount;
  8828.           rgb_green := tex.FImage.rgb_green.bitcount;
  8829.           rgb_blue := tex.FImage.rgb_blue.bitcount;
  8830.           rgb_alpha := tex.FImage.rgb_alpha.bitcount;
  8831.           idx_index := 8;
  8832.         end;
  8833.       DXTextureImageType_PaletteIndexedColor:
  8834.         begin
  8835.           {  Index Color  }
  8836.           rgb_red := 8;
  8837.           rgb_green := 8;
  8838.           rgb_blue := 8;
  8839.           rgb_alpha := tex.FImage.idx_alpha.bitcount;
  8840.           idx_index := tex.FImage.idx_index.bitcount;
  8841.         end;
  8842.     end;
  8843.  
  8844.     {  The texture examines whether this pixel format can be used.  }
  8845.     if lpDDPixFmt.dwFlags and DDPF_RGB = 0 then Exit;
  8846.  
  8847.     case tex.FImage.ImageType of
  8848.       DXTextureImageType_RGBColor:
  8849.         begin
  8850.           if lpDDPixFmt.dwFlags and DDPF_PALETTEINDEXED <> 0 then Exit;
  8851.         end;
  8852.       DXTextureImageType_PaletteIndexedColor:
  8853.         begin
  8854.           if (lpDDPixFmt.dwFlags and DDPF_PALETTEINDEXED <> 0) and
  8855.             (GetPaletteBitCount(lpDDPixFmt) < idx_index) then Exit;
  8856.         end;
  8857.     end;
  8858.  
  8859.     {  The pixel format which can be used is selected carefully.  }
  8860.     if tex.FEnumTextureFormatFlag then
  8861.     begin
  8862.       if lpDDPixFmt.dwFlags and DDPF_PALETTEINDEXED <> 0 then
  8863.       begin
  8864.         {  Bit count check  }
  8865.         if Abs(Integer(lpDDPixFmt.dwRGBBitCount) - idx_index) >
  8866.           Abs(Integer(tex.FTextureFormat.ddpfPixelFormat.dwRGBBitCount) - idx_index) then Exit;
  8867.  
  8868.         {  Alpha channel check  }
  8869.         if rgb_alpha > 0 then Exit;
  8870.       end else
  8871.         if lpDDPixFmt.dwFlags and DDPF_RGB <> 0 then
  8872.         begin
  8873.         {  The alpha channel is indispensable.  }
  8874.           if (rgb_alpha > 0) and (tex.FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_ALPHAPIXELS = 0) and
  8875.             (lpDDPixFmt.dwFlags and DDPF_ALPHAPIXELS <> 0) then
  8876.           begin
  8877.             UseThisFormat;
  8878.             Exit;
  8879.           end;
  8880.  
  8881.         {  Alpha channel check  }
  8882.           if (rgb_alpha > 0) and (tex.FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_ALPHAPIXELS <> 0) and
  8883.             (lpDDPixFmt.dwFlags and DDPF_ALPHAPIXELS = 0) then
  8884.           begin
  8885.             Exit;
  8886.           end;
  8887.  
  8888.         {  Bit count check  }
  8889.           if tex.FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED = 0 then
  8890.           begin
  8891.             sum1 := Sqr(GetMaskBitCount(lpDDPixFmt.dwRBitMask) - rgb_red) +
  8892.               Sqr(GetMaskBitCount(lpDDPixFmt.dwGBitMask) - rgb_green) +
  8893.               Sqr(GetMaskBitCount(lpDDPixFmt.dwBBitMask) - rgb_blue) +
  8894.               Sqr(GetMaskBitCount(lpDDPixFmt.dwRGBAlphaBitMask) - rgb_alpha);
  8895.  
  8896.             sum2 := Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwRBitMask) - rgb_red) +
  8897.               Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwGBitMask) - rgb_green) +
  8898.               Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwBBitMask) - rgb_blue) +
  8899.               Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwRGBAlphaBitMask) - rgb_alpha);
  8900.  
  8901.             if sum1 > sum2 then Exit;
  8902.           end;
  8903.         end;
  8904.     end;
  8905.  
  8906.     UseThisFormat;
  8907.   end;
  8908.  
  8909. var
  8910.   Width, Height: Integer;
  8911.   PaletteCaps: DWORD;
  8912.   Palette: IDirectDrawPalette;
  8913.   {$IFDEF D3D_deprecated}TempD3DDevDesc: TD3DDeviceDesc;{$ENDIF}
  8914.   D3DDevDesc7: TD3DDeviceDesc7;
  8915.   TempSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF};
  8916. begin
  8917.   Finalize;
  8918.   try
  8919.     if FDXDraw.D3DDevice7 <> nil then
  8920.     begin
  8921.       FDXDraw.D3DDevice7.GetCaps(D3DDevDesc7);
  8922.       FD3DDevDesc.dpcLineCaps.dwTextureCaps := D3DDevDesc7.dpcLineCaps.dwTextureCaps;
  8923.       FD3DDevDesc.dpcTriCaps.dwTextureCaps := D3DDevDesc7.dpcTriCaps.dwTextureCaps;
  8924.       FD3DDevDesc.dwMinTextureWidth := D3DDevDesc7.dwMinTextureWidth;
  8925.       FD3DDevDesc.dwMaxTextureWidth := D3DDevDesc7.dwMaxTextureWidth;
  8926.     end
  8927.     {$IFDEF D3D_deprecated}
  8928.     else
  8929.     begin
  8930.       FD3DDevDesc.dwSize := SizeOf(FD3DDevDesc);
  8931.       TempD3DDevDesc.dwSize := SizeOf(TempD3DDevDesc);
  8932.       FDXDraw.D3DDevice3.GetCaps(FD3DDevDesc, TempD3DDevDesc);
  8933.     end{$ENDIF};
  8934.  
  8935.     if FImage <> nil then
  8936.     begin
  8937.       {  Size adjustment of texture  }
  8938.       if FD3DDevDesc.dpcTriCaps.dwTextureCaps and D3DPTEXTURECAPS_POW2 <> 0 then
  8939.       begin
  8940.         {  The size of the texture is only Sqr(n).  }
  8941.         Width := Max(1 shl GetBitCount(FImage.Width), 1);
  8942.         Height := Max(1 shl GetBitCount(FImage.Height), 1);
  8943.       end
  8944.       else
  8945.       begin
  8946.         Width := FImage.Width;
  8947.         Height := FImage.Height;
  8948.       end;
  8949.  
  8950.       if FD3DDevDesc.dpcTriCaps.dwTextureCaps and D3DPTEXTURECAPS_SQUAREONLY <> 0 then
  8951.       begin
  8952.         {  The size of the texture is only a square.  }
  8953.         if Width < Height then Width := Height;
  8954.         Height := Width;
  8955.       end;
  8956.  
  8957.       if FD3DDevDesc.dwMinTextureWidth > 0 then
  8958.         Width := Max(Width, FD3DDevDesc.dwMinTextureWidth);
  8959.  
  8960.       if FD3DDevDesc.dwMaxTextureWidth > 0 then
  8961.         Width := Min(Width, FD3DDevDesc.dwMaxTextureWidth);
  8962.  
  8963.       if FD3DDevDesc.dwMinTextureHeight > 0 then
  8964.         Height := Max(Height, FD3DDevDesc.dwMinTextureHeight);
  8965.  
  8966.       if FD3DDevDesc.dwMaxTextureHeight > 0 then
  8967.         Height := Min(Height, FD3DDevDesc.dwMaxTextureHeight);
  8968.  
  8969.       {  Pixel format selection  }
  8970.       FEnumTextureFormatFlag := False;
  8971.       if FDXDraw.D3DDevice7 <> nil then
  8972.         FDXDraw.D3DDevice7.EnumTextureFormats(@EnumTextureFormatCallback, Self)
  8973.       {$IFDEF D3D_deprecated}else
  8974.         FDXDraw.D3DDevice3.EnumTextureFormats(@EnumTextureFormatCallback, Self){$ENDIF};
  8975.  
  8976.       if not FEnumTextureFormatFlag then
  8977.         raise EDirect3DTextureError.CreateFmt(SCannotInitialized, [STexture]);
  8978.  
  8979.       {  Is Mipmap surface used ?  }
  8980.       FUseMipmap := FMipmap and (FTextureFormat.ddpfPixelFormat.dwRGBBitCount > 8) and
  8981.         (FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap] > 0) and (FDXDraw.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_MIPMAP <> 0);
  8982.  
  8983.       {  Surface form setting  }
  8984.       with FTextureFormat do
  8985.       begin
  8986.         dwSize := SizeOf(FTextureFormat);
  8987.         dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
  8988.         ddsCaps.dwCaps := DDSCAPS_TEXTURE;
  8989.         ddsCaps.dwCaps2 := 0;
  8990.         dwWidth := Width;
  8991.         dwHeight := Height;
  8992.  
  8993.         if doHardware in FDXDraw.NowOptions then
  8994.           ddsCaps.dwCaps2 := ddsCaps.dwCaps2 or DDSCAPS2_TEXTUREMANAGE
  8995.         else
  8996.           ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
  8997.  
  8998.         if FUseMipmap then
  8999.         begin
  9000.           dwFlags := dwFlags or DDSD_MIPMAPCOUNT;
  9001.           ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_MIPMAP or DDSCAPS_COMPLEX;
  9002.           dwMipMapCount := FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap];
  9003.         end;
  9004.       end;
  9005.     end;
  9006.  
  9007.     FSurface := TDirectDrawSurface.Create(FDXDraw.DDraw);
  9008.     FSurface.DDraw.DXResult := FSurface.DDraw.{$IFDEF D3D_deprecated}IDraw4{$ELSE}IDraw7{$ENDIF}.CreateSurface(FTextureFormat, TempSurface, nil);
  9009.     if FSurface.DDraw.DXResult <> DD_OK then
  9010.       raise EDirect3DTextureError.CreateFmt(SCannotInitialized, [STexture]);
  9011.     FSurface.{$IFDEF D3D_deprecated}IDDSurface4{$ELSE}IDDSurface7{$ENDIF} := TempSurface;
  9012.  
  9013.     {  Palette making  }
  9014.     if (FImage <> nil) and (FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED <> 0) then
  9015.     begin
  9016.       if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8 <> 0 then
  9017.         PaletteCaps := DDPCAPS_8BIT or DDPCAPS_ALLOW256
  9018.       else
  9019.       if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4 <> 0 then
  9020.         PaletteCaps := DDPCAPS_4BIT
  9021.       else
  9022.       if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED2 <> 0 then
  9023.         PaletteCaps := DDPCAPS_2BIT
  9024.       else
  9025.       if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1 <> 0 then
  9026.         PaletteCaps := DDPCAPS_1BIT
  9027.       else
  9028.         PaletteCaps := 0;
  9029.  
  9030.       if PaletteCaps <> 0 then
  9031.       begin
  9032.         if FDXDraw.DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.CreatePalette(PaletteCaps, @FImage.idx_palette, Palette, nil) <> 0 then
  9033.           Exit;
  9034.  
  9035.         FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetPalette(Palette);
  9036.       end;
  9037.     end;
  9038.  
  9039.     FNeedLoadTexture := True;
  9040.   except
  9041.     Finalize;
  9042.     raise;
  9043.   end;
  9044. end;
  9045.  
  9046. procedure TDirect3DTexture2.Load;
  9047. const
  9048.   MipmapCaps: TDDSCaps2 = (dwCaps: DDSCAPS_TEXTURE or DDSCAPS_MIPMAP);
  9049. var
  9050.   CurSurface, NextSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF};
  9051.   Index: Integer;
  9052.   SrcImage: TDXTextureImage;
  9053. begin
  9054.   if FSurface = nil then
  9055.     Initialize;
  9056.  
  9057.   FNeedLoadTexture := False;
  9058.   if FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DDERR_SURFACELOST then
  9059.     FSurface.Restore;
  9060.  
  9061.   {  Color key setting.  }
  9062.   SetColorKey;
  9063.  
  9064.   {  Image loading into surface.  }
  9065.   if FImage <> nil then
  9066.   begin
  9067.     if FSrcImage is TDIB then
  9068.       SetDIB(TDIB(FSrcImage));
  9069.  
  9070.     CurSurface := FSurface.{$IFDEF D3D_deprecated}ISurface4{$ELSE}ISurface7{$ENDIF};
  9071.     Index := 0;
  9072.     while CurSurface <> nil do
  9073.     begin
  9074.       SrcImage := FImage;
  9075.       if Index > 0 then
  9076.       begin
  9077.         if Index - 1 >= FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap] then
  9078.           Break;
  9079.         SrcImage := FImage.SubGroupImages[DXTextureImageGroupType_Mipmap, Index - 1];
  9080.       end;
  9081.  
  9082.       LoadSubTexture(CurSurface, SrcImage);
  9083.  
  9084.       if CurSurface.GetAttachedSurface(MipmapCaps, NextSurface) = 0 then
  9085.         CurSurface := NextSurface
  9086.       else
  9087.         CurSurface := nil;
  9088.  
  9089.       Inc(Index);
  9090.     end;
  9091.   end
  9092.   else
  9093.     DoRestoreSurface;
  9094. end;
  9095.  
  9096. procedure TDirect3DTexture2.SetColorKey;
  9097. var
  9098.   ck: TDDColorKey;
  9099. begin
  9100.   FUseColorKey := False;
  9101.  
  9102.   if (FSurface <> nil) and FTransparent and (FD3DDevDesc.dpcTriCaps.dwTextureCaps and D3DPTEXTURECAPS_TRANSPARENCY <> 0) then
  9103.   begin
  9104.     FillChar(ck, SizeOf(ck), 0);
  9105.     if FSurface.SurfaceDesc.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED <> 0 then
  9106.     begin
  9107.       if FTransparentColor shr 24 = $01 then
  9108.       begin
  9109.         {  Palette index  }
  9110.         ck.dwColorSpaceLowValue := FTransparentColor and $FF;
  9111.       end
  9112.       else
  9113.         if FImage <> nil then
  9114.         begin
  9115.         {  RGB value  }
  9116.           ck.dwColorSpaceLowValue := FImage.PaletteIndex(GetRValue(FTransparentColor), GetGValue(FTransparentColor), GetBValue(FTransparentColor));
  9117.         end else
  9118.           Exit;
  9119.     end
  9120.     else
  9121.     begin
  9122.       if (FImage <> nil) and (FImage.ImageType = DXTextureImageType_PaletteIndexedColor) and (FTransparentColor shr 24 = $01) then
  9123.       begin
  9124.         {  Palette index  }
  9125.         ck.dwColorSpaceLowValue :=
  9126.           dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwRBitMask, False), FImage.idx_palette[FTransparentColor and $FF].peRed) or
  9127.           dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwGBitMask, False), FImage.idx_palette[FTransparentColor and $FF].peGreen) or
  9128.           dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwBBitMask, False), FImage.idx_palette[FTransparentColor and $FF].peBlue);
  9129.       end
  9130.       else
  9131.         if FTransparentColor shr 24 = $00 then
  9132.         begin
  9133.         {  RGB value  }
  9134.           ck.dwColorSpaceLowValue :=
  9135.             dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwRBitMask, False), GetRValue(FTransparentColor)) or
  9136.             dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwGBitMask, False), GetGValue(FTransparentColor)) or
  9137.             dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwBBitMask, False), GetBValue(FTransparentColor));
  9138.         end
  9139.         else
  9140.           Exit;
  9141.     end;
  9142.  
  9143.     ck.dwColorSpaceHighValue := ck.dwColorSpaceLowValue;
  9144.     FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetColorKey(DDCKEY_SRCBLT, @ck);
  9145.  
  9146.     FUseColorKey := True;
  9147.   end;
  9148. end;
  9149.  
  9150. procedure TDirect3DTexture2.LoadSubTexture(Dest: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF}; SrcImage: TDXTextureImage);
  9151. const
  9152.   Mask1: array[0..7] of DWORD = (1, 2, 4, 8, 16, 32, 64, 128);
  9153.   Mask2: array[0..3] of DWORD = (3, 12, 48, 192);
  9154.   Mask4: array[0..1] of DWORD = ($0F, $F0);
  9155.   Shift1: array[0..7] of DWORD = (0, 1, 2, 3, 4, 5, 6, 7);
  9156.   Shift2: array[0..3] of DWORD = (0, 2, 4, 6);
  9157.   Shift4: array[0..1] of DWORD = (0, 4);
  9158.  
  9159.   procedure SetPixel(const ddsd: TDDSurfaceDesc2; x, y: Integer; c: DWORD);
  9160.   begin
  9161.     case ddsd.ddpfPixelFormat.dwRGBBitCount of
  9162.       1: PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 8)^ :=
  9163.         (PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 8)^ and (not Mask1[x mod 8])) or (c shl Shift1[x mod 8]);
  9164.       2: PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 4)^ :=
  9165.         (PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 4)^ and (not Mask2[x mod 4])) or (c shl Shift2[x mod 4]);
  9166.       4: PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 2)^ :=
  9167.         (PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 2)^ and (not Mask4[x mod 2])) or (c shl Shift4[x mod 2]);
  9168.       8: PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x)^ := c;
  9169.       16: PWord(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 2)^ := c;
  9170.       24: begin
  9171.           PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 3)^ := c shr 0;
  9172.           PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 3 + 1)^ := c shr 8;
  9173.           PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 3 + 2)^ := c shr 16;
  9174.         end;
  9175.       32: PDWORD(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 4)^ := c;
  9176.     end;
  9177.   end;
  9178.  
  9179.   procedure LoadTexture_IndexToIndex;
  9180.   var
  9181.     ddsd: TDDSurfaceDesc2;
  9182.     x, y: Integer;
  9183.   begin
  9184.     ddsd.dwSize := SizeOf(ddsd);
  9185.     if Dest.Lock(nil, ddsd, DDLOCK_WAIT, 0) = 0 then
  9186.     begin
  9187.       try
  9188.         if (SrcImage.idx_index.Mask = DWORD(1 shl ddsd.ddpfPixelFormat.dwRGBBitCount) - 1) and
  9189.           (SrcImage.idx_alpha.Mask = 0) and
  9190.           (SrcImage.BitCount = Integer(ddsd.ddpfPixelFormat.dwRGBBitCount)) and
  9191.           (not SrcImage.PackedPixelOrder)
  9192.         then
  9193.         begin
  9194.           for y := 0 to ddsd.dwHeight - 1 do
  9195.             Move(SrcImage.ScanLine[y]^, Pointer(Integer(ddsd.lpSurface) + ddsd.lPitch * y)^, (Integer(ddsd.dwWidth) * SrcImage.BitCount + 7) div 8);
  9196.         end
  9197.         else
  9198.         begin
  9199.           for y := 0 to ddsd.dwHeight - 1 do
  9200.           begin
  9201.             for x := 0 to ddsd.dwWidth - 1 do
  9202.               SetPixel(ddsd, x, y, dxtDecodeChannel(SrcImage.idx_index, SrcImage.Pixels[x, y]));
  9203.           end;
  9204.         end;
  9205.       finally
  9206.         Dest.UnLock(ddsd.lpSurface);
  9207.       end;
  9208.     end;
  9209.   end;
  9210.  
  9211.   procedure LoadTexture_IndexToRGB;
  9212.   var
  9213.     ddsd: TDDSurfaceDesc2;
  9214.     x, y: Integer;
  9215.     c, cIdx, cA: DWORD;
  9216.     dest_red_fmt, dest_green_fmt, dest_blue_fmt, dest_alpha_fmt: TDXTextureImageChannel;
  9217.   begin
  9218.     ddsd.dwSize := SizeOf(ddsd);
  9219.     if Dest.Lock(nil, ddsd, DDLOCK_WAIT, 0) = 0 then
  9220.     begin
  9221.       try
  9222.         dest_red_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRBitMask, False);
  9223.         dest_green_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwGBitMask, False);
  9224.         dest_blue_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwBBitMask, False);
  9225.         dest_alpha_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRGBAlphaBitMask, False);
  9226.  
  9227.         if SrcImage.idx_alpha.mask <> 0 then
  9228.         begin
  9229.           for y := 0 to ddsd.dwHeight - 1 do
  9230.             for x := 0 to ddsd.dwWidth - 1 do
  9231.             begin
  9232.               c := SrcImage.Pixels[x, y];
  9233.               cIdx := dxtDecodeChannel(SrcImage.idx_index, c);
  9234.  
  9235.               c := dxtEncodeChannel(dest_red_fmt, SrcImage.idx_palette[cIdx].peRed) or
  9236.                 dxtEncodeChannel(dest_green_fmt, SrcImage.idx_palette[cIdx].peGreen) or
  9237.                 dxtEncodeChannel(dest_blue_fmt, SrcImage.idx_palette[cIdx].peBlue) or
  9238.                 dxtEncodeChannel(dest_alpha_fmt, dxtDecodeChannel(SrcImage.idx_alpha, c));
  9239.  
  9240.               SetPixel(ddsd, x, y, c);
  9241.             end;
  9242.         end
  9243.         else
  9244.         begin
  9245.           cA := dxtEncodeChannel(dest_alpha_fmt, 255);
  9246.  
  9247.           for y := 0 to ddsd.dwHeight - 1 do
  9248.             for x := 0 to ddsd.dwWidth - 1 do
  9249.             begin
  9250.               c := SrcImage.Pixels[x, y];
  9251.               cIdx := dxtDecodeChannel(SrcImage.idx_index, c);
  9252.  
  9253.               c := dxtEncodeChannel(dest_red_fmt, SrcImage.idx_palette[cIdx].peRed) or
  9254.                 dxtEncodeChannel(dest_green_fmt, SrcImage.idx_palette[cIdx].peGreen) or
  9255.                 dxtEncodeChannel(dest_blue_fmt, SrcImage.idx_palette[cIdx].peBlue) or cA;
  9256.  
  9257.               SetPixel(ddsd, x, y, c);
  9258.             end;
  9259.         end;
  9260.       finally
  9261.         Dest.UnLock(ddsd.lpSurface);
  9262.       end;
  9263.     end;
  9264.   end;
  9265.  
  9266.   procedure LoadTexture_RGBToRGB;
  9267.   var
  9268.     ddsd: TDDSurfaceDesc2;
  9269.     x, y: Integer;
  9270.     c, cA: DWORD;
  9271.     dest_red_fmt, dest_green_fmt, dest_blue_fmt, dest_alpha_fmt: TDXTextureImageChannel;
  9272.   begin
  9273.     ddsd.dwSize := SizeOf(ddsd);
  9274.     if Dest.Lock(nil, ddsd, DDLOCK_WAIT, 0) = 0 then
  9275.     begin
  9276.       try
  9277.         dest_red_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRBitMask, False);
  9278.         dest_green_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwGBitMask, False);
  9279.         dest_blue_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwBBitMask, False);
  9280.         dest_alpha_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRGBAlphaBitMask, False);
  9281.  
  9282.         if (dest_red_fmt.Mask = SrcImage.rgb_red.Mask) and (dest_green_fmt.Mask = SrcImage.rgb_green.Mask) and
  9283.           (dest_blue_fmt.Mask = SrcImage.rgb_blue.Mask) and (dest_alpha_fmt.Mask = SrcImage.rgb_alpha.Mask) and
  9284.           (Integer(ddsd.ddpfPixelFormat.dwRGBBitCount) = SrcImage.BitCount) and (not SrcImage.PackedPixelOrder)
  9285.         then
  9286.         begin
  9287.           for y := 0 to ddsd.dwHeight - 1 do
  9288.             Move(SrcImage.ScanLine[y]^, Pointer(Integer(ddsd.lpSurface) + ddsd.lPitch * y)^, (Integer(ddsd.dwWidth) * SrcImage.BitCount + 7) div 8);
  9289.         end
  9290.         else
  9291.           if SrcImage.rgb_alpha.mask <> 0 then
  9292.           begin
  9293.             for y := 0 to ddsd.dwHeight - 1 do
  9294.               for x := 0 to ddsd.dwWidth - 1 do
  9295.               begin
  9296.                 c := SrcImage.Pixels[x, y];
  9297.  
  9298.                 c := dxtEncodeChannel(dest_red_fmt, dxtDecodeChannel(SrcImage.rgb_red, c)) or
  9299.                   dxtEncodeChannel(dest_green_fmt, dxtDecodeChannel(SrcImage.rgb_green, c)) or
  9300.                   dxtEncodeChannel(dest_blue_fmt, dxtDecodeChannel(SrcImage.rgb_blue, c)) or
  9301.                   dxtEncodeChannel(dest_alpha_fmt, dxtDecodeChannel(SrcImage.rgb_alpha, c));
  9302.  
  9303.                 SetPixel(ddsd, x, y, c);
  9304.               end;
  9305.           end
  9306.           else
  9307.           begin
  9308.             cA := dxtEncodeChannel(dest_alpha_fmt, 255);
  9309.  
  9310.             for y := 0 to ddsd.dwHeight - 1 do
  9311.               for x := 0 to ddsd.dwWidth - 1 do
  9312.               begin
  9313.                 c := SrcImage.Pixels[x, y];
  9314.  
  9315.                 c := dxtEncodeChannel(dest_red_fmt, dxtDecodeChannel(SrcImage.rgb_red, c)) or
  9316.                   dxtEncodeChannel(dest_green_fmt, dxtDecodeChannel(SrcImage.rgb_green, c)) or
  9317.                   dxtEncodeChannel(dest_blue_fmt, dxtDecodeChannel(SrcImage.rgb_blue, c)) or cA;
  9318.  
  9319.                 SetPixel(ddsd, x, y, c);
  9320.               end;
  9321.           end;
  9322.       finally
  9323.         Dest.UnLock(ddsd.lpSurface);
  9324.       end;
  9325.     end;
  9326.   end;
  9327.  
  9328. var
  9329.   SurfaceDesc: TDDSurfaceDesc2;
  9330. begin
  9331.   SurfaceDesc.dwSize := SizeOf(SurfaceDesc);
  9332.   Dest.GetSurfaceDesc(SurfaceDesc);
  9333.  
  9334.   if SurfaceDesc.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED <> 0 then
  9335.   begin
  9336.     case SrcImage.ImageType of
  9337.       DXTextureImageType_PaletteIndexedColor: LoadTexture_IndexToIndex;
  9338.       DXTextureImageType_RGBColor: ;
  9339.     end;
  9340.   end else if SurfaceDesc.ddpfPixelFormat.dwFlags and DDPF_RGB <> 0 then
  9341.   begin
  9342.     case SrcImage.ImageType of
  9343.       DXTextureImageType_PaletteIndexedColor: LoadTexture_IndexToRGB;
  9344.       DXTextureImageType_RGBColor: LoadTexture_RGBToRGB;
  9345.     end;
  9346.   end;
  9347. end;
  9348.  
  9349. { Support function }
  9350.  
  9351. function GetWidthBytes(Width, BitCount: Integer): Integer;
  9352. begin
  9353.   Result := (((Width * BitCount) + 31) div 32) * 4;
  9354. end;
  9355.  
  9356. function dxtEncodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
  9357. begin
  9358.   Result := ((c shl Channel._rshift) shr Channel._lshift) and Channel.Mask;
  9359. end;
  9360.  
  9361. function dxtDecodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
  9362. begin
  9363.   Result := ((c and Channel.Mask) shr Channel._rshift) shl Channel._lshift;
  9364.   Result := Result or (Result shr Channel._BitCount2);
  9365. end;
  9366.  
  9367. function dxtMakeChannel(Mask: DWORD; indexed: Boolean): TDXTextureImageChannel;
  9368.  
  9369.   function GetMaskBitCount(b: Integer): Integer;
  9370.   var
  9371.     i: Integer;
  9372.   begin
  9373.     i := 0;
  9374.     while (i < 31) and (((1 shl i) and b) = 0) do Inc(i);
  9375.  
  9376.     Result := 0;
  9377.     while ((1 shl i) and b) <> 0 do
  9378.     begin
  9379.       Inc(i);
  9380.       Inc(Result);
  9381.     end;
  9382.   end;
  9383.  
  9384.   function GetBitCount2(b: Integer): Integer;
  9385.   begin
  9386.     Result := 0;
  9387.     while (Result < 31) and (((1 shl Result) and b) = 0) do Inc(Result);
  9388.   end;
  9389.  
  9390. begin
  9391.   Result.BitCount := GetMaskBitCount(Mask);
  9392.   Result.Mask := Mask;
  9393.  
  9394.   if indexed then
  9395.   begin
  9396.     Result._rshift := GetBitCount2(Mask);
  9397.     Result._lshift := 0;
  9398.     Result._Mask2 := 1 shl Result.BitCount - 1;
  9399.     Result._BitCount2 := 0;
  9400.   end
  9401.   else
  9402.   begin
  9403.     Result._rshift := GetBitCount2(Mask) - (8 - Result.BitCount);
  9404.     if Result._rshift < 0 then
  9405.     begin
  9406.       Result._lshift := -Result._rshift;
  9407.       Result._rshift := 0;
  9408.     end
  9409.     else
  9410.       Result._lshift := 0;
  9411.     Result._Mask2 := (1 shl Result.BitCount - 1) shl (8 - Result.BitCount);
  9412.     Result._BitCount2 := 8 - Result.BitCount;
  9413.   end;
  9414. end;
  9415.  
  9416. {  TDXTextureImage  }
  9417.  
  9418. var
  9419.   _DXTextureImageLoadFuncList: TList;
  9420.  
  9421. procedure DXTextureImage_LoadDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage); forward;
  9422. procedure DXTextureImage_LoadBitmapFunc(Stream: TStream; Image: TDXTextureImage); forward;
  9423.  
  9424. function DXTextureImageLoadFuncList: TList;
  9425. begin
  9426.   if _DXTextureImageLoadFuncList = nil then
  9427.   begin
  9428.     _DXTextureImageLoadFuncList := TList.Create;
  9429.     _DXTextureImageLoadFuncList.Add(@DXTextureImage_LoadDXTextureImageFunc);
  9430.     _DXTextureImageLoadFuncList.Add(@DXTextureImage_LoadBitmapFunc);
  9431.   end;
  9432.   Result := _DXTextureImageLoadFuncList;
  9433. end;
  9434.  
  9435. class procedure TDXTextureImage.RegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
  9436. begin
  9437.   if DXTextureImageLoadFuncList.IndexOf(@LoadFunc) = -1 then
  9438.     DXTextureImageLoadFuncList.Add(@LoadFunc);
  9439. end;
  9440.  
  9441. class procedure TDXTextureImage.UnRegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
  9442. begin
  9443.   DXTextureImageLoadFuncList.Remove(@LoadFunc);
  9444. end;
  9445.  
  9446. constructor TDXTextureImage.Create;
  9447. begin
  9448.   inherited Create;
  9449.   FSubImage := TList.Create;
  9450. end;
  9451.  
  9452. constructor TDXTextureImage.CreateSub(AOwner: TDXTextureImage);
  9453. begin
  9454.   Create;
  9455.  
  9456.   FOwner := AOwner;
  9457.   try
  9458.     FOwner.FSubImage.Add(Self);
  9459.   except
  9460.     FOwner := nil;
  9461.     raise;
  9462.   end;
  9463. end;
  9464.  
  9465. destructor TDXTextureImage.Destroy;
  9466. begin
  9467.   Clear;
  9468.   FSubImage.Free;
  9469.   if FOwner <> nil then
  9470.     FOwner.FSubImage.Remove(Self);
  9471.   inherited Destroy;
  9472. end;
  9473.  
  9474. procedure TDXTextureImage.DoSaveProgress(Progress, ProgressCount: Integer);
  9475. begin
  9476.   if Assigned(FOnSaveProgress) then
  9477.     FOnSaveProgress(Self, Progress, ProgressCount);
  9478. end;
  9479.  
  9480. procedure TDXTextureImage.Assign(Source: TDXTextureImage);
  9481. var
  9482.   y: Integer;
  9483. begin
  9484.   SetSize(Source.ImageType, Source.Width, Source.Height, Source.BitCount, Source.WidthBytes);
  9485.  
  9486.   idx_index := Source.idx_index;
  9487.   idx_alpha := Source.idx_alpha;
  9488.   idx_palette := Source.idx_palette;
  9489.  
  9490.   rgb_red := Source.rgb_red;
  9491.   rgb_green := Source.rgb_green;
  9492.   rgb_blue := Source.rgb_blue;
  9493.   rgb_alpha := Source.rgb_alpha;
  9494.  
  9495.   for y := 0 to Height - 1 do
  9496.     Move(Source.ScanLine[y]^, ScanLine[y]^, WidthBytes);
  9497.  
  9498.   Transparent := Source.Transparent;
  9499.   TransparentColor := Source.TransparentColor;
  9500.   ImageGroupType := Source.ImageGroupType;
  9501.   ImageID := Source.ImageID;
  9502.   ImageName := Source.ImageName;
  9503. end;
  9504.  
  9505. procedure TDXTextureImage.ClearImage;
  9506. begin
  9507.   if FAutoFreeImage then
  9508.     FreeMem(FPBits);
  9509.  
  9510.   FImageType := DXTextureImageType_PaletteIndexedColor;
  9511.   FWidth := 0;
  9512.   FHeight := 0;
  9513.   FBitCount := 0;
  9514.   FWidthBytes := 0;
  9515.   FNextLine := 0;
  9516.   FSize := 0;
  9517.   FPBits := nil;
  9518.   FTopPBits := nil;
  9519.   FAutoFreeImage := False;
  9520. end;
  9521.  
  9522. procedure TDXTextureImage.Clear;
  9523. begin
  9524.   ClearImage;
  9525.  
  9526.   while SubImageCount > 0 do
  9527.     SubImages[SubImageCount - 1].Free;
  9528.  
  9529.   FImageGroupType := 0;
  9530.   FImageID := 0;
  9531.   FImageName := '';
  9532.  
  9533.   FTransparent := False;
  9534.   FTransparentColor := 0;
  9535.  
  9536.   FillChar(idx_index, SizeOf(idx_index), 0);
  9537.   FillChar(idx_alpha, SizeOf(idx_alpha), 0);
  9538.   FillChar(idx_palette, SizeOf(idx_palette), 0);
  9539.   FillChar(rgb_red, SizeOf(rgb_red), 0);
  9540.   FillChar(rgb_green, SizeOf(rgb_green), 0);
  9541.   FillChar(rgb_blue, SizeOf(rgb_blue), 0);
  9542.   FillChar(rgb_alpha, SizeOf(rgb_alpha), 0);
  9543. end;
  9544.  
  9545. procedure TDXTextureImage.SetImage(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes, NextLine: Integer;
  9546.   PBits, TopPBits: Pointer; Size: Integer; AutoFree: Boolean);
  9547. begin
  9548.   ClearImage;
  9549.  
  9550.   FAutoFreeImage := AutoFree;
  9551.   FImageType := ImageType;
  9552.   FWidth := Width;
  9553.   FHeight := Height;
  9554.   FBitCount := BitCount;
  9555.   FWidthBytes := WidthBytes;
  9556.   FNextLine := NextLine;
  9557.   FSize := Size;
  9558.   FPBits := PBits;
  9559.   FTopPBits := TopPBits;
  9560. end;
  9561.  
  9562. procedure TDXTextureImage.SetSize(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes: Integer);
  9563. var
  9564.   APBits: Pointer;
  9565. begin
  9566.   ClearImage;
  9567.  
  9568.   if WidthBytes = 0 then
  9569.     WidthBytes := GetWidthBytes(Width, BitCount);
  9570.  
  9571.   GetMem(APBits, WidthBytes * Height);
  9572.   SetImage(ImageType, Width, Height, BitCount, WidthBytes,
  9573.     WidthBytes, APBits, APBits, WidthBytes * Height, True);
  9574. end;
  9575.  
  9576. function TDXTextureImage.GetScanLine(y: Integer): Pointer;
  9577. begin
  9578.   Result := Pointer(Integer(FTopPBits) + FNextLine * y);
  9579. end;
  9580.  
  9581. function TDXTextureImage.GetSubGroupImageCount(GroupTypeID: DWORD): Integer;
  9582. var
  9583.   i: Integer;
  9584. begin
  9585.   Result := 0;
  9586.   for i := 0 to SubImageCount - 1 do
  9587.     if SubImages[i].ImageGroupType = GroupTypeID then
  9588.       Inc(Result);
  9589. end;
  9590.  
  9591. function TDXTextureImage.GetSubGroupImage(GroupTypeID: DWORD; Index: Integer): TDXTextureImage;
  9592. var
  9593.   i, j: Integer;
  9594. begin
  9595.   j := 0;
  9596.   for i := 0 to SubImageCount - 1 do
  9597.     if SubImages[i].ImageGroupType = GroupTypeID then
  9598.     begin
  9599.       if j = Index then
  9600.       begin
  9601.         Result := SubImages[i];
  9602.         Exit;
  9603.       end;
  9604.  
  9605.       Inc(j);
  9606.     end;
  9607.  
  9608.   Result := nil;
  9609.   SubImages[-1];
  9610. end;
  9611.  
  9612. function TDXTextureImage.GetSubImageCount: Integer;
  9613. begin
  9614.   Result := 0;
  9615.   if Assigned(FSubImage) then
  9616.     Result := FSubImage.Count;
  9617. end;
  9618.  
  9619. function TDXTextureImage.GetSubImage(Index: Integer): TDXTextureImage;
  9620. begin
  9621.   Result := FSubImage[Index];
  9622. end;
  9623.  
  9624. function TDXTextureImage.EncodeColor(R, G, B, A: Byte): DWORD;
  9625. begin
  9626.   if ImageType = DXTextureImageType_PaletteIndexedColor then
  9627.   begin
  9628.     Result := dxtEncodeChannel(idx_index, PaletteIndex(R, G, B)) or
  9629.       dxtEncodeChannel(idx_alpha, A);
  9630.   end
  9631.   else
  9632.   begin
  9633.     Result := dxtEncodeChannel(rgb_red, R) or
  9634.       dxtEncodeChannel(rgb_green, G) or
  9635.       dxtEncodeChannel(rgb_blue, B) or
  9636.       dxtEncodeChannel(rgb_alpha, A);
  9637.   end;
  9638. end;
  9639.  
  9640. function TDXTextureImage.PaletteIndex(R, G, B: Byte): DWORD;
  9641. var
  9642.   i, d, d2: Integer;
  9643. begin
  9644.   Result := 0;
  9645.   if ImageType = DXTextureImageType_PaletteIndexedColor then
  9646.   begin
  9647.     d := MaxInt;
  9648.     for i := 0 to (1 shl idx_index.BitCount) - 1 do
  9649.       with idx_palette[i] do
  9650.       begin
  9651.         d2 := Abs((peRed - R)) * Abs((peRed - R)) + Abs((peGreen - G)) * Abs((peGreen - G)) + Abs((peBlue - B)) * Abs((peBlue - B));
  9652.         if d > d2 then
  9653.         begin
  9654.           d := d2;
  9655.           Result := i;
  9656.         end;
  9657.       end;
  9658.   end;
  9659. end;
  9660.  
  9661. const
  9662.   Mask1: array[0..7] of DWORD = (1, 2, 4, 8, 16, 32, 64, 128);
  9663.   Mask2: array[0..3] of DWORD = (3, 12, 48, 192);
  9664.   Mask4: array[0..1] of DWORD = ($0F, $F0);
  9665.  
  9666.   Shift1: array[0..7] of DWORD = (0, 1, 2, 3, 4, 5, 6, 7);
  9667.   Shift2: array[0..3] of DWORD = (0, 2, 4, 6);
  9668.   Shift4: array[0..1] of DWORD = (0, 4);
  9669.  
  9670. type
  9671.   PByte3 = ^TByte3;
  9672.   TByte3 = array[0..2] of Byte;
  9673.  
  9674. function TDXTextureImage.GetPixel(x, y: Integer): DWORD;
  9675. begin
  9676.   Result := 0;
  9677.   if (x >= 0) and (x < FWidth) and (y >= 0) and (y < FHeight) then
  9678.   begin
  9679.     case FBitCount of
  9680.       1: begin
  9681.           if FPackedPixelOrder then
  9682.             Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 3)^ and Mask1[7 - x and 7]) shr Shift1[7 - x and 7]
  9683.           else
  9684.             Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7];
  9685.         end;
  9686.       2: begin
  9687.           if FPackedPixelOrder then
  9688.             Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 2)^ and Mask2[3 - x and 3]) shr Shift2[3 - x and 3]
  9689.           else
  9690.             Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 2)^ and Mask2[x and 3]) shr Shift2[x and 3];
  9691.         end;
  9692.       4: begin
  9693.           if FPackedPixelOrder then
  9694.             Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 1)^ and Mask4[1 - x and 1]) shr Shift4[1 - x and 1]
  9695.           else
  9696.             Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1];
  9697.         end;
  9698.       8: Result := PByte(Integer(FTopPBits) + FNextLine * y + x)^;
  9699.       16: Result := PWord(Integer(FTopPBits) + FNextLine * y + x * 2)^;
  9700.       24: PByte3(@Result)^ := PByte3(Integer(FTopPBits) + FNextLine * y + x * 3)^;
  9701.       32: Result := PDWORD(Integer(FTopPBits) + FNextLine * y + x * 4)^;
  9702.     end;
  9703.   end;
  9704. end;
  9705.  
  9706. procedure TDXTextureImage.SetPixel(x, y: Integer; c: DWORD);
  9707. var
  9708.   P: PByte;
  9709. begin
  9710.   if (x >= 0) and (x < FWidth) and (y >= 0) and (y < FHeight) then
  9711.   begin
  9712.     case FBitCount of
  9713.       1: begin
  9714.           P := Pointer(Integer(FTopPBits) + FNextLine * y + x shr 3);
  9715.           if FPackedPixelOrder then
  9716.             P^ := (P^ and (not Mask1[7 - x and 7])) or ((c and 1) shl Shift1[7 - x and 7])
  9717.           else
  9718.             P^ := (P^ and (not Mask1[x and 7])) or ((c and 1) shl Shift1[x and 7]);
  9719.         end;
  9720.       2: begin
  9721.           P := Pointer(Integer(FTopPBits) + FNextLine * y + x shr 2);
  9722.           if FPackedPixelOrder then
  9723.             P^ := (P^ and (not Mask2[3 - x and 3])) or ((c and 3) shl Shift2[3 - x and 3])
  9724.           else
  9725.             P^ := (P^ and (not Mask2[x and 3])) or ((c and 3) shl Shift2[x and 3]);
  9726.         end;
  9727.       4: begin
  9728.           P := Pointer(Integer(FTopPBits) + FNextLine * y + x shr 1);
  9729.           if FPackedPixelOrder then
  9730.             P^ := (P^ and (not Mask4[1 - x and 1])) or ((c and 7) shl Shift4[1 - x and 1])
  9731.           else
  9732.             P^ := (P^ and (not Mask4[x and 1])) or ((c and 7) shl Shift4[x and 1]);
  9733.         end;
  9734.       8: PByte(Integer(FTopPBits) + FNextLine * y + x)^ := c;
  9735.       16: PWord(Integer(FTopPBits) + FNextLine * y + x * 2)^ := c;
  9736.       24: PByte3(Integer(FTopPBits) + FNextLine * y + x * 3)^ := PByte3(@c)^;
  9737.       32: PDWORD(Integer(FTopPBits) + FNextLine * y + x * 4)^ := c;
  9738.     end;
  9739.   end;
  9740. end;
  9741.  
  9742. procedure TDXTextureImage.LoadFromFile(const FileName: string);
  9743. var
  9744.   Stream: TFileStream;
  9745. begin
  9746.   Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  9747.   try
  9748.     LoadFromStream(Stream);
  9749.   finally
  9750.     Stream.Free;
  9751.   end;
  9752. end;
  9753.  
  9754. procedure TDXTextureImage.LoadFromStream(Stream: TStream);
  9755. var
  9756.   i, p: Integer;
  9757. begin
  9758.   Clear;
  9759.  
  9760.   p := Stream.Position;
  9761.   for i := 0 to DXTextureImageLoadFuncList.Count - 1 do
  9762.   begin
  9763.     Stream.Position := p;
  9764.     try
  9765.       TDXTextureImageLoadFunc(DXTextureImageLoadFuncList[i])(Stream, Self);
  9766.       Exit;
  9767.     except
  9768.       Clear;
  9769.     end;
  9770.   end;
  9771.  
  9772.   raise EDXTextureImageError.Create(SNotSupportGraphicFile);
  9773. end;
  9774.  
  9775. procedure TDXTextureImage.SaveToFile(const FileName: string);
  9776. var
  9777.   Stream: TFileStream;
  9778. begin
  9779.   Stream := TFileStream.Create(FileName, fmCreate);
  9780.   try
  9781.     SaveToStream(Stream);
  9782.   finally
  9783.     Stream.Free;
  9784.   end;
  9785. end;
  9786.  
  9787. procedure DXTextureImage_SaveDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage); forward;
  9788.  
  9789. procedure TDXTextureImage.SaveToStream(Stream: TStream);
  9790. begin
  9791.   DXTextureImage_SaveDXTextureImageFunc(Stream, Self);
  9792. end;
  9793.  
  9794. {  DXTextureImage_LoadDXTextureImageFunc  }
  9795.  
  9796. const
  9797.   DXTextureImageFile_Type = 'dxt:';
  9798.   DXTextureImageFile_Version = $100;
  9799.  
  9800.   DXTextureImageCompress_None = 0;
  9801.   DXTextureImageCompress_ZLIB = 1; // ZLIB enabled
  9802.  
  9803.   DXTextureImageFileCategoryType_Image = $100;
  9804.  
  9805.   DXTextureImageFileBlockID_EndFile = 0;
  9806.   DXTextureImageFileBlockID_EndGroup = 1;
  9807.   DXTextureImageFileBlockID_StartGroup = 2;
  9808.   DXTextureImageFileBlockID_Image_Format = DXTextureImageFileCategoryType_Image + 1;
  9809.   DXTextureImageFileBlockID_Image_PixelData = DXTextureImageFileCategoryType_Image + 2;
  9810.   DXTextureImageFileBlockID_Image_GroupInfo = DXTextureImageFileCategoryType_Image + 3;
  9811.   DXTextureImageFileBlockID_Image_Name = DXTextureImageFileCategoryType_Image + 4;
  9812.   DXTextureImageFileBlockID_Image_TransparentColor = DXTextureImageFileCategoryType_Image + 5;
  9813.  
  9814. type
  9815.   TDXTextureImageFileHeader = packed record
  9816.     FileType: array[0..4] of Char;
  9817.     ver: DWORD;
  9818.   end;
  9819.  
  9820.   TDXTextureImageFileBlockHeader = packed record
  9821.     ID: DWORD;
  9822.     Size: Integer;
  9823.   end;
  9824.  
  9825.   TDXTextureImageFileBlockHeader_StartGroup = packed record
  9826.     CategoryType: DWORD;
  9827.   end;
  9828.  
  9829.   TDXTextureImageHeader_Image_Format = packed record
  9830.     ImageType: TDXTextureImageType;
  9831.     Width: DWORD;
  9832.     Height: DWORD;
  9833.     BitCount: DWORD;
  9834.     WidthBytes: DWORD;
  9835.   end;
  9836.  
  9837.   TDXTextureImageHeader_Image_Format_Index = packed record
  9838.     idx_index_Mask: DWORD;
  9839.     idx_alpha_Mask: DWORD;
  9840.     idx_palette: array[0..255] of TPaletteEntry;
  9841.   end;
  9842.  
  9843.   TDXTextureImageHeader_Image_Format_RGB = packed record
  9844.     rgb_red_Mask: DWORD;
  9845.     rgb_green_Mask: DWORD;
  9846.     rgb_blue_Mask: DWORD;
  9847.     rgb_alpha_Mask: DWORD;
  9848.   end;
  9849.  
  9850.   TDXTextureImageHeader_Image_GroupInfo = packed record
  9851.     ImageGroupType: DWORD;
  9852.     ImageID: DWORD;
  9853.   end;
  9854.  
  9855.   TDXTextureImageHeader_Image_PixelData = packed record
  9856.     Compress: DWORD;
  9857.   end;
  9858.  
  9859.   TDXTextureImageHeader_Image_TransparentColor = packed record
  9860.     Transparent: Boolean;
  9861.     TransparentColor: DWORD;
  9862.   end;
  9863.  
  9864. procedure DXTextureImage_LoadDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage);
  9865.  
  9866.   procedure ReadGroup_Image(Image: TDXTextureImage);
  9867.   var
  9868.     i: Integer;
  9869.     BlockHeader: TDXTextureImageFileBlockHeader;
  9870.     NextPos: Integer;
  9871.     SubImage: TDXTextureImage;
  9872.     Header_StartGroup: TDXTextureImageFileBlockHeader_StartGroup;
  9873.     Header_Image_Format: TDXTextureImageHeader_Image_Format;
  9874.     Header_Image_Format_Index: TDXTextureImageHeader_Image_Format_Index;
  9875.     Header_Image_Format_RGB: TDXTextureImageHeader_Image_Format_RGB;
  9876.     Header_Image_GroupInfo: TDXTextureImageHeader_Image_GroupInfo;
  9877.     Header_Image_TransparentColor: TDXTextureImageHeader_Image_TransparentColor;
  9878.     Header_Image_PixelData: TDXTextureImageHeader_Image_PixelData;
  9879.     ImageName: string;
  9880.     {$IFDEF DXTextureImage_UseZLIB}
  9881.     Decompression: TDecompressionStream;
  9882.     {$ENDIF}
  9883.   begin
  9884.     while True do
  9885.     begin
  9886.       Stream.ReadBuffer(BlockHeader, SizeOf(BlockHeader));
  9887.       NextPos := Stream.Position + BlockHeader.Size;
  9888.  
  9889.       case BlockHeader.ID of
  9890.         DXTextureImageFileBlockID_EndGroup:
  9891.           begin
  9892.             {  End of group  }
  9893.             Break;
  9894.           end;
  9895.         DXTextureImageFileBlockID_StartGroup:
  9896.           begin
  9897.             {  Beginning of group  }
  9898.             Stream.ReadBuffer(Header_StartGroup, SizeOf(Header_StartGroup));
  9899.             case Header_StartGroup.CategoryType of
  9900.               DXTextureImageFileCategoryType_Image:
  9901.                 begin
  9902.                   {  Image group  }
  9903.                   SubImage := TDXTextureImage.CreateSub(Image);
  9904.                   try
  9905.                     ReadGroup_Image(SubImage);
  9906.                   except
  9907.                     SubImage.Free;
  9908.                     raise;
  9909.                   end;
  9910.                 end;
  9911.             end;
  9912.           end;
  9913.         DXTextureImageFileBlockID_Image_Format:
  9914.           begin
  9915.             {  Image information reading (size etc.)  }
  9916.             Stream.ReadBuffer(Header_Image_Format, SizeOf(Header_Image_Format));
  9917.  
  9918.             if (Header_Image_Format.ImageType <> DXTextureImageType_PaletteIndexedColor) and
  9919.               (Header_Image_Format.ImageType <> DXTextureImageType_RGBColor)
  9920.             then
  9921.               raise EDXTextureImageError.Create(SInvalidDXTFile);
  9922.  
  9923.             Image.SetSize(Header_Image_Format.ImageType, Header_Image_Format.Width, Header_Image_Format.Height,
  9924.               Header_Image_Format.BitCount, Header_Image_Format.Widthbytes);
  9925.  
  9926.             if Header_Image_Format.ImageType = DXTextureImageType_PaletteIndexedColor then
  9927.             begin
  9928.               {  INDEX IMAGE  }
  9929.               Stream.ReadBuffer(Header_Image_Format_Index, SizeOf(Header_Image_Format_Index));
  9930.  
  9931.               Image.idx_index := dxtMakeChannel(Header_Image_Format_Index.idx_index_Mask, True);
  9932.               Image.idx_alpha := dxtMakeChannel(Header_Image_Format_Index.idx_alpha_Mask, False);
  9933.  
  9934.               for i := 0 to 255 do
  9935.                 Image.idx_palette[i] := Header_Image_Format_Index.idx_palette[i];
  9936.             end
  9937.             else
  9938.             if Header_Image_Format.ImageType = DXTextureImageType_RGBColor then
  9939.             begin
  9940.               {  RGB IMAGE  }
  9941.               Stream.ReadBuffer(Header_Image_Format_RGB, SizeOf(Header_Image_Format_RGB));
  9942.  
  9943.               Image.rgb_red := dxtMakeChannel(Header_Image_Format_RGB.rgb_red_Mask, False);
  9944.               Image.rgb_green := dxtMakeChannel(Header_Image_Format_RGB.rgb_green_Mask, False);
  9945.               Image.rgb_blue := dxtMakeChannel(Header_Image_Format_RGB.rgb_blue_Mask, False);
  9946.               Image.rgb_alpha := dxtMakeChannel(Header_Image_Format_RGB.rgb_alpha_Mask, False);
  9947.             end;
  9948.           end;
  9949.         DXTextureImageFileBlockID_Image_Name:
  9950.           begin
  9951.             {  Name reading  }
  9952.             SetLength(ImageName, BlockHeader.Size);
  9953.             Stream.ReadBuffer(ImageName[1], BlockHeader.Size);
  9954.  
  9955.             Image.ImageName := ImageName;
  9956.           end;
  9957.         DXTextureImageFileBlockID_Image_GroupInfo:
  9958.           begin
  9959.             {  Image group information reading  }
  9960.             Stream.ReadBuffer(Header_Image_GroupInfo, SizeOf(Header_Image_GroupInfo));
  9961.  
  9962.             Image.ImageGroupType := Header_Image_GroupInfo.ImageGroupType;
  9963.             Image.ImageID := Header_Image_GroupInfo.ImageID;
  9964.           end;
  9965.         DXTextureImageFileBlockID_Image_TransparentColor:
  9966.           begin
  9967.             {  Transparent color information reading  }
  9968.             Stream.ReadBuffer(Header_Image_TransparentColor, SizeOf(Header_Image_TransparentColor));
  9969.  
  9970.             Image.Transparent := Header_Image_TransparentColor.Transparent;
  9971.             Image.TransparentColor := Header_Image_TransparentColor.TransparentColor;
  9972.           end;
  9973.         DXTextureImageFileBlockID_Image_PixelData:
  9974.           begin
  9975.             {  Pixel data reading  }
  9976.             Stream.ReadBuffer(Header_Image_PixelData, SizeOf(Header_Image_PixelData));
  9977.  
  9978.             case Header_Image_PixelData.Compress of
  9979.               DXTextureImageCompress_None:
  9980.                 begin
  9981.                    {  NO compress  }
  9982.                   for i := 0 to Image.Height - 1 do
  9983.                     Stream.ReadBuffer(Image.ScanLine[i]^, Header_Image_Format.Widthbytes);
  9984.                 end;
  9985.               {$IFDEF DXTextureImage_UseZLIB}
  9986.               DXTextureImageCompress_ZLIB:
  9987.                 begin
  9988.                    {  ZLIB compress enabled  }
  9989.                   Decompression := TDecompressionStream.Create(Stream);
  9990.                   try
  9991.                     for i := 0 to Image.Height - 1 do
  9992.                       Decompression.ReadBuffer(Image.ScanLine[i]^, Header_Image_Format.Widthbytes);
  9993.                   finally
  9994.                     Decompression.Free;
  9995.                   end;
  9996.                 end;
  9997.               {$ENDIF}
  9998.             else
  9999.               raise EDXTextureImageError.CreateFmt('Decompression error (%d)', [Header_Image_PixelData.Compress]);
  10000.             end;
  10001.           end;
  10002.  
  10003.       end;
  10004.  
  10005.       Stream.Seek(NextPos, soFromBeginning);
  10006.     end;
  10007.   end;
  10008.  
  10009. var
  10010.   FileHeader: TDXTextureImageFileHeader;
  10011.   BlockHeader: TDXTextureImageFileBlockHeader;
  10012.   Header_StartGroup: TDXTextureImageFileBlockHeader_StartGroup;
  10013.   NextPos: Integer;
  10014. begin
  10015.   {  File header reading  }
  10016.   Stream.ReadBuffer(FileHeader, SizeOf(FileHeader));
  10017.  
  10018.   if FileHeader.FileType <> DXTextureImageFile_Type then
  10019.     raise EDXTextureImageError.Create(SInvalidDXTFile);
  10020.   if FileHeader.ver <> DXTextureImageFile_Version then
  10021.     raise EDXTextureImageError.Create(SInvalidDXTFile);
  10022.  
  10023.   while True do
  10024.   begin
  10025.     Stream.ReadBuffer(BlockHeader, SizeOf(BlockHeader));
  10026.     NextPos := Stream.Position + BlockHeader.Size;
  10027.  
  10028.     case BlockHeader.ID of
  10029.       DXTextureImageFileBlockID_EndFile:
  10030.         begin
  10031.           {  End of file  }
  10032.           Break;
  10033.         end;
  10034.       DXTextureImageFileBlockID_StartGroup:
  10035.         begin
  10036.           {  Beginning of group  }
  10037.           Stream.ReadBuffer(Header_StartGroup, SizeOf(Header_StartGroup));
  10038.           case Header_StartGroup.CategoryType of
  10039.             DXTextureImageFileCategoryType_Image: ReadGroup_Image(Image);
  10040.           end;
  10041.         end;
  10042.     end;
  10043.  
  10044.     Stream.Seek(NextPos, soFromBeginning);
  10045.   end;
  10046. end;
  10047.  
  10048. type
  10049.   PDXTextureImageFileBlockHeaderWriter_BlockInfo = ^TDXTextureImageFileBlockHeaderWriter_BlockInfo;
  10050.   TDXTextureImageFileBlockHeaderWriter_BlockInfo = record
  10051.     BlockID: DWORD;
  10052.     StreamPos: Integer;
  10053.   end;
  10054.  
  10055.   TDXTextureImageFileBlockHeaderWriter = class
  10056.   private
  10057.     FStream: TStream;
  10058.     FList: TList;
  10059.   public
  10060.     constructor Create(Stream: TStream);
  10061.     destructor Destroy; override;
  10062.     procedure StartBlock(BlockID: DWORD);
  10063.     procedure EndBlock;
  10064.     procedure WriteBlock(BlockID: DWORD);
  10065.     procedure StartGroup(CategoryType: DWORD);
  10066.     procedure EndGroup;
  10067.   end;
  10068.  
  10069. constructor TDXTextureImageFileBlockHeaderWriter.Create(Stream: TStream);
  10070. begin
  10071.   inherited Create;
  10072.   FStream := Stream;
  10073.   FList := TList.Create;
  10074. end;
  10075.  
  10076. destructor TDXTextureImageFileBlockHeaderWriter.Destroy;
  10077. var
  10078.   i: Integer;
  10079. begin
  10080.   for i := 0 to FList.Count - 1 do
  10081.     Dispose(PDXTextureImageFileBlockHeaderWriter_BlockInfo(FList[i]));
  10082.   FList.Free;
  10083.   inherited Destroy;
  10084. end;
  10085.  
  10086. procedure TDXTextureImageFileBlockHeaderWriter.StartBlock(BlockID: DWORD);
  10087. var
  10088.   BlockInfo: PDXTextureImageFileBlockHeaderWriter_BlockInfo;
  10089.   BlockHeader: TDXTextureImageFileBlockHeader;
  10090. begin
  10091.   New(BlockInfo);
  10092.   BlockInfo.BlockID := BlockID;
  10093.   BlockInfo.StreamPos := FStream.Position;
  10094.   FList.Add(BlockInfo);
  10095.  
  10096.   BlockHeader.ID := BlockID;
  10097.   BlockHeader.Size := 0;
  10098.   FStream.WriteBuffer(BlockHeader, SizeOf(BlockHeader));
  10099. end;
  10100.  
  10101. procedure TDXTextureImageFileBlockHeaderWriter.EndBlock;
  10102. var
  10103.   BlockHeader: TDXTextureImageFileBlockHeader;
  10104.   BlockInfo: PDXTextureImageFileBlockHeaderWriter_BlockInfo;
  10105.   CurStreamPos: Integer;
  10106. begin
  10107.   CurStreamPos := FStream.Position;
  10108.   try
  10109.     BlockInfo := FList[FList.Count - 1];
  10110.  
  10111.     FStream.Position := BlockInfo.StreamPos;
  10112.     BlockHeader.ID := BlockInfo.BlockID;
  10113.     BlockHeader.Size := CurStreamPos - (BlockInfo.StreamPos + SizeOf(TDXTextureImageFileBlockHeader));
  10114.     FStream.WriteBuffer(BlockHeader, SizeOf(BlockHeader));
  10115.   finally
  10116.     FStream.Position := CurStreamPos;
  10117.  
  10118.     Dispose(FList[FList.Count - 1]);
  10119.     FList.Count := FList.Count - 1;
  10120.   end;
  10121. end;
  10122.  
  10123. procedure TDXTextureImageFileBlockHeaderWriter.WriteBlock(BlockID: DWORD);
  10124. var
  10125.   BlockHeader: TDXTextureImageFileBlockHeader;
  10126. begin
  10127.   BlockHeader.ID := BlockID;
  10128.   BlockHeader.Size := 0;
  10129.   FStream.WriteBuffer(BlockHeader, SizeOf(BlockHeader));
  10130. end;
  10131.  
  10132. procedure TDXTextureImageFileBlockHeaderWriter.StartGroup(CategoryType: DWORD);
  10133. var
  10134.   Header_StartGroup: TDXTextureImageFileBlockHeader_StartGroup;
  10135. begin
  10136.   StartBlock(DXTextureImageFileBlockID_StartGroup);
  10137.  
  10138.   Header_StartGroup.CategoryType := CategoryType;
  10139.   FStream.WriteBuffer(Header_StartGroup, SizeOf(Header_StartGroup));
  10140. end;
  10141.  
  10142. procedure TDXTextureImageFileBlockHeaderWriter.EndGroup;
  10143. begin
  10144.   WriteBlock(DXTextureImageFileBlockID_EndGroup);
  10145.   EndBlock;
  10146. end;
  10147.  
  10148. procedure DXTextureImage_SaveDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage);
  10149. var
  10150.   Progress: Integer;
  10151.   ProgressCount: Integer;
  10152.   BlockHeaderWriter: TDXTextureImageFileBlockHeaderWriter;
  10153.  
  10154.   function CalcProgressCount(Image: TDXTextureImage): Integer;
  10155.   var
  10156.     i: Integer;
  10157.   begin
  10158.     Result := Image.WidthBytes * Image.Height;
  10159.     for i := 0 to Image.SubImageCount - 1 do
  10160.       Inc(Result, CalcProgressCount(Image.SubImages[i]));
  10161.   end;
  10162.  
  10163.   procedure AddProgress(Count: Integer);
  10164.   begin
  10165.     Inc(Progress, Count);
  10166.     Image.DoSaveProgress(Progress, ProgressCount);
  10167.   end;
  10168.  
  10169.   procedure WriteGroup_Image(Image: TDXTextureImage);
  10170.   var
  10171.     i: Integer;
  10172.     Header_Image_Format: TDXTextureImageHeader_Image_Format;
  10173.     Header_Image_Format_Index: TDXTextureImageHeader_Image_Format_Index;
  10174.     Header_Image_Format_RGB: TDXTextureImageHeader_Image_Format_RGB;
  10175.     Header_Image_GroupInfo: TDXTextureImageHeader_Image_GroupInfo;
  10176.     Header_Image_TransparentColor: TDXTextureImageHeader_Image_TransparentColor;
  10177.     Header_Image_PixelData: TDXTextureImageHeader_Image_PixelData;
  10178.   {$IFDEF DXTextureImage_UseZLIB}
  10179.     Compression: TCompressionStream;
  10180.   {$ENDIF}
  10181.   begin
  10182.     BlockHeaderWriter.StartGroup(DXTextureImageFileCategoryType_Image);
  10183.     try
  10184.       {  Image format writing  }
  10185.       if Image.Size > 0 then
  10186.       begin
  10187.         Header_Image_Format.ImageType := Image.ImageType;
  10188.         Header_Image_Format.Width := Image.Width;
  10189.         Header_Image_Format.Height := Image.Height;
  10190.         Header_Image_Format.BitCount := Image.BitCount;
  10191.         Header_Image_Format.WidthBytes := Image.WidthBytes;
  10192.  
  10193.         BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_Format);
  10194.         try
  10195.           Stream.WriteBuffer(Header_Image_Format, SizeOf(Header_Image_Format));
  10196.  
  10197.           case Image.ImageType of
  10198.             DXTextureImageType_PaletteIndexedColor:
  10199.               begin
  10200.                 {  INDEX IMAGE  }
  10201.                 Header_Image_Format_Index.idx_index_Mask := Image.idx_index.Mask;
  10202.                 Header_Image_Format_Index.idx_alpha_Mask := Image.idx_alpha.Mask;
  10203.                 for i := 0 to 255 do
  10204.                   Header_Image_Format_Index.idx_palette[i] := Image.idx_palette[i];
  10205.  
  10206.                 Stream.WriteBuffer(Header_Image_Format_Index, SizeOf(Header_Image_Format_Index));
  10207.               end;
  10208.             DXTextureImageType_RGBColor:
  10209.               begin
  10210.                 {  RGB IMAGE  }
  10211.                 Header_Image_Format_RGB.rgb_red_Mask := Image.rgb_red.Mask;
  10212.                 Header_Image_Format_RGB.rgb_green_Mask := Image.rgb_green.Mask;
  10213.                 Header_Image_Format_RGB.rgb_blue_Mask := Image.rgb_blue.Mask;
  10214.                 Header_Image_Format_RGB.rgb_alpha_Mask := Image.rgb_alpha.Mask;
  10215.  
  10216.                 Stream.WriteBuffer(Header_Image_Format_RGB, SizeOf(Header_Image_Format_RGB));
  10217.               end;
  10218.           end;
  10219.         finally
  10220.           BlockHeaderWriter.EndBlock;
  10221.         end;
  10222.       end;
  10223.  
  10224.       {  Image group information writing  }
  10225.       BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_GroupInfo);
  10226.       try
  10227.         Header_Image_GroupInfo.ImageGroupType := Image.ImageGroupType;
  10228.         Header_Image_GroupInfo.ImageID := Image.ImageID;
  10229.  
  10230.         Stream.WriteBuffer(Header_Image_GroupInfo, SizeOf(Header_Image_GroupInfo));
  10231.       finally
  10232.         BlockHeaderWriter.EndBlock;
  10233.       end;
  10234.  
  10235.       {  Name writing  }
  10236.       BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_Name);
  10237.       try
  10238.         Stream.WriteBuffer(Image.ImageName[1], Length(Image.ImageName));
  10239.       finally
  10240.         BlockHeaderWriter.EndBlock;
  10241.       end;
  10242.  
  10243.       {  Transparent color writing  }
  10244.       BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_TransparentColor);
  10245.       try
  10246.         Header_Image_TransparentColor.Transparent := Image.Transparent;
  10247.         Header_Image_TransparentColor.TransparentColor := Image.TransparentColor;
  10248.  
  10249.         Stream.WriteBuffer(Header_Image_TransparentColor, SizeOf(Header_Image_TransparentColor));
  10250.       finally
  10251.         BlockHeaderWriter.EndBlock;
  10252.       end;
  10253.  
  10254.       {  Pixel data writing  }
  10255.       if Image.Size > 0 then
  10256.       begin
  10257.         {  Writing start  }
  10258.         BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_PixelData);
  10259.         try
  10260.           {  Scan compress type  }
  10261.           case Image.FileCompressType of
  10262.             DXTextureImageFileCompressType_None:
  10263.               begin
  10264.                 Header_Image_PixelData.Compress := DXTextureImageCompress_None;
  10265.               end;
  10266.             {$IFDEF DXTextureImage_UseZLIB}
  10267.             DXTextureImageFileCompressType_ZLIB:
  10268.               begin
  10269.                 Header_Image_PixelData.Compress := DXTextureImageCompress_ZLIB;
  10270.               end;
  10271.             {$ENDIF}
  10272.           else
  10273.             Header_Image_PixelData.Compress := DXTextureImageCompress_None;
  10274.           end;
  10275.  
  10276.           Stream.WriteBuffer(Header_Image_PixelData, SizeOf(Header_Image_PixelData));
  10277.  
  10278.           case Header_Image_PixelData.Compress of
  10279.             DXTextureImageCompress_None:
  10280.               begin
  10281.                 for i := 0 to Image.Height - 1 do
  10282.                 begin
  10283.                   Stream.WriteBuffer(Image.ScanLine[i]^, Image.Widthbytes);
  10284.                   AddProgress(Image.Widthbytes);
  10285.                 end;
  10286.               end;
  10287.             {$IFDEF DXTextureImage_UseZLIB}
  10288.             DXTextureImageCompress_ZLIB:
  10289.               begin
  10290.                 Compression := TCompressionStream.Create(clMax, Stream);
  10291.                 try
  10292.                   for i := 0 to Image.Height - 1 do
  10293.                   begin
  10294.                     Compression.WriteBuffer(Image.ScanLine[i]^, Image.WidthBytes);
  10295.                     AddProgress(Image.Widthbytes);
  10296.                   end;
  10297.                 finally
  10298.                   Compression.Free;
  10299.                 end;
  10300.               end;
  10301.             {$ENDIF}
  10302.           end;
  10303.         finally
  10304.           BlockHeaderWriter.EndBlock;
  10305.         end;
  10306.       end;
  10307.  
  10308.       {  Sub-image writing  }
  10309.       for i := 0 to Image.SubImageCount - 1 do
  10310.         WriteGroup_Image(Image.SubImages[i]);
  10311.     finally
  10312.       BlockHeaderWriter.EndGroup;
  10313.     end;
  10314.   end;
  10315.  
  10316. var
  10317.   FileHeader: TDXTextureImageFileHeader;
  10318. begin
  10319.   Progress := 0;
  10320.   ProgressCount := CalcProgressCount(Image);
  10321.  
  10322.   {  File header writing  }
  10323.   FileHeader.FileType := DXTextureImageFile_Type;
  10324.   FileHeader.ver := DXTextureImageFile_Version;
  10325.   Stream.WriteBuffer(FileHeader, SizeOf(FileHeader));
  10326.  
  10327.   {  Image writing  }
  10328.   BlockHeaderWriter := TDXTextureImageFileBlockHeaderWriter.Create(Stream);
  10329.   try
  10330.     {  Image writing  }
  10331.     WriteGroup_Image(Image);
  10332.  
  10333.     {  End of file  }
  10334.     BlockHeaderWriter.WriteBlock(DXTextureImageFileBlockID_EndFile);
  10335.   finally
  10336.     BlockHeaderWriter.Free;
  10337.   end;
  10338. end;
  10339.  
  10340. {  DXTextureImage_LoadBitmapFunc  }
  10341.  
  10342. procedure DXTextureImage_LoadBitmapFunc(Stream: TStream; Image: TDXTextureImage);
  10343. type
  10344.   TDIBPixelFormat = packed record
  10345.     RBitMask, GBitMask, BBitMask: DWORD;
  10346.   end;
  10347. var
  10348.   TopDown: Boolean;
  10349.   BF: TBitmapFileHeader;
  10350.   BI: TBitmapInfoHeader;
  10351.  
  10352.   procedure DecodeRGB;
  10353.   var
  10354.     y: Integer;
  10355.   begin
  10356.     for y := 0 to Image.Height - 1 do
  10357.     begin
  10358.       if TopDown then
  10359.         Stream.ReadBuffer(Image.ScanLine[y]^, Image.WidthBytes)
  10360.       else
  10361.         Stream.ReadBuffer(Image.ScanLine[Image.Height - y - 1]^, Image.WidthBytes);
  10362.     end;
  10363.   end;
  10364.  
  10365.   procedure DecodeRLE4;
  10366.   var
  10367.     SrcDataP: Pointer;
  10368.     B1, B2, C: Byte;
  10369.     Dest, Src, P: PByte;
  10370.     X, Y, i: Integer;
  10371.   begin
  10372.     GetMem(SrcDataP, BI.biSizeImage);
  10373.     try
  10374.       Stream.ReadBuffer(SrcDataP^, BI.biSizeImage);
  10375.  
  10376.       Dest := Image.TopPBits;
  10377.       Src := SrcDataP;
  10378.       X := 0;
  10379.       Y := 0;
  10380.  
  10381.       while True do
  10382.       begin
  10383.         B1 := Src^; Inc(Src);
  10384.         B2 := Src^; Inc(Src);
  10385.  
  10386.         if B1 = 0 then
  10387.         begin
  10388.           case B2 of
  10389.             0: begin {  End of line  }
  10390.                 X := 0; Inc(Y);
  10391.                 Dest := Image.ScanLine[Y];
  10392.               end;
  10393.             1: Break; {  End of bitmap  }
  10394.             2: begin {  Difference of coordinates  }
  10395.                 Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
  10396.                 Dest := Image.ScanLine[Y];
  10397.               end;
  10398.           else
  10399.             {  Absolute mode  }
  10400.             C := 0;
  10401.             for i := 0 to B2 - 1 do
  10402.             begin
  10403.               if i and 1 = 0 then
  10404.               begin
  10405.                 C := Src^; Inc(Src);
  10406.               end
  10407.               else
  10408.               begin
  10409.                 C := C shl 4;
  10410.               end;
  10411.  
  10412.               P := Pointer(Integer(Dest) + X shr 1);
  10413.               if X and 1 = 0 then
  10414.                 P^ := (P^ and $0F) or (C and $F0)
  10415.               else
  10416.                 P^ := (P^ and $F0) or ((C and $F0) shr 4);
  10417.  
  10418.               Inc(X);
  10419.             end;
  10420.           end;
  10421.         end
  10422.         else
  10423.         begin
  10424.           {  Encoding mode  }
  10425.           for i := 0 to B1 - 1 do
  10426.           begin
  10427.             P := Pointer(Integer(Dest) + X shr 1);
  10428.             if X and 1 = 0 then
  10429.               P^ := (P^ and $0F) or (B2 and $F0)
  10430.             else
  10431.               P^ := (P^ and $F0) or ((B2 and $F0) shr 4);
  10432.  
  10433.             Inc(X);
  10434.  
  10435.             // Swap nibble
  10436.             B2 := (B2 shr 4) or (B2 shl 4);
  10437.           end;
  10438.         end;
  10439.  
  10440.         {  Word arrangement  }
  10441.         Inc(Src, Longint(Src) and 1);
  10442.       end;
  10443.     finally
  10444.       FreeMem(SrcDataP);
  10445.     end;
  10446.   end;
  10447.  
  10448.   procedure DecodeRLE8;
  10449.   var
  10450.     SrcDataP: Pointer;
  10451.     B1, B2: Byte;
  10452.     Dest, Src: PByte;
  10453.     X, Y: Integer;
  10454.   begin
  10455.     GetMem(SrcDataP, BI.biSizeImage);
  10456.     try
  10457.       Stream.ReadBuffer(SrcDataP^, BI.biSizeImage);
  10458.  
  10459.       Dest := Image.TopPBits;
  10460.       Src := SrcDataP;
  10461.       X := 0;
  10462.       Y := 0;
  10463.  
  10464.       while True do
  10465.       begin
  10466.         B1 := Src^; Inc(Src);
  10467.         B2 := Src^; Inc(Src);
  10468.  
  10469.         if B1 = 0 then
  10470.         begin
  10471.           case B2 of
  10472.             0: begin {  End of line  }
  10473.                 X := 0; Inc(Y);
  10474.                 Dest := Pointer(Longint(Image.TopPBits) + Y * Image.NextLine + X);
  10475.               end;
  10476.             1: Break; {  End of bitmap  }
  10477.             2: begin {  Difference of coordinates  }
  10478.                 Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
  10479.                 Dest := Pointer(Longint(Image.TopPBits) + Y * Image.NextLine + X);
  10480.               end;
  10481.           else
  10482.             {  Absolute mode  }
  10483.             Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
  10484.           end;
  10485.         end
  10486.         else
  10487.         begin
  10488.           {  Encoding mode  }
  10489.           FillChar(Dest^, B1, B2); Inc(Dest, B1);
  10490.         end;
  10491.  
  10492.         {  Word arrangement  }
  10493.         Inc(Src, Longint(Src) and 1);
  10494.       end;
  10495.     finally
  10496.       FreeMem(SrcDataP);
  10497.     end;
  10498.   end;
  10499.  
  10500. var
  10501.   BC: TBitmapCoreHeader;
  10502.   RGBTriples: array[0..255] of TRGBTriple;
  10503.   RGBQuads: array[0..255] of TRGBQuad;
  10504.   i, PalCount, j: Integer;
  10505.   OS2: Boolean;
  10506.   PixelFormat: TDIBPixelFormat;
  10507. begin
  10508.   {  File header reading  }
  10509.   i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
  10510.   if i = 0 then Exit;
  10511.   if i <> SizeOf(TBitmapFileHeader) then
  10512.     raise EDXTextureImageError.Create(SInvalidDIB);
  10513.  
  10514.   {  Is the head 'BM'?  }
  10515.   if BF.bfType <> Ord('B') + Ord('M') * $100 then
  10516.     raise EDXTextureImageError.Create(SInvalidDIB);
  10517.  
  10518.   {  Reading of size of header  }
  10519.   i := Stream.Read(BI.biSize, 4);
  10520.   if i <> 4 then
  10521.     raise EDXTextureImageError.Create(SInvalidDIB);
  10522.  
  10523.   {  Kind check of DIB  }
  10524.   OS2 := False;
  10525.  
  10526.   case BI.biSize of
  10527.     SizeOf(TBitmapCoreHeader):
  10528.       begin
  10529.         {  OS/2 type  }
  10530.         Stream.ReadBuffer(Pointer(Integer(@BC) + 4)^, SizeOf(TBitmapCoreHeader) - 4);
  10531.  
  10532.         FilLChar(BI, SizeOf(BI), 0);
  10533.         with BI do
  10534.         begin
  10535.           biClrUsed := 0;
  10536.           biCompression := BI_RGB;
  10537.           biBitCount := BC.bcBitCount;
  10538.           biHeight := BC.bcHeight;
  10539.           biWidth := BC.bcWidth;
  10540.         end;
  10541.  
  10542.         OS2 := True;
  10543.       end;
  10544.     SizeOf(TBitmapInfoHeader):
  10545.       begin
  10546.         {  Windows type  }
  10547.         Stream.ReadBuffer(Pointer(Integer(@BI) + 4)^, SizeOf(TBitmapInfoHeader) - 4);
  10548.       end;
  10549.   else
  10550.     raise EDXTextureImageError.Create(SInvalidDIB);
  10551.   end;
  10552.  
  10553.   {  Bit mask reading  }
  10554.   if BI.biCompression = BI_BITFIELDS then
  10555.   begin
  10556.     Stream.ReadBuffer(PixelFormat, SizeOf(PixelFormat));
  10557.   end
  10558.   else
  10559.   begin
  10560.     if BI.biBitCount = 16 then
  10561.     begin
  10562.       PixelFormat.RBitMask := $7C00;
  10563.       PixelFormat.GBitMask := $03E0;
  10564.       PixelFormat.BBitMask := $001F;
  10565.     end else if (BI.biBitCount = 24) or (BI.biBitCount = 32) then
  10566.     begin
  10567.       PixelFormat.RBitMask := $00FF0000;
  10568.       PixelFormat.GBitMask := $0300FF00;
  10569.       PixelFormat.BBitMask := $000000FF;
  10570.     end;
  10571.   end;
  10572.  
  10573.   {  DIB making  }
  10574.   if BI.biHeight < 0 then
  10575.   begin
  10576.     BI.biHeight := -BI.biHeight;
  10577.     TopDown := True;
  10578.   end
  10579.   else
  10580.     TopDown := False;
  10581.  
  10582.   if BI.biBitCount in [1, 4, 8] then
  10583.   begin
  10584.     Image.SetSize(DXTextureImageType_PaletteIndexedColor, BI.biWidth, BI.biHeight, BI.biBitCount,
  10585.       (((BI.biWidth * BI.biBitCount) + 31) div 32) * 4);
  10586.  
  10587.     Image.idx_index := dxtMakeChannel(1 shl BI.biBitCount - 1, True);
  10588.     Image.PackedPixelOrder := True;
  10589.   end
  10590.   else
  10591.   begin
  10592.     Image.SetSize(DXTextureImageType_RGBColor, BI.biWidth, BI.biHeight, BI.biBitCount,
  10593.       (((BI.biWidth * BI.biBitCount) + 31) div 32) * 4);
  10594.  
  10595.     Image.rgb_red := dxtMakeChannel(PixelFormat.RBitMask, False);
  10596.     Image.rgb_green := dxtMakeChannel(PixelFormat.GBitMask, False);
  10597.     Image.rgb_blue := dxtMakeChannel(PixelFormat.BBitMask, False);
  10598.  
  10599.     j := Image.rgb_red.BitCount + Image.rgb_green.BitCount + Image.rgb_blue.BitCount;
  10600.     if j < BI.biBitCount then
  10601.       Image.rgb_alpha := dxtMakeChannel((1 shl (BI.biBitCount - j) - 1) shl j, False);
  10602.  
  10603.     Image.PackedPixelOrder := False;
  10604.   end;
  10605.  
  10606.   {  palette reading  }
  10607.   PalCount := BI.biClrUsed;
  10608.   if (PalCount = 0) and (BI.biBitCount <= 8) then
  10609.     PalCount := 1 shl BI.biBitCount;
  10610.   if PalCount > 256 then PalCount := 256;
  10611.  
  10612.   if OS2 then
  10613.   begin
  10614.     {  OS/2 type  }
  10615.     Stream.ReadBuffer(RGBTriples, SizeOf(TRGBTriple) * PalCount);
  10616.     for i := 0 to PalCount - 1 do
  10617.     begin
  10618.       Image.idx_palette[i].peRed := RGBTriples[i].rgbtRed;
  10619.       Image.idx_palette[i].peGreen := RGBTriples[i].rgbtGreen;
  10620.       Image.idx_palette[i].peBlue := RGBTriples[i].rgbtBlue;
  10621.     end;
  10622.   end
  10623.   else
  10624.   begin
  10625.     {  Windows type  }
  10626.     Stream.ReadBuffer(RGBQuads, SizeOf(TRGBQuad) * PalCount);
  10627.     for i := 0 to PalCount - 1 do
  10628.     begin
  10629.       Image.idx_palette[i].peRed := RGBQuads[i].rgbRed;
  10630.       Image.idx_palette[i].peGreen := RGBQuads[i].rgbGreen;
  10631.       Image.idx_palette[i].peBlue := RGBQuads[i].rgbBlue;
  10632.     end;
  10633.   end;
  10634.  
  10635.   {  Pixel data reading  }
  10636.   case BI.biCompression of
  10637.     BI_RGB: DecodeRGB;
  10638.     BI_BITFIELDS: DecodeRGB;
  10639.     BI_RLE4: DecodeRLE4;
  10640.     BI_RLE8: DecodeRLE8;
  10641.   else
  10642.     raise EDXTextureImageError.Create(SInvalidDIB);
  10643.   end;
  10644. end;
  10645.  
  10646. { TDXTBase }
  10647.  
  10648. //Note by JB.
  10649. //This class is supplement of original Hori's code.
  10650. //For use alphablend you can have a bitmap 32 bit RGBA
  10651. //when isn't alphachannel present, it works like RGB 24bit
  10652.  
  10653. //functions required actualized DIB source for works with alphachannel
  10654.  
  10655. function TDXTBase.GetCompression: TDXTextureImageFileCompressType;
  10656. begin
  10657.   Result := FParamsFormat.Compress;
  10658. end;
  10659.  
  10660. procedure TDXTBase.SetCompression(const Value: TDXTextureImageFileCompressType);
  10661. begin
  10662.   FParamsFormat.Compress := Value;
  10663. end;
  10664.  
  10665. function TDXTBase.GetWidth: Integer;
  10666. begin
  10667.   Result := FParamsFormat.Width;
  10668. end;
  10669.  
  10670. procedure TDXTBase.SetWidth(const Value: Integer);
  10671. begin
  10672.   FParamsFormat.Width := Value;
  10673. end;
  10674.  
  10675. function TDXTBase.GetMipmap: Integer;
  10676. begin
  10677.   Result := FParamsFormat.MipmapCount;
  10678. end;
  10679.  
  10680. procedure TDXTBase.SetMipmap(const Value: Integer);
  10681. begin
  10682.   if Value = -1 then
  10683.     FParamsFormat.MipmapCount := MaxInt
  10684.   else
  10685.     FParamsFormat.MipmapCount := Value;
  10686. end;
  10687.  
  10688. function TDXTBase.GetTransparentColor: TColorRef;
  10689. begin
  10690.   Result := FParamsFormat.TransparentColor;
  10691. end;
  10692.  
  10693. procedure TDXTBase.SetTransparentColor(const Value: TColorRef);
  10694. begin
  10695.   FParamsFormat.Transparent := True;
  10696.   FParamsFormat.TransparentColor := RGB(Value shr 16, Value shr 8, Value);
  10697. end;
  10698.  
  10699. procedure TDXTBase.SetTransparentColorIndexed(const Value: TColorRef);
  10700. begin
  10701.   FParamsFormat.TransparentColor := PaletteIndex(Value);
  10702. end;
  10703.  
  10704. function TDXTBase.GetHeight: Integer;
  10705. begin
  10706.   Result := FParamsFormat.Height;
  10707. end;
  10708.  
  10709. procedure TDXTBase.SetHeight(const Value: Integer);
  10710. begin
  10711.   FParamsFormat.Height := Value;
  10712. end;
  10713.  
  10714. procedure TDXTBase.SetChannelY(T: TDIB);
  10715. begin
  10716.  
  10717. end;
  10718.  
  10719. procedure TDXTBase.LoadChannelRGBFromFile(const FileName: string);
  10720. begin
  10721.   FStrImageFileName := FileName;
  10722.   try
  10723.     EvaluateChannels([rgbRed, rgbGreen, rgbBlue], '', '');
  10724.   finally
  10725.     FStrImageFileName := '';
  10726.   end;
  10727. end;
  10728.  
  10729. function TDXTBase.LoadFromFile(iFilename: string): Boolean;
  10730. begin
  10731.   Result := FileExists(iFilename);
  10732.   if Result then
  10733.   try
  10734.     Texture.LoadFromFile(iFileName);
  10735.   except
  10736.     Result := False;
  10737.   end;
  10738. end;
  10739.  
  10740. procedure TDXTBase.LoadChannelAFromFile(const FileName: string);
  10741. begin
  10742.   FStrImageFileName := FileName;
  10743.   try
  10744.     EvaluateChannels([rgbAlpha], '', '');
  10745.   finally
  10746.     FStrImageFileName := '';
  10747.   end;
  10748. end;
  10749.  
  10750. constructor TDXTBase.Create;
  10751. var
  10752.   Channel: TDXTImageChannel;
  10753. begin
  10754.   FillChar(Channel, SizeOf(Channel), 0);
  10755.   FilLChar(FParamsFormat, SizeOf(FParamsFormat), 0);
  10756.   FParamsFormat.Compress := DXTextureImageFileCompressType_None;
  10757.   FHasImageList := TList.Create;
  10758.   for Channel := Low(Channel) to High(Channel) do
  10759.     FChannelChangeTable[Channel] := Channel;
  10760.   FChannelChangeTable[rgbAlpha] := yuvY;
  10761.   FDIB := nil;
  10762.   FStrImageFileName := '';
  10763. end;
  10764.  
  10765. procedure TDXTBase.SetChannelRGBA(T: TDIB);
  10766. begin
  10767.   FDIB := T;
  10768.   try
  10769.     EvaluateChannels([rgbRed, rgbGreen, rgbBlue, rgbAlpha], '', '');
  10770.   finally
  10771.     FDIB := nil;
  10772.   end;
  10773. end;
  10774.  
  10775. procedure TDXTBase.BuildImage(Image: TDXTextureImage);
  10776. type
  10777.   TOutputImageChannelInfo2 = record
  10778.     Image: TDXTextureImage;
  10779.     Channels: TDXTImageChannels;
  10780.   end;
  10781. var
  10782.   cR, cG, cB: Byte;
  10783.  
  10784.   function GetChannelVal(const Channel: TDXTextureImageChannel; SrcChannel: TDXTImageChannel): DWORD;
  10785.   begin
  10786.     case SrcChannel of
  10787.       rgbRed: Result := dxtEncodeChannel(Channel, cR);
  10788.       rgbGreen: Result := dxtEncodeChannel(Channel, cG);
  10789.       rgbBlue: Result := dxtEncodeChannel(Channel, cB);
  10790.       yuvY: Result := dxtEncodeChannel(Channel, (cR * 306 + cG * 602 + cB * 116) div 1024);
  10791.     else Result := 0;
  10792.     end;
  10793.   end;
  10794.  
  10795. var
  10796.   HasImageChannelList: array[0..Ord(High(TDXTImageChannel)) + 1] of TOutputImageChannelInfo2;
  10797.   HasImageChannelListCount: Integer;
  10798.   x, y, i: Integer;
  10799.   c, c2, c3: DWORD;
  10800.   Channel: TDXTImageChannel;
  10801.   Flag: Boolean;
  10802.  
  10803.   SrcImage: TDXTextureImage;
  10804.   UseChannels: TDXTImageChannels;
  10805. begin
  10806.   HasImageChannelListCount := 0;
  10807.   for Channel := Low(Channel) to High(Channel) do
  10808.     if Channel in FHasChannels then
  10809.     begin
  10810.       Flag := False;
  10811.       for i := 0 to HasImageChannelListCount - 1 do
  10812.         if HasImageChannelList[i].Image = FHasChannelImages[Channel].Image then
  10813.         begin
  10814.           HasImageChannelList[i].Channels := HasImageChannelList[i].Channels + [Channel];
  10815.           Flag := True;
  10816.           Break;
  10817.         end;
  10818.       if not Flag then
  10819.       begin
  10820.         HasImageChannelList[HasImageChannelListCount].Image := FHasChannelImages[Channel].Image;
  10821.         HasImageChannelList[HasImageChannelListCount].Channels := [Channel];
  10822.         Inc(HasImageChannelListCount);
  10823.       end;
  10824.     end;
  10825.  
  10826.   cR := 0;
  10827.   cG := 0;
  10828.   cB := 0;
  10829.  
  10830.   if Image.ImageType = DXTextureImageType_PaletteIndexedColor then
  10831.   begin
  10832.     {  Index color  }
  10833.     for y := 0 to Image.Height - 1 do
  10834.       for x := 0 to Image.Width - 1 do
  10835.       begin
  10836.         c := 0;
  10837.  
  10838.         for i := 0 to HasImageChannelListCount - 1 do
  10839.         begin
  10840.           SrcImage := HasImageChannelList[i].Image;
  10841.           UseChannels := HasImageChannelList[i].Channels;
  10842.  
  10843.           case SrcImage.ImageType of
  10844.             DXTextureImageType_PaletteIndexedColor:
  10845.               begin
  10846.                 c2 := SrcImage.Pixels[x, y];
  10847.                 c3 := dxtDecodeChannel(SrcImage.idx_index, c2);
  10848.  
  10849.                 if rgbRed in UseChannels then
  10850.                   c := c or dxtEncodeChannel(Image.idx_index, c3);
  10851.  
  10852.                 cR := SrcImage.idx_palette[c3].peRed;
  10853.                 cG := SrcImage.idx_palette[c3].peGreen;
  10854.                 cB := SrcImage.idx_palette[c3].peBlue;
  10855.               end;
  10856.             DXTextureImageType_RGBColor:
  10857.               begin
  10858.                 c2 := SrcImage.Pixels[x, y];
  10859.  
  10860.                 cR := dxtDecodeChannel(SrcImage.rgb_red, c2);
  10861.                 cG := dxtDecodeChannel(SrcImage.rgb_green, c2);
  10862.                 cB := dxtDecodeChannel(SrcImage.rgb_blue, c2);
  10863.               end;
  10864.           end;
  10865.  
  10866.           if rgbAlpha in UseChannels then
  10867.             c := c or GetChannelVal(Image.idx_alpha, FChannelChangeTable[rgbAlpha]);
  10868.         end;
  10869.  
  10870.         Image.Pixels[x, y] := c;
  10871.       end;
  10872.   end
  10873.   else
  10874.     if Image.ImageType = DXTextureImageType_RGBColor then
  10875.     begin
  10876.     {  RGB color  }
  10877.       for y := 0 to Image.Height - 1 do
  10878.         for x := 0 to Image.Width - 1 do
  10879.         begin
  10880.           c := 0;
  10881.  
  10882.           for i := 0 to HasImageChannelListCount - 1 do
  10883.           begin
  10884.             SrcImage := HasImageChannelList[i].Image;
  10885.             UseChannels := HasImageChannelList[i].Channels;
  10886.  
  10887.             case SrcImage.ImageType of
  10888.               DXTextureImageType_PaletteIndexedColor:
  10889.                 begin
  10890.                   c2 := SrcImage.Pixels[x, y];
  10891.                   c3 := dxtDecodeChannel(SrcImage.idx_index, c2);
  10892.  
  10893.                   cR := SrcImage.idx_palette[c3].peRed;
  10894.                   cG := SrcImage.idx_palette[c3].peGreen;
  10895.                   cB := SrcImage.idx_palette[c3].peBlue;
  10896.                 end;
  10897.               DXTextureImageType_RGBColor:
  10898.                 begin
  10899.                   c2 := SrcImage.Pixels[x, y];
  10900.  
  10901.                   cR := dxtDecodeChannel(SrcImage.rgb_red, c2);
  10902.                   cG := dxtDecodeChannel(SrcImage.rgb_green, c2);
  10903.                   cB := dxtDecodeChannel(SrcImage.rgb_blue, c2);
  10904.                 end;
  10905.             end;
  10906.  
  10907.             if rgbRed in UseChannels then
  10908.               c := c or GetChannelVal(Image.rgb_red, FChannelChangeTable[rgbRed]);
  10909.             if rgbGreen in UseChannels then
  10910.               c := c or GetChannelVal(Image.rgb_green, FChannelChangeTable[rgbGreen]);
  10911.             if rgbBlue in UseChannels then
  10912.               c := c or GetChannelVal(Image.rgb_Blue, FChannelChangeTable[rgbBlue]);
  10913.             if rgbAlpha in UseChannels then
  10914.               c := c or GetChannelVal(Image.rgb_alpha, FChannelChangeTable[rgbAlpha]);
  10915.           end;
  10916.  
  10917.           Image.Pixels[x, y] := c;
  10918.         end;
  10919.     end;
  10920. end;
  10921.  
  10922. procedure TDXTBase.SetChannelR(T: TDIB);
  10923. begin
  10924.   FDIB := T;
  10925.   try
  10926.     EvaluateChannels([rgbRed], '', '');
  10927.   finally
  10928.     FDIB := nil;
  10929.   end;
  10930. end;
  10931.  
  10932. function GetBitCount(b: Integer): Integer;
  10933. begin
  10934.   Result := 32;
  10935.   while (Result > 0) and (((1 shl (Result - 1)) and b) = 0) do Dec(Result);
  10936. end;
  10937.  
  10938. procedure TDXTBase.CalcOutputBitFormat;
  10939. var
  10940.   BitCount: DWORD;
  10941.   NewWidth, NewHeight, i, j: Integer;
  10942.   Channel: TDXTImageChannel;
  10943. begin
  10944.   {  Size calculation  }
  10945.   NewWidth := 1 shl GetBitCount(TDXTextureImage(FHasImageList[0]).Width);
  10946.   NewHeight := 1 shl GetBitCount(TDXTextureImage(FHasImageList[0]).Height);
  10947.   NewWidth := Max(NewWidth, NewHeight);
  10948.   NewHeight := NewWidth;
  10949.   if Abs(FParamsFormat.Width - NewWidth) > Abs(FParamsFormat.Width - NewWidth div 2) then
  10950.     NewWidth := NewWidth div 2;
  10951.   if Abs(FParamsFormat.Height - NewHeight) > Abs(FParamsFormat.Height - NewHeight div 2) then
  10952.     NewHeight := NewHeight div 2;
  10953.  
  10954.   if FParamsFormat.Width = 0 then FParamsFormat.Width := NewWidth;
  10955.   if FParamsFormat.Height = 0 then FParamsFormat.Height := NewHeight;
  10956.  
  10957.   {  Other several calculation  }
  10958.   i := Min(FParamsFormat.Width, FParamsFormat.Height);
  10959.   j := 0;
  10960.   while i > 1 do
  10961.   begin
  10962.     i := i div 2;
  10963.     Inc(j);
  10964.   end;
  10965.  
  10966.   FParamsFormat.MipmapCount := Min(j, FParamsFormat.MipmapCount);
  10967.  
  10968.   {  Output type calculation  }
  10969.   if (FHasChannelImages[rgbRed].Image = FHasChannelImages[rgbGreen].Image) and
  10970.     (FHasChannelImages[rgbRed].Image = FHasChannelImages[rgbBlue].Image) and
  10971.     (FHasChannelImages[rgbRed].Image <> nil) and
  10972.     (FHasChannelImages[rgbRed].Image.ImageType = DXTextureImageType_PaletteIndexedColor) and
  10973.  
  10974.     (FHasChannelImages[rgbRed].BitCount = 8) and
  10975.     (FHasChannelImages[rgbGreen].BitCount = 8) and
  10976.     (FHasChannelImages[rgbBlue].BitCount = 8) and
  10977.  
  10978.     (FChannelChangeTable[rgbRed] = rgbRed) and
  10979.     (FChannelChangeTable[rgbGreen] = rgbGreen) and
  10980.     (FChannelChangeTable[rgbBlue] = rgbBlue) and
  10981.  
  10982.     (FParamsFormat.Width = FHasChannelImages[rgbRed].Image.Width) and
  10983.     (FParamsFormat.Height = FHasChannelImages[rgbRed].Image.Height) and
  10984.  
  10985.     (FParamsFormat.MipmapCount = 0)
  10986.   then
  10987.   begin
  10988.     FParamsFormat.ImageType := DXTextureImageType_PaletteIndexedColor;
  10989.   end
  10990.   else
  10991.     FParamsFormat.ImageType := DXTextureImageType_RGBColor;
  10992.  
  10993.   {  Bit several calculations  }
  10994.   FParamsFormat.BitCount := 0;
  10995.  
  10996.   for Channel := Low(TDXTImageChannel) to High(TDXTImageChannel) do
  10997.     if (FHasChannelImages[Channel].Image <> nil) and (FHasChannelImages[Channel].Image.ImageType = DXTextureImageType_PaletteIndexedColor) then
  10998.     begin
  10999.       FParamsFormat.idx_palette := FHasChannelImages[Channel].Image.idx_palette;
  11000.       Break;
  11001.     end;
  11002.  
  11003.   if FParamsFormat.ImageType = DXTextureImageType_PaletteIndexedColor then
  11004.   begin
  11005.     {  Index channel }
  11006.     if rgbRed in FHasChannels then
  11007.     begin
  11008.       BitCount := FHasChannelImages[rgbRed].BitCount;
  11009.       FParamsFormat.idx_index := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, True);
  11010.       Inc(FParamsFormat.BitCount, BitCount);
  11011.     end;
  11012.  
  11013.     {  Alpha channel  }
  11014.     if rgbAlpha in FHasChannels then
  11015.     begin
  11016.       BitCount := FHasChannelImages[rgbAlpha].BitCount;
  11017.       FParamsFormat.idx_alpha := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
  11018.       Inc(FParamsFormat.BitCount, BitCount);
  11019.     end;
  11020.   end
  11021.   else
  11022.   begin
  11023.     {  B channel }
  11024.     if rgbBlue in FHasChannels then
  11025.     begin
  11026.       BitCount := FHasChannelImages[rgbBlue].BitCount;
  11027.       FParamsFormat.rgb_blue := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
  11028.       Inc(FParamsFormat.BitCount, BitCount);
  11029.     end;
  11030.  
  11031.     {  G channel }
  11032.     if rgbGreen in FHasChannels then
  11033.     begin
  11034.       BitCount := FHasChannelImages[rgbGreen].BitCount;
  11035.       FParamsFormat.rgb_green := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
  11036.       Inc(FParamsFormat.BitCount, BitCount);
  11037.     end;
  11038.  
  11039.     {  R channel }
  11040.     if rgbRed in FHasChannels then
  11041.     begin
  11042.       BitCount := FHasChannelImages[rgbRed].BitCount;
  11043.       FParamsFormat.rgb_red := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
  11044.       Inc(FParamsFormat.BitCount, BitCount);
  11045.     end;
  11046.  
  11047.     {  Alpha channel }
  11048.     if rgbAlpha in FHasChannels then
  11049.     begin
  11050.       BitCount := FHasChannelImages[rgbAlpha].BitCount;
  11051.       FParamsFormat.rgb_alpha := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
  11052.       Inc(FParamsFormat.BitCount, BitCount);
  11053.     end;
  11054.   end;
  11055.  
  11056.   {  As for the number of bits only either of 1, 2, 4, 8, 16, 24, 32  }
  11057.   if FParamsFormat.BitCount in [3] then
  11058.     FParamsFormat.BitCount := 4
  11059.   else
  11060.   if FParamsFormat.BitCount in [5..7] then
  11061.     FParamsFormat.BitCount := 8
  11062.   else
  11063.   if FParamsFormat.BitCount in [9..15] then
  11064.     FParamsFormat.BitCount := 16
  11065.   else
  11066.   if FParamsFormat.BitCount in [17..23] then
  11067.     FParamsFormat.BitCount := 24
  11068.   else
  11069.   if FParamsFormat.BitCount in [25..31] then
  11070.     FParamsFormat.BitCount := 32;
  11071.  
  11072.   {  Transparent color  }
  11073.   if (FParamsFormat.ImageType = DXTextureImageType_RGBColor) and (FParamsFormat.TransparentColor shr 24 = $01) then
  11074.   begin
  11075.     FParamsFormat.TransparentColor := RGB(FParamsFormat.idx_palette[Byte(FParamsFormat.TransparentColor)].peRed,
  11076.       FParamsFormat.idx_palette[Byte(FParamsFormat.TransparentColor)].peGreen,
  11077.       FParamsFormat.idx_palette[Byte(FParamsFormat.TransparentColor)].peBlue);
  11078.   end;
  11079. end;
  11080.  
  11081. procedure TDXTBase.LoadChannelRGBAFromFile(const FileName: string);
  11082. begin
  11083.   FStrImageFileName := FileName;
  11084.   try
  11085.     EvaluateChannels([rgbRed, rgbGreen, rgbBlue, rgbAlpha], '', '');
  11086.   finally
  11087.     FStrImageFileName := '';
  11088.   end;
  11089. end;
  11090.  
  11091. procedure TDXTBase.SetChannelB(T: TDIB);
  11092. begin
  11093.   FDIB := T;
  11094.   try
  11095.     EvaluateChannels([rgbBlue], '', '');
  11096.   finally
  11097.     FDIB := nil;
  11098.   end;
  11099. end;
  11100.  
  11101. procedure TDXTBase.SetChannelRGB(T: TDIB);
  11102. begin
  11103.   FDIB := T;
  11104.   try
  11105.     EvaluateChannels([rgbRed, rgbGreen, rgbBlue], '', '');
  11106.   finally
  11107.     FDIB := nil;
  11108.   end;
  11109. end;
  11110.  
  11111. procedure TDXTBase.SaveToFile(iFilename: string {$IFDEF VER4UP} = ''{$ENDIF});
  11112. var
  11113.   Image: TDXTextureImage;
  11114. begin
  11115.   {  Create output stream  }
  11116.   Image := Self.Texture;
  11117.   if (FHasImageList.Count > 0) and Assigned(Image) then
  11118.   begin
  11119.     if iFilename <> '' then
  11120.       Image.SaveToFile(iFilename)
  11121.     else
  11122.       Image.SaveToFile(FParamsFormat.Name + '.dxt');
  11123.   end;
  11124. end;
  11125.  
  11126. procedure TDXTBase.SetChannelA(T: TDIB);
  11127. begin
  11128.   FDIB := T;
  11129.   try
  11130.     EvaluateChannels([rgbAlpha], '', '');
  11131.   finally
  11132.     FDIB := nil;
  11133.   end;
  11134. end;
  11135.  
  11136. procedure TDXTBase.SetChannelG(T: TDIB);
  11137. begin
  11138.   FDIB := T;
  11139.   try
  11140.     EvaluateChannels([rgbGreen], '', '');
  11141.   finally
  11142.     FDIB := nil;
  11143.   end;
  11144. end;
  11145.  
  11146. destructor TDXTBase.Destroy;
  11147. var I: Integer;
  11148. begin
  11149.   for I := 0 to FHasImageList.Count - 1 do
  11150.     TDXTextureImage(FHasImageList[I]).Free;
  11151.   FHasImageList.Free;
  11152.   inherited Destroy;
  11153. end;
  11154.  
  11155. function TDXTBase.GetPicture: TDXTextureImage;
  11156. var
  11157.   MemoryStream: TMemoryStream;
  11158. begin
  11159.   Result := TDXTextureImage.Create;
  11160.   try
  11161.     if (FStrImageFileName <> '') and FileExists(FStrImageFileName) then
  11162.     begin
  11163.       Result.LoadFromFile(FStrImageFileName);
  11164.       Result.FImageName := ExtractFilename(FStrImageFileName);
  11165.     end
  11166.     else
  11167.       if Assigned(FDIB) then
  11168.       begin
  11169.         MemoryStream := TMemoryStream.Create;
  11170.         try
  11171.           FDIB.SaveToStream(MemoryStream);
  11172.           MemoryStream.Position := 0; //reading from 0
  11173.           Result.LoadFromStream(MemoryStream);
  11174.         finally
  11175.           MemoryStream.Free;
  11176.         end;
  11177.         Result.FImageName := Format('DIB%x', [Integer(Result)]); //supplement name
  11178.       end;
  11179.   except
  11180.     on E: Exception do
  11181.     begin
  11182.       EDXTBaseError.Create(E.Message);
  11183.     end;
  11184.   end
  11185. end;
  11186.  
  11187. procedure TDXTBase.Resize(Image: TDXTextureImage; NewWidth, NewHeight: Integer;
  11188.   FilterTypeResample: TFilterTypeResample);
  11189.   //resize used for Mipmap
  11190. var
  11191.   DIB: TDIB;
  11192.   x, y: Integer;
  11193.   c: DWORD;
  11194.   MemoryStream: TMemoryStream;
  11195. begin
  11196.   {  Exit when no resize  }
  11197.   if (Image.Width = NewWidth) and (Image.Height = NewHeight) then Exit;
  11198.   {  Supplement for image resizing  }
  11199.   //raise EDXTBaseError.Create('Invalid image size for texture.');
  11200.   {  No image at start  }
  11201.   DIB := TDIB.Create; //DIB accept
  11202.   try
  11203.     DIB.SetSize(Image.Width, Image.Height, Image.BitCount);
  11204.     {  of type  }
  11205.     for y := 0 to Image.Height - 1 do
  11206.       for x := 0 to Image.Width - 1 do
  11207.       begin
  11208.         if Image.ImageType = DXTextureImageType_PaletteIndexedColor then
  11209.         begin
  11210.           c := dxtDecodeChannel(Image.idx_index, Image.Pixels[x, y]);
  11211.           DIB.Pixels[x, y] := (Image.idx_palette[c].peRed shl 16) or
  11212.             (Image.idx_palette[c].peGreen shl 8) or
  11213.             Image.idx_palette[c].peBlue;
  11214.         end
  11215.         else begin
  11216.           c := Image.Pixels[x, y];
  11217.           DIB.Pixels[x, y] := (dxtDecodeChannel(Image.rgb_red, c) shl 16) or
  11218.             (dxtDecodeChannel(Image.rgb_green, c) shl 8) or
  11219.             dxtDecodeChannel(Image.rgb_blue, c);
  11220.         end;
  11221.       end;
  11222.  
  11223.     {  Resize for 24 bitcount deep }
  11224.     Image.SetSize(DXTextureImageType_RGBColor, Width, Height, Image.BitCount, 0);
  11225.  
  11226.     Image.rgb_red := dxtMakeChannel($FF0000, False);
  11227.     Image.rgb_green := dxtMakeChannel($00FF00, False);
  11228.     Image.rgb_blue := dxtMakeChannel($0000FF, False);
  11229.     Image.rgb_alpha := dxtMakeChannel(0, False);
  11230.  
  11231.     {  Resample routine DIB based there  }
  11232.     DIB.DoResample(Width, Height, FilterTypeResample);
  11233.  
  11234.     {Image returned through stream}
  11235.     Image.ClearImage;
  11236.     MemoryStream := TMemoryStream.Create;
  11237.     try
  11238.       DIB.SaveToStream(MemoryStream);
  11239.       MemoryStream.Position := 0; //from first byte
  11240.       Image.LoadFromStream(MemoryStream);
  11241.     finally
  11242.       MemoryStream.Free;
  11243.     end;
  11244.   finally
  11245.     DIB.Free;
  11246.   end;
  11247. end;
  11248.  
  11249. procedure TDXTBase.EvaluateChannels
  11250.   (const CheckChannelUsed: TDXTImageChannels;
  11251.   const CheckChannelChanged, CheckBitCountForChannel: string);
  11252. var J: Integer;
  11253.   Channel: TDXTImageChannel;
  11254.   ChannelBitCount: array[TDXTImageChannel] of Integer;
  11255.   ChannelParamName: TDXTImageChannels;
  11256.   Image: TDXTextureImage;
  11257.   Q: TDXTImageChannel;
  11258. begin
  11259.   Fillchar(ChannelBitCount, SizeOf(ChannelBitCount), 0);
  11260.   ChannelParamName := [];
  11261.   {  The channel which you use acquisition  }
  11262.   J := 0;
  11263.   for Q := rgbRed to rgbAlpha do
  11264.   begin
  11265.     if Q in CheckChannelUsed then
  11266.     begin
  11267.       Inc(J);
  11268.       Channel := Q;
  11269.       if not (Channel in FHasChannels) then
  11270.       begin
  11271.         if CheckBitCountForChannel <> '' then
  11272.           ChannelBitCount[Channel] := StrToInt(Copy(CheckBitCountForChannel, j, 1))
  11273.         else
  11274.           ChannelBitCount[Channel] := 8; {poke default value}
  11275.         if ChannelBitCount[Channel] <> 0 then
  11276.           ChannelParamName := ChannelParamName + [Channel];
  11277.  
  11278.         if CheckChannelChanged <> '' then
  11279.         begin
  11280.           case UpCase(CheckChannelChanged[j]) of
  11281.             'R': FChannelChangeTable[Channel] := rgbRed;
  11282.             'G': FChannelChangeTable[Channel] := rgbGreen;
  11283.             'B': FChannelChangeTable[Channel] := rgbBlue;
  11284.             'Y': FChannelChangeTable[Channel] := yuvY;
  11285.             'N': FChannelChangeTable[Channel] := rgbNone;
  11286.           else
  11287.             raise EDXTBaseError.CreateFmt('Invalid channel type(%s)', [CheckChannelChanged[j]]);
  11288.           end;
  11289.         end;
  11290.       end;
  11291.     end;
  11292.   end;
  11293.   {  Processing of each  }
  11294.   if ChannelParamName <> [] then
  11295.   begin
  11296.     {  Picture load  }
  11297.     Image := nil;
  11298.     {pokud je image uz nahrany tj. stejneho jmena, pokracuj dale}
  11299.     for j := 0 to FHasImageList.Count - 1 do
  11300.       if AnsiCompareFileName(TDXTextureImage(FHasImageList[j]).ImageName, FStrImageFileName) = 0 then
  11301.       begin
  11302.         Image := FHasImageList[j];
  11303.         Break;
  11304.       end;
  11305.     {obrazek neexistuje, musi se dotahnout bud z proudu, souboru nebo odjinut}
  11306.     if Image = nil then
  11307.     begin
  11308.       try
  11309.         Image := GetPicture;
  11310.       except
  11311.         if Assigned(Image) then
  11312.         begin
  11313.           {$IFNDEF VER5UP}
  11314.           Image.Free; Image := nil;
  11315.           {$ELSE}
  11316.           FreeAndNil(Image);
  11317.           {$ENDIF}
  11318.         end;
  11319.         raise;
  11320.       end;
  11321.       FHasImageList.Add(Image);
  11322.     end;
  11323.  
  11324.     {  Each channel processing  }
  11325.     for Channel := Low(Channel) to High(Channel) do
  11326.       if Channel in ChannelParamName then
  11327.       begin
  11328.         if ChannelBitCount[Channel] >= 0 then
  11329.           FHasChannelImages[Channel].BitCount := ChannelBitCount[Channel]
  11330.         else
  11331.         begin
  11332.           case Image.ImageType of
  11333.             DXTextureImageType_PaletteIndexedColor:
  11334.               begin
  11335.                 case Channel of
  11336.                   rgbRed: FHasChannelImages[Channel].BitCount := 8;
  11337.                   rgbGreen: FHasChannelImages[Channel].BitCount := 8;
  11338.                   rgbBlue: FHasChannelImages[Channel].BitCount := 8;
  11339.                   rgbAlpha: FHasChannelImages[Channel].BitCount := 8;
  11340.                 end;
  11341.               end;
  11342.             DXTextureImageType_RGBColor:
  11343.               begin
  11344.                 case Channel of
  11345.                   rgbRed: FHasChannelImages[Channel].BitCount := Image.rgb_red.BitCount;
  11346.                   rgbGreen: FHasChannelImages[Channel].BitCount := Image.rgb_green.BitCount;
  11347.                   rgbBlue: FHasChannelImages[Channel].BitCount := Image.rgb_blue.BitCount;
  11348.                   rgbAlpha: FHasChannelImages[Channel].BitCount := 8;
  11349.                 end;
  11350.               end;
  11351.           end;
  11352.         end;
  11353.         if FHasChannelImages[Channel].BitCount = 0 then Continue;
  11354.         FHasChannels := FHasChannels + [Channel];
  11355.         FHasChannelImages[Channel].Image := Image;
  11356.       end;
  11357.   end;
  11358. end;
  11359.  
  11360. function TDXTBase.GetTexture: TDXTextureImage;
  11361. var
  11362.   i, j: Integer;
  11363.   SubImage: TDXTextureImage;
  11364.   CurWidth, CurHeight: Integer;
  11365. begin
  11366.   Result := nil;
  11367.   if FHasImageList.Count = 0 then
  11368.     raise EDXTBaseError.Create('No image found');
  11369.  
  11370.   {  Output format calculation  }
  11371.   CalcOutputBitFormat;
  11372.   Result := TDXTextureImage.Create;
  11373.   try
  11374.     Result.SetSize(FParamsFormat.ImageType, FParamsFormat.Width, FParamsFormat.Height, FParamsFormat.BitCount, 0);
  11375.  
  11376.     Result.idx_index := FParamsFormat.idx_index;
  11377.     Result.idx_alpha := FParamsFormat.idx_alpha;
  11378.     Result.idx_palette := FParamsFormat.idx_palette;
  11379.  
  11380.     Result.rgb_red := FParamsFormat.rgb_red;
  11381.     Result.rgb_green := FParamsFormat.rgb_green;
  11382.     Result.rgb_blue := FParamsFormat.rgb_blue;
  11383.     Result.rgb_alpha := FParamsFormat.rgb_alpha;
  11384.  
  11385.     Result.ImageName := FParamsFormat.Name;
  11386.  
  11387.     Result.Transparent := FParamsFormat.Transparent;
  11388.     if FParamsFormat.TransparentColor shr 24 = $01 then
  11389.       Result.TransparentColor := dxtEncodeChannel(Result.idx_index, PaletteIndex(Byte(FParamsFormat.TransparentColor)))
  11390.     else
  11391.       Result.TransparentColor := Result.EncodeColor(GetRValue(FParamsFormat.TransparentColor), GetGValue(FParamsFormat.TransparentColor), GetBValue(FParamsFormat.TransparentColor), 0);
  11392.  
  11393.     BuildImage(Result);
  11394.  
  11395.     if FParamsFormat.ImageType = DXTextureImageType_RGBColor then
  11396.     begin
  11397.       BuildImage(Result);
  11398.       {  Picture information store here  }
  11399.       CurWidth := FParamsFormat.Width;
  11400.       CurHeight := FParamsFormat.Height;
  11401.       for i := 0 to FParamsFormat.MipmapCount - 1 do
  11402.       begin
  11403.         CurWidth := CurWidth div 2;
  11404.         CurHeight := CurHeight div 2;
  11405.         if (CurWidth <= 0) or (CurHeight <= 0) then Break;
  11406.         {  Resize calc here }
  11407.         for j := 0 to FHasImageList.Count - 1 do
  11408.           Resize(FHasImageList[j], CurWidth, CurHeight, ftrTriangle);
  11409.  
  11410.         SubImage := TDXTextureImage.CreateSub(Result);
  11411.         SubImage.SetSize(FParamsFormat.ImageType, CurWidth, CurHeight, FParamsFormat.BitCount, 0);
  11412.  
  11413.         SubImage.idx_index := FParamsFormat.idx_index;
  11414.         SubImage.idx_alpha := FParamsFormat.idx_alpha;
  11415.         SubImage.idx_palette := FParamsFormat.idx_palette;
  11416.  
  11417.         SubImage.rgb_red := FParamsFormat.rgb_red;
  11418.         SubImage.rgb_green := FParamsFormat.rgb_green;
  11419.         SubImage.rgb_blue := FParamsFormat.rgb_blue;
  11420.         SubImage.rgb_alpha := FParamsFormat.rgb_alpha;
  11421.  
  11422.         SubImage.ImageGroupType := DXTextureImageGroupType_Normal;
  11423.         SubImage.ImageID := i;
  11424.         SubImage.ImageName := Format('%s - mimap #%d', [Result.ImageName, i + 1]);
  11425.  
  11426.         BuildImage(SubImage);
  11427.       end;
  11428.     end;
  11429.     Result.FileCompressType := FParamsFormat.Compress;
  11430.   except
  11431.     on E: Exception do
  11432.     begin
  11433.       {$IFNDEF VER5UP}
  11434.       Result.Free;
  11435.       Result := nil;
  11436.       {$ELSE}
  11437.       FreeAndNil(Result);
  11438.       {$ENDIF}
  11439.       raise EDXTBaseError.Create(E.Message);
  11440.     end;
  11441.   end;
  11442. end;
  11443.  
  11444. { DIB2DTX }
  11445.  
  11446. procedure dib2dxt(DIBImage: TDIB; out DXTImage: TDXTextureImage{$IFDEF DXTextureImage_UseZLIB}; const Shrink: Boolean = True{$ENDIF});
  11447. var
  11448.   TexImage: TDXTBase;
  11449.   DIB: TDIB;
  11450. begin
  11451.   TexImage := TDXTBase.Create;
  11452.   try
  11453.     {$IFDEF DXTextureImage_UseZLIB}
  11454.     if Shrink then
  11455.     begin
  11456.       TexImage.Compression := DXTextureImageFileCompressType_ZLIB;
  11457.       TexImage.Mipmap := 4;
  11458.     end;
  11459.     {$ENDIF}
  11460.     try
  11461.       if DIBImage.HasAlphaChannel then
  11462.       begin
  11463.         DIB := DIBImage.RGBChannel;
  11464.         TexImage.SetChannelRGB(DIB);
  11465.         DIB.Free;
  11466.         DIB := DIBImage.AlphaChannel;
  11467.         TexImage.SetChannelA(DIB);
  11468.         DIB.Free;
  11469.       end
  11470.       else
  11471.         TexImage.SetChannelRGB(DIBImage);
  11472.  
  11473.       DXTImage := TexImage.Texture;
  11474.     except
  11475.       if Assigned(DXTImage) then
  11476.         DXTImage.Free;
  11477.       DXTImage := nil;
  11478.     end;
  11479.   finally
  11480.     TexImage.Free;
  11481.   end
  11482. end;
  11483.  
  11484. {$IFDEF D3DRM}
  11485.  
  11486. {  TDirect3DRMUserVisual  }
  11487.  
  11488. procedure TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK(lpD3DRMobj: IDirect3DRMObject;
  11489.   lpArg: Pointer); cdecl;
  11490. begin
  11491.   TDirect3DRMUserVisual(lpArg).Free;
  11492. end;
  11493.  
  11494. function TDirect3DRMUserVisual_D3DRMUSERVISUALCALLBACK(lpD3DRMUV: IDirect3DRMUserVisual;
  11495.   lpArg: Pointer; lpD3DRMUVreason: TD3DRMUserVisualReason;
  11496.   lpD3DRMDev: IDirect3DRMDevice; lpD3DRMview: IDirect3DRMViewport): Integer; cdecl;
  11497. begin
  11498.   Result := TDirect3DRMUserVisual(lpArg).DoRender(lpD3DRMUVreason, lpD3DRMDev, lpD3DRMview);
  11499. end;
  11500.  
  11501. constructor TDirect3DRMUserVisual.Create(D3DRM: IDirect3DRM);
  11502. begin
  11503.   inherited Create;
  11504.  
  11505.   if D3DRM.CreateUserVisual(@TDirect3DRMUserVisual_D3DRMUSERVISUALCALLBACK,
  11506.     Self, FUserVisual) <> D3DRM_OK
  11507.   then
  11508.     raise EDirect3DRMUserVisualError.CreateFmt(SCannotMade, ['IDirect3DRMUserVisual']);
  11509.  
  11510.   FUserVisual.AddDestroyCallback(@TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK, Self);
  11511. end;
  11512.  
  11513. destructor TDirect3DRMUserVisual.Destroy;
  11514. begin
  11515.   if FUserVisual <> nil then
  11516.     FUserVisual.DeleteDestroyCallback(@TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK, Self);
  11517.   FUserVisual := nil;
  11518.   inherited Destroy;
  11519. end;
  11520.  
  11521. function TDirect3DRMUserVisual.DoRender(Reason: TD3DRMUserVisualReason;
  11522.   D3DRMDev: IDirect3DRMDevice; D3DRMView: IDirect3DRMViewport): HRESULT;
  11523. begin
  11524.   Result := 0;
  11525. end;
  11526. {$ENDIF}
  11527.  
  11528. {  TPictureCollectionItem  }
  11529.  
  11530. type
  11531.   TPictureCollectionItemPattern = class(TCollectionItem)
  11532.   private
  11533.     FRect: TRect;
  11534.     FSurface: TDirectDrawSurface;
  11535.   end;
  11536.  
  11537. constructor TPictureCollectionItem.Create(Collection: TCollection);
  11538. begin
  11539.   inherited Create(Collection);
  11540.   FPicture := TPicture.Create;
  11541.   FPatterns := TCollection.Create(TPictureCollectionItemPattern);
  11542.   FSurfaceList := TList.Create;
  11543.   FTransparent := True;
  11544. end;
  11545.  
  11546. destructor TPictureCollectionItem.Destroy;
  11547. begin
  11548.   Finalize;
  11549.   FPicture.Free;
  11550.   FPatterns.Free;
  11551.   FSurfaceList.Free;
  11552.   inherited Destroy;
  11553. end;
  11554.  
  11555. procedure TPictureCollectionItem.Assign(Source: TPersistent);
  11556. var
  11557.   PrevInitialized: Boolean;
  11558. begin
  11559.   if Source is TPictureCollectionItem then
  11560.   begin
  11561.     PrevInitialized := Initialized;
  11562.     Finalize;
  11563.  
  11564.     FPatternHeight := TPictureCollectionItem(Source).FPatternHeight;
  11565.     FPatternWidth := TPictureCollectionItem(Source).FPatternWidth;
  11566.     FSkipHeight := TPictureCollectionItem(Source).FSkipHeight;
  11567.     FSkipWidth := TPictureCollectionItem(Source).FSkipWidth;
  11568.     FSystemMemory := TPictureCollectionItem(Source).FSystemMemory;
  11569.     FTransparent := TPictureCollectionItem(Source).FTransparent;
  11570.     FTransparentColor := TPictureCollectionItem(Source).FTransparentColor;
  11571.  
  11572.     FPicture.Assign(TPictureCollectionItem(Source).FPicture);
  11573.  
  11574.     if PrevInitialized then
  11575.       Restore;
  11576.   end else
  11577.     inherited Assign(Source);
  11578. end;
  11579.  
  11580. procedure TPictureCollectionItem.ClearSurface;
  11581. var
  11582.   i: Integer;
  11583. begin
  11584.   FPatterns.Clear;
  11585.   for i := 0 to FSurfaceList.Count - 1 do
  11586.     TDirectDrawSurface(FSurfaceList[i]).Free;
  11587.   FSurfaceList.Clear;
  11588. end;
  11589.  
  11590. function TPictureCollectionItem.GetHeight: Integer;
  11591. begin
  11592.   Result := FPatternHeight;
  11593.   if (Result <= 0) then
  11594.     Result := FPicture.Height;
  11595. end;
  11596.  
  11597. function TPictureCollectionItem.GetPictureCollection: TPictureCollection;
  11598. begin
  11599.   Result := Collection as TPictureCollection;
  11600. end;
  11601.  
  11602. function TPictureCollectionItem.GetPatternRect(Index: Integer): TRect;
  11603. begin
  11604.   if (Index >= 0) and (index < FPatterns.Count) then
  11605.     //Result := (FPatterns.Items[Index] as TPictureCollectionItemPattern).FRect
  11606.     Result := TPictureCollectionItemPattern(FPatterns.Items[Index]).FRect
  11607.   else
  11608.     Result := Rect(0, 0, 0, 0);
  11609. end;
  11610.  
  11611. function TPictureCollectionItem.GetPatternSurface(Index: Integer): TDirectDrawSurface;
  11612. begin
  11613.   if (Index >= 0) and (index < FPatterns.Count) then
  11614.     Result := TPictureCollectionItemPattern(FPatterns.Items[Index]).FSurface
  11615.   else
  11616.     Result := nil;
  11617. end;
  11618.  
  11619. function TPictureCollectionItem.GetPatternCount: Integer;
  11620. var
  11621.   XCount, YCount: Integer;
  11622. begin
  11623.   if FSurfaceList.Count = 0 then
  11624.   begin
  11625.     if PatternWidth = 0 then PatternWidth := FPicture.Width; //prevent division by zero
  11626.     XCount := FPicture.Width div (PatternWidth + SkipWidth);
  11627.     if FPicture.Width - XCount * (PatternWidth + SkipWidth) = PatternWidth then
  11628.       Inc(XCount);
  11629.     if PatternHeight = 0 then PatternHeight := FPicture.Height; //prevent division by zero
  11630.     YCount := FPicture.Height div (PatternHeight + SkipHeight);
  11631.     if FPicture.Height - YCount * (PatternHeight + SkipHeight) = PatternHeight then
  11632.       Inc(YCount);
  11633.     Result := XCount * YCount;
  11634.   end else
  11635.     Result := FPatterns.Count;
  11636. end;
  11637.  
  11638. function TPictureCollectionItem.GetWidth: Integer;
  11639. begin
  11640.   Result := FPatternWidth;
  11641.   if (Result <= 0) then
  11642.     Result := FPicture.Width;
  11643. end;
  11644.  
  11645. procedure TPictureCollectionItem.Draw(Dest: TDirectDrawSurface; X, Y,
  11646.   PatternIndex: Integer);
  11647. begin
  11648.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11649.   begin
  11650.     {$IFDEF DrawHWAcc}
  11651.     with TPictureCollection(Self.GetPictureCollection) do
  11652.       if FDXDraw.CheckD3D(Dest) then
  11653.       begin
  11654.         FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, Bounds(X, Y, Width, Height), PatternIndex, rtDraw{$IFNDEF VER4UP}, $FF{$ENDIF});
  11655.       end
  11656.       else
  11657.     {$ENDIF DrawHWAcc}
  11658.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11659.           Dest.Draw(X, Y, FRect, FSurface, Transparent);
  11660.   end;
  11661. end;
  11662.  
  11663. procedure TPictureCollectionItem.DrawFlipHV(Dest: TDirectDrawSurface; X, Y,
  11664.   PatternIndex: Integer);
  11665. var
  11666.   flrc: trect;
  11667. begin
  11668.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11669.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11670.     begin
  11671.       flrc.Left := frect.right; flrc.Right := frect.left;
  11672.       flrc.Top := fpicture.height - frect.top;
  11673.       flrc.Bottom := fpicture.height - frect.bottom;
  11674.       Dest.Draw(X, Y, Flrc, FSurface, Transparent);
  11675.     end;
  11676. end;
  11677.  
  11678. procedure TPictureCollectionItem.DrawFlipH(Dest: TDirectDrawSurface; X, Y,
  11679.   PatternIndex: Integer);
  11680. var
  11681.   flrc: TRect;
  11682. begin
  11683.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11684.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11685.     begin
  11686.       if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Dest) then
  11687.       begin
  11688.         flrc := frect;
  11689.         Dest.MirrorFlip([rmfMirror]);
  11690.       end
  11691.       else
  11692.       begin
  11693.         flrc.Left := fpicture.width - frect.left;
  11694.         flrc.Right := fpicture.width - frect.right;
  11695.         flrc.Top := frect.Top; flrc.Bottom := frect.Bottom;
  11696.       end;
  11697.       Dest.Draw(X, Y, Flrc, FSurface, Transparent);
  11698.     end;
  11699. end;
  11700.  
  11701. procedure TPictureCollectionItem.DrawFlipV(Dest: TDirectDrawSurface; X, Y,
  11702.   PatternIndex: Integer);
  11703. var
  11704.   flrc: TRect;
  11705. begin
  11706.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11707.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11708.     begin
  11709.       if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Dest) then
  11710.       begin
  11711.         flrc := frect;
  11712.         Dest.MirrorFlip([rmfFlip]);
  11713.       end
  11714.       else
  11715.       begin
  11716.         flrc.Left := frect.left; flrc.Right := frect.right;
  11717.         flrc.Top := fpicture.height - frect.top;
  11718.         flrc.Bottom := fpicture.height - frect.bottom;
  11719.       end;
  11720.       Dest.Draw(X, Y, Flrc, FSurface, Transparent);
  11721.     end;
  11722. end;
  11723.  
  11724. procedure TPictureCollectionItem.StretchDraw(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer);
  11725. begin
  11726.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11727.   begin
  11728.     {$IFDEF DrawHWAcc}
  11729.     with TPictureCollection(Self.GetPictureCollection) do
  11730.       if FDXDraw.CheckD3D(Dest) then
  11731.       begin
  11732.         FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, DestRect, PatternIndex, rtDraw{$IFNDEF VER4UP}, $FF{$ENDIF})
  11733.       end
  11734.       else
  11735.     {$ENDIF DrawHWAcc}
  11736.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11737.           Dest.StretchDraw(DestRect, FRect, FSurface, Transparent);
  11738.   end;
  11739. end;
  11740.  
  11741. procedure TPictureCollectionItem.DrawAdd(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  11742.   Alpha: Integer);
  11743. begin
  11744.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11745.   begin
  11746.     with TPictureCollection(Self.GetPictureCollection) do
  11747.       if FDXDraw.CheckD3D(Dest) then
  11748.       begin
  11749.         FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, DestRect, PatternIndex, rtAdd, Alpha)
  11750.       end
  11751.       else
  11752.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11753.           Dest.DrawAdd(DestRect, FRect, FSurface, Transparent, Alpha);
  11754.   end;
  11755. end;
  11756.  
  11757. procedure TPictureCollectionItem.DrawAddCol(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  11758.   Color: Integer; Alpha: Integer);
  11759. begin
  11760.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11761.   begin
  11762.     with TPictureCollection(Self.GetPictureCollection) do
  11763.       if FDXDraw.CheckD3D(Dest) then
  11764.       begin
  11765.         FDXDraw.FD2D.D2DRenderCol(Self, DestRect, PatternIndex, Color, rtAdd, Alpha)
  11766.       end
  11767.       else
  11768.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11769.           Dest.DrawAdd(DestRect, FRect, FSurface, Transparent, Alpha);
  11770.   end;
  11771. end;
  11772.  
  11773. procedure TPictureCollectionItem.DrawAlpha(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  11774.   Alpha: Integer);
  11775. begin
  11776.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11777.   begin
  11778.     with TPictureCollection(Self.GetPictureCollection) do
  11779.       if FDXDraw.CheckD3D(Dest) then
  11780.       begin
  11781.         FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, DestRect, PatternIndex, rtBlend, Alpha)
  11782.       end
  11783.       else
  11784.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11785.           Dest.DrawAlpha(DestRect, FRect, FSurface, Transparent, Alpha);
  11786.   end;
  11787. end;
  11788.  
  11789. procedure TPictureCollectionItem.DrawSub(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  11790.   Alpha: Integer);
  11791. begin
  11792.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11793.   begin
  11794.     with TPictureCollection(Self.GetPictureCollection) do
  11795.       if FDXDraw.CheckD3D(Dest) then
  11796.       begin
  11797.         FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, DestRect, PatternIndex, rtSub, Alpha)
  11798.       end
  11799.       else
  11800.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11801.           Dest.DrawSub(DestRect, FRect, FSurface, Transparent, Alpha);
  11802.   end;
  11803. end;
  11804.  
  11805. procedure TPictureCollectionItem.DrawSubCol(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  11806.   Color: Integer; Alpha: Integer);
  11807. begin
  11808.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11809.   begin
  11810.     with TPictureCollection(Self.GetPictureCollection) do
  11811.       if FDXDraw.CheckD3D(Dest) then
  11812.       begin
  11813.         FDXDraw.FD2D.D2DRenderCol(Self, DestRect, PatternIndex, Color, rtSub, Alpha)
  11814.       end
  11815.       else
  11816.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11817.           Dest.DrawSub(DestRect, FRect, FSurface, Transparent, Alpha);
  11818.   end;
  11819. end;
  11820.  
  11821. procedure TPictureCollectionItem.DrawRotate(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11822.   CenterX, CenterY: Double; Angle: single);
  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.         //X,Y................ Center of rotation
  11830.         //Width,Height....... Picture
  11831.         //PatternIndex....... Piece of picture
  11832.         //CenterX,CenterY ... Center of rotation on picture
  11833.         //Angle.............. Angle of rotation
  11834.         FDXDraw.FD2D.D2DRenderRotate(Self, X, Y, Width, Height, PatternIndex, rtDraw, CenterX, CenterY, Angle{$IFNDEF VER4UP}, $FF{$ENDIF});
  11835.       end
  11836.       else
  11837.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11838.           Dest.DrawRotate(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle);
  11839.   end;
  11840. end;
  11841.  
  11842. procedure TPictureCollectionItem.DrawRotateAdd(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11843.   CenterX, CenterY: Double; Angle: single; Alpha: Integer);
  11844. begin
  11845.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11846.   begin
  11847.     with TPictureCollection(Self.GetPictureCollection) do
  11848.       if FDXDraw.CheckD3D(Dest) then
  11849.       begin
  11850.         FDXDraw.FD2D.D2DRenderRotate(Self, X, Y, Width, Height, PatternIndex, rtAdd, CenterX, CenterY, Angle, Alpha);
  11851.       end
  11852.       else
  11853.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11854.           Dest.DrawRotateAdd(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  11855.   end;
  11856. end;
  11857.  
  11858. procedure TPictureCollectionItem.DrawRotateAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11859.   CenterX, CenterY: Double; Angle: single; Alpha: Integer);
  11860. begin
  11861.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11862.   begin
  11863.     with TPictureCollection(Self.GetPictureCollection) do
  11864.       if FDXDraw.CheckD3D(Dest) then
  11865.       begin
  11866.         FDXDraw.FD2D.D2DRenderRotate(Self, X, Y, Width, Height, PatternIndex, rtBlend, CenterX, CenterY, Angle, Alpha);
  11867.       end
  11868.       else
  11869.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11870.           Dest.DrawRotateAlpha(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  11871.   end;
  11872. end;
  11873.  
  11874. procedure TPictureCollectionItem.DrawRotateSub(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11875.   CenterX, CenterY: Double; Angle: single; Alpha: Integer);
  11876. begin
  11877.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11878.   begin
  11879.     with TPictureCollection(Self.GetPictureCollection) do
  11880.       if FDXDraw.CheckD3D(Dest) then
  11881.       begin
  11882.         FDXDraw.FD2D.D2DRenderRotate(Self, X, Y, Width, Height, PatternIndex, rtSub, CenterX, CenterY, Angle, Alpha);
  11883.       end
  11884.       else
  11885.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11886.           Dest.DrawRotateSub(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  11887.   end;
  11888. end;
  11889.  
  11890. procedure TPictureCollectionItem.DrawWaveX(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11891.   amp, Len, ph: Integer);
  11892. begin
  11893.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11894.   begin
  11895.     with TPictureCollection(Self.GetPictureCollection) do
  11896.       if FDXDraw.CheckD3D(Dest) then
  11897.       begin
  11898.         FDXDraw.FD2D.D2DRenderWaveX(Self, X, Y, Width, Height, PatternIndex, rtDraw,
  11899.           Transparent, amp, Len, ph{$IFNDEF VER4UP}, $FF{$ENDIF});
  11900.       end
  11901.       else
  11902.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11903.           Dest.DrawWaveX(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph);
  11904.   end;
  11905. end;
  11906.  
  11907. procedure TPictureCollectionItem.DrawWaveXAdd(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11908.   amp, Len, ph, Alpha: Integer);
  11909. begin
  11910.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11911.   begin
  11912.     with TPictureCollection(Self.GetPictureCollection) do
  11913.       if FDXDraw.CheckD3D(Dest) then
  11914.       begin
  11915.         FDXDraw.FD2D.D2DRenderWaveX(Self, X, Y, Width, Height, PatternIndex, rtAdd,
  11916.           Transparent, amp, Len, ph, Alpha);
  11917.       end
  11918.       else
  11919.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11920.           Dest.DrawWaveXAdd(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
  11921.   end;
  11922. end;
  11923.  
  11924. procedure TPictureCollectionItem.DrawWaveXAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11925.   amp, Len, ph, Alpha: Integer);
  11926. begin
  11927.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11928.   begin
  11929.     with TPictureCollection(Self.GetPictureCollection) do
  11930.       if FDXDraw.CheckD3D(Dest) then
  11931.       begin
  11932.         FDXDraw.FD2D.D2DRenderWaveX(Self, X, Y, Width, Height, PatternIndex, rtBlend,
  11933.           Transparent, amp, Len, ph, Alpha);
  11934.       end
  11935.       else
  11936.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11937.           Dest.DrawWaveXAlpha(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
  11938.   end;
  11939. end;
  11940.  
  11941. procedure TPictureCollectionItem.DrawWaveXSub(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  11942.   amp, Len, ph, Alpha: Integer);
  11943. begin
  11944.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11945.   begin
  11946.     with TPictureCollection(Self.GetPictureCollection) do
  11947.       if FDXDraw.CheckD3D(Dest) then
  11948.       begin
  11949.         FDXDraw.FD2D.D2DRenderWaveX(Self, X, Y, Width, Height, PatternIndex, rtSub,
  11950.           Transparent, amp, Len, ph, Alpha);
  11951.       end
  11952.       else
  11953.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  11954.           Dest.DrawWaveXSub(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
  11955.   end;
  11956. end;
  11957.  
  11958. procedure TPictureCollectionItem.DrawWaveYSub(Dest: TDirectDrawSurface; X, Y,
  11959.   Width, Height, PatternIndex, amp, Len, ph, Alpha: Integer);
  11960. begin
  11961.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11962.   begin
  11963.     with TPictureCollection(Self.GetPictureCollection) do
  11964.       if FDXDraw.CheckD3D(Dest) then
  11965.       begin
  11966.         FDXDraw.FD2D.D2DRenderWaveY(Self, X, Y, Width, Height, PatternIndex, rtSub,
  11967.           Transparent, amp, Len, ph, Alpha);
  11968.       end
  11969.       {there is not software version}
  11970.   end;
  11971. end;
  11972.  
  11973. procedure TPictureCollectionItem.DrawWaveY(Dest: TDirectDrawSurface; X, Y,
  11974.   Width, Height, PatternIndex, amp, Len, ph: Integer);
  11975. begin
  11976.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11977.   begin
  11978.     with TPictureCollection(Self.GetPictureCollection) do
  11979.       if FDXDraw.CheckD3D(Dest) then
  11980.       begin
  11981.         FDXDraw.FD2D.D2DRenderWaveY(Self, X, Y, Width, Height, PatternIndex, rtDraw,
  11982.           Transparent, amp, Len, ph{$IFNDEF VER4UP}, $FF{$ENDIF});
  11983.       end
  11984.   end;
  11985. end;
  11986.  
  11987. procedure TPictureCollectionItem.DrawWaveYAdd(Dest: TDirectDrawSurface; X, Y,
  11988.   Width, Height, PatternIndex, amp, Len, ph, Alpha: Integer);
  11989. begin
  11990.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  11991.   begin
  11992.     with TPictureCollection(Self.GetPictureCollection) do
  11993.       if FDXDraw.CheckD3D(Dest) then
  11994.       begin
  11995.         FDXDraw.FD2D.D2DRenderWaveY(Self, X, Y, Width, Height, PatternIndex, rtAdd,
  11996.           Transparent, amp, Len, ph, Alpha);
  11997.       end
  11998.   end;
  11999. end;
  12000.  
  12001. procedure TPictureCollectionItem.DrawWaveYAlpha(Dest: TDirectDrawSurface; X, Y,
  12002.   Width, Height, PatternIndex, amp, Len, ph, Alpha: Integer);
  12003. begin
  12004.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12005.   begin
  12006.     with TPictureCollection(Self.GetPictureCollection) do
  12007.       if FDXDraw.CheckD3D(Dest) then
  12008.       begin
  12009.         FDXDraw.FD2D.D2DRenderWaveY(Self, X, Y, Width, Height, PatternIndex, rtBlend,
  12010.           Transparent, amp, Len, ph, Alpha);
  12011.       end
  12012.   end;
  12013. end;
  12014.  
  12015. procedure TPictureCollectionItem.Finalize;
  12016. begin
  12017.   if FInitialized then
  12018.   begin
  12019.     FInitialized := False;
  12020.     ClearSurface;
  12021.   end;
  12022. end;
  12023.  
  12024. procedure TPictureCollectionItem.UpdateTag;
  12025.  
  12026.   function AddSurface(const SrcRect: TRect): TDirectDrawSurface;
  12027.   begin
  12028.     Result := TDirectDrawSurface.Create(PictureCollection.DXDraw.DDraw);
  12029.     FSurfaceList.Add(Result);
  12030.  
  12031.     Result.SystemMemory := FSystemMemory;
  12032.     Result.LoadFromGraphicRect(FPicture.Graphic, 0, 0, SrcRect);
  12033.     Result.TransparentColor := Result.ColorMatch(FTransparentColor);
  12034.   end;
  12035.  
  12036. var
  12037.   x, y, x2, y2: Integer;
  12038.   BlockWidth, BlockHeight, BlockXCount, BlockYCount: Integer;
  12039.   Width2, Height2: Integer;
  12040.   TempSurface : TDirectDrawSurface;
  12041. begin
  12042.   if FPicture.Graphic = nil then Exit;
  12043. //  ClearSurface;
  12044.   Width2 := Width + SkipWidth;
  12045.   Height2 := Height + SkipHeight;
  12046.  
  12047.   if (Width = FPicture.Width) and (Height = FPicture.Height) then
  12048.   begin
  12049.     with TPictureCollectionItemPattern.Create(FPatterns) do
  12050.     begin
  12051.      TempSurface := TDirectDrawSurface.Create(PictureCollection.DXDraw.DDraw);
  12052.      FSurface := TempSurface;
  12053.       FRect := Bounds(0, 0, FPicture.Width, FPicture.Height);
  12054.      TempSurface.LoadFromGraphicRect(FPicture.Graphic, 0, 0, FRect);
  12055.      TempSurface.SystemMemory := FSystemMemory;
  12056.      TempSurface.TransparentColor := TempSurface.ColorMatch(FTransparentColor);
  12057.      FSurfaceList.Add(TempSurface);
  12058.     end;
  12059.   end
  12060.  else
  12061.  if FSystemMemory then
  12062.   begin
  12063.     AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
  12064.     for y := 0 to (FPicture.Height + SkipHeight) div Height2 - 1 do
  12065.       for x := 0 to (FPicture.Width + SkipWidth) div Width2 - 1 do
  12066.         with TPictureCollectionItemPattern.Create(FPatterns) do
  12067.         begin
  12068.           FRect := Bounds(x * Width2, y * Height2, Width, Height);
  12069.           FSurface := TDirectDrawSurface(FSurfaceList[0]);
  12070.         end;
  12071.   end
  12072.   else
  12073.   begin
  12074.     {  Load to a video memory with dividing the image.   }
  12075.     BlockWidth := Min(((SurfaceDivWidth + Width2 - 1) div Width2) * Width2,
  12076.       (FPicture.Width + SkipWidth) div Width2 * Width2);
  12077.     BlockHeight := Min(((SurfaceDivHeight + Height2 - 1) div Height2) * Height2,
  12078.       (FPicture.Height + SkipHeight) div Height2 * Height2);
  12079.  
  12080.     if (BlockWidth = 0) or (BlockHeight = 0) then Exit;
  12081.  
  12082.     BlockXCount := (FPicture.Width + BlockWidth - 1) div BlockWidth;
  12083.     BlockYCount := (FPicture.Height + BlockHeight - 1) div BlockHeight;
  12084.  
  12085.     for y := 0 to BlockYCount - 1 do
  12086.       for x := 0 to BlockXCount - 1 do
  12087.       begin
  12088.         x2 := Min(BlockWidth, Max(FPicture.Width - x * BlockWidth, 0));
  12089.         if x2 = 0 then x2 := BlockWidth;
  12090.  
  12091.         y2 := Min(BlockHeight, Max(FPicture.Height - y * BlockHeight, 0));
  12092.         if y2 = 0 then y2 := BlockHeight;
  12093.  
  12094.         AddSurface(Bounds(x * BlockWidth, y * BlockHeight, x2, y2));
  12095.       end;
  12096.  
  12097.     for y := 0 to (FPicture.Height + SkipHeight) div Height2 - 1 do
  12098.       for x := 0 to (FPicture.Width + SkipWidth) div Width2 - 1 do
  12099.       begin
  12100.         x2 := x * Width2;
  12101.         y2 := y * Height2;
  12102.         with TPictureCollectionItemPattern.Create(FPatterns) do
  12103.         begin
  12104.           FRect := Bounds(x2 - (x2 div BlockWidth * BlockWidth), y2 - (y2 div BlockHeight * BlockHeight), Width, Height);
  12105.           FSurface := TDirectDrawSurface(FSurfaceList[(x2 div BlockWidth) + ((y2 div BlockHeight) * BlockXCount)]);
  12106.         end;
  12107.       end;
  12108.   end;
  12109. end;
  12110.  
  12111. procedure TPictureCollectionItem.Initialize;
  12112. begin
  12113.   Finalize;
  12114.   FInitialized := PictureCollection.Initialized;
  12115.   UpdateTag;
  12116. end;
  12117.  
  12118. procedure TPictureCollectionItem.Restore;
  12119.  
  12120.   function AddSurface(const SrcRect: TRect): TDirectDrawSurface;
  12121.   begin
  12122.     Result := TDirectDrawSurface.Create(PictureCollection.DXDraw.DDraw);
  12123.     FSurfaceList.Add(Result);
  12124.  
  12125.     Result.SystemMemory := FSystemMemory;
  12126.     Result.LoadFromGraphicRect(FPicture.Graphic, 0, 0, SrcRect);
  12127.     Result.TransparentColor := Result.ColorMatch(FTransparentColor);
  12128.   end;
  12129.  
  12130. var
  12131.   x, y, x2, y2: Integer;
  12132.   BlockWidth, BlockHeight, BlockXCount, BlockYCount: Integer;
  12133.   Width2, Height2: Integer;
  12134. begin
  12135.   if FPicture.Graphic = nil then Exit;
  12136.  
  12137.   if not FInitialized then
  12138.   begin
  12139.     if PictureCollection.Initialized then
  12140.       Initialize;
  12141.     if not FInitialized then Exit;
  12142.   end;
  12143.  
  12144.   ClearSurface;
  12145.  
  12146.   Width2 := Width + SkipWidth;
  12147.   Height2 := Height + SkipHeight;
  12148.  
  12149.   if (Width = FPicture.Width) and (Height = FPicture.Height) then
  12150.   begin
  12151.     {  There is no necessity of division because the number of patterns is one.   }
  12152.     with TPictureCollectionItemPattern.Create(FPatterns) do
  12153.     begin
  12154.       FRect := Bounds(0, 0, FPicture.Width, FPicture.Height);
  12155.       FSurface := AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
  12156.     end;
  12157.   end
  12158.   else
  12159.   if FSystemMemory then
  12160.   begin
  12161.     {  Load to a system memory.  }
  12162.     AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
  12163.  
  12164.     for y := 0 to (FPicture.Height + SkipHeight) div Height2 - 1 do
  12165.       for x := 0 to (FPicture.Width + SkipWidth) div Width2 - 1 do
  12166.         with TPictureCollectionItemPattern.Create(FPatterns) do
  12167.         begin
  12168.           FRect := Bounds(x * Width2, y * Height2, Width, Height);
  12169.           FSurface := TDirectDrawSurface(FSurfaceList[0]);
  12170.         end;
  12171.   end
  12172.   else
  12173.   begin
  12174.     {  Load to a video memory with dividing the image.   }
  12175.     BlockWidth := Min(((SurfaceDivWidth + Width2 - 1) div Width2) * Width2,
  12176.       (FPicture.Width + SkipWidth) div Width2 * Width2);
  12177.     BlockHeight := Min(((SurfaceDivHeight + Height2 - 1) div Height2) * Height2,
  12178.       (FPicture.Height + SkipHeight) div Height2 * Height2);
  12179.  
  12180.     if (BlockWidth = 0) or (BlockHeight = 0) then Exit;
  12181.  
  12182.     BlockXCount := (FPicture.Width + BlockWidth - 1) div BlockWidth;
  12183.     BlockYCount := (FPicture.Height + BlockHeight - 1) div BlockHeight;
  12184.  
  12185.     for y := 0 to BlockYCount - 1 do
  12186.       for x := 0 to BlockXCount - 1 do
  12187.       begin
  12188.         x2 := Min(BlockWidth, Max(FPicture.Width - x * BlockWidth, 0));
  12189.         if x2 = 0 then x2 := BlockWidth;
  12190.  
  12191.         y2 := Min(BlockHeight, Max(FPicture.Height - y * BlockHeight, 0));
  12192.         if y2 = 0 then y2 := BlockHeight;
  12193.  
  12194.         AddSurface(Bounds(x * BlockWidth, y * BlockHeight, x2, y2));
  12195.       end;
  12196.  
  12197.     for y := 0 to (FPicture.Height + SkipHeight) div Height2 - 1 do
  12198.       for x := 0 to (FPicture.Width + SkipWidth) div Width2 - 1 do
  12199.       begin
  12200.         x2 := x * Width2;
  12201.         y2 := y * Height2;
  12202.         with TPictureCollectionItemPattern.Create(FPatterns) do
  12203.         begin
  12204.           FRect := Bounds(x2 - (x2 div BlockWidth * BlockWidth), y2 - (y2 div BlockHeight * BlockHeight), Width, Height);
  12205.           FSurface := TDirectDrawSurface(FSurfaceList[(x2 div BlockWidth) + ((y2 div BlockHeight) * BlockXCount)]);
  12206.         end;
  12207.       end;
  12208.   end;
  12209.   {Code added for better compatibility}
  12210.   {When is any picture changed, then all textures cleared and list have to reloaded}
  12211.   with PictureCollection do
  12212.     {$IFDEF D3D_deprecated}if (do3D in FDXDraw.Options) then{$ENDIF}
  12213.       if AsSigned(FDXDraw.FD2D) then
  12214.         if Assigned(FDXDraw.FD2D.D2DTextures) then
  12215.           FDXDraw.FD2D.D2DTextures.D2DPruneAllTextures;
  12216. end;
  12217.  
  12218. procedure TPictureCollectionItem.SetPicture(Value: TPicture);
  12219. begin
  12220.   FPicture.Assign(Value);
  12221. end;
  12222.  
  12223. procedure TPictureCollectionItem.SetTransparentColor(Value: TColor);
  12224. var
  12225.   i: Integer;
  12226.   Surface: TDirectDrawSurface;
  12227. begin
  12228.   if Value <> FTransparentColor then
  12229.   begin
  12230.     FTransparentColor := Value;
  12231.     for i := 0 to FSurfaceList.Count - 1 do
  12232.     begin
  12233.       try
  12234.         Surface := TDirectDrawSurface(FSurfaceList[i]);
  12235.         Surface.TransparentColor := Surface.ColorMatch(FTransparentColor);
  12236.       except
  12237.       end;
  12238.     end;
  12239.   end;
  12240. end;
  12241.  
  12242. procedure TPictureCollectionItem.DrawAlphaCol(Dest: TDirectDrawSurface;
  12243.   const DestRect: TRect; PatternIndex, Color, Alpha: Integer);
  12244. begin
  12245.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12246.   begin
  12247.     with TPictureCollection(Self.GetPictureCollection) do
  12248.       if FDXDraw.CheckD3D(Dest) then
  12249.       begin
  12250.         FDXDraw.FD2D.D2DRenderCol(Self, DestRect, PatternIndex, color, rtBlend, Alpha)
  12251.       end else
  12252.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  12253.           Dest.DrawAlpha(DestRect, FRect, FSurface, Transparent, Alpha);
  12254.   end;
  12255. end;
  12256.  
  12257. procedure TPictureCollectionItem.DrawRotateAddCol(Dest: TDirectDrawSurface;
  12258.   X, Y, Width, Height, PatternIndex: Integer; CenterX, CenterY: Double;
  12259.   Angle: single; Color, Alpha: Integer);
  12260. begin
  12261.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12262.   begin
  12263.     with TPictureCollection(Self.GetPictureCollection) do
  12264.       if FDXDraw.CheckD3D(Dest) then
  12265.       begin
  12266.         FDXDraw.FD2D.D2DRenderRotateModeCol(Self, rtAdd, X, Y, Width,
  12267.           Height, PatternIndex, CenterX, CenterY, Angle, Color, Alpha);
  12268.       end
  12269.       else
  12270.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  12271.           Dest.DrawRotateAdd(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  12272.   end;
  12273. end;
  12274.  
  12275. procedure TPictureCollectionItem.DrawRotateAlphaCol(Dest: TDirectDrawSurface;
  12276.   X, Y, Width, Height, PatternIndex: Integer; CenterX, CenterY: Double;
  12277.   Angle: single; Color, Alpha: Integer);
  12278. begin
  12279.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12280.   begin
  12281.     with TPictureCollection(Self.GetPictureCollection) do
  12282.       if FDXDraw.CheckD3D(Dest) then
  12283.       begin
  12284.         FDXDraw.FD2D.D2DRenderRotateModeCol(Self, rtBlend, X, Y, Width,
  12285.           Height, PatternIndex, CenterX, CenterY, Angle, Color, Alpha);
  12286.       end
  12287.       else
  12288.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  12289.           Dest.DrawRotateAlpha(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  12290.   end;
  12291. end;
  12292.  
  12293. procedure TPictureCollectionItem.DrawRotateSubCol(Dest: TDirectDrawSurface;
  12294.   X, Y, Width, Height, PatternIndex: Integer; CenterX, CenterY: Double;
  12295.   Angle: single; Color, Alpha: Integer);
  12296. begin
  12297.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12298.   begin
  12299.     with TPictureCollection(Self.GetPictureCollection) do
  12300.       if FDXDraw.CheckD3D(Dest) then
  12301.       begin
  12302.         FDXDraw.FD2D.D2DRenderRotateModeCol(Self, rtSub, X, Y, Width,
  12303.           Height, PatternIndex, CenterX, CenterY, Angle, Color, Alpha);
  12304.       end
  12305.       else
  12306.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  12307.           Dest.DrawRotateSub(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  12308.   end;
  12309. end;
  12310.  
  12311. procedure TPictureCollectionItem.DrawCol(Dest: TDirectDrawSurface;
  12312.   const DestRect, SourceRect: TRect; PatternIndex: Integer; Faded: Boolean;
  12313.   RenderType: TRenderType; Color, Specular: Integer; Alpha: Integer);
  12314. begin
  12315.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12316.   begin
  12317.     with TPictureCollection(Self.GetPictureCollection) do
  12318.       if FDXDraw.CheckD3D(Dest) then
  12319.       begin
  12320.         FDXDraw.FD2D.D2DRenderColoredPartition(Self, DestRect, PatternIndex,
  12321.           Color, Specular, Faded, SourceRect, RenderType,
  12322.           Alpha)
  12323.       end
  12324.       else
  12325.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  12326.           Dest.DrawAlpha(DestRect, FRect, FSurface, Transparent, Alpha);
  12327.   end;
  12328. end;
  12329.  
  12330. procedure TPictureCollectionItem.DrawRect(Dest: TDirectDrawSurface;
  12331.   const DestRect, SourceRect: TRect; PatternIndex: Integer;
  12332.   RenderType: TRenderType; Transparent: Boolean; Alpha: Integer);
  12333. begin
  12334.   if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
  12335.   begin
  12336.     {$IFDEF DrawHWAcc}
  12337.     with TPictureCollection(Self.GetPictureCollection) do
  12338.       if FDXDraw.CheckD3D(Dest) then
  12339.       begin
  12340.         FDXDraw.FD2D.D2DRender(Self, DestRect, PatternIndex, SourceRect, RenderType, Alpha);
  12341.       end
  12342.       else
  12343.     {$ENDIF DrawHWAcc}
  12344.         with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  12345.         begin
  12346.           case RenderType of
  12347.             rtDraw: Dest.StretchDraw(DestRect, SourceRect, FSurface, Transparent);
  12348.               //Dest.Draw(DestRect.Left, DestRect.Top, SourceRect, FSurface, Transparent);
  12349.             rtBlend: Dest.DrawAlpha(DestRect, SourceRect, FSurface, Transparent, Alpha);
  12350.             rtAdd: Dest.DrawAdd(DestRect, SourceRect, FSurface, Transparent, Alpha);
  12351.             rtSub: Dest.DrawSub(DestRect, SourceRect, FSurface, Transparent, Alpha);
  12352.           end;
  12353.         end;
  12354.   end;
  12355. end;
  12356.  
  12357. {  TPictureCollection  }
  12358.  
  12359. constructor TPictureCollection.Create(AOwner: TPersistent);
  12360. begin
  12361.   inherited Create(TPictureCollectionItem);
  12362.   FOwner := AOwner;
  12363. end;
  12364.  
  12365. destructor TPictureCollection.Destroy;
  12366. begin
  12367.   Finalize;
  12368.   inherited Destroy;
  12369. end;
  12370.  
  12371. function TPictureCollection.GetItem(Index: Integer): TPictureCollectionItem;
  12372. begin
  12373.   Result := TPictureCollectionItem(inherited Items[Index]);
  12374. end;
  12375.  
  12376. function TPictureCollection.GetOwner: TPersistent;
  12377. begin
  12378.   Result := FOwner;
  12379. end;
  12380.  
  12381. function TPictureCollection.Find(const Name: string): TPictureCollectionItem;
  12382. var
  12383.   i: Integer;
  12384. begin
  12385.   i := IndexOf(Name);
  12386.   if i = -1 then
  12387.     raise EPictureCollectionError.CreateFmt(SImageNotFound, [Name]);
  12388.   Result := Items[i];
  12389. end;
  12390.  
  12391. procedure TPictureCollection.Finalize;
  12392. var
  12393.   i: Integer;
  12394. begin
  12395.   try
  12396.     for i := 0 to Count - 1 do
  12397.       Items[i].Finalize;
  12398.   finally
  12399.     FDXDraw := nil;
  12400.   end;
  12401. end;
  12402.  
  12403. procedure TPictureCollection.InitializeImages(DXDraw: TCustomDXDraw; Id : Integer);
  12404. var
  12405.   i: Integer;
  12406. begin
  12407.   If id = -1 Then
  12408.    Finalize;
  12409.   FDXDraw := DXDraw;
  12410.  
  12411.   if not Initialized then
  12412.     raise EPictureCollectionError.CreateFmt(SCannotInitialized, [ClassName]);
  12413.  
  12414.   for i := 0 to Count - 1 do
  12415.    If (id = -1) or (id = i) Then
  12416.     Items[i].Initialize;
  12417. end;
  12418.  
  12419. procedure TPictureCollection.Initialize(DXDraw: TCustomDXDraw);
  12420. var
  12421.   i: Integer;
  12422. begin
  12423.   Finalize;
  12424.   FDXDraw := DXDraw;
  12425.  
  12426.   if not Initialized then
  12427.     raise EPictureCollectionError.CreateFmt(SCannotInitialized, [ClassName]);
  12428.  
  12429.   for i := 0 to Count - 1 do
  12430.     Items[i].Initialize;
  12431. end;
  12432.  
  12433. function TPictureCollection.Initialized: Boolean;
  12434. begin
  12435.   Result := (FDXDraw <> nil) and (FDXDraw.Initialized);
  12436. end;
  12437.  
  12438. procedure TPictureCollection.Restore;
  12439. var
  12440.   i: Integer;
  12441. begin
  12442.   for i := 0 to Count - 1 do
  12443.     Items[i].Restore;
  12444. end;
  12445.  
  12446. procedure TPictureCollection.MakeColorTable;
  12447. var
  12448.   UseColorTable: array[0..255] of Boolean;
  12449.   PaletteCount: Integer;
  12450.  
  12451.   procedure SetColor(Index: Integer; Col: TRGBQuad);
  12452.   begin
  12453.     UseColorTable[Index] := True;
  12454.     ColorTable[Index] := Col;
  12455.     Inc(PaletteCount);
  12456.   end;
  12457.  
  12458.   procedure AddColor(Col: TRGBQuad);
  12459.   var
  12460.     i: Integer;
  12461.   begin
  12462.     for i := 0 to 255 do
  12463.       if UseColorTable[i] then
  12464.         if DWORD(ColorTable[i]) = DWORD(Col) then
  12465.           Exit;
  12466.     for i := 0 to 255 do
  12467.       if not UseColorTable[i] then
  12468.       begin
  12469.         SetColor(i, Col);
  12470.         Exit;
  12471.       end;
  12472.   end;
  12473.  
  12474.   procedure AddDIB(DIB: TDIB);
  12475.   var
  12476.     i: Integer;
  12477.   begin
  12478.     if DIB.BitCount > 8 then Exit;
  12479.  
  12480.     for i := 0 to 255 do
  12481.       AddColor(DIB.ColorTable[i]);
  12482.   end;
  12483.  
  12484.   procedure AddGraphic(Graphic: TGraphic);
  12485.   var
  12486.     i, n: Integer;
  12487.     PaletteEntries: TPaletteEntries;
  12488.   begin
  12489.     if Graphic.Palette <> 0 then
  12490.     begin
  12491.       n := GetPaletteEntries(Graphic.Palette, 0, 256, PaletteEntries);
  12492.       for i := 0 to n - 1 do
  12493.         AddColor(PaletteEntryToRGBQuad(PaletteEntries[i]));
  12494.     end;
  12495.   end;
  12496.  
  12497. var
  12498.   i: Integer;
  12499. begin
  12500.   FillChar(UseColorTable, SizeOf(UseColorTable), 0);
  12501.   FillChar(ColorTable, SizeOf(ColorTable), 0);
  12502.  
  12503.   PaletteCount := 0;
  12504.  
  12505.   {  The system color is included.  }
  12506.   SetColor(0, RGBQuad(0, 0, 0));
  12507.   SetColor(1, RGBQuad(128, 0, 0));
  12508.   SetColor(2, RGBQuad(0, 128, 0));
  12509.   SetColor(3, RGBQuad(128, 128, 0));
  12510.   SetColor(4, RGBQuad(0, 0, 128));
  12511.   SetColor(5, RGBQuad(128, 0, 128));
  12512.   SetColor(6, RGBQuad(0, 128, 128));
  12513.   SetColor(7, RGBQuad(192, 192, 192));
  12514.  
  12515.   SetColor(248, RGBQuad(128, 128, 128));
  12516.   SetColor(249, RGBQuad(255, 0, 0));
  12517.   SetColor(250, RGBQuad(0, 255, 0));
  12518.   SetColor(251, RGBQuad(255, 255, 0));
  12519.   SetColor(252, RGBQuad(0, 0, 255));
  12520.   SetColor(253, RGBQuad(255, 0, 255));
  12521.   SetColor(254, RGBQuad(0, 255, 255));
  12522.   SetColor(255, RGBQuad(255, 255, 255));
  12523.  
  12524.   for i := 0 to Count - 1 do
  12525.     if Items[i].Picture.Graphic <> nil then
  12526.     begin
  12527.       if Items[i].Picture.Graphic is TDIB then
  12528.         AddDIB(TDIB(Items[i].Picture.Graphic))
  12529.       else
  12530.         AddGraphic(Items[i].Picture.Graphic);
  12531.       if PaletteCount = 256 then Break;
  12532.     end;
  12533. end;
  12534.  
  12535. procedure TPictureCollection.DefineProperties(Filer: TFiler);
  12536. begin
  12537.   inherited DefineProperties(Filer);
  12538.   Filer.DefineBinaryProperty('ColorTable', ReadColorTable, WriteColorTable, True);
  12539. end;
  12540.  
  12541. type
  12542.   TPictureCollectionComponent = class(TComponent)
  12543.   private
  12544.     FList: TPictureCollection;
  12545.   published
  12546.     property List: TPictureCollection read FList write FList;
  12547.   end;
  12548.  
  12549. procedure TPictureCollection.LoadFromFile(const FileName: string);
  12550. var
  12551.   Stream: TFileStream;
  12552. begin
  12553.   Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  12554.   try
  12555.     LoadFromStream(Stream);
  12556.   finally
  12557.     Stream.Free;
  12558.   end;
  12559. end;
  12560.  
  12561. procedure TPictureCollection.LoadFromStream(Stream: TStream);
  12562. var
  12563.   Component: TPictureCollectionComponent;
  12564. begin
  12565.   Clear;
  12566.   Component := TPictureCollectionComponent.Create(nil);
  12567.   try
  12568.     Component.FList := Self;
  12569.     Stream.ReadComponentRes(Component);
  12570.  
  12571.     if Initialized then
  12572.     begin
  12573.       Initialize(FDXDraw);
  12574.       Restore;
  12575.     end;
  12576.   finally
  12577.     Component.Free;
  12578.   end;
  12579. end;
  12580.  
  12581. procedure TPictureCollection.SaveToFile(const FileName: string);
  12582. var
  12583.   Stream: TFileStream;
  12584. begin
  12585.   Stream := TFileStream.Create(FileName, fmCreate);
  12586.   try
  12587.     SaveToStream(Stream);
  12588.   finally
  12589.     Stream.Free;
  12590.   end;
  12591. end;
  12592.  
  12593. procedure TPictureCollection.SaveToStream(Stream: TStream);
  12594. var
  12595.   Component: TPictureCollectionComponent;
  12596. begin
  12597.   Component := TPictureCollectionComponent.Create(nil);
  12598.   try
  12599.     Component.FList := Self;
  12600.     Stream.WriteComponentRes('DelphiXPictureCollection', Component);
  12601.   finally
  12602.     Component.Free;
  12603.   end;
  12604. end;
  12605.  
  12606. procedure TPictureCollection.ReadColorTable(Stream: TStream);
  12607. begin
  12608.   Stream.ReadBuffer(ColorTable, SizeOf(ColorTable));
  12609. end;
  12610.  
  12611. procedure TPictureCollection.WriteColorTable(Stream: TStream);
  12612. begin
  12613.   Stream.WriteBuffer(ColorTable, SizeOf(ColorTable));
  12614. end;
  12615.  
  12616. {  TCustomDXImageList  }
  12617.  
  12618. constructor TCustomDXImageList.Create(AOnwer: TComponent);
  12619. begin
  12620.   inherited Create(AOnwer);
  12621.   FItems := TPictureCollection.Create(Self);
  12622. end;
  12623.  
  12624. destructor TCustomDXImageList.Destroy;
  12625. begin
  12626.   DXDraw := nil;
  12627.   FItems.Free;
  12628.   inherited Destroy;
  12629. end;
  12630.  
  12631. procedure TCustomDXImageList.Notification(AComponent: TComponent;
  12632.   Operation: TOperation);
  12633. begin
  12634.   inherited Notification(AComponent, Operation);
  12635.   if (Operation = opRemove) and (DXDraw = AComponent) then
  12636.     DXDraw := nil;
  12637. end;
  12638.  
  12639. procedure TCustomDXImageList.DXDrawNotifyEvent(Sender: TCustomDXDraw;
  12640.   NotifyType: TDXDrawNotifyType);
  12641. begin
  12642.   case NotifyType of
  12643.     dxntDestroying: DXDraw := nil;
  12644.     dxntInitialize: FItems.Initialize(Sender);
  12645.     dxntFinalize: FItems.Finalize;
  12646.     dxntRestore: FItems.Restore;
  12647.   end;
  12648. end;
  12649.  
  12650. procedure TCustomDXImageList.SetDXDraw(Value: TCustomDXDraw);
  12651. begin
  12652.   if FDXDraw <> nil then
  12653.     FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
  12654.  
  12655.   FDXDraw := Value;
  12656.  
  12657.   if FDXDraw <> nil then
  12658.     FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
  12659. end;
  12660.  
  12661. procedure TCustomDXImageList.SetItems(Value: TPictureCollection);
  12662. begin
  12663.   FItems.Assign(Value);
  12664. end;
  12665.  
  12666. {  TDirectDrawOverlay  }
  12667.  
  12668. constructor TDirectDrawOverlay.Create(DDraw: TDirectDraw; TargetSurface: TDirectDrawSurface);
  12669. begin
  12670.   inherited Create;
  12671.   FDDraw := DDraw;
  12672.   FTargetSurface := TargetSurface;
  12673.   FVisible := True;
  12674. end;
  12675.  
  12676. constructor TDirectDrawOverlay.CreateWindowed(WindowHandle: HWND);
  12677. {$IFDEF D3D_deprecated}
  12678. const
  12679.   PrimaryDesc: TDDSurfaceDesc = (
  12680.     dwSize: SizeOf(PrimaryDesc);
  12681.     dwFlags: DDSD_CAPS;
  12682.     ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE)
  12683.     );
  12684. {$ELSE}
  12685. var
  12686.   PrimaryDesc: TDDSurfaceDesc2;
  12687. {$ENDIF}
  12688. begin
  12689.   FDDraw2 := TDirectDraw.CreateEx(nil, False);
  12690.   if FDDraw2.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.SetCooperativeLevel(WindowHandle, DDSCL_NORMAL) <> DD_OK then
  12691.     raise EDirectDrawOverlayError.CreateFmt(SCannotInitialized, [SOverlay]);
  12692.  
  12693.   FTargetSurface2 := TDirectDrawSurface.Create(FDDraw2);
  12694.   {$IFNDEF D3D_deprecated}
  12695.   FillChar(PrimaryDesc, SizeOf(PrimaryDesc), 0);
  12696.   PrimaryDesc.dwSize := SizeOf(PrimaryDesc);
  12697.   PrimaryDesc.dwFlags := DDSD_CAPS;
  12698.   PrimaryDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
  12699.   {$ENDIF}
  12700.   if not FTargetSurface2.CreateSurface(PrimaryDesc) then
  12701.     raise EDirectDrawOverlayError.CreateFmt(SCannotInitialized, [SOverlay]);
  12702.  
  12703.   Create(FDDraw2, FTargetSurface2);
  12704. end;
  12705.  
  12706. destructor TDirectDrawOverlay.Destroy;
  12707. begin
  12708.   Finalize;
  12709.   FTargetSurface2.Free;
  12710.   FDDraw2.Free;
  12711.   inherited Destroy;
  12712. end;
  12713.  
  12714. procedure TDirectDrawOverlay.Finalize;
  12715. begin
  12716.   FBackSurface.Free; FBackSurface := nil;
  12717.   FSurface.Free; FSurface := nil;
  12718. end;
  12719.  
  12720. procedure TDirectDrawOverlay.Initialize(const SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF});
  12721. {$IFDEF D3D_deprecated}
  12722. const
  12723.   BackBufferCaps: TDDSCaps = (dwCaps: DDSCAPS_BACKBUFFER);
  12724. var
  12725.   DDSurface: IDirectDrawSurface;
  12726. {$ELSE}
  12727. var
  12728.   DDSurface: IDirectDrawSurface7;
  12729.   BackBufferCaps: TDDSCaps2;
  12730. {$ENDIF}
  12731. begin
  12732.   Finalize;
  12733.   try
  12734.     FSurface := TDirectDrawSurface.Create(FDDraw);
  12735.     if not FSurface.CreateSurface(SurfaceDesc) then
  12736.       raise EDirectDrawOverlayError.CreateFmt(SCannotInitialized, [SOverlay]);
  12737.  
  12738.     FBackSurface := TDirectDrawSurface.Create(FDDraw);
  12739.     {$IFNDEF D3D_deprecated}
  12740.     BackBufferCaps.dwCaps := DDSCAPS_BACKBUFFER;
  12741.     {$ENDIF}
  12742.     if SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_FLIP <> 0 then
  12743.     begin
  12744.       if FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetAttachedSurface(BackBufferCaps, DDSurface) = DD_OK then
  12745.         FBackSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := DDSurface;
  12746.     end
  12747.     else
  12748.       FBackSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF};
  12749.  
  12750.     if FVisible then
  12751.       SetOverlayRect(FOverlayRect)
  12752.     else
  12753.       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));
  12754.   except
  12755.     Finalize;
  12756.     raise;
  12757.   end;
  12758. end;
  12759.  
  12760. procedure TDirectDrawOverlay.Flip;
  12761. begin
  12762.   if FSurface = nil then Exit;
  12763.  
  12764.   if FSurface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_FLIP <> 0 then
  12765.     FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.Flip(nil, DDFLIP_WAIT);
  12766. end;
  12767.  
  12768. procedure TDirectDrawOverlay.SetOverlayColorKey(Value: TColor);
  12769. begin
  12770.   FOverlayColorKey := Value;
  12771.   if FSurface <> nil then
  12772.     SetOverlayRect(FOverlayRect);
  12773. end;
  12774.  
  12775. procedure TDirectDrawOverlay.SetOverlayRect(const Value: TRect);
  12776. var
  12777.   DestRect, SrcRect: TRect;
  12778.   XScaleRatio, YScaleRatio: Integer;
  12779.   OverlayFX: TDDOverlayFX;
  12780.   OverlayFlags: DWORD;
  12781. begin
  12782.   FOverlayRect := Value;
  12783.   if (FSurface <> nil) and FVisible then
  12784.   begin
  12785.     DestRect := FOverlayRect;
  12786.     SrcRect.Left := 0;
  12787.     SrcRect.Top := 0;
  12788.     SrcRect.Right := FSurface.SurfaceDesc.dwWidth;
  12789.     SrcRect.Bottom := FSurface.SurfaceDesc.dwHeight;
  12790.  
  12791.     OverlayFlags := DDOVER_SHOW;
  12792.  
  12793.     FillChar(OverlayFX, SizeOf(OverlayFX), 0);
  12794.     OverlayFX.dwSize := SizeOf(OverlayFX);
  12795.  
  12796.     {  Scale rate limitation  }
  12797.     XScaleRatio := (DestRect.right - DestRect.left) * 1000 div (SrcRect.right - SrcRect.left);
  12798.     YScaleRatio := (DestRect.bottom - DestRect.top) * 1000 div (SrcRect.bottom - SrcRect.top);
  12799.  
  12800.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH <> 0)
  12801.       and (FDDraw.DriverCaps.dwMinOverlayStretch <> 0)
  12802.       and (XScaleRatio < Integer(FDDraw.DriverCaps.dwMinOverlayStretch))
  12803.     then
  12804.     begin
  12805.       DestRect.Right := DestRect.Left + (Integer(FSurface.SurfaceDesc.dwWidth) * (Integer(FDDraw.DriverCaps.dwMinOverlayStretch) + 1)) div 1000;
  12806.     end;
  12807.  
  12808.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH <> 0)
  12809.       and (FDDraw.DriverCaps.dwMaxOverlayStretch <> 0)
  12810.       and (XScaleRatio > Integer(FDDraw.DriverCaps.dwMaxOverlayStretch))
  12811.     then
  12812.     begin
  12813.       DestRect.Right := DestRect.Left + (Integer(FSurface.SurfaceDesc.dwWidth) * (Integer(FDDraw.DriverCaps.dwMaxOverlayStretch) + 999)) div 1000;
  12814.     end;
  12815.  
  12816.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH <> 0)
  12817.       and (FDDraw.DriverCaps.dwMinOverlayStretch <> 0)
  12818.       and (YScaleRatio < Integer(FDDraw.DriverCaps.dwMinOverlayStretch))
  12819.     then
  12820.     begin
  12821.       DestRect.Bottom := DestRect.Top + (Integer(FSurface.SurfaceDesc.dwHeight) * (Integer(FDDraw.DriverCaps.dwMinOverlayStretch) + 1)) div 1000;
  12822.     end;
  12823.  
  12824.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH <> 0)
  12825.       and (FDDraw.DriverCaps.dwMaxOverlayStretch <> 0)
  12826.       and (YScaleRatio > Integer(FDDraw.DriverCaps.dwMaxOverlayStretch))
  12827.     then
  12828.     begin
  12829.       DestRect.Bottom := DestRect.Top + (Integer(FSurface.SurfaceDesc.dwHeight) * (Integer(FDDraw.DriverCaps.dwMaxOverlayStretch) + 999)) div 1000;
  12830.     end;
  12831.  
  12832.     {  Clipping at forwarding destination  }
  12833.     XScaleRatio := (DestRect.Right - DestRect.Left) * 1000 div (SrcRect.Right - SrcRect.Left);
  12834.     YScaleRatio := (DestRect.Bottom - DestRect.Top) * 1000 div (SrcRect.Bottom - SrcRect.Top);
  12835.  
  12836.     if DestRect.Top < 0 then
  12837.     begin
  12838.       SrcRect.Top := -DestRect.Top * 1000 div YScaleRatio;
  12839.       DestRect.Top := 0;
  12840.     end;
  12841.  
  12842.     if DestRect.Left < 0 then
  12843.     begin
  12844.       SrcRect.Left := -DestRect.Left * 1000 div XScaleRatio;
  12845.       DestRect.Left := 0;
  12846.     end;
  12847.  
  12848.     if DestRect.Right > Integer(FTargetSurface.SurfaceDesc.dwWidth) then
  12849.     begin
  12850.       SrcRect.Right := Integer(FSurface.SurfaceDesc.dwWidth) - ((DestRect.Right - Integer(FTargetSurface.SurfaceDesc.dwWidth)) * 1000 div XScaleRatio);
  12851.       DestRect.Right := FTargetSurface.SurfaceDesc.dwWidth;
  12852.     end;
  12853.  
  12854.     if DestRect.Bottom > Integer(FTargetSurface.SurfaceDesc.dwHeight) then
  12855.     begin
  12856.       SrcRect.Bottom := Integer(FSurface.SurfaceDesc.dwHeight) - ((DestRect.Bottom - Integer(FTargetSurface.SurfaceDesc.dwHeight)) * 1000 div YScaleRatio);
  12857.       DestRect.Bottom := FTargetSurface.SurfaceDesc.dwHeight;
  12858.     end;
  12859.  
  12860.     {  Forwarding former arrangement  }
  12861.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNBOUNDARYSRC <> 0) and (FDDraw.DriverCaps.dwAlignBoundarySrc <> 0) then
  12862.     begin
  12863.       SrcRect.Left := (SrcRect.Left + Integer(FDDraw.DriverCaps.dwAlignBoundarySrc) div 2) div
  12864.         Integer(FDDraw.DriverCaps.dwAlignBoundarySrc) * Integer(FDDraw.DriverCaps.dwAlignBoundarySrc);
  12865.     end;
  12866.  
  12867.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNSIZESRC <> 0) and (FDDraw.DriverCaps.dwAlignSizeSrc <> 0) then
  12868.     begin
  12869.       SrcRect.Right := SrcRect.Left + (SrcRect.Right - SrcRect.Left + Integer(FDDraw.DriverCaps.dwAlignSizeSrc) div 2) div
  12870.         Integer(FDDraw.DriverCaps.dwAlignSizeSrc) * Integer(FDDraw.DriverCaps.dwAlignSizeSrc);
  12871.     end;
  12872.  
  12873.     {  Forwarding destination arrangement  }
  12874.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNBOUNDARYDEST <> 0) and (FDDraw.DriverCaps.dwAlignBoundaryDest <> 0) then
  12875.     begin
  12876.       DestRect.Left := (DestRect.Left + Integer(FDDraw.DriverCaps.dwAlignBoundaryDest) div 2) div
  12877.         Integer(FDDraw.DriverCaps.dwAlignBoundaryDest) * Integer(FDDraw.DriverCaps.dwAlignBoundaryDest);
  12878.     end;
  12879.  
  12880.     if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNSIZEDEST <> 0) and (FDDraw.DriverCaps.dwAlignSizeDest <> 0) then
  12881.     begin
  12882.       DestRect.Right := DestRect.Left + (DestRect.Right - DestRect.Left) div
  12883.         Integer(FDDraw.DriverCaps.dwAlignSizeDest) * Integer(FDDraw.DriverCaps.dwAlignSizeDest);
  12884.     end;
  12885.  
  12886.     {  Color key setting  }
  12887.     if FDDraw.DriverCaps.dwCKeyCaps and DDCKEYCAPS_DESTOVERLAY <> 0 then
  12888.     begin
  12889.       OverlayFX.dckDestColorkey.dwColorSpaceLowValue := FTargetSurface.ColorMatch(FOverlayColorKey);
  12890.       OverlayFX.dckDestColorkey.dwColorSpaceHighValue := OverlayFX.dckDestColorkey.dwColorSpaceLowValue;
  12891.  
  12892.       OverlayFlags := OverlayFlags or (DDOVER_KEYDESTOVERRIDE or DDOVER_DDFX);
  12893.     end;
  12894.  
  12895.     FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.UpdateOverlay(@SrcRect, FTargetSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, @DestRect, OverlayFlags, @OverlayFX);
  12896.   end;
  12897. end;
  12898.  
  12899. procedure TDirectDrawOverlay.SetVisible(Value: Boolean);
  12900. begin
  12901.   FVisible := False;
  12902.   if FSurface <> nil then
  12903.   begin
  12904.     if FVisible then
  12905.       SetOverlayRect(FOverlayRect)
  12906.     else
  12907.       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));
  12908.   end;
  12909. end;
  12910.  
  12911. { TDXFont }
  12912.  
  12913. constructor TDXFont.Create(AOwner: TComponent);
  12914. begin
  12915.   inherited Create(AOwner);
  12916. end;
  12917.  
  12918. destructor TDXFont.Destroy;
  12919. begin
  12920.   inherited Destroy;
  12921. end;
  12922.  
  12923. procedure TDXFont.Notification(AComponent: TComponent; Operation: TOperation);
  12924. begin
  12925.   inherited Notification(AComponent, Operation);
  12926.   if (Operation = opRemove) and (AComponent = FDXImageList) then
  12927.   begin
  12928.     FDXImageList := nil;
  12929.   end;
  12930. end; {Notification}
  12931.  
  12932. procedure TDXFont.SetFont(const Value: string);
  12933. begin
  12934.   FFont := Value;
  12935.   if assigned(FDXImageList) then
  12936.   begin
  12937.     FFontIndex := FDXImageList.items.IndexOf(FFont); { find font once }
  12938.     fOffset := FDXImageList.Items[FFontIndex].PatternWidth;
  12939.   end;
  12940. end;
  12941.  
  12942. procedure TDXFont.SetFontIndex(const Value: Integer);
  12943. begin
  12944.   FFontIndex := Value;
  12945.   if assigned(FDXImageList) then
  12946.   begin
  12947.     FFont := FDXImageList.Items[FFontIndex].Name;
  12948.     fOffset := FDXImageList.Items[FFontIndex].PatternWidth;
  12949.   end;
  12950. end;
  12951.  
  12952. procedure TDXFont.TextOut(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string);
  12953. var
  12954.   loop, letter: Integer;
  12955.   UpperText: string;
  12956. begin
  12957.   if not assigned(FDXImageList) then
  12958.     exit;
  12959.   Offset := FDXImageList.Items[FFontIndex].PatternWidth;
  12960.   UpperText := AnsiUppercase(text);
  12961.   for loop := 1 to Length(UpperText) do
  12962.   begin
  12963.     letter := AnsiPos(UpperText[loop], Alphabet) - 1;
  12964.     if letter < 0 then letter := 30;
  12965.     FDXImageList.items[FFontIndex].Draw(DirectDrawSurface, x + Offset * loop, y, letter);
  12966.   end; { loop }
  12967. end;
  12968.  
  12969. { TDXPowerFontEffectsParameters }
  12970.  
  12971. procedure TDXPowerFontEffectsParameters.SetAlphaValue(
  12972.   const Value: Integer);
  12973. begin
  12974.   FAlphaValue := Value;
  12975. end;
  12976.  
  12977. procedure TDXPowerFontEffectsParameters.SetAngle(const Value: Integer);
  12978. begin
  12979.   FAngle := Value;
  12980. end;
  12981.  
  12982. procedure TDXPowerFontEffectsParameters.SetCenterX(const Value: Integer);
  12983. begin
  12984.   FCenterX := Value;
  12985. end;
  12986.  
  12987. procedure TDXPowerFontEffectsParameters.SetCenterY(const Value: Integer);
  12988. begin
  12989.   FCenterY := Value;
  12990. end;
  12991.  
  12992. procedure TDXPowerFontEffectsParameters.SetHeight(const Value: Integer);
  12993. begin
  12994.   FHeight := Value;
  12995. end;
  12996.  
  12997. procedure TDXPowerFontEffectsParameters.SetWAmplitude(
  12998.   const Value: Integer);
  12999. begin
  13000.   FWAmplitude := Value;
  13001. end;
  13002.  
  13003. procedure TDXPowerFontEffectsParameters.SetWidth(const Value: Integer);
  13004. begin
  13005.   FWidth := Value;
  13006. end;
  13007.  
  13008. procedure TDXPowerFontEffectsParameters.SetWLenght(const Value: Integer);
  13009. begin
  13010.   FWLenght := Value;
  13011. end;
  13012.  
  13013. procedure TDXPowerFontEffectsParameters.SetWPhase(const Value: Integer);
  13014. begin
  13015.   FWPhase := Value;
  13016. end;
  13017.  
  13018. { TDXPowerFont }
  13019.  
  13020. constructor TDXPowerFont.Create(AOwner: TComponent);
  13021. begin
  13022.   inherited Create(AOwner);
  13023.   FUseEnterChar := True;
  13024.   FEnterCharacter := '|<';
  13025.   FAlphabets := PowerAlphaBet;
  13026.   FTextOutType := ttNormal;
  13027.   FTextOutEffect := teNormal;
  13028.   FEffectsParameters := TDXPowerFontEffectsParameters.Create;
  13029. end;
  13030.  
  13031. destructor TDXPowerFont.Destroy;
  13032. begin
  13033.   inherited Destroy;
  13034. end;
  13035.  
  13036. procedure TDXPowerFont.SetAlphabets(const Value: string);
  13037. begin
  13038.   if FDXImageList <> nil then
  13039.     if Length(Value) > FDXImageList.Items[FFontIndex].PatternCount - 1 then Exit;
  13040.   FAlphabets := Value;
  13041. end;
  13042.  
  13043. procedure TDXPowerFont.SetEnterCharacter(const Value: string);
  13044. begin
  13045.   if Length(Value) >= 2 then Exit;
  13046.   FEnterCharacter := Value;
  13047. end;
  13048.  
  13049. procedure TDXPowerFont.SetFont(const Value: string);
  13050. begin
  13051.   FFont := Value;
  13052.   if FDXImageList <> nil then
  13053.   begin
  13054.     FFontIndex := FDXImageList.Items.IndexOf(FFont); // Find font once...
  13055.     Offset := FDXImageList.Items[FFontIndex].PatternWidth;
  13056.  
  13057.     FEffectsParameters.Width := FDXImageList.Items[FFontIndex].PatternWidth;
  13058.     FEffectsParameters.Height := FDXImageList.Items[FFontIndex].PatternHeight;
  13059.   end;
  13060. end;
  13061.  
  13062. procedure TDXPowerFont.SetFontIndex(const Value: Integer);
  13063. begin
  13064.   FFontIndex := Value;
  13065.   if FDXImageList <> nil then
  13066.   begin
  13067.     FFont := FDXImageList.Items[FFontIndex].Name;
  13068.     Offset := FDXImageList.Items[FFontIndex].PatternWidth;
  13069.  
  13070.     FEffectsParameters.Width := FDXImageList.Items[FFontIndex].PatternWidth;
  13071.     FEffectsParameters.Height := FDXImageList.Items[FFontIndex].PatternHeight;
  13072.   end;
  13073. end;
  13074.  
  13075. procedure TDXPowerFont.SetEffectsParameters(const Value: TDXPowerFontEffectsParameters);
  13076. begin
  13077.   FEffectsParameters := Value;
  13078. end;
  13079.  
  13080. procedure TDXPowerFont.SetTextOutEffect(const Value: TDXPowerFontTextOutEffect);
  13081. begin
  13082.   FTextOutEffect := Value;
  13083. end;
  13084.  
  13085. procedure TDXPowerFont.SetTextOutType(const Value: TDXPowerFontTextOutType);
  13086. begin
  13087.   FTextOutType := Value;
  13088. end;
  13089.  
  13090. procedure TDXPowerFont.SetUseEnterChar(const Value: Boolean);
  13091. begin
  13092.   FUseEnterChar := Value;
  13093. end;
  13094.  
  13095. function TDXPowerFont.TextOutFast(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string): Boolean;
  13096. var
  13097.   Loop, Letter: Integer;
  13098.   txt: string;
  13099. begin
  13100.   Result := False;
  13101.   if FDXImageList = nil then Exit;
  13102.         // modified
  13103.   case FTextOutType of
  13104.     ttNormal: Txt := Text;
  13105.     ttUpperCase: Txt := AnsiUpperCase(Text);
  13106.     ttLowerCase: Txt := AnsiLowerCase(Text);
  13107.   end;
  13108.   Offset := FDXImageList.Items[FFontIndex].PatternWidth;
  13109.   Loop := 1;
  13110.   while (Loop <= Length(Text)) do
  13111.   begin
  13112.     Letter := AnsiPos(txt[Loop], FAlphabets); // modified
  13113.     if (Letter > 0) and (Letter < FDXImageList.Items[FFontIndex].PatternCount - 1) then
  13114.       FDXImageList.Items[FFontIndex].Draw(DirectDrawSurface, X + (Offset * Loop), Y, Letter - 1);
  13115.     Inc(Loop);
  13116.   end;
  13117.   Result := True;
  13118. end;
  13119.  
  13120. function TDXPowerFont.TextOut(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string): Boolean;
  13121. var
  13122.   Loop, Letter: Integer;
  13123.   FCalculatedEnters, EnterHeghit, XLoop: Integer;
  13124.   DoTextOut: Boolean;
  13125.   Txt: string;
  13126.   Rect: TRect;
  13127. begin
  13128.   Result := False;
  13129.   if FDXImageList = nil then Exit;
  13130.   Txt := Text;
  13131.   DoTextOut := True;
  13132.   if Assigned(FBeforeTextOut) then FBeforeTextOut(Self, Txt, DoTextOut);
  13133.   if not DoTextOut then Exit;
  13134.   // modified
  13135.   case FTextOutType of
  13136.     ttNormal: Txt := Text;
  13137.     ttUpperCase: Txt := AnsiUpperCase(Text);
  13138.     ttLowerCase: Txt := AnsiLowerCase(Text);
  13139.   end;
  13140.   Offset := FDXImageList.Items[FFontIndex].PatternWidth;
  13141.   FCalculatedEnters := 0;
  13142.   EnterHeghit := FDXImageList.Items[FFontIndex].PatternHeight;
  13143.   XLoop := 0;
  13144.   Loop := 1;
  13145.   while (Loop <= Length(Txt)) do
  13146.   begin
  13147.     if FUseEnterChar then
  13148.     begin
  13149.       if Txt[Loop] = FEnterCharacter[1] then begin Inc(FCalculatedEnters); Inc(Loop); end;
  13150.       if Txt[Loop] = FEnterCharacter[2] then begin Inc(FCalculatedEnters); XLoop := 0; {-FCalculatedEnters;} Inc(Loop); end;
  13151.     end;
  13152.     Letter := AnsiPos(Txt[Loop], FAlphabets); // modified
  13153.  
  13154.     if (Letter > 0) and (Letter < FDXImageList.Items[FFontIndex].PatternCount - 1) then
  13155.       case FTextOutEffect of
  13156.         teNormal: FDXImageList.Items[FFontIndex].Draw(DirectDrawSurface, X + (Offset * XLoop), Y + (FCalculatedEnters * EnterHeghit), Letter - 1);
  13157.         teRotat: FDXImageList.Items[FFontIndex].DrawRotate(DirectDrawSurface, X + (Offset * XLoop), Y + (FCalculatedEnters * EnterHeghit), FEffectsParameters.Width, FEffectsParameters.Height, Letter - 1, FEffectsParameters.CenterX, FEffectsParameters.CenterY, FEffectsParameters.Angle);
  13158.         teAlphaBlend:
  13159.           begin
  13160.             Rect.Left := X + (Offset * XLoop);
  13161.             Rect.Top := Y + (FCalculatedEnters * EnterHeghit);
  13162.             Rect.Right := Rect.Left + FEffectsParameters.Width;
  13163.             Rect.Bottom := Rect.Top + FEffectsParameters.Height;
  13164.  
  13165.             FDXImageList.Items[FFontIndex].DrawAlpha(DirectDrawSurface, Rect, Letter - 1, FEffectsParameters.AlphaValue);
  13166.           end;
  13167.         teWaveX: FDXImageList.Items[FFontIndex].DrawWaveX(DirectDrawSurface, X + (Offset * XLoop), Y + (FCalculatedEnters * EnterHeghit), FEffectsParameters.Width, FEffectsParameters.Height, Letter - 1, FEffectsParameters.WAmplitude, FEffectsParameters.WLenght, FEffectsParameters.WPhase);
  13168.       end;
  13169.     Inc(Loop);
  13170.     Inc(XLoop);
  13171.   end;
  13172.   if Assigned(FAfterTextOut) then FAfterTextOut(Self, Txt);
  13173.   Result := True;
  13174. end;
  13175.  
  13176. //---------------------------------------------------------------------------
  13177. {
  13178. Main code supported hardware acceleration by videoadapteur
  13179.  *  Copyright (c) 2004-2010 Jaro Benes
  13180.  *  All Rights Reserved
  13181.  *  Version 1.09
  13182.  *  D2D Hardware module - main implementation part
  13183.  *  web site: www.micrel.cz/Dx
  13184.  *  e-mail: delphix_d2d@micrel.cz
  13185. }
  13186.  
  13187. constructor TD2DTextures.Create(DDraw: TCustomDXDraw);
  13188. begin
  13189.   //inherited;
  13190.   FDDraw := DDraw; //reload DDraw
  13191. {$IFNDEF VER4UP}
  13192.   TexLen := 0;
  13193.   Texture := nil;
  13194. {$ELSE}
  13195.   SetLength(Texture, 0);
  13196. {$ENDIF}
  13197. end;
  13198.  
  13199. destructor TD2DTextures.Destroy;
  13200. var
  13201.   I: Integer;
  13202. begin
  13203.   if Assigned(Texture) then
  13204.     {$IFDEF VER4UP}
  13205.     for I := Low(Texture) to High(Texture) do
  13206.     begin
  13207.       Texture[I].D2DTexture.Free;
  13208.       {$IFDEF VIDEOTEX}
  13209.       if Assigned(Texture[I].VDIB) then
  13210.         Texture[I].VDIB.Free;
  13211.       {$ENDIF}
  13212.     end;
  13213.     {$ELSE}
  13214.     for I := 0 to TexLen - 1 do
  13215.     begin
  13216.       Texture[I].D2DTexture.Free;
  13217.       {$IFDEF VIDEOTEX}
  13218.       if Assigned(Texture[I].VDIB) then
  13219.         Texture[I].VDIB.Free;
  13220.       {$ENDIF}
  13221.     end;
  13222.     {$ENDIF}
  13223.   inherited;
  13224. end;
  13225.  
  13226. function TD2DTextures.GetD2DMaxTextures: Integer;
  13227. begin
  13228.   Result := {$IFDEF VER4UP}Length(Texture){$ELSE}TexLen{$ENDIF};
  13229. end;
  13230.  
  13231. procedure TD2DTextures.SaveTextures(path: string);
  13232. var I: Integer;
  13233. begin
  13234.   if Texture <> nil then
  13235.     {$IFDEF VER4UP}
  13236.     if Length(Texture) > 0 then
  13237.       for I := Low(Texture) to High(Texture) do
  13238.     {$ELSE}
  13239.     if TexLen > 0 then
  13240.       for I := 0 to TexLen - 1 do
  13241.     {$ENDIF}
  13242.         Texture[I].D2DTexture.FImage.SaveToFile(path + Texture[I].Name + '.dxt');
  13243. end;
  13244.  
  13245. procedure TD2DTextures.SetD2DMaxTextures(const Value: Integer);
  13246. begin
  13247.   if Value > 0 then
  13248.   {$IFDEF VER4UP}
  13249.     SetLength(Texture, Value)
  13250.   {$ELSE}
  13251.     Inc(TexLen);
  13252.   if Texture = nil then
  13253.     Texture := AllocMem(SizeOf(TTextureRec))
  13254.   else begin
  13255.       {alokuj pamet}
  13256.     ReallocMem(Texture, TexLen * SizeOf(TTextureRec));
  13257.   end;
  13258.   {$ENDIF}
  13259. end;
  13260.  
  13261. function TD2DTextures.Find(byName: string): Integer;
  13262. var I: Integer;
  13263. begin
  13264.   Result := -1;
  13265.   if Texture <> nil then
  13266.     {$IFDEF VER4UP}
  13267.     if Length(Texture) > 0 then
  13268.       for I := Low(Texture) to High(Texture) do
  13269.         if AnsiUpperCase(Texture[I].Name) = AnsiUpperCase(byName) then
  13270.         begin
  13271.           Result := I;
  13272.           Exit;
  13273.         end;
  13274.     {$ELSE}
  13275.     if TexLen > 0 then
  13276.       for I := 0 to TexLen - 1 do
  13277.         if AnsiUpperCase(Texture[I].Name) = AnsiUpperCase(byName) then
  13278.         begin
  13279.           Result := I;
  13280.           Exit;
  13281.         end;
  13282.     {$ENDIF}
  13283. end;
  13284.  
  13285. function TD2DTextures.GetTextureByName(const byName: string): TDirect3DTexture2;
  13286. begin
  13287.   Result := nil;
  13288.   if Assigned(Texture) then
  13289.     Result := Texture[Find(byName)].D2DTexture;
  13290. end;
  13291.  
  13292. function TD2DTextures.GetTextureByIndex(const byIndex: Integer): TDirect3DTexture2;
  13293. begin
  13294.   Result := nil;
  13295.   {$IFNDEF VER4UP}
  13296.   if Assigned(Texture) and (byIndex >= 0) and (byIndex <= (TexLen - 1)) then
  13297.     Result := Texture[byIndex].D2DTexture;
  13298.   {$ELSE}
  13299.   if Assigned(Texture) and (byIndex in [0..High(Texture)]) then
  13300.     Result := Texture[byIndex].D2DTexture;
  13301.   {$ENDIF}
  13302. end;
  13303.  
  13304. function TD2DTextures.GetTextureNameByIndex(const byIndex: Integer): string;
  13305. begin
  13306.   Result := '';
  13307.   {$IFNDEF VER4UP}
  13308.   if Assigned(Texture) and (byIndex >= 0) and (byIndex <= (TexLen - 1)) then
  13309.     Result := Texture[byIndex].Name;
  13310.   {$ELSE}
  13311.   if Assigned(Texture) and (byIndex in [0..High(Texture)]) then
  13312.     Result := Texture[byIndex].Name;
  13313.   {$ENDIF}
  13314. end;
  13315.  
  13316. function TD2DTextures.Count: Integer;
  13317. begin
  13318.   Result := 0;
  13319.   if Assigned(Texture) then
  13320.   {$IFNDEF VER4UP}
  13321.     Result := TexLen;
  13322.   {$ELSE}
  13323.     Result := High(Texture) + 1;
  13324.   {$ENDIF}
  13325. end;
  13326.  
  13327. procedure TD2DTextures.D2DPruneAllTextures;
  13328. var I: Integer;
  13329. begin
  13330.   if not Assigned(Texture) then Exit;
  13331.   {$IFDEF VER4UP}
  13332.   for I := Low(Texture) to High(Texture) do
  13333.   {$ELSE}
  13334.   for I := 0 to TexLen - 1 do
  13335.   {$ENDIF}
  13336.   begin
  13337.     Texture[I].D2DTexture.Free;
  13338.     {$IFDEF VIDEOTEX}
  13339.     if Assigned(Texture[I].VDIB) then
  13340.       Texture[I].VDIB.Free;
  13341.     {$ENDIF}
  13342.   end;
  13343.   {$IFDEF VER4UP}
  13344.   SetLength(Texture, 0);
  13345.   {$ELSE}
  13346.   TexLen := 0;
  13347.   {$ENDIF}
  13348. end;
  13349.  
  13350. procedure TD2DTextures.D2DFreeTextures;
  13351. var I: Integer;
  13352. begin
  13353.   if not Assigned(Texture) then Exit;
  13354.   {$IFDEF VER4UP}
  13355.   for I := Low(Texture) to High(Texture) do
  13356.   {$ELSE}
  13357.   for I := 0 to TexLen - 1 do
  13358.   {$ENDIF}
  13359.   begin
  13360.     Texture[I].D2DTexture.Free;
  13361.     {$IFDEF VIDEOTEX}
  13362.     if Assigned(Texture[I].VDIB) then
  13363.       Texture[I].VDIB.Free;
  13364.     {$ENDIF}  
  13365.   end;
  13366.   {$IFNDEF VER4UP}
  13367.   FreeMem(Texture, TexLen * SizeOf(TTextureRec));
  13368.   Texture := nil;
  13369.   {$ENDIF}
  13370. end;
  13371.  
  13372. procedure TD2DTextures.D2DPruneTextures;
  13373. begin
  13374.   if {$IFDEF VER4UP}Length(Texture){$ELSE}TexLen{$ENDIF} > maxTexBlock then
  13375.   begin
  13376.     D2DPruneAllTextures
  13377.   end;
  13378. end;
  13379.  
  13380. procedure TD2DTextures.SizeAdjust(var DIB: TDIB; var FloatX1, FloatY1, FloatX2, FloatY2: Double);
  13381. var
  13382.   X, Y: Integer;
  13383.   tempDIB: TDIB;
  13384. begin {auto-adjust size n^2 for accelerator compatibility}
  13385.   X := 1;
  13386.   repeat
  13387.     X := X * 2;
  13388.   until DIB.Width <= X;
  13389.   Y := 1;
  13390.   repeat
  13391.     Y := Y * 2
  13392.   until DIB.Height <= Y;
  13393.   {$IFDEF FORCE_SQUARE}
  13394.   X := Max(X, Y);
  13395.   Y := X;
  13396.   {$ENDIF}
  13397.   if (X = DIB.Width) and (Y = DIB.Height) then
  13398.   begin
  13399.     if DIB.BitCount = 32 then Exit; {do not touch}
  13400.     {code for correction a DIB.BitCount to 24 bit only}
  13401.     tempDIB := TDIB.Create;
  13402.     try
  13403.       tempDIB.SetSize(X, Y, 24);
  13404.       FillChar(tempDIB.PBits^, tempDIB.Size, 0);
  13405.       tempDIB.Canvas.Draw(0, 0, DIB);
  13406.       DIB.Assign(tempDIB);
  13407.     finally
  13408.       tempDIB.Free;
  13409.     end;
  13410.     Exit;
  13411.   end;
  13412.   tempDIB := TDIB.Create;
  13413.   try
  13414.     if DIB.BitCount = 32 then
  13415.     begin
  13416.       tempDIB.SetSize(X, Y, 32);
  13417.       FillChar(tempDIB.PBits^, tempDIB.Size, 0);
  13418.       //tempDIB.Canvas.Brush.Color := clBlack;
  13419.       //tempDIB.Canvas.FillRect(Bounds(0, 0, X, Y));
  13420.       tempDIB.Canvas.Draw(0, 0, DIB);
  13421. //      if DIB.HasAlphaChannel then
  13422. //        tempDIB.AssignAlphaChannel(DIB);
  13423.     end
  13424.     else
  13425.     begin
  13426.       tempDIB.SetSize(X, Y, 24 {DIB.BitCount}); {bad value for some 16}
  13427.       FillChar(tempDIB.PBits^, tempDIB.Size, 0);
  13428.       //tempDIB.Canvas.Brush.Color := clBlack;
  13429.       //tempDIB.Canvas.FillRect(Bounds(0, 0, X, Y));
  13430.       tempDIB.Canvas.Draw(0, 0, DIB);
  13431.     end;
  13432.     FloatX2 := (1 / tempDIB.Width) * DIB.Width;
  13433.     FloatY2 := (1 / tempDIB.Height) * DIB.Height;
  13434.     DIB.Assign(tempDIB);
  13435.   finally
  13436.     tempDIB.Free;
  13437.   end
  13438. end;
  13439.  
  13440. function TD2DTextures.CanFindTexture(aImage: TPictureCollectionItem): Boolean;
  13441. var I: Integer;
  13442. begin
  13443.   Result := True;
  13444.   {$IFDEF VER4UP}
  13445.   if Length(Texture) > 0 then
  13446.   {$ELSE}
  13447.   if TexLen > 0 then
  13448.   {$ENDIF}
  13449.     for I := 0 to D2DMaxTextures - 1 do
  13450.       if Texture[I].Name = aImage.Name then Exit;
  13451.   Result := False;
  13452. end;
  13453.  
  13454. function TD2DTextures.LoadTextures(aImage: TPictureCollectionItem): Boolean;
  13455. var
  13456.   {$IFNDEF VIDEOTEX}
  13457.   VDIB: TDIB;
  13458.   {$ENDIF}
  13459.   T: TDXTextureImage;
  13460. begin
  13461.   Result := True;
  13462.   try
  13463.     D2DPruneTextures; {up to maxTexBlock textures only}
  13464.     D2DMaxTextures := D2DMaxTextures + 1;
  13465.     if aImage.Name = '' then // FIX: OPTIMIZED
  13466.       aImage.Name := aImage.GetNamePath; {this name is supplement name, when wasn't aImage.Name fill}
  13467.     {$IFDEF VIDEOTEX}Texture[D2DMaxTextures - 1].{$ENDIF}VDIB := TDIB.Create;
  13468.     try
  13469.     with Texture[D2DMaxTextures - 1] do
  13470.     begin
  13471.       VDIB.Assign(aImage.Picture.Graphic);
  13472.       VDIB.Transparent := aImage.Transparent;
  13473.       FloatX1 := 0; FloatY1 := 0; FloatX2 := 1; FloatY2 := 1;
  13474.       SizeAdjust(VDIB, FloatX1, FloatY1, FloatX2, FloatY2);
  13475.       Name := aImage.Name;
  13476.       Width := VDIB.Width;
  13477.       Height := VDIB.Height;
  13478.       if VDIB.HasAlphaChannel then
  13479.       begin
  13480.         DIB2DXT(VDIB, T);
  13481.         T.ImageName := aImage.Name;
  13482.         T.Transparent := aImage.Transparent;
  13483.         D2DTexture := TDirect3DTexture2.Create(FDDraw, T, False);
  13484.         D2DTexture.Transparent := aImage.Transparent;
  13485.         AlphaChannel := True;
  13486.         //**T.Free; DO NOT FREE - surface is lost ** FIX by JB.
  13487.       end
  13488.       else
  13489.       begin
  13490.         D2DTexture := TDirect3DTexture2.Create(FDDraw, VDIB, False);
  13491.         D2DTexture.TransparentColor := DWORD(aImage.TransparentColor);
  13492.         D2DTexture.Surface.TransparentColor := DWORD(aImage.TransparentColor);
  13493.         D2DTexture.Transparent := aImage.Transparent;
  13494.         AlphaChannel := False;
  13495.       end;
  13496.     end;
  13497.     finally
  13498.       {$IFNDEF VIDEOTEX}
  13499.       VDIB.Free;
  13500.       {$ENDIF}
  13501.     end;
  13502.   except
  13503.     D2DMaxTextures := D2DMaxTextures - 1;
  13504.     Result := False;
  13505.   end;
  13506. end;
  13507.  
  13508. {$IFDEF VER4UP}
  13509. function TD2DTextures.CanFindTexture(const TexName: string): Boolean;
  13510. {$ELSE}
  13511. function TD2DTextures.CanFindTexture2(const TexName: string): Boolean;
  13512. {$ENDIF}
  13513. var I: Integer;
  13514. begin
  13515.   Result := True;
  13516. {$IFDEF VER4UP}
  13517.   if Length(Texture) > 0 then
  13518. {$ELSE}
  13519.   if TexLen > 0 then
  13520. {$ENDIF}
  13521.     for I := 0 to D2DMaxTextures - 1 do
  13522.       if Texture[I].Name = TexName then Exit;
  13523.   Result := False;
  13524. end;
  13525.  
  13526. function TD2DTextures.SetTransparentColor(dds: TDirectDrawSurface; PixelColor: Integer; Transparent: Boolean): Integer;
  13527. {Give a speculative transparent color value from DDS}
  13528. var
  13529.   ddck: TDDColorKey;
  13530.   CLL: Integer;
  13531. begin
  13532.   Result := 0;
  13533.   if dds.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  13534.     if dds.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetColorKey(DDCKEY_SRCBLT, ddck) = DD_OK then
  13535.       Result := ddck.dwColorSpaceLowValue;
  13536.   CLL := PixelColor; {have to pick up color from 0,0 pix of DIB}
  13537.   if Transparent then {and must be transparent}
  13538.     if (CLL <> Result) then {when different}
  13539.       Result := CLL; {use our TransparentColor}
  13540. end;
  13541.  
  13542. {$IFDEF VER4UP}
  13543. function TD2DTextures.LoadTextures(dds: TDirectDrawSurface; Transparent: Boolean; asTexName: string): Boolean;
  13544. {$ELSE}
  13545. function TD2DTextures.LoadTextures2(dds: TDirectDrawSurface; Transparent: Boolean; asTexName: string): Boolean;
  13546. {$ENDIF}
  13547. var
  13548.   {$IFNDEF VIDEOTEX}
  13549.   VDIB: TDIB;
  13550.   {$ENDIF}
  13551.   Col: Integer;
  13552.   T: PTextureRec;
  13553. begin
  13554.   Result := True;
  13555.   T := nil;
  13556.   try
  13557.     if dds.Modified then
  13558.     begin
  13559.       {search existing texture and return the pointer}
  13560.       T := Addr(Texture[Find(asTexName)]);
  13561.       {$IFNDEF VIDEOTEX}VDIB := TDIB.Create;{$ENDIF}
  13562.     end
  13563.     else
  13564.     begin
  13565.       D2DPruneTextures; {up to maxTexBlock textures only}
  13566.       D2DMaxTextures := D2DMaxTextures + 1; {next to new space}
  13567.       T := Addr(Texture[D2DMaxTextures - 1]); {is new place}
  13568.       {set name}
  13569.       T.Name := asTexName;
  13570.       {and create video-dib object for store the picture periodically changed}
  13571.       {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB := TDIB.Create;
  13572.       //T.VDIB.PixelFormat := MakeDIBPixelFormat(8, 8, 8);
  13573.     end;
  13574.     try
  13575.       {the dds assigned here}
  13576.       {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Assign(dds);
  13577.       {with full adjustation}
  13578.       T.FloatX1 := 0; T.FloatY1 := 0; T.FloatX2 := 1; T.FloatY2 := 1;
  13579.       SizeAdjust({$IFDEF VIDEOTEX}T.{$ENDIF}VDIB, T.FloatX1, T.FloatY1, T.FloatX2, T.FloatY2);
  13580.       {and store 'changed' values of size here}
  13581.       T.Width := {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Width;
  13582.       T.Height := {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Height;
  13583.       {and it have to set by dds as transparent, when it set up}
  13584.       {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Transparent := Transparent;
  13585.       {get up transparent color}
  13586.       Col := SetTransparentColor(dds, {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Pixels[0, 0], Transparent);
  13587.       if dds.Modified then
  13588.         T.D2DTexture.Load {for minimize time only load as videotexture}
  13589.       else
  13590.         T.D2DTexture := TDirect3DTexture2.Create(FDDraw, {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB, False); {create it}
  13591.       {don't forget set transparent values on texture!}
  13592.       T.D2DTexture.TransparentColor := DWORD(COL);
  13593.       T.D2DTexture.Surface.TransparentColor := DWORD(COL);
  13594.       T.D2DTexture.Transparent := Transparent;
  13595.     finally
  13596.      {$IFNDEF VIDEOTEX}
  13597.       if Assigned(VDIB) then VDIB.Free;
  13598.      {$ENDIF}
  13599.     end;
  13600.   except
  13601.     {eh, sorry, when is not the dds modified, roll back and release last the VDIB}
  13602.     if not dds.Modified then
  13603.       if T <> nil then
  13604.       begin
  13605.         if Assigned({$IFDEF VIDEOTEX}T.{$ENDIF}VDIB) then
  13606.         {$IFNDEF D5UP}
  13607.         begin {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Free; {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB := nil; end;
  13608.         {$ELSE}
  13609.           FreeAndNil({$IFDEF VIDEOTEX}T.{$ENDIF}VDIB);
  13610.         {$ENDIF}
  13611.         if Assigned(T.D2DTexture) then
  13612.         {$IFNDEF D5UP}
  13613.         begin T.D2DTexture.Free; T.D2DTexture := nil; end;
  13614.         {$ELSE}
  13615.           FreeAndNil(T.D2DTexture);
  13616.         {$ENDIF}
  13617.  
  13618.         D2DMaxTextures := D2DMaxTextures - 1; //go back
  13619.       end;
  13620.     Result := False;
  13621.   end;
  13622.   dds.Modified := False; {this flag turn off always}
  13623. end;
  13624.  
  13625. {$IFDEF VER4UP}
  13626. function TD2DTextures.LoadTextures(dds: TDirectDrawSurface; Transparent: Boolean;
  13627.   TransparentColor: Integer; asTexName: string): Boolean;
  13628. {$ELSE}
  13629. function TD2DTextures.LoadTextures3(dds: TDirectDrawSurface; Transparent: Boolean;
  13630.   TransparentColor: Integer; asTexName: string): Boolean;
  13631. {$ENDIF}
  13632.   function getDDSTransparentColor(DIB: TDIB; dds: TDirectDrawSurface): Integer;
  13633.   var CLL: Integer; ddck: TDDColorKey;
  13634.   begin
  13635.     Result := 0;
  13636.     if dds.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
  13637.       if dds.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetColorKey(DDCKEY_SRCBLT, ddck) = DD_OK then
  13638.         Result := ddck.dwColorSpaceLowValue;
  13639.     CLL := TransparentColor;
  13640.     if (CLL = -1) or (cardinal(CLL) <> DIB.Pixels[0, 0]) then //when is DDS
  13641.       CLL := DIB.Pixels[0, 0]; //have to pick up color from 0,0 pix of DIB
  13642.     if Transparent then //and must be transparent
  13643.       if CLL <> Result then //when different
  13644.         Result := CLL; //use TransparentColor
  13645.   end;
  13646. var
  13647.   {$IFNDEF VIDEOTEX}
  13648.   VDIB: TDIB;
  13649.   {$ENDIF}
  13650.   COL: Integer;
  13651.   T: TDXTextureImage;
  13652. begin
  13653.   Result := True;
  13654.   try
  13655.     D2DPruneTextures; {up to maxTexBlock textures only}
  13656.     D2DMaxTextures := D2DMaxTextures + 1;
  13657.     Texture[D2DMaxTextures - 1].Name := asTexName;
  13658.     {$IFDEF VIDEOTEX}Texture[D2DMaxTextures - 1].{$ENDIF}VDIB := TDIB.Create;
  13659.     try
  13660.     with Texture[D2DMaxTextures - 1] do
  13661.     begin
  13662.       VDIB.AsSign(dds);
  13663.       VDIB.Transparent := Transparent;
  13664.       FloatX1 := 0; FloatY1 := 0; FloatX2 := 1; FloatY2 := 1;
  13665.       SizeAdjust(VDIB, FloatX1, FloatY1, FloatX2, FloatY2);
  13666.       Width := VDIB.Width;
  13667.       Height := VDIB.Height;
  13668.       if VDIB.HasAlphaChannel then
  13669.       begin
  13670.         DIB2DXT(VDIB, T);
  13671.         T.ImageName := asTexName;
  13672.         T.Transparent := Transparent;
  13673.         D2DTexture := TDirect3DTexture2.Create(FDDraw, T, False);
  13674.         D2DTexture.Transparent := Transparent;
  13675.         AlphaChannel := True;
  13676.         //**T.Free; DO NOT FREE - surface is lost ** FIX by JB.
  13677.       end
  13678.       else
  13679.       begin
  13680.         D2DTexture := TDirect3DTexture2.Create(FDDraw, VDIB, False);
  13681.         if transparentcolor = -1 then
  13682.           COL := getDDSTransparentColor(VDIB, DDS)
  13683.         else
  13684.           COL := D2DTexture.Surface.ColorMatch(transparentcolor);
  13685.           D2DTexture.TransparentColor := DWORD(COL); //**
  13686.           D2DTexture.Surface.TransparentColor := DWORD(COL); //**
  13687.           D2DTexture.Transparent := Transparent;
  13688.           AlphaChannel := False;
  13689.       end;
  13690.     end
  13691.     finally
  13692.       {$IFNDEF VIDEOTEX}
  13693.       VDIB.Free;
  13694.       {$ENDIF}
  13695.     end;
  13696.   except
  13697.     D2DMaxTextures := D2DMaxTextures - 1;
  13698.     Result := False;
  13699.   end;
  13700. end;
  13701.  
  13702. {$IFDEF VER4UP}
  13703. function TD2DTextures.CanFindTexture(const Color: LongInt): Boolean;
  13704. {$ELSE}
  13705. function TD2DTextures.CanFindTexture3(const Color: LongInt): Boolean;
  13706. {$ENDIF}
  13707. var I: Integer;
  13708. begin
  13709.   Result := True;
  13710.   {$IFDEF VER4UP}
  13711.   if Length(Texture) > 0 then
  13712.   {$ELSE}
  13713.   if TexLen > 0 then
  13714.   {$ENDIF}
  13715.     for I := 0 to D2DMaxTextures - 1 do
  13716.       if Texture[I].Name = '$' + IntToStr(Color) then Exit;
  13717.   Result := False;
  13718. end;
  13719.  
  13720. {$IFDEF VER4UP}
  13721. function TD2DTextures.LoadTextures(Color: LongInt): Boolean;
  13722. {$ELSE}
  13723. function TD2DTextures.LoadTextures4(Color: LongInt): Boolean;
  13724. {$ENDIF}
  13725. var
  13726.   S: string;
  13727.   {$IFNDEF VIDEOTEX}
  13728.   VDIB: TDIB;
  13729.   {$ENDIF}
  13730. begin
  13731.   Result := True;
  13732.   try
  13733.     D2DPruneTextures; {up to maxTexBlock textures only}
  13734.     D2DMaxTextures := D2DMaxTextures + 1;
  13735.     S := '$' + IntToStr(Color); {this name is supplement name}
  13736.     {$IFDEF VIDEOTEX}Texture[D2DMaxTextures - 1].{$ENDIF}VDIB := TDIB.Create;
  13737.     try
  13738.     with Texture[D2DMaxTextures - 1] do
  13739.     begin
  13740.       VDIB.SetSize(16, 16, 24); {16x16 good size}
  13741.       VDIB.Canvas.Brush.Color := Color;
  13742.       VDIB.Canvas.FillRect(Bounds(0, 0, 16, 16));
  13743.  
  13744.       FloatX1 := 0;
  13745.       FloatY1 := 0;
  13746.       FloatX2 := 1;
  13747.       FloatY2 := 1;
  13748.       Name := S;
  13749.       D2DTexture := TDirect3DTexture2.Create(FDDraw, VDIB, False);
  13750.       D2DTexture.Transparent := False; //cannot be transparent
  13751.     end;
  13752.     finally
  13753.       {$IFNDEF VIDEOTEX}
  13754.       VDIB.Free;
  13755.       {$ENDIF}
  13756.     end;
  13757.   except
  13758.     D2DMaxTextures := D2DMaxTextures - 1;
  13759.     Result := False;
  13760.   end;
  13761. end;
  13762.  
  13763. {$IFDEF VIDEOTEX}
  13764. function TD2DTextures.GetTexLayoutByName(name: string): TDIB;
  13765. var
  13766.   I: Integer;
  13767. begin
  13768.   Result := nil;
  13769.   I := Find(name);
  13770.   {$IFDEF VER4UP}
  13771.   if (I >= Low(Texture)) and (I <= High(Texture)) then
  13772.   {$ELSE}
  13773.   if I <> -1 then
  13774.   {$ENDIF}
  13775.     Result := Texture[I].VDIB
  13776. end;
  13777. {$ENDIF}
  13778.  
  13779. //---------------------------------------------------------------------------
  13780.  
  13781. constructor TD2D.Create(DDraw: TCustomDXDraw);
  13782. begin
  13783.   inherited Create;
  13784.   //after inheritance
  13785.   FDDraw := DDraw;
  13786.   FD2DTextureFilter := D2D_POINT {D2D_LINEAR};
  13787.   {$IFNDEF D3D_deprecated}
  13788.   FD2DTexture := TD2DTextures.Create(FDDraw);
  13789.   {$ENDIF}
  13790.   InitVertex;
  13791.   {internal allocation of texture}
  13792.   CanUseD2D := {$IFDEF D3D_deprecated}(do3D in FDDraw.Options) and
  13793.     (doDirectX7Mode in FDDraw.Options) and
  13794.     (doHardware in FDDraw.Options){$ELSE}True{$ENDIF};
  13795.   FDIB := TDIB.Create;
  13796.   FInitialized := False;
  13797. end;
  13798.  
  13799. destructor TD2D.Destroy;
  13800. begin
  13801.   {freeing texture and stop using it}
  13802.   CanUseD2D := False;
  13803.   if AsSigned(FD2DTexture) then
  13804.   begin
  13805.     FD2DTexture.Free; {add 29.5.2005 Takanori Kawasaki}
  13806.     FD2DTexture := nil;
  13807.   end;
  13808.   FDIB.Free;
  13809.   inherited Destroy;
  13810. end;
  13811.  
  13812. procedure TD2D.InitVertex;
  13813. var i: Integer;
  13814. begin
  13815.   Fillchar(FVertex, SizeOf(FVertex), 0);
  13816.   for i := 0 to 3 do
  13817.   begin
  13818.     FVertex[i].Specular := D3DRGB(1.0, 1.0, 1.0);
  13819.     FVertex[i].rhw := 1.0;
  13820.   end;
  13821. end;
  13822.  
  13823. //---------------------------------------------------------------------------
  13824.  
  13825. procedure TD2D.BeginScene();
  13826. begin
  13827.   asm
  13828.     FINIT
  13829.   end;
  13830.   FDDraw.D3DDevice7.BeginScene();
  13831.   asm
  13832.     FINIT
  13833.   end;
  13834.   FDDraw.D3DDevice7.Clear(0, nil, D3DCLEAR_TARGET, 0, 0, 0);
  13835. end;
  13836.  
  13837. //---------------------------------------------------------------------------
  13838.  
  13839. procedure TD2D.EndScene();
  13840. begin
  13841.   asm
  13842.     FINIT
  13843.   end;
  13844.   FDDraw.D3DDevice7.EndScene();
  13845.   asm
  13846.     FINIT
  13847.   end;
  13848. end;
  13849.  
  13850. function TD2D.D2DTexturedOn(Image: TPictureCollectionItem; Pattern: Integer; SubPatternRect: TRect; RenderType: TRenderType; Alpha: Byte): Boolean;
  13851. var I: Integer;
  13852.   SrcX, SrcY, diffX: Double;
  13853.   R: TRect;
  13854.   Q: TTextureRec;
  13855. begin
  13856.   Result := False;
  13857.   FDDraw.D3DDevice7.SetTexture(0, nil);
  13858.   if not FD2DTexture.CanFindTexture(Image) then {when no texture in list try load it}
  13859.     if not FD2DTexture.LoadTextures(Image) then {loading is here}
  13860.       Exit; {on error occurr out}
  13861.   I := FD2DTexture.Find(Image.Name);
  13862.   if I = -1 then Exit;
  13863.   {set pattern as texture}
  13864. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
  13865. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
  13866.   try
  13867.     RenderError := FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7) <> DD_OK;
  13868.     case RenderType of
  13869.       rtDraw: begin D2DEffectSolid; D2DWhite; end;
  13870.       rtBlend: begin D2DEffectBlend; D2DAlphaVertex(Alpha); end;
  13871.       rtAdd: begin D2DEffectAdd; D2DFade(Alpha); end;
  13872.       rtSub: begin D2DEffectSub; D2DFade(Alpha); end;
  13873.     end;
  13874.   except
  13875.     RenderError := True;
  13876.     FD2DTexture.D2DPruneAllTextures;
  13877.     Image.Restore;
  13878.     SetD2DTextureFilter(D2D_LINEAR);
  13879.     Exit;
  13880.   end;
  13881.   {set transparent area}
  13882.   RenderError := FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Ord(FD2DTexture.Texture[I].D2DTexture.Transparent)) <> DD_OK;
  13883.   {except for Draw when alphachannel exists}
  13884.   {change for blend drawing but save transparent area still}
  13885.   if FD2DTexture.Texture[I].AlphaChannel then
  13886.     {when is Draw selected then}
  13887.     if RenderType = rtDraw then
  13888.     begin
  13889.       D2DEffectBlend;
  13890.       D2DAlphaVertex($FF);
  13891.     end;
  13892.   {pokud je obrazek rozdeleny, nastav oka site}
  13893.   if (Image.PatternHeight <> 0) or (Image.PatternWidth <> 0) then
  13894.   begin
  13895.     {vezmi rect jenom dilku}
  13896.     R := Image.PatternRects[Pattern];
  13897.     SrcX := 1 / FD2DTexture.Texture[I].Width;
  13898.     SrcY := 1 / FD2DTexture.Texture[I].Height;
  13899.     //namapovani vertexu na texturu
  13900.     FD2DTexture.Texture[I].FloatX1 := SrcX * R.Left;
  13901.     FD2DTexture.Texture[I].FloatY1 := SrcY * R.Top;
  13902.     {for meshed subimage contain one image only can be problem there}
  13903.     diffX := 0.5; if Image.PatternCount = 1 then diffX := 0;
  13904.     FD2DTexture.Texture[I].FloatX2 := SrcX * (R.Right - diffX);
  13905.     FD2DTexture.Texture[I].FloatY2 := SrcY * (R.Bottom - diffX);
  13906.     if not (
  13907.       (SubPatternRect.Left = Image.PatternRects[Pattern].Left) and
  13908.       (SubPatternRect.Top = Image.PatternRects[Pattern].Top) and
  13909.       (SubPatternRect.Right = Image.PatternRects[Pattern].Right) and
  13910.       (SubPatternRect.Bottom = Image.PatternRects[Pattern].Bottom))
  13911.     then
  13912.     begin
  13913.       {remaping subtexture via subpattern}
  13914.       Q.FloatX1 := SrcX * SubPatternRect.Left;
  13915.       Q.FloatY1 := SrcY * SubPatternRect.Top;
  13916.       Q.FloatX2 := SrcX * (SubPatternRect.Right - diffX);
  13917.       Q.FloatY2 := SrcY * (SubPatternRect.Bottom - diffX);
  13918.       D2DTU(Q); {with mirroring/flipping}
  13919.       Result := not RenderError;
  13920.       Exit;
  13921.     end;
  13922.   end; {jinak celeho obrazku}
  13923.  
  13924.   {  X1,Y1             X2,Y1
  13925.   0  +-----------------+  1
  13926.      |                 |
  13927.      |                 |
  13928.      |                 |
  13929.      |                 |
  13930.   2  +-----------------+  3
  13931.      X1,Y2             X2,Y2  }
  13932.   D2DTU(FD2DTexture.Texture[I]);
  13933.   Result := not RenderError;
  13934. end;
  13935.  
  13936. function TD2D.D2DTexturedOnDDSTex(dds: TDirectDrawSurface; SubPatternRect: TRect; Transparent: Boolean): Integer;
  13937. {special version of map for TDirectDrawSurface only}
  13938. {set up transparent color from this surface}
  13939. var
  13940.   TexName: string;
  13941. begin
  13942.   Result := -1;
  13943.   {pokud je seznam prazdny, nahrej texturu}
  13944.   if dds.Caption <> '' then TexName := dds.Caption
  13945.   else TexName := IntToStr(Integer(dds)); {simple but stupid}
  13946.   if not FD2DTexture.{$IFDEF VER4UP}CanFindTexture{$ELSE}CanFindTexture2{$ENDIF}(TexName) then
  13947.   begin
  13948.     {when texture doesn't exists, has to the Modified flag turn off}
  13949.     if dds.Modified then
  13950.       dds.Modified := not dds.Modified;
  13951.     if not FD2DTexture.{$IFDEF VER4UP}LoadTextures{$ELSE}LoadTextures2{$ENDIF}(dds, Transparent, TexName) then
  13952.       Exit; {nepovede-li se to, pak ven}
  13953.   end
  13954.   else
  13955.     if dds.Modified then
  13956.     begin {when modifying, load texture allways}
  13957.       if not FD2DTexture.{$IFDEF VER4UP}LoadTextures{$ELSE}LoadTextures2{$ENDIF}(dds, Transparent, TexName) then
  13958.         Exit; {nepovede-li se to, pak ven}
  13959.     end;
  13960.   Result := FD2DTexture.Find(TexName);
  13961. end;
  13962.  
  13963. function IsNotZero(Z: TRect): Boolean;
  13964. begin
  13965.   Result := ((Z.Right - Z.Left) > 0) and ((Z.Bottom - Z.Top) > 0)
  13966. end;
  13967.  
  13968. function TD2D.D2DTexturedOnDDS(dds: TDirectDrawSurface; SubPatternRect: TRect; Transparent: Boolean; RenderType: TRenderType; Alpha: Byte): Boolean;
  13969. var I: Integer;
  13970.   SrcX, SrcY: Double;
  13971. begin
  13972.   Result := False;
  13973.   FDDraw.D3DDevice7.SetTexture(0, nil);
  13974.   {call a low level routine for load DDS texture}
  13975.   I := D2DTexturedOnDDSTex(dds, SubPatternRect, Transparent);
  13976.   if I = -1 then Exit;
  13977.   {set pattern as texture}
  13978. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
  13979. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
  13980.   try
  13981.     RenderError := FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7) <> DD_OK;
  13982.     case RenderType of
  13983.       rtDraw: begin D2DEffectSolid; D2DWhite; end;
  13984.       rtBlend: begin D2DEffectBlend; D2DAlphaVertex(Alpha); end;
  13985.       rtAdd: begin D2DEffectAdd; D2DFade(Alpha); end;
  13986.       rtSub: begin D2DEffectSub; D2DFade(Alpha); end;
  13987.     end;
  13988.   except
  13989.     RenderError := True;
  13990.     FD2DTexture.D2DPruneAllTextures;
  13991.     SetD2DTextureFilter(D2D_LINEAR); //default
  13992.     Exit;
  13993.   end;
  13994.   {set transparent area}
  13995.   RenderError := FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Ord(FD2DTexture.Texture[I].D2DTexture.Transparent)) <> DD_OK;
  13996.   if IsNotZero(SubPatternRect) then
  13997.   begin
  13998.     {Set Texture Coordinates}
  13999.     SrcX := 1 / FD2DTexture.Texture[I].D2DTexture.FImage.Width;
  14000.     SrcY := 1 / FD2DTexture.Texture[I].D2DTexture.FImage.Height;
  14001.     //namapovani vertexu na texturu
  14002.     FD2DTexture.Texture[I].FloatX1 := SrcX * SubPatternRect.Left;
  14003.     FD2DTexture.Texture[I].FloatY1 := SrcY * SubPatternRect.Top;
  14004.     FD2DTexture.Texture[I].FloatX2 := SrcX * (SubPatternRect.Right - 0.5 { - 1}); //by Speeeder
  14005.     FD2DTexture.Texture[I].FloatY2 := SrcY * (SubPatternRect.Bottom - 0.5 { - 1}); //by Speeeder
  14006.   end;
  14007.   D2DTU(FD2DTexture.Texture[I]);
  14008.   Result := not RenderError;
  14009. end;
  14010.  
  14011. //---------------------------------------------------------------------------
  14012.  
  14013. procedure TD2D.SaveTextures(path: string);
  14014. begin
  14015.   FD2DTexture.SaveTextures(path);
  14016. end;
  14017.  
  14018. procedure TD2D.SetCanUseD2D(const Value: Boolean);
  14019. begin
  14020.   case Value of
  14021.     False: {prestava se uzivat}
  14022.       if AsSigned(FD2DTexture) and (Value <> FCanUseD2D) then
  14023.       begin
  14024.         FInitialized := False;
  14025.       end;
  14026.     True:
  14027.       if Value <> FCanUseD2D then
  14028.       begin
  14029.         {$IFDEF D3D_deprecated}
  14030.         FD2DTexture := TD2DTextures.Create(FDDraw);
  14031.         TextureFilter := D2D_LINEAR;
  14032.         {$ENDIF}
  14033.       end
  14034.   end;
  14035.   FCanUseD2D := Value;
  14036. end;
  14037.  
  14038. function TD2D.GetCanUseD2D: Boolean;
  14039. begin
  14040.   {$IFDEF D3D_deprecated}
  14041.   {Mode has to do3D, doDirectX7Mode and doHardware}
  14042.   if (do3D in FDDraw.Options) and
  14043.     (doDirectX7Mode in FDDraw.Options) and
  14044.     (doHardware in FDDraw.Options)
  14045.   then
  14046.   begin
  14047.     if not FCanUseD2D then CanUseD2D := True;
  14048.   end
  14049.   else
  14050.     if not (do3D in FDDraw.Options) or
  14051.       not (doDirectX7Mode in FDDraw.Options) or
  14052.       not (doHardware in FDDraw.Options)
  14053.       then
  14054.       if FCanUseD2D then FCanUseD2D := False; // CanUseD2D -> FCanUseD2D
  14055.   {$ELSE}
  14056.   FCanUseD2D := (doHardware in FDDraw.Options);
  14057.   {$ENDIF}
  14058.   FBitCount := FDDraw.Surface.SurfaceDesc.ddpfPixelFormat.dwRGBBitCount;
  14059.   {supported 16 or 32 bitcount deepth only}
  14060.   {$IFDEF D3D_deprecated}
  14061.   if not (FBitCount in [16, 32]) then FCanUseD2D := False;
  14062.   {$ENDIF}
  14063.   if not FInitialized then
  14064.     if FCanUseD2D and Assigned(FDDraw.D3DDevice7) then
  14065.     begin
  14066.       FDDraw.D3DDevice7.GetCaps(FD3DDevDesc7);
  14067.       FInitialized := True;
  14068.     end;
  14069.  
  14070.   Result := FCanUseD2D;
  14071. end;
  14072.  
  14073. procedure TD2D.SetD2DTextureFilter(const Value: TD2DTextureFilter);
  14074. begin
  14075.   FD2DTextureFilter := Value;
  14076.   if {$IFDEF D3D_deprecated}(do3D in FDDraw.Options) and{$ENDIF} AsSigned(FDDraw.D3DDevice7) then
  14077.   begin
  14078.     FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter) + 1));
  14079.     FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter) + 1));
  14080.   end;
  14081. end;
  14082.  
  14083. procedure TD2D.SetD2DAntialiasFilter(const Value: TD3DAntialiasMode);
  14084. begin
  14085.   FD2DAntialiasFilter := Value;
  14086.   if {$IFDEF D3D_deprecated}(do3D in FDDraw.Options) and{$ENDIF} AsSigned(FDDraw.D3DDevice7) then
  14087.   begin
  14088.     FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_ANTIALIAS, Ord(Value));
  14089.   end;
  14090. end;
  14091.  
  14092. procedure TD2D.D2DRect(R: TRect);
  14093. begin
  14094.   FVertex[0].sx := R.Left - 0.5;
  14095.   FVertex[0].sy := R.Top - 0.5;
  14096.   FVertex[1].sx := R.Right - 0.5;
  14097.   FVertex[1].sy := R.Top - 0.5;
  14098.   FVertex[2].sx := R.Left - 0.5;
  14099.   FVertex[2].sy := R.Bottom - 0.5;
  14100.   FVertex[3].sx := R.Right - 0.5;
  14101.   FVertex[3].sy := R.Bottom - 0.5;
  14102. end;
  14103.  
  14104. procedure TD2D.D2DTU(T: TTextureRec);
  14105. begin
  14106.   if FMirrorFlipSet = [rmfMirror] then
  14107.   begin
  14108.     {  X1,Y1             X2,Y1
  14109.     0  +-----------------+  1
  14110.        |                 |
  14111.        |                 |
  14112.        |                 |
  14113.        |                 |
  14114.     2  +-----------------+  3
  14115.        X1,Y2             X2,Y2  }
  14116.     FVertex[1].tu := T.FloatX1;
  14117.     FVertex[1].tv := T.FloatY1;
  14118.     FVertex[0].tu := T.FloatX2;
  14119.     FVertex[0].tv := T.FloatY1;
  14120.     FVertex[3].tu := T.FloatX1;
  14121.     FVertex[3].tv := T.FloatY2;
  14122.     FVertex[2].tu := T.FloatX2;
  14123.     FVertex[2].tv := T.FloatY2;
  14124.   end
  14125.   else
  14126.   if FMirrorFlipSet = [rmfFlip] then
  14127.   begin
  14128.     {  X1,Y1             X2,Y1
  14129.     0  +-----------------+  1
  14130.        |                 |
  14131.        |                 |
  14132.        |                 |
  14133.        |                 |
  14134.     2  +-----------------+  3
  14135.        X1,Y2             X2,Y2  }
  14136.     FVertex[2].tu := T.FloatX1;
  14137.     FVertex[2].tv := T.FloatY1;
  14138.     FVertex[3].tu := T.FloatX2;
  14139.     FVertex[3].tv := T.FloatY1;
  14140.     FVertex[0].tu := T.FloatX1;
  14141.     FVertex[0].tv := T.FloatY2;
  14142.     FVertex[1].tu := T.FloatX2;
  14143.     FVertex[1].tv := T.FloatY2;
  14144.   end
  14145.   else
  14146.   if FMirrorFlipSet = [rmfMirror, rmfFlip] then
  14147.   begin
  14148.     {  X1,Y1             X2,Y1
  14149.     0  +-----------------+  1
  14150.        |                 |
  14151.        |                 |
  14152.        |                 |
  14153.        |                 |
  14154.     2  +-----------------+  3
  14155.        X1,Y2             X2,Y2  }
  14156.     FVertex[3].tu := T.FloatX1;
  14157.     FVertex[3].tv := T.FloatY1;
  14158.     FVertex[2].tu := T.FloatX2;
  14159.     FVertex[2].tv := T.FloatY1;
  14160.     FVertex[1].tu := T.FloatX1;
  14161.     FVertex[1].tv := T.FloatY2;
  14162.     FVertex[0].tu := T.FloatX2;
  14163.     FVertex[0].tv := T.FloatY2;
  14164.   end
  14165.   else
  14166.   begin
  14167.     {  X1,Y1             X2,Y1
  14168.     0  +-----------------+  1
  14169.        |                 |
  14170.        |                 |
  14171.        |                 |
  14172.        |                 |
  14173.     2  +-----------------+  3
  14174.        X1,Y2             X2,Y2  }
  14175.     FVertex[0].tu := T.FloatX1;
  14176.     FVertex[0].tv := T.FloatY1;
  14177.     FVertex[1].tu := T.FloatX2;
  14178.     FVertex[1].tv := T.FloatY1;
  14179.     FVertex[2].tu := T.FloatX1;
  14180.     FVertex[2].tv := T.FloatY2;
  14181.     FVertex[3].tu := T.FloatX2;
  14182.     FVertex[3].tv := T.FloatY2;
  14183.   end;
  14184. end;
  14185.  
  14186. {Final public routines}
  14187.  
  14188. function TD2D.D2DRender(Image: TPictureCollectionItem; DestRect: TRect;
  14189.   Pattern: Integer; SourceRect: TRect; RenderType: TRenderType; Alpha: Byte): Boolean;
  14190. begin
  14191.   Result := False; if not CanUseD2D then Exit;
  14192.   if D2DTexturedOnSubRect(Image, Pattern, Image.PatternRects[Pattern], SourceRect, RenderType, Alpha) then
  14193.   begin
  14194.     D2DRect(DestRect);
  14195.     Result := RenderQuad;
  14196.   end;
  14197. end;
  14198.  
  14199. function TD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Image: TPictureCollectionItem; R: TRect;
  14200.   Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14201. begin
  14202.   Result := False; if not CanUseD2D then Exit;
  14203.   if D2DTexturedOn(Image, Pattern, Image.PatternRects[Pattern], RenderType, Alpha) then
  14204.   begin
  14205.     D2DRect(R);
  14206.     Result := RenderQuad;
  14207.   end;
  14208. end;
  14209.  
  14210. function TD2D.D2DRenderDDS(Source: TDirectDrawSurface; SourceRect, DestRect: TRect;
  14211.   Transparent: Boolean; Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14212. begin
  14213.   Result := False; if not CanUseD2D then Exit;
  14214.   if D2DTexturedOnDDS(Source, SourceRect, Transparent, RenderType, Alpha) then
  14215.   begin
  14216.     D2DRect(DestRect);
  14217.     Result := RenderQuad;
  14218.   end;
  14219. end;
  14220.  
  14221. function TD2D.D2DRenderCol(Image: TPictureCollectionItem; R: TRect;
  14222.   Pattern, Color: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14223. begin
  14224.   Result := False; if not CanUseD2D then Exit;
  14225.   if D2DTexturedOn(Image, Pattern, Image.PatternRects[Pattern], RenderType, Alpha) then
  14226.   begin
  14227.     D2DRect(R);
  14228.     Result := RenderQuad;
  14229.   end;
  14230. end;
  14231.  
  14232. function TD2D.D2DRenderColDDS(Source: TDirectDrawSurface; SourceRect, DestRect: TRect;
  14233.   Transparent: Boolean; Pattern, Color: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14234. begin
  14235.   Result := False; if not CanUseD2D then Exit;
  14236.   {Add}
  14237.   if D2DTexturedOnDDS(Source, SourceRect, Transparent, RenderType, Alpha) then
  14238.   begin
  14239.     D2DRect(DestRect);
  14240.     Result := RenderQuad;
  14241.   end;
  14242. end;
  14243.  
  14244. function TD2D.D2DRenderDrawXY(Image: TPictureCollectionItem; X, Y: Integer;
  14245.   Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14246. var PWidth, PHeight: Integer;
  14247. begin
  14248.   Result := False; if not CanUseD2D then Exit;
  14249.   {Draw}
  14250.   if D2DTexturedOn(Image, Pattern, Image.PatternRects[Pattern], RenderType, Alpha) then
  14251.   begin
  14252.     PWidth := Image.PatternWidth; if PWidth = 0 then PWidth := Image.Width;
  14253.     PHeight := Image.PatternHeight; if PHeight = 0 then PHeight := Image.Height;
  14254.     D2DRect(Bounds(X, Y, PWidth, PHeight));
  14255.     Result := RenderQuad;
  14256.   end;
  14257. end;
  14258.  
  14259. function TD2D.D2DRenderDrawDDSXY(Source: TDirectDrawSurface; X, Y: Integer;
  14260.   Transparent: Boolean; Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14261. begin
  14262.   Result := False; if not CanUseD2D then Exit;
  14263.   {Draw}
  14264.   if D2DTexturedOnDDS(Source, ZeroRect, Transparent, RenderType, Alpha) then
  14265.   begin
  14266.     D2DRect(Bounds(X, Y, Source.Width, Source.Height));
  14267.     Result := RenderQuad;
  14268.   end;
  14269. end;
  14270.  
  14271. {$IFDEF VER4UP}
  14272. function TD2D.D2DRenderDrawDDSXY(Source: TDirectDrawSurface; X, Y: Integer;
  14273.   SrcRect: TRect; Transparent: Boolean; Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
  14274. begin
  14275.   Result := False; if not CanUseD2D then Exit;
  14276.   {Draw}
  14277.   if D2DTexturedOnDDS(Source, SrcRect, Transparent, RenderType, Alpha) then
  14278.   begin
  14279.     D2DRect(Bounds(X, Y, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top));
  14280.     Result := RenderQuad;
  14281.   end;
  14282. end;
  14283. {$ENDIF}
  14284.  
  14285. {Rotate functions}
  14286.  
  14287. procedure TD2D.D2DRotate(X, Y, W, H: Integer; Px, Py: Double; Angle: Single);
  14288.   procedure SinCosS(const Theta: Single; var Sin, Cos: Single); register;
  14289.   { EAX contains address of Sin}
  14290.   { EDX contains address of Cos}
  14291.   { Theta is passed over the stack}
  14292.   asm
  14293.     FLD  Theta
  14294.     FSINCOS
  14295.     FSTP DWORD PTR [EDX]    // cosine
  14296.     FSTP DWORD PTR [EAX]    // sine
  14297.   end;
  14298. const PI256 = 2 * PI / 256;
  14299. var x1, y1, up, s_angle, c_angle, s_up, c_up: Single;
  14300. begin
  14301.   angle := angle * PI256; up := angle + PI / 2;
  14302.   x1 := w * px; y1 := h * py;
  14303.   SinCosS(angle, s_angle, c_angle);
  14304.   SinCosS(up, s_up, c_up);
  14305.   FVertex[0].sx := X - x1 * c_angle - y1 * c_up;
  14306.   FVertex[0].sy := Y - x1 * s_angle - y1 * s_up;
  14307.   FVertex[1].sx := FVertex[0].sx + W * c_angle;
  14308.   FVertex[1].sy := FVertex[0].sy + W * s_angle;
  14309.   FVertex[2].sx := FVertex[0].sx + H * c_up;
  14310.   FVertex[2].sy := FVertex[0].sy + H * s_up;
  14311.   FVertex[3].sx := FVertex[2].sx + W * c_angle;
  14312.   FVertex[3].sy := FVertex[2].sy + W * s_angle;
  14313. end;
  14314.  
  14315. function TD2D.D2DRenderRotate(Image: TPictureCollectionItem; RotX, RotY,
  14316.   PictWidth, PictHeight, PatternIndex: Integer; RenderType: TRenderType;
  14317.   CenterX, CenterY: Double;
  14318.   Angle: single; Alpha: Byte): Boolean;
  14319. begin
  14320.   Result := False; if not CanUseD2D then Exit;
  14321.   {load textures and map it, set of effect}
  14322.   if D2DTexturedOn(Image, PatternIndex, Image.PatternRects[PatternIndex], RenderType, Alpha) then
  14323.   begin
  14324.     {do rotate mesh}
  14325.     D2DRotate(RotX, RotY, PictWidth, PictHeight, CenterX, CenterY, Angle);
  14326.     {render it}
  14327.     Result := RenderQuad;
  14328.   end;
  14329. end;
  14330.  
  14331. function TD2D.D2DRenderRotateDDS(Image: TDirectDrawSurface; SourceRect: TRect; RotX, RotY,
  14332.   PictWidth, PictHeight: Integer; RenderType: TRenderType;
  14333.   CenterX, CenterY: Double; Angle: single; Alpha: Byte;
  14334.   Transparent: Boolean): Boolean;
  14335. begin
  14336.   Result := False; if not CanUseD2D then Exit;
  14337.   {load textures and map it, set of effect}
  14338.   if D2DTexturedOnDDS(Image, SourceRect, Transparent, RenderType, Alpha) then
  14339.   begin
  14340.     {do rotate mesh}
  14341.     D2DRotate(RotX, RotY, PictWidth, PictHeight, CenterX, CenterY, Angle);
  14342.     {render it}
  14343.     Result := RenderQuad;
  14344.   end;
  14345. end;
  14346.  
  14347. {------------------------------------------------------------------------------}
  14348. {created 31.1.2005 JB.}
  14349. {replacement original Hori's functionality}
  14350. {24.4.2006 create WaveY as supplement like WaveX functions}
  14351. {14.5.2006 added functionality for tile drawing through PatternIndex}
  14352.  
  14353. function TD2D.D2DMeshMapToWave(dds: TDirectDrawSurface; Transparent: Boolean;
  14354.   TransparentColor: Integer; X, Y, iWidth, iHeight, PatternIndex: Integer;
  14355.   PatternRect: TRect;
  14356.   Amp, Len, Ph, Alpha: Integer; effect: TRenderType; DoY: Boolean): Boolean;
  14357.   function D2DTexturedOn(dds: TDirectDrawSurface; Transparent: Boolean; var TexNo: Integer): Boolean;
  14358.   {special version of mapping for TDirectDrawSurface only}
  14359.   {set up transparent color from this surface}
  14360.   var I: Integer;
  14361.     TexName: string;
  14362.   begin
  14363.     Result := False;
  14364.     TexNo := -1;
  14365.     RenderError := FDDraw.D3DDevice7.SetTexture(0, nil) <> DD_OK;
  14366.     {pokud je seznam prazdny, nahrej texturu}
  14367.     if dds.Caption <> '' then TexName := dds.Caption
  14368.     else TexName := IntToStr(Integer(dds));
  14369.     if not FD2DTexture.{$IFDEF VER4UP}CanFindTexture{$ELSE}CanFindTexture2{$ENDIF}(TexName) then
  14370.       {nepovede-li se to, pak ven}
  14371.       if not FD2DTexture.{$IFDEF VER4UP}LoadTextures{$ELSE}LoadTextures3{$ENDIF}(dds, Transparent, TransparentColor, TexName) then Exit;
  14372.     I := FD2DTexture.Find(TexName);
  14373.     if I = -1 then Exit;
  14374.     TexNo := I;
  14375.     {set pattern as texture}
  14376. //    FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
  14377. //    FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
  14378.     try
  14379.       RenderError := FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7) <> DD_OK;
  14380.       //Result := True; {not RetderError}
  14381.     except
  14382.       RenderError := True;
  14383.       Result := False;
  14384.       FD2DTexture.D2DPruneAllTextures;
  14385.       Exit;
  14386.     end;
  14387.     {set transparent area}
  14388.     RenderError := FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Ord(FD2DTexture.Texture[I].D2DTexture.Transparent)) <> DD_OK;
  14389.     Result := not RenderError;
  14390.   end;
  14391. type
  14392.   TVertexArray = array{$IFNDEF VER4UP} [0..0]{$ENDIF} of TD3DTLVERTEX;
  14393.   {$IFNDEF VER4UP}
  14394.   PVertexArray = ^TVertexArray;
  14395.   {$ENDIF}
  14396. var
  14397.   SVertex: {$IFDEF VER4UP}TVertexArray{$ELSE}PVertexArray{$ENDIF};
  14398.   I, maxVertex, maxPix, VStepVx, TexNo, Width, Height: Integer;
  14399.   VStep, VStepTo, D, Z, FX1, FX2, FY1, FY2, SX, SY, X1, Y1, X2, Y2: Extended;
  14400.   R: TRect;
  14401.   clr: DWORD;
  14402. begin
  14403.   Result := False;
  14404.   {zde uschovano maximum [0..1] po adjustaci textury, ktera nemela nektery rozmer 2^n}
  14405.   {FD2DTexture.Texture[I].FloatX2;}
  14406.   {FD2DTexture.Texture[I].FloatY2;}
  14407.   {napr. pokud byl rozmer 0.7 pak je nutno prepocitat tento interval [0..0.7] na height}
  14408.   if not D2DTexturedOn(dds, Transparent, TexNo) then Exit;
  14409.   {musi se prenastavit velikost pokud je PatternIndex <> -1}
  14410.   Width := iWidth;
  14411.   Height := iHeight;
  14412.   {remove into local variabled for multi-picture adjustation}
  14413.   FX1 := FD2DTexture.Texture[TexNo].FloatX1;
  14414.   FX2 := FD2DTexture.Texture[TexNo].FloatX2;
  14415.   FY1 := FD2DTexture.Texture[TexNo].FloatY1;
  14416.   FY2 := FD2DTexture.Texture[TexNo].FloatY2;
  14417.   {when pattertindex selected, get real value of subtexture}
  14418.   if (PatternIndex <> -1) {and (PatternRect <> ZeroRect)} then
  14419.   begin
  14420.     R := PatternRect;
  14421.     Width := R.Right - R.Left;
  14422.     Height := R.Bottom - R.Top;
  14423.     {scale unit of full new width and height}
  14424.     SX := 1 / FD2DTexture.Texture[TexNo].Width;
  14425.     SY := 1 / FD2DTexture.Texture[TexNo].Height;
  14426.     {remap there}
  14427.     FX1 := R.Left * SX;
  14428.     FX2 := R.Right * SX;
  14429.     FY1 := R.Top * SY;
  14430.     FY2 := R.Bottom * SY;
  14431.   end;
  14432.   {nastavuje se tolik vertexu, kolik je potreba}
  14433.   {speculative set up of rows for better look how needed}
  14434.   if not DoY then
  14435.   begin
  14436.     maxVertex := 2 * Trunc(Height / Len * 8);
  14437.     if (maxVertex mod 2) > 0 then {top to limits}
  14438.       Inc(maxVertex, 2);
  14439.     if (maxVertex div 2) > Height then {correct to Height}
  14440.       maxVertex := 2 * Height;
  14441.   end
  14442.   else
  14443.   begin
  14444.     maxVertex := 2 * Trunc(Width / Len * 8);
  14445.     if (maxVertex mod 2) > 0 then {top to limits}
  14446.       Inc(maxVertex, 2);
  14447.     if (maxVertex div 2) > Width then {correct to Width}
  14448.       maxVertex := 2 * Width;
  14449.   end;
  14450.  
  14451.   {pocet pixlu mezi ploskami}
  14452.   if not DoY then
  14453.   begin
  14454.     repeat
  14455.       if (Height mod (maxVertex div 2)) <> 0 then
  14456.         Inc(maxVertex, 2);
  14457.       maxPix := Height div (maxVertex div 2);
  14458.     until (Height mod (maxVertex div 2)) = 0;
  14459.     {krok k nastaveni vertexu}
  14460.     VStep := (FY2 - FY1) / (maxVertex div 2);
  14461.   end
  14462.   else
  14463.   begin
  14464.     repeat
  14465.       if (Width mod (maxVertex div 2)) <> 0 then
  14466.         Inc(maxVertex, 2);
  14467.       maxPix := Width div (maxVertex div 2);
  14468.     until (Width mod (maxVertex div 2)) = 0;
  14469.     {krok k nastaveni vertexu}
  14470.     VStep := (FX2 - FX1) / (maxVertex div 2);
  14471.   end;
  14472.   //prostor
  14473.   {$IFDEF VER4UP}
  14474.   SetLength(SVertex, maxVertex);
  14475.   {$ELSE}
  14476.   SVertex := AllocMem(maxVertex * SizeOf(TD3DTLVERTEX));
  14477.   try
  14478.   {$ENDIF}
  14479.     //inicializace
  14480.     VStepVx := 0;
  14481.     VStepTo := 0;
  14482.     D := ph / (128 / PI); {shift wave}
  14483.     Z := (Len / 2) / PI; {wave length to radians}
  14484.     clr := D2DVertColor(Effect, Alpha); //effect cumulate to one param and one line of code
  14485.     {vlastni nastaveni vertexu v pasu vertexu}
  14486.     for I := 0 to maxVertex - 1 do
  14487.     begin
  14488.       SVertex[I].Specular := D3DRGB(1.0, 1.0, 1.0);
  14489.       SVertex[I].rhw := 1.0;
  14490.       SVertex[I].color := clr;
  14491.       if not DoY then
  14492.         case (I + 1) mod 2 of //triangle driver
  14493.           1: begin
  14494.               if I <> 0 then Inc(VStepVx, maxPix);
  14495.               SVertex[I].sx := X + Trunc(amp * Sin((Y + VStepVx) / Z + D)) - 0.5; //levy
  14496.               SVertex[I].sy := Y + VStepVx - 0.5;
  14497.               if FMirrorFlipSet = [rmfMirror] then
  14498.               begin
  14499.                 X1 := FX2; if I <> 0 then VStepTo := VStepTo + VStep;
  14500.                 Y1 := FY1 + VStepTo;
  14501.               end
  14502.               else
  14503.                 if FMirrorFlipSet = [rmfFlip] then
  14504.                 begin
  14505.                   X1 := FX1;
  14506.                   Y1 := FY2 - VStepTo;
  14507.                 end
  14508.                 else
  14509.                   if FMirrorFlipSet = [rmfMirror, rmfFlip] then
  14510.                   begin
  14511.                     X1 := FX2;
  14512.                     Y1 := FY2 - VStepTo;
  14513.                   end
  14514.                   else
  14515.                   begin
  14516.                     X1 := FX1; if I <> 0 then VStepTo := VStepTo + VStep;
  14517.                     Y1 := FY1 + VStepTo;
  14518.                   end;
  14519.               SVertex[I].tu := X1;
  14520.               SVertex[I].tv := Y1;
  14521.             end;
  14522.           0: begin
  14523.               SVertex[I].sx := X + Width + Trunc(amp * Sin((Y + VStepVx) / Z + D)) - 1; //pravy
  14524.               SVertex[I].sy := Y + VStepVx;
  14525.               if FMirrorFlipSet = [rmfMirror] then
  14526.               begin
  14527.                 X2 := FX1;
  14528.                 Y2 := FY1 + VStepTo;
  14529.               end
  14530.               else
  14531.                 if FMirrorFlipSet = [rmfFlip] then
  14532.                 begin
  14533.                   X2 := FX2;
  14534.                   Y2 := FY2 - VStepTo; if I <> 0 then VStepTo := VStepTo + VStep;
  14535.                 end
  14536.                 else
  14537.                   if FMirrorFlipSet = [rmfMirror, rmfFlip] then
  14538.                   begin
  14539.                     X2 := FX1;
  14540.                     Y2 := FY2 - VStepTo; if I <> 0 then VStepTo := VStepTo + VStep;
  14541.                   end
  14542.                   else
  14543.                   begin
  14544.                     X2 := FX2;
  14545.                     Y2 := FY1 + VStepTo;
  14546.                   end;
  14547.               SVertex[I].tu := X2;
  14548.               SVertex[I].tv := Y2;
  14549.             end;
  14550.         end {case}
  14551.       else
  14552.         case (I + 1) mod 2 of //triangle driver
  14553.           0: begin
  14554.               if I <> 0 then Inc(VStepVx, maxPix);
  14555.               SVertex[I].sy := Y + Trunc(amp * Sin((X + VStepVx) / Z + D)) - 0.5; //hore
  14556.               SVertex[I].sx := X + VStepVx - 0.5;
  14557.               if FMirrorFlipSet = [rmfMirror] then
  14558.               begin
  14559.                 Y1 := FY1; if I <> 0 then VStepTo := VStepTo + VStep;
  14560.                 X1 := FX2 - VStepTo;
  14561.               end
  14562.               else
  14563.                 if FMirrorFlipSet = [rmfFlip] then
  14564.                 begin
  14565.                   Y1 := FY2; if I <> 0 then VStepTo := VStepTo + VStep;
  14566.                   X1 := FX1 + VStepTo;
  14567.                 end
  14568.                 else
  14569.                   if FMirrorFlipSet = [rmfMirror, rmfFlip] then
  14570.                   begin
  14571.                     Y1 := FY2; if I <> 0 then VStepTo := VStepTo + VStep;
  14572.                     X1 := FX2 - VStepTo;
  14573.                   end
  14574.                   else
  14575.                   begin
  14576.                     Y1 := FY1; if I <> 0 then VStepTo := VStepTo + VStep;
  14577.                     X1 := FX1 + VStepTo;
  14578.                   end;
  14579.               SVertex[I].tu := X1;
  14580.               SVertex[I].tv := Y1;
  14581.             end;
  14582.           1: begin
  14583.               SVertex[I].sy := Y + Height + Trunc(amp * Sin((X + VStepVx) / Z + D)) - 1; //dole
  14584.               SVertex[I].sx := X + VStepVx;
  14585.               if FMirrorFlipSet = [rmfMirror] then
  14586.               begin
  14587.                 Y2 := FY2;
  14588.                 X2 := FX2 - VStepTo;
  14589.               end
  14590.               else
  14591.                 if FMirrorFlipSet = [rmfFlip] then
  14592.                 begin
  14593.                   Y2 := FY1;
  14594.                   X2 := FX1 + VStepTo;
  14595.                 end
  14596.                 else
  14597.                   if FMirrorFlipSet = [rmfMirror, rmfFlip] then
  14598.                   begin
  14599.                     Y2 := FY1;
  14600.                     X2 := FX2 - VStepTo;
  14601.                   end
  14602.                   else
  14603.                   begin
  14604.                     Y2 := FY2;
  14605.                     X2 := FX1 + VStepTo;
  14606.                   end;
  14607.               SVertex[I].tu := X2;
  14608.               SVertex[I].tv := Y2;
  14609.             end;
  14610.         end;
  14611.     end;
  14612.     {set of effect}
  14613.     case Effect of
  14614.       rtDraw: D2DEffectSolid;
  14615.       rtBlend: D2DEffectBlend;
  14616.       rtAdd: D2DEffectAdd;
  14617.       rtSub: D2DEffectSub;
  14618.     end;
  14619.     with FDDraw.D3DDevice7 do
  14620.     begin
  14621.       {kreslime hned zde}//render now and here
  14622.       Result := DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, SVertex[0], maxVertex, D3DDP_WAIT) = DD_OK;
  14623.       //zpet hodnoty
  14624.       //FIX InitVertex;
  14625.       FMirrorFlipSet := []; {only for one operation, back to normal position}
  14626.       {restore device status}
  14627.       RenderError := SetTextureStageState(1, D3DTSS_COLOROP, Ord(D3DTOP_DISABLE)) <> DD_OK;
  14628.       RenderError := SetTextureStageState(1, D3DTSS_ALPHAOP, Ord(D3DTOP_DISABLE)) <> DD_OK;
  14629.       RenderError := SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 0) <> DD_OK;
  14630.     end;
  14631.   {$IFNDEF VER4UP}
  14632.   finally
  14633.     FreeMem(SVertex, maxVertex * SizeOf(TD3DTLVERTEX));
  14634.   end;
  14635.   {$ENDIF}
  14636. end;
  14637.  
  14638. function TD2D.D2DRenderWaveX(Image: TPictureCollectionItem; X, Y, Width,
  14639.   Height, PatternIndex: Integer; RenderType: TRenderType; transparent: Boolean;
  14640.   amp, Len, ph, Alpha: Integer): Boolean;
  14641. begin
  14642.   Result := False; if not CanUseD2D then Exit;
  14643.   {load textures and map, do make wave mesh and render it}
  14644.   Result := D2DMeshMapToWave(Image.PatternSurfaces[PatternIndex], transparent,
  14645.     Image.FTransparentColor, X, Y, Width, Height, PatternIndex,
  14646.     Image.PatternRects[PatternIndex],
  14647.     amp, Len, ph, Alpha, RenderType{$IFNDEF VER4UP}, False{$ENDIF});
  14648. end;
  14649.  
  14650. function TD2D.D2DRenderWaveXDDS(Source: TDirectDrawSurface; X, Y, Width,
  14651.   Height: Integer; RenderType: TRenderType; Transparent: Boolean; Amp, Len, Ph, Alpha: Integer): Boolean;
  14652. begin
  14653.   Result := False; if not CanUseD2D then Exit;
  14654.   {load textures and map, do make wave mesh and render it}
  14655.   Result := D2DMeshMapToWave(Source, transparent, -1, X, Y, Width, Height, -1,
  14656.     ZeroRect,
  14657.     amp, Len, ph, Alpha, RenderType{$IFNDEF VER4UP}, False{$ENDIF});
  14658. end;
  14659.  
  14660. function TD2D.D2DRenderWaveY(Image: TPictureCollectionItem; X, Y, Width,
  14661.   Height, PatternIndex: Integer; RenderType: TRenderType; Transparent: Boolean;
  14662.   Amp, Len, Ph, Alpha: Integer): Boolean;
  14663. begin
  14664.   Result := False; if not CanUseD2D then Exit;
  14665.   {load textures and map, do make wave mesh and render it}
  14666.   Result := D2DMeshMapToWave(Image.PatternSurfaces[PatternIndex], transparent,
  14667.     Image.FTransparentColor, X, Y, Width, Height, PatternIndex,
  14668.     Image.PatternRects[PatternIndex],
  14669.     amp, Len, ph, Alpha, RenderType, True);
  14670. end;
  14671.  
  14672. function TD2D.D2DRenderWaveYDDS(Source: TDirectDrawSurface; X, Y, Width,
  14673.   Height: Integer; RenderType: TRenderType; Transparent: Boolean;
  14674.   Amp, Len, Ph, Alpha: Integer): Boolean;
  14675. begin
  14676.   Result := False; if not CanUseD2D then Exit;
  14677.   {load textures and map, do make wave mesh and render it}
  14678.   Result := D2DMeshMapToWave(Source, transparent, -1, X, Y, Width, Height, -1,
  14679.     ZeroRect,
  14680.     amp, Len, ph, Alpha, RenderType, True);
  14681. end;
  14682.  
  14683. function TD2D.D2DTexturedOnRect(Rect: TRect; Color: LongInt): Boolean;
  14684. var I: Integer;
  14685. begin
  14686.   Result := False;
  14687.   FDDraw.D3DDevice7.SetTexture(0, nil);
  14688.   if not FD2DTexture.{$IFDEF VER4UP}CanFindTexture{$ELSE}CanFindTexture3{$ENDIF}(Color) then {when no texture in list try load it}
  14689.     if not FD2DTexture.{$IFDEF VER4UP}LoadTextures{$ELSE}LoadTextures4{$ENDIF}(Color) then Exit; {on error occurr go out}
  14690.   I := FD2DTexture.Find('$' + IntToStr(Color)); //simply .. but stupid
  14691.   if I = -1 then Exit;
  14692.   {set pattern as texture}
  14693. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
  14694. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
  14695.   try
  14696.     RenderError := FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7) <> DD_OK;
  14697.   except
  14698.     RenderError := True;
  14699.     FD2DTexture.D2DPruneAllTextures;
  14700.     exit;
  14701.   end;
  14702.   {set transparent part}
  14703.   FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, 0); //no transparency
  14704.  
  14705.   D2DTU(FD2DTexture.Texture[I]);
  14706.   Result := not RenderError;
  14707. end;
  14708.  
  14709. function TD2D.D2DTexturedOnSubRect(Image: TPictureCollectionItem;
  14710.   Pattern: Integer; SubPatternRect, SubRect: TRect; RenderType: TRenderType;
  14711.   Alpha: Byte): Boolean;
  14712. label
  14713.   lblHop;  
  14714. var
  14715.   I, W, H: Integer;
  14716.   SrcX, SrcY, diffX: Double;
  14717.   R, tmpSubRect: TRect;
  14718.   Q: TTextureRec;
  14719.   qFloatX1, qFloatX2, qFloatY1, qFloatY2: Double;
  14720. begin
  14721.   Result := False;
  14722.   FDDraw.D3DDevice7.SetTexture(0, nil);
  14723.   if not FD2DTexture.CanFindTexture(Image) then {when no texture in list try load it}
  14724.     if not FD2DTexture.LoadTextures(Image) then {loading is here}
  14725.       Exit; {on error occurr out}
  14726.   I := FD2DTexture.Find(Image.Name);
  14727.   if I = -1 then Exit;
  14728.   {set pattern as texture}
  14729. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
  14730. //  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
  14731.   try
  14732.     FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7);
  14733.     case RenderType of
  14734.       rtDraw: begin D2DEffectSolid; D2DWhite; end;
  14735.       rtBlend: begin D2DEffectBlend; D2DAlphaVertex(Alpha); end;
  14736.       rtAdd: begin D2DEffectAdd; D2DFade(Alpha); end;
  14737.       rtSub: begin D2DEffectSub; D2DFade(Alpha); end;
  14738.     end;
  14739.   except
  14740.     RenderError := true;
  14741.     FD2DTexture.D2DPruneAllTextures;
  14742.     Image.Restore;
  14743.     SetD2DTextureFilter(D2D_LINEAR);
  14744.     Exit;
  14745.   end;
  14746.   {set transparent part}
  14747.   FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Ord(FD2DTexture.Texture[I].D2DTexture.Transparent));
  14748.   {except for Draw when alphachannel exists}
  14749.   {change for blend drawing but save transparent area still}
  14750.   if FD2DTexture.Texture[I].AlphaChannel then
  14751.     {when is Draw selected then}
  14752.     if RenderType = rtDraw then
  14753.     begin
  14754.       D2DEffectBlend; D2DAlphaVertex($FF);
  14755.     end;
  14756.   {pokud je obrazek rozdeleny, nastav oka site}
  14757.   if (Image.PatternHeight <> 0) or (Image.PatternWidth <> 0) then
  14758.   begin
  14759.     {vezmi rect jenom dilku}
  14760.     R := Image.PatternRects[Pattern];
  14761.  
  14762.     if not CompareMem(@SubRect, @ZeroRect, SizeOf(SubRect)) then
  14763.     begin
  14764.       {ktere oko site to je?}
  14765.       W := SubRect.Right - SubRect.Left; {takhle je siroky}
  14766.       H := SubRect.Bottom - SubRect.Top; {takhle je vysoky}
  14767.       tmpSubRect := Bounds(R.Left + SubRect.Left, R.Top + SubRect.Top, W, H);
  14768.       if RectInRect(tmpSubRect, R) then
  14769.       begin
  14770.         {pokud je subrect jeste v ramci patternu, musi se posouvat podle patternindex}
  14771.         Inc(R.Left, SubRect.Left);
  14772.         Inc(R.Top, SubRect.Top);
  14773.         if (R.Left + W) < R.Right then R.Right := R.Left + W;
  14774.         if (R.Top + H) < R.Bottom then R.Bottom := R.Top + H;
  14775.         goto lblHop;
  14776.       end;
  14777.     end;
  14778.     SrcX := 1 / FD2DTexture.Texture[I].Width;
  14779.     SrcY := 1 / FD2DTexture.Texture[I].Height;
  14780.     //namapovani vertexu na texturu
  14781.     FD2DTexture.Texture[I].FloatX1 := SrcX * R.Left;
  14782.     FD2DTexture.Texture[I].FloatY1 := SrcY * R.Top;
  14783.     {for meshed subimage contain one image only can be problem there}
  14784.     diffX := 0.5; if Image.PatternCount = 1 then diffX := 0;
  14785.     FD2DTexture.Texture[I].FloatX2 := SrcX * (R.Right - diffX);
  14786.     FD2DTexture.Texture[I].FloatY2 := SrcY * (R.Bottom - diffX);
  14787.     if not (
  14788.       (SubPatternRect.Left = Image.PatternRects[Pattern].Left) and
  14789.       (SubPatternRect.Top = Image.PatternRects[Pattern].Top) and
  14790.       (SubPatternRect.Right = Image.PatternRects[Pattern].Right) and
  14791.       (SubPatternRect.Bottom = Image.PatternRects[Pattern].Bottom))
  14792.     then
  14793.     begin
  14794.       {remaping subtexture via subpattern}
  14795.       Q.FloatX1 := SrcX * SubPatternRect.Left;
  14796.       Q.FloatY1 := SrcY * SubPatternRect.Top;
  14797.       Q.FloatX2 := SrcX * (SubPatternRect.Right - diffX);
  14798.       Q.FloatY2 := SrcY * (SubPatternRect.Bottom - diffX);
  14799.       D2DTU(Q); {with mirroring/flipping}
  14800.       Result := True;
  14801.       Exit;
  14802.     end;
  14803.   end; {jinak celeho obrazku}
  14804.  
  14805.   if not CompareMem(@SubRect, @ZeroRect, SizeOf(SubRect)) then
  14806.     if RectInRect(SubRect, Bounds(0,0, FD2DTexture.Texture[I].Width, FD2DTexture.Texture[I].Height)) then
  14807.     begin
  14808.       R := SubRect;
  14809.      lblHop:
  14810.       SrcX := 1 / FD2DTexture.Texture[I].Width;
  14811.       SrcY := 1 / FD2DTexture.Texture[I].Height;
  14812.       //namapovani vertexu na texturu
  14813.       qFloatX1 := FD2DTexture.Texture[I].FloatX1;
  14814.       qFloatY1 := FD2DTexture.Texture[I].FloatY1;
  14815.       qFloatX2 := FD2DTexture.Texture[I].FloatX2;
  14816.       qFloatY2 := FD2DTexture.Texture[I].FloatY2;
  14817.       try
  14818.         FD2DTexture.Texture[I].FloatX1 := SrcX * R.Left;
  14819.         FD2DTexture.Texture[I].FloatY1 := SrcY * R.Top;
  14820.         {for meshed subimage contain one image only can be problem there}
  14821.         diffX := 0.5; if Image.PatternCount = 1 then diffX := 0;
  14822.         FD2DTexture.Texture[I].FloatX2 := SrcX * (R.Right - diffX);
  14823.         FD2DTexture.Texture[I].FloatY2 := SrcY * (R.Bottom - diffX);
  14824.         {remaping subtexture via subpattern}
  14825.         D2DTU(FD2DTexture.Texture[I]); {with mirroring/flipping}
  14826.         Result := True;
  14827.         Exit;
  14828.       finally
  14829.         FD2DTexture.Texture[I].FloatX1 := qFloatX1;
  14830.         FD2DTexture.Texture[I].FloatY1 := qFloatY1;
  14831.         FD2DTexture.Texture[I].FloatX2 := qFloatX2;
  14832.         FD2DTexture.Texture[I].FloatY2 := qFloatY2;
  14833.       end;
  14834.     end;
  14835.  
  14836.   {  X1,Y1             X2,Y1
  14837.   0  +-----------------+  1
  14838.      |                 |
  14839.      |                 |
  14840.      |                 |
  14841.      |                 |
  14842.   2  +-----------------+  3
  14843.      X1,Y2             X2,Y2  }
  14844.   D2DTU(FD2DTexture.Texture[I]);
  14845.   Result := True;
  14846. end;
  14847.  
  14848. function TD2D.D2DRenderColoredPartition(Image: TPictureCollectionItem;
  14849.   DestRect: TRect;
  14850.   PatternIndex, Color, Specular: Integer;
  14851.   Faded: Boolean;
  14852.   SourceRect: TRect;
  14853.   RenderType: TRenderType;
  14854.   Alpha: Byte): Boolean;
  14855. begin
  14856.   Result := False; if not CanUseD2D then Exit;
  14857.   {set of effect before fade}
  14858.   case RenderType of
  14859.     rtDraw: D2DEffectSolid;
  14860.     rtBlend: D2DEffectBlend;
  14861.     rtAdd: D2DEffectAdd;
  14862.     rtSub: D2DEffectSub;
  14863.   end;
  14864.   if Faded then D2DFade(Alpha);
  14865.  
  14866.   D2DColoredVertex(Color);
  14867.   if Specular <> Round(D3DRGB(1.0, 1.0, 1.0)) then
  14868.     D2DSpecularVertex(Specular);
  14869.   {load textures and map it}
  14870.   if D2DTexturedOn(Image, PatternIndex, SourceRect, RenderType, Alpha) then
  14871.   begin
  14872.     D2DRect(DestRect);
  14873.     {render it}
  14874.     Result := RenderQuad;
  14875.   end;
  14876. end;
  14877.  
  14878. function TD2D.D2DRenderFillRect(Rect: TRect; RGBColor: LongInt;
  14879.   RenderType: TRenderType; Alpha: Byte): Boolean;
  14880. begin
  14881.   Result := False; if not CanUseD2D then Exit;
  14882.   case RenderType of
  14883.     rtDraw: begin D2DEffectSolid; D2DColoredVertex(RGBColor); end;
  14884.     rtBlend: begin D2DEffectBlend; D2DAlphaVertex(Alpha); end;
  14885.     rtAdd: begin D2DEffectAdd; D2DFade(Alpha); end;
  14886.     rtSub: begin D2DEffectSub; D2DFade(Alpha); end;
  14887.   end;
  14888.   if D2DTexturedOnRect(Rect, RGBColor) then
  14889.   begin
  14890.     D2DRect(Rect);
  14891.     Result := RenderQuad;
  14892.   end;
  14893. end;
  14894.  
  14895. function TD2D.D2DRenderRotateModeCol(Image: TPictureCollectionItem;
  14896.   RenderType: TRenderType;
  14897.   RotX, RotY, PictWidth, PictHeight, PatternIndex: Integer; CenterX,
  14898.   CenterY: Double; Angle: single; Color: Integer; Alpha: Byte): Boolean;
  14899. begin
  14900.   Result := False; if not CanUseD2D then Exit;
  14901.   {set of effect before colored}
  14902.   case RenderType of
  14903.     rtDraw: D2DEffectSolid;
  14904.     rtAdd: D2DEffectAdd;
  14905.     rtSub: D2DEffectSub;
  14906.     rtBlend: D2DEffectBlend;
  14907.   end;
  14908.   D2DFadeColored(Color, Alpha);
  14909.   {load textures and map it}
  14910.   if D2DTexturedOn(Image, PatternIndex, Image.PatternRects[PatternIndex], RenderType, Alpha) then
  14911.   begin
  14912.     {do rotate mesh}
  14913.     D2DRotate(RotX, RotY, PictWidth, PictHeight, CenterX, CenterY, Angle);
  14914.     {render it}
  14915.     Result := RenderQuad;
  14916.   end;
  14917. end;
  14918.  
  14919. function TD2D.D2DRenderRotateModeColDDS(Image: TDirectDrawSurface;
  14920.   RotX, RotY, PictWidth, PictHeight: Integer; RenderType: TRenderType;
  14921.   CenterX, CenterY: Double; Angle: Single; Color: Integer; Alpha: Byte;
  14922.   Transparent: Boolean): Boolean;
  14923. begin
  14924.   Result := False; if not CanUseD2D then Exit;
  14925.   {set of effect}
  14926.   D2DFadeColored(Color, Alpha);
  14927.   {load textures and map it}
  14928.   if D2DTexturedOnDDS(Image, ZeroRect, Transparent, RenderType, Alpha) then
  14929.   begin
  14930.     {do rotate mesh}
  14931.     D2DRotate(RotX, RotY, PictWidth, PictHeight, CenterX, CenterY, Angle);
  14932.     {render it}
  14933.     Result := RenderQuad;
  14934.   end;
  14935. end;
  14936.  
  14937. procedure TD2D.D2DEffectSolid;
  14938. begin
  14939.   with FDDraw.D3DDevice7 do
  14940.   begin
  14941.     SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 0);
  14942.     //SetRenderState(D3DRENDERSTATE_FILLMODE, Integer(D3DFILL_SOLID));
  14943.     SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Integer(True));
  14944.     SetRenderState(D3DRENDERSTATE_SRCBLEND, Integer(D3DBLEND_ONE));
  14945.   end;
  14946. end;
  14947.  
  14948. procedure TD2D.D2DEffectBlend;
  14949. begin
  14950.   with FDDraw.D3DDevice7 do
  14951.   begin
  14952.     SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 1);
  14953.     SetRenderState(D3DRENDERSTATE_SRCBLEND, Integer(D3DBLEND_SRCALPHA));
  14954.     SetRenderState(D3DRENDERSTATE_DESTBLEND, Integer(D3DBLEND_INVSRCALPHA));
  14955.  
  14956.     SetTextureStageState(0, D3DTSS_COLOROP, Integer(D3DTOP_MODULATE));
  14957.     SetTextureStageState(0, D3DTSS_COLORARG1, Integer(D3DTA_TEXTURE));
  14958.     SetTextureStageState(0, D3DTSS_COLORARG2, Integer(D3DTA_CURRENT));
  14959.  
  14960.     SetTextureStageState(0, D3DTSS_ALPHAOP, Integer(D3DTOP_BLENDDIFFUSEALPHA));
  14961.     SetTextureStageState(0, D3DTSS_ALPHAARG1, Integer(D3DTA_TEXTURE));
  14962.     SetTextureStageState(0, D3DTSS_ALPHAARG2, Integer(D3DTA_CURRENT));
  14963.  
  14964.     SetTextureStageState(0, D3DTSS_ALPHAOP, Integer(D3DTOP_MODULATE));
  14965.   end;
  14966. end;
  14967.  
  14968. procedure TD2D.D2DEffectAdd;
  14969. begin
  14970.   with FDDraw.D3DDevice7 do
  14971.   begin
  14972.     SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 1);
  14973.     SetRenderState(D3DRENDERSTATE_SRCBLEND, Integer(D3DBLEND_ONE));
  14974.     SetRenderState(D3DRENDERSTATE_DESTBLEND, Integer(D3DBLEND_ONE));
  14975.     SetTextureStageState(0, D3DTSS_ALPHAOP, Ord(D3DTOP_SELECTARG1));
  14976.     SetTextureStageState(0, D3DTSS_ALPHAARG1,  D3DTA_CURRENT);
  14977.     SetTextureStageState(0, D3DTSS_ALPHAOP, Integer(D3DTOP_MODULATE));
  14978.   end;
  14979. end;
  14980.  
  14981. procedure TD2D.D2DEffectSub;
  14982. begin
  14983.   with FDDraw.D3DDevice7 do
  14984.   begin
  14985.     SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 1);
  14986.     SetRenderState(D3DRENDERSTATE_SRCBLEND, Integer(D3DBLEND_ZERO));
  14987.     SetRenderState(D3DRENDERSTATE_DESTBLEND, Integer(D3DBLEND_INVSRCCOLOR));
  14988.     SetTextureStageState(0, D3DTSS_ALPHAOP, Ord(D3DTOP_SELECTARG1));
  14989.     SetTextureStageState(0, D3DTSS_ALPHAARG1,  D3DTA_CURRENT);
  14990.     SetTextureStageState(0, D3DTSS_ALPHAOP, Integer(D3DTOP_MODULATE));
  14991.   end;
  14992. end;
  14993.  
  14994. function TD2D.D2DAlphaVertex(Alpha: Integer): Integer;
  14995. begin
  14996.   Result := RGBA_MAKE($FF, $FF, $FF, Alpha);
  14997.   FVertex[0].Color := Result;
  14998.   FVertex[1].Color := Result;
  14999.   FVertex[2].Color := Result;
  15000.   FVertex[3].Color := Result;
  15001. end;
  15002.  
  15003. procedure TD2D.D2DColoredVertex(C: Integer);
  15004. begin
  15005.   C := D3DRGB(C and $FF / 255, (C shr 8) and $FF / 255, (C shr 16) and $FF / 255);
  15006.   FVertex[0].Color := C;
  15007.   FVertex[1].Color := C;
  15008.   FVertex[2].Color := C;
  15009.   FVertex[3].Color := C;
  15010. end;
  15011.  
  15012. procedure TD2D.D2DColAlpha(C, Alpha: Integer);
  15013. begin
  15014.   C := D3DRGBA(C and $FF / 255, (C shr 8) and $FF / 255, (C shr 16) and $FF / 255, Alpha / 255);
  15015.   FVertex[0].Color := C;
  15016.   FVertex[1].Color := C;
  15017.   FVertex[2].Color := C;
  15018.   FVertex[3].Color := C;
  15019. end;
  15020.  
  15021. procedure TD2D.D2DSpecularVertex(C: Integer);
  15022. begin
  15023.   C := D3DRGB(C and $FF / 255, (C shr 8) and $FF / 255, (C shr 16) and $FF / 255);
  15024.   FVertex[0].Specular := C;
  15025.   FVertex[1].Specular := C;
  15026.   FVertex[2].Specular := C;
  15027.   FVertex[3].Specular := C;
  15028. end;
  15029.  
  15030. procedure TD2D.D2DCol4Alpha(C1, C2, C3, C4, Alpha: Integer);
  15031. begin
  15032.   FVertex[0].Color := D3DRGBA(C1 and $FF / 255, (C1 shr 8) and $FF / 255,
  15033.     (C1 shr 16) and $FF / 255, Alpha / 255);
  15034.   FVertex[1].Color := D3DRGBA(C2 and $FF / 255, (C2 shr 8) and $FF / 255,
  15035.     (C2 shr 16) and $FF / 255, Alpha / 255);
  15036.   FVertex[2].Color := D3DRGBA(C3 and $FF / 255, (C3 shr 8) and $FF / 255,
  15037.     (C3 shr 16) and $FF / 255, Alpha / 255);
  15038.   FVertex[3].Color := D3DRGBA(C4 and $FF / 255, (C4 shr 8) and $FF / 255,
  15039.     (C4 shr 16) and $FF / 255, Alpha / 255);
  15040. end;
  15041.  
  15042. function TD2D.D2DVertColor(RenderType: TRenderType; Alpha: Byte): DWORD;
  15043. begin
  15044.   case RenderType of //effect cumulate to one param and four line of code
  15045.     rtDraw: Result := RGB_MAKE($FF, $FF, $FF);
  15046.     rtBlend: Result := RGBA_MAKE($FF, $FF, $FF, Alpha);
  15047.     rtAdd: Result := RGB_MAKE(Alpha, Alpha, Alpha);
  15048.     rtSub: Result := RGB_MAKE(Alpha, Alpha, Alpha);
  15049.   else
  15050.     Result := RGB_MAKE($FF, $FF, $FF);
  15051.   end;
  15052. end;
  15053.  
  15054. function TD2D.D2DWhite: Integer;
  15055. begin
  15056.   Result := RGB_MAKE($FF, $FF, $FF);
  15057.   FVertex[0].Color := Result;
  15058.   FVertex[1].Color := Result;
  15059.   FVertex[2].Color := Result;
  15060.   FVertex[3].Color := Result;
  15061. end;
  15062.  
  15063. function TD2D.D2DFade(Alpha: Integer): Integer;
  15064. begin
  15065.   Result := RGB_MAKE(Alpha, Alpha, Alpha);
  15066.   FVertex[0].Color := Result;
  15067.   FVertex[1].Color := Result;
  15068.   FVertex[2].Color := Result;
  15069.   FVertex[3].Color := Result;
  15070. end;
  15071.  
  15072. procedure TD2D.D2DFadeColored(C, Alpha: Integer);
  15073. var mult: single;
  15074. begin
  15075.   mult := Alpha / 65025; //Alpha/255/255;
  15076.   C := D3DRGB((C and $FF) * mult, ((C shr 8) and $FF) * mult, ((C shr 16) and $FF) * mult);
  15077.   FVertex[0].Color := C;
  15078.   FVertex[1].Color := C;
  15079.   FVertex[2].Color := C;
  15080.   FVertex[3].Color := C;
  15081. end;
  15082.  
  15083. procedure TD2D.D2DFade4Colored(C1, C2, C3, C4, Alpha: Integer);
  15084. var mult: single;
  15085. begin
  15086.   mult := Alpha / 65025; //Alpha/255/255;
  15087.   FVertex[0].Color := D3DRGB((C1 and $FF) * mult, ((C1 shr 8) and $FF) * mult,
  15088.     ((C1 shr 16) and $FF) * mult);
  15089.   FVertex[1].Color := D3DRGB((C2 and $FF) * mult, ((C2 shr 8) and $FF) * mult,
  15090.     ((C2 shr 16) and $FF) * mult);
  15091.   FVertex[2].Color := D3DRGB((C3 and $FF) * mult, ((C3 shr 8) and $FF) * mult,
  15092.     ((C3 shr 16) and $FF) * mult);
  15093.   FVertex[3].Color := D3DRGB((C4 and $FF) * mult, ((C4 shr 8) and $FF) * mult,
  15094.     ((C4 shr 16) and $FF) * mult);
  15095. end;
  15096.  
  15097. function TD2D.RenderQuad: Boolean;
  15098. begin
  15099.   Result := FDDraw.D3DDevice7.DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, FVertex, 4, D3DDP_WAIT) <> DD_OK;
  15100.   InitVertex;
  15101.   FMirrorFlipSet := []; {only for one operation, back to normal position}
  15102.   {restore device status}
  15103.   with FDDraw.D3DDevice7 do
  15104.   begin
  15105.     SetTextureStageState(1, D3DTSS_COLOROP, Ord(D3DTOP_DISABLE));
  15106.     SetTextureStageState(1, D3DTSS_ALPHAOP, Ord(D3DTOP_DISABLE));
  15107.     SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 0);
  15108.   end;
  15109. end;
  15110.  
  15111. function TD2D.RenderTri: Boolean;
  15112. begin
  15113.   Result := FDDraw.D3DDevice7.DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, FVertex, 3, D3DDP_WAIT) <> DD_OK;
  15114.   InitVertex;
  15115.   FMirrorFlipSet := []; {only for one operation, back to normal position}
  15116.   {restore device status}
  15117.   with FDDraw.D3DDevice7 do
  15118.   begin
  15119.     SetTextureStageState(1, D3DTSS_COLOROP, Ord(D3DTOP_DISABLE));
  15120.     SetTextureStageState(1, D3DTSS_ALPHAOP, Ord(D3DTOP_DISABLE));
  15121.     SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 0);
  15122.   end;
  15123. end;
  15124.  
  15125. procedure TD2D.D2DMeshMapToRect(R: TRect);
  15126. begin
  15127.   FVertex[0].sx := R.Left - 0.5;
  15128.   FVertex[0].sy := R.Top - 0.5;
  15129.   FVertex[1].sx := R.Right - 0.5;
  15130.   FVertex[1].sy := R.Top - 0.5;
  15131.   FVertex[2].sx := R.Left - 0.5;
  15132.   FVertex[2].sy := R.Bottom - 0.5;
  15133.   FVertex[3].sx := R.Right - 0.5;
  15134.   FVertex[3].sy := R.Bottom - 0.5;
  15135. end;
  15136.  
  15137. function TD2D.D2DInitializeSurface: Boolean;
  15138. begin
  15139.   Result := False;
  15140.   if Assigned(FDDraw.D3DDevice7) then
  15141.     Result := FDDraw.D3DDevice7.SetRenderTarget(FDDraw.Surface.IDDSurface7, 0) = DD_OK;
  15142. end;
  15143.  
  15144. procedure TD2D.D2DUpdateTextures;
  15145. var I: Integer;
  15146. begin
  15147.   {$IFDEF VER4UP}
  15148.   for I := Low(FD2DTexture.Texture) to High(FD2DTexture.Texture) do
  15149.   {$ELSE}
  15150.   for I := 0 to FD2DTexture.TexLen - 1 do
  15151.   {$ENDIF}
  15152.   begin
  15153.     FD2DTexture.Texture[I].Width := FD2DTexture.Texture[I].D2DTexture.Surface.Width;
  15154.     FD2DTexture.Texture[I].Height := FD2DTexture.Texture[I].D2DTexture.Surface.Height;
  15155. //    FD2DTexture.Texture[I].AlphaChannel := ?
  15156.   end;
  15157. end;
  15158.  
  15159. {  TTrace  }
  15160.  
  15161. constructor TTrace.Create(Collection: TCollection);
  15162. begin
  15163.   inherited Create(Collection);
  15164.   FBlit := TBlit.Create(Self);
  15165.   FBlit.FEngine := TCustomDXDraw(Traces.FOwner);
  15166. end;
  15167.  
  15168. destructor TTrace.Destroy;
  15169. begin
  15170.   FBlit.Free;
  15171.   inherited Destroy;
  15172. end;
  15173.  
  15174. function TTrace.GetDisplayName: string;
  15175. begin
  15176.   Result := inherited GetDisplayName
  15177. end;
  15178.  
  15179. procedure TTrace.SetDisplayName(const Value: string);
  15180. begin
  15181.   if (Value <> '') and (AnsiCompareText(Value, GetDisplayName) <> 0) and
  15182.     (Collection is TTraces) and (TTraces(Collection).IndexOf(Value) >= 0) then
  15183.     raise Exception.Create(Format('Item duplicate name "%s" error', [Value]));
  15184.   inherited SetDisplayName(Value);
  15185. end;
  15186.  
  15187. function TTrace.GetTraces: TTraces;
  15188. begin
  15189.   if Collection is TTraces then
  15190.     Result := TTraces(Collection)
  15191.   else
  15192.     Result := nil;
  15193. end;
  15194.  
  15195. procedure TTrace.Render(const LagCount: Integer);
  15196. begin
  15197.   FBlit.DoMove(LagCount);
  15198.   FBlit.DoCollision;
  15199.   FBlit.DoDraw;
  15200.   if Assigned(FBlit.FOnRender) then
  15201.     FBlit.FOnRender(FBlit);
  15202. end;
  15203.  
  15204. function TTrace.IsActualized: Boolean;
  15205. begin
  15206.   Result := FActualized;
  15207. end;
  15208.  
  15209. procedure TTrace.Assign(Source: TPersistent);
  15210. begin
  15211.   if Source is TTrace then begin
  15212.     //FTracePoints.Assign(TTrace(Source).FTracePoints);
  15213.     FBlit.Assign(TTrace(Source).FBlit);
  15214.     FTag := TTrace(Source).FTag;
  15215.   end
  15216.   else
  15217.     inherited Assign(Source);
  15218. end;
  15219.  
  15220. function TTrace.GetActive: Boolean;
  15221. begin
  15222.   Result := FBlit.FActive;
  15223. end;
  15224.  
  15225. procedure TTrace.SetActive(const Value: Boolean);
  15226. begin
  15227.   FBlit.FActive := Value;
  15228. end;
  15229.  
  15230. function TTrace.GetOnCollision: TNotifyEvent;
  15231. begin
  15232.   Result := FBlit.FOnCollision;
  15233. end;
  15234.  
  15235. procedure TTrace.SetOnCollision(const Value: TNotifyEvent);
  15236. begin
  15237.   FBlit.FOnCollision := Value;
  15238. end;
  15239.  
  15240. function TTrace.GetOnGetImage: TNotifyEvent;
  15241. begin
  15242.   Result := FBlit.FOnGetImage;
  15243. end;
  15244.  
  15245. procedure TTrace.SetOnGetImage(const Value: TNotifyEvent);
  15246. begin
  15247.   FBlit.FOnGetImage := Value;
  15248. end;
  15249.  
  15250. function TTrace.GetOnDraw: TNotifyEvent;
  15251. begin
  15252.   Result := FBlit.FOnDraw;
  15253. end;
  15254.  
  15255. procedure TTrace.SetOnDraw(const Value: TNotifyEvent);
  15256. begin
  15257.   FBlit.FOnDraw := Value;
  15258. end;
  15259.  
  15260. function TTrace.GetOnMove: TBlitMoveEvent;
  15261. begin
  15262.   Result := FBlit.FOnMove;
  15263. end;
  15264.  
  15265. procedure TTrace.SetOnMove(const Value: TBlitMoveEvent);
  15266. begin
  15267.   FBlit.FOnMove := Value;
  15268. end;
  15269.  
  15270. function TTrace.Clone(NewName: string; OffsetX, OffsetY: Integer;
  15271.   Angle: Single): TTrace;
  15272. var
  15273.   NewItem: TTrace;
  15274.   I: Integer;
  15275. begin
  15276.   NewItem := GetTraces.Add;
  15277.   NewItem.Assign(Self);
  15278.   NewItem.Name := NewName;
  15279.   for I := 0 to NewItem.Blit.GetPathCount - 1 do begin
  15280.     NewItem.Blit.FPathArr[I].X := NewItem.Blit.FPathArr[I].X + OffsetX;
  15281.     NewItem.Blit.FPathArr[I].Y := NewItem.Blit.FPathArr[I].Y + OffsetY;
  15282.   end;
  15283.   Result := NewItem
  15284. end;
  15285.  
  15286. function TTrace.GetOnRender: TOnRender;
  15287. begin
  15288.   Result := FBlit.FOnRender;
  15289. end;
  15290.  
  15291. procedure TTrace.SetOnRender(const Value: TOnRender);
  15292. begin
  15293.   FBlit.FOnRender := Value;
  15294. end;
  15295.  
  15296. {  TTraces  }
  15297.  
  15298. constructor TTraces.Create(AOwner: TComponent);
  15299. begin
  15300.   inherited Create(TTrace);
  15301.   FOwner := AOwner;
  15302. end;
  15303.  
  15304. destructor TTraces.Destroy;
  15305. begin
  15306.   inherited Destroy;
  15307. end;
  15308.  
  15309. function TTraces.Add: TTrace;
  15310. begin
  15311.   Result := TTrace(inherited Add);
  15312. end;
  15313.  
  15314. function TTraces.Find(const Name: string): TTrace;
  15315. var
  15316.   i: Integer;
  15317. begin
  15318.   i := IndexOf(Name);
  15319.   if i = -1 then
  15320.     raise EDXTracerError.CreateFmt('Tracer item named %s not found', [Name]);
  15321.   Result := Items[i];
  15322. end;
  15323.  
  15324. function TTraces.GetItem(Index: Integer): TTrace;
  15325. begin
  15326.   Result := TTrace(inherited GetItem(Index));
  15327. end;
  15328.  
  15329. procedure TTraces.SetItem(Index: Integer;
  15330.   Value: TTrace);
  15331. begin
  15332.   inherited SetItem(Index, Value);
  15333. end;
  15334.  
  15335. procedure TTraces.Update(Item: TCollectionItem);
  15336. begin
  15337.   inherited Update(Item);
  15338. end;
  15339.  
  15340. {$IFDEF VER4UP}
  15341. function TTraces.Insert(Index: Integer): TTrace;
  15342. begin
  15343.   Result := TTrace(inherited Insert(Index));
  15344. end;
  15345. {$ENDIF}
  15346.  
  15347. function TTraces.GetOwner: TPersistent;
  15348. begin
  15349.   Result := FOwner;
  15350. end;
  15351.  
  15352. {  TBlit  }
  15353.  
  15354. function TBlit.GetWorldX: Double;
  15355. begin
  15356.   if Parent <> nil then
  15357.     Result := Parent.WorldX + FBlitRec.FX
  15358.   else
  15359.     Result := FBlitRec.FX;
  15360. end;
  15361.  
  15362. function TBlit.GetWorldY: Double;
  15363. begin
  15364.   if Parent <> nil then
  15365.     Result := Parent.WorldY + FBlitRec.FY
  15366.   else
  15367.     Result := FBlitRec.FY;
  15368. end;
  15369.  
  15370. procedure TBlit.DoMove(LagCount: Integer);
  15371. var
  15372.   MoveIt: Boolean;
  15373. begin
  15374.   if not FBlitRec.FMoved then Exit;
  15375.   if AsSigned(FOnMove) then begin
  15376.     MoveIt := True; {if nothing then reanimate will force}
  15377.     FOnMove(Self, LagCount, MoveIt); {when returned MoveIt = true still that do not move}
  15378.     if MoveIt then
  15379.       ReAnimate(LagCount); //for reanimation
  15380.   end
  15381.   else begin
  15382.     ReAnimate(LagCount);
  15383.   end;
  15384.   {there is moving to next foot of the path}
  15385.   if Active then
  15386.     if GetPathCount > 0 then begin
  15387.       Dec(FCurrentTime, LagCount);
  15388.       if FCurrentTime < 0 then begin
  15389.         if FBustrofedon then begin
  15390.           case FCurrentDirection of
  15391.             True: begin
  15392.                 Inc(FCurrentPosition); //go forward
  15393.                 if FCurrentPosition = (GetPathCount - 1) then
  15394.                   FCurrentDirection := not FCurrentDirection //change direction
  15395.               end;
  15396.             False: begin
  15397.                 Dec(FCurrentPosition); //go backward
  15398.                 if FCurrentPosition = 0 then
  15399.                   FCurrentDirection := not FCurrentDirection //change direction
  15400.               end;
  15401.           end;
  15402.         end
  15403.         else
  15404.           if FCurrentPosition < (GetPathCount - 1) then begin
  15405.             Inc(FCurrentPosition) //go forward only
  15406.           end
  15407.           else
  15408.             if FMovingRepeatly then
  15409.               FCurrentPosition := 0; {return to start}
  15410.         {get actual new value for showing time}
  15411.         {must be pick-up there, after change of the current position}
  15412.         FCurrentTime := Path[FCurrentPosition].StayOn; {cas mezi pohyby}
  15413.       end;
  15414.       X := Path[FCurrentPosition].X;
  15415.       Y := Path[FCurrentPosition].Y;
  15416.     end;
  15417.   {}
  15418. end;
  15419.  
  15420. function TBlit.GetDrawImageIndex: Integer;
  15421. begin
  15422.   Result := FBlitRec.FAnimStart + Trunc(FBlitRec.FAnimPos);
  15423. end;
  15424.  
  15425. procedure TBlit.DoDraw;
  15426. var
  15427.   f: TRenderMirrorFlipSet;
  15428.   r: TRect;
  15429. begin
  15430.   with FBlitRec do begin
  15431.     if not FVisible then Exit;
  15432.     if FImage = nil then DoGetImage;
  15433.     if FImage = nil then Exit;
  15434.     {owner draw called here}
  15435.     if AsSigned(FOnDraw) then
  15436.       FOnDraw(Self)
  15437.     else
  15438.     {when is not owner draw then go here}
  15439.     begin
  15440.       f := [];
  15441.       if FMirror then f := f + [rmfMirror];
  15442.       if FFlip then f := f + [rmfFlip];
  15443.       r := Bounds(Round(FX), Round(FY), FImage.Width, FImage.Height);
  15444.       DXDraw_Render(FEngine, FImage, r,
  15445.         GetDrawImageIndex, FBlurImageArr, FBlurImage, FTextureFilter, f, FBlendMode, FAngle,
  15446.         FAlpha, FCenterX, FCenterY, FScale, FWaveType, FAmplitude, FAmpLength, FPhase);
  15447.     end;
  15448.   end
  15449. end;
  15450.  
  15451. function Mod2f(i: Double; i2: Integer): Double;
  15452. begin
  15453.   if i2 = 0 then
  15454.     Result := i
  15455.   else
  15456.   begin
  15457.     Result := i - Round(i / i2) * i2;
  15458.     if Result < 0 then
  15459.       Result := i2 + Result;
  15460.   end;
  15461. end;
  15462.  
  15463. procedure TBlit.ReAnimate(MoveCount: Integer);
  15464. var I: Integer;
  15465. begin
  15466.   with FBlitRec do begin
  15467.     FAnimPos := FAnimPos + FAnimSpeed * MoveCount;
  15468.  
  15469.     if FAnimLooped then
  15470.     begin
  15471.       if FAnimCount > 0 then
  15472.         FAnimPos := Mod2f(FAnimPos, FAnimCount)
  15473.       else
  15474.         FAnimPos := 0;
  15475.     end
  15476.     else
  15477.     begin
  15478.       if Round(FAnimPos) >= FAnimCount then
  15479.       begin
  15480.         FAnimPos := FAnimCount - 1;
  15481.         FAnimSpeed := 0;
  15482.       end;
  15483.       if FAnimPos < 0 then
  15484.       begin
  15485.         FAnimPos := 0;
  15486.         FAnimSpeed := 0;
  15487.       end;
  15488.     end;
  15489.     {incerease or decrease speed}
  15490.     if (FEnergy <> 0) then begin
  15491.       FSpeedX := FSpeedX + FSpeedX * FEnergy;
  15492.       FSpeedY := FSpeedY + FSpeedY * FEnergy;
  15493.     end;
  15494.     {adjust with speed}
  15495.     if (FSpeedX > 0) or (FSpeedY > 0) then begin
  15496.       FX := FX + FSpeedX * MoveCount;
  15497.       FY := FY + FSpeedY * MoveCount;
  15498.     end;
  15499.     {and gravity aplicable}
  15500.     if (FGravityX > 0) or (FGravityY > 0) then begin
  15501.       FX := FX + FGravityX * MoveCount;
  15502.       FY := FY + FGravityY * MoveCount;
  15503.     end;
  15504.     if FBlurImage then begin
  15505.       {ale jen jsou-li jine souradnice}
  15506.       if (FBlurImageArr[High(FBlurImageArr)].eX <> Round(WorldX)) or
  15507.       (FBlurImageArr[High(FBlurImageArr)].eY <> Round(WorldY)) then begin
  15508.         for i := Low(FBlurImageArr) + 1 to High(FBlurImageArr) do begin
  15509.           FBlurImageArr[i - 1] := FBlurImageArr[i];
  15510.           {adjust the blur intensity}
  15511.           FBlurImageArr[i - 1].eIntensity := Round(FAlpha / (High(FBlurImageArr) + 1)) * (i - 1);
  15512.         end;
  15513.         with FBlurImageArr[High(FBlurImageArr)] do begin
  15514.           eX := Round(WorldX);
  15515.           eY := Round(WorldY);
  15516.           ePatternIndex := GetDrawImageIndex;
  15517.           eIntensity := Round(FAlpha / (High(FBlurImageArr) + 1)) * High(FBlurImageArr);
  15518.           eBlendMode := FBlendMode;
  15519.           eActive := True;
  15520.         end;
  15521.       end;
  15522.     end;
  15523.   end;
  15524. end;
  15525.  
  15526. function TBlit.DoCollision: TBlit;
  15527. var
  15528.   i, maxzaxis: Integer;
  15529. begin
  15530.   Result := nil;
  15531.   if not FBlitRec.FCollisioned then Exit;
  15532.   if AsSigned(FOnCollision) then
  15533.     FOnCollision(Self)
  15534.   else begin
  15535.     {over z axis}
  15536.     maxzaxis := 0;
  15537.     for i := 0 to FEngine.Traces.Count - 1 do
  15538.       maxzaxis := Max(maxzaxis, FEngine.Traces.Items[i].FBlit.Z);
  15539.     {for all items}
  15540.     for i := 0 to FEngine.Traces.Count - 1 do
  15541.       {no self item}
  15542.       if FEngine.Traces.Items[i].FBlit <> Self then
  15543.         {through engine}
  15544.         with FEngine.Traces.Items[i] do
  15545.           {test overlap}
  15546.           if OverlapRect(Bounds(Round(FBlit.WorldX), Round(FBlit.WorldY),
  15547.             FBlit.Width, FBlit.Height), Bounds(Round(WorldX), Round(WorldY), Width, Height)) then
  15548.           begin
  15549.             {if any, then return first blit}
  15550.             Result := FBlit;
  15551.             {and go out}
  15552.             Break;
  15553.           end;
  15554.   end;
  15555. end;
  15556.  
  15557. procedure TBlit.DoGetImage;
  15558. begin
  15559.   {init image when object come from form}
  15560.   if FImage = nil then
  15561.     if AsSigned(FOnGetImage) then begin
  15562.       FOnGetImage(Self);
  15563.       if FImage = nil then
  15564.         raise EDXBlitError.Create('Undefined image file!');
  15565.       FBlitRec.FWidth := FImage.Width;
  15566.       FBlitRec.FHeight := FImage.Height;
  15567.     end;
  15568. end;
  15569.  
  15570. constructor TBlit.Create(AParent: TObject);
  15571. begin
  15572.   inherited Create;
  15573.   FParent := nil;
  15574.   if AParent is TBlit then
  15575.     FParent := TBlit(AParent);
  15576.   FillChar(FBlitRec, SizeOf(FBlitRec), 0);
  15577.   with FBlitRec do begin
  15578.     FCollisioned := True; {can be collisioned}
  15579.     FMoved := True; {can be moved}
  15580.     FVisible := True; {can be rendered}
  15581.     FAnimCount := 0;
  15582.     FAnimLooped := False;
  15583.     FAnimPos := 0;
  15584.     FAnimSpeed := 0;
  15585.     FAnimStart := 0;
  15586.     FAngle := 0;
  15587.     FAlpha := $FF;
  15588.     FCenterX := 0.5;
  15589.     FCenterY := 0.5;
  15590.     FScale := 1;
  15591.     FBlendMode := rtDraw;
  15592.     FAmplitude := 0;
  15593.     FAmpLength := 0;
  15594.     FPhase := 0;
  15595.     FWaveType := wtWaveNone;
  15596.     FSpeedX := 0;
  15597.     FSpeedY := 0;
  15598.     FGravityX := 0;
  15599.     FGravityY := 0;
  15600.     FEnergy := 0;
  15601.     FBlurImage := False;
  15602.     FMirror := False;
  15603.     FFlip := False;
  15604.   end;
  15605.   FillChar(FBlurImageArr, SizeOf(FBlitRec), 0);
  15606.   FActive := True; {active on}
  15607.   FMovingRepeatly := True;
  15608.   {super private}
  15609.   FCurrentTime := 0;
  15610.   FCurrentPosition := 0;
  15611.   FCurrentDirection := True;
  15612. end;
  15613.  
  15614. destructor TBlit.Destroy;
  15615. begin
  15616.   {$IFDEF VER4UP}
  15617.   SetLength(FPathArr, 0);
  15618.   {$ELSE}
  15619.   SetPathLen(0);
  15620.   {$ENDIF}
  15621.   inherited;
  15622. end;
  15623.  
  15624. function TBlit.GetMoved: Boolean;
  15625. begin
  15626.   Result := FBlitRec.FMoved;
  15627. end;
  15628.  
  15629. procedure TBlit.SetMoved(const Value: Boolean);
  15630. begin
  15631.   FBlitRec.FMoved := Value;
  15632. end;
  15633.  
  15634. function TBlit.GetWaveType: TWaveType;
  15635. begin
  15636.   Result := FBlitRec.FWaveType;
  15637. end;
  15638.  
  15639. procedure TBlit.SetWaveType(const Value: TWaveType);
  15640. begin
  15641.   FBlitRec.FWaveType := Value;
  15642. end;
  15643.  
  15644. function TBlit.GetAmplitude: Integer;
  15645. begin
  15646.   Result := FBlitRec.FAmplitude;
  15647. end;
  15648.  
  15649. procedure TBlit.SetAmplitude(const Value: Integer);
  15650. begin
  15651.   FBlitRec.FAmplitude := Value;
  15652. end;
  15653.  
  15654. function TBlit.GetAnimStart: Integer;
  15655. begin
  15656.   Result := FBlitRec.FAnimStart;
  15657. end;
  15658.  
  15659. procedure TBlit.SetAnimStart(const Value: Integer);
  15660. begin
  15661.   FBlitRec.FAnimStart := Value;
  15662. end;
  15663.  
  15664. function TBlit.GetAmpLength: Integer;
  15665. begin
  15666.   Result := FBlitRec.FAmpLength;
  15667. end;
  15668.  
  15669. procedure TBlit.SetAmpLength(const Value: Integer);
  15670. begin
  15671.   FBlitRec.FAmpLength := Value;
  15672. end;
  15673.  
  15674. function TBlit.GetWidth: Integer;
  15675. begin
  15676.   Result := FBlitRec.FWidth;
  15677. end;
  15678.  
  15679. procedure TBlit.SetWidth(const Value: Integer);
  15680. begin
  15681.   FBlitRec.FWidth := Value;
  15682. end;
  15683.  
  15684. function TBlit.GetGravityX: Single;
  15685. begin
  15686.   Result := FBlitRec.FGravityX;
  15687. end;
  15688.  
  15689. procedure TBlit.SetGravityX(const Value: Single);
  15690. begin
  15691.   FBlitRec.FGravityX := Value;
  15692. end;
  15693.  
  15694. function TBlit.StoreGravityX: Boolean;
  15695. begin
  15696.   Result := FBlitRec.FGravityX <> 1.0;
  15697. end;
  15698.  
  15699. function TBlit.GetPhase: Integer;
  15700. begin
  15701.   Result := FBlitRec.FPhase;
  15702. end;
  15703.  
  15704. procedure TBlit.SetPhase(const Value: Integer);
  15705. begin
  15706.   FBlitRec.FPhase := Value;
  15707. end;
  15708.  
  15709. function TBlit.GetAnimPos: Double;
  15710. begin
  15711.   Result := FBlitRec.FAnimPos;
  15712. end;
  15713.  
  15714. procedure TBlit.SetAnimPos(const Value: Double);
  15715. begin
  15716.   FBlitRec.FAnimPos := Value;
  15717. end;
  15718.  
  15719. function TBlit.StoreAnimPos: Boolean;
  15720. begin
  15721.   Result := FBlitRec.FAnimPos <> 0;
  15722. end;
  15723.  
  15724. function TBlit.GetFlip: Boolean;
  15725. begin
  15726.   Result := FBlitRec.FFlip;
  15727. end;
  15728.  
  15729. procedure TBlit.SetFlip(const Value: Boolean);
  15730. begin
  15731.   FBlitRec.FFlip := Value;
  15732. end;
  15733.  
  15734. function TBlit.GetGravityY: Single;
  15735. begin
  15736.   Result := FBlitRec.FGravityY;
  15737. end;
  15738.  
  15739. procedure TBlit.SetGravityY(const Value: Single);
  15740. begin
  15741.   FBlitRec.FGravityY := Value;
  15742. end;
  15743.  
  15744. function TBlit.StoreGravityY: Boolean;
  15745. begin
  15746.   Result := FBlitRec.FGravityY <> 1.0;
  15747. end;
  15748.  
  15749. function TBlit.GetSpeedX: Single;
  15750. begin
  15751.   Result := FBlitRec.FSpeedX;
  15752. end;
  15753.  
  15754. procedure TBlit.SetSpeedX(const Value: Single);
  15755. begin
  15756.   FBlitRec.FSpeedX := Value;
  15757. end;
  15758.  
  15759. function TBlit.StoreSpeedX: Boolean;
  15760. begin
  15761.   Result := FBlitRec.FSpeedX <> 0;
  15762. end;
  15763.  
  15764. function TBlit.GetSpeedY: Single;
  15765. begin
  15766.   Result := FBlitRec.FSpeedY;
  15767. end;
  15768.  
  15769. procedure TBlit.SetSpeedY(const Value: Single);
  15770. begin
  15771.   FBlitRec.FSpeedY := Value;
  15772. end;
  15773.  
  15774. function TBlit.StoreSpeedY: Boolean;
  15775. begin
  15776.   Result := FBlitRec.FSpeedY <> 0;
  15777. end;
  15778.  
  15779. function TBlit.GetCenterX: Double;
  15780. begin
  15781.   Result := FBlitRec.FCenterX;
  15782. end;
  15783.  
  15784. procedure TBlit.SetCenterX(const Value: Double);
  15785. begin
  15786.   FBlitRec.FCenterX := Value;
  15787. end;
  15788.  
  15789. function TBlit.StoreCenterX: Boolean;
  15790. begin
  15791.   Result := FBlitRec.FCenterX <> 0.5;
  15792. end;
  15793.  
  15794. function TBlit.GetAngle: Single;
  15795. begin
  15796.   Result := FBlitRec.FAngle;
  15797. end;
  15798.  
  15799. procedure TBlit.SetAngle(const Value: Single);
  15800. begin
  15801.   FBlitRec.FAngle := Value;
  15802. end;
  15803.  
  15804. function TBlit.StoreAngle: Boolean;
  15805. begin
  15806.   Result := FBlitRec.FAngle <> 0;
  15807. end;
  15808.  
  15809. function TBlit.GetBlurImage: Boolean;
  15810. begin
  15811.   Result := FBlitRec.FBlurImage;
  15812. end;
  15813.  
  15814. procedure TBlit.SetBlurImage(const Value: Boolean);
  15815. begin
  15816.   FBlitRec.FBlurImage := Value;
  15817. end;
  15818.  
  15819. function TBlit.GetCenterY: Double;
  15820. begin
  15821.   Result := FBlitRec.FCenterY;
  15822. end;
  15823.  
  15824. procedure TBlit.SetCenterY(const Value: Double);
  15825. begin
  15826.   FBlitRec.FCenterY := Value;
  15827. end;
  15828.  
  15829. function TBlit.StoreCenterY: Boolean;
  15830. begin
  15831.   Result := FBlitRec.FCenterY <> 0.5;
  15832. end;
  15833.  
  15834. function TBlit.GetBlendMode: TRenderType;
  15835. begin
  15836.   Result := FBlitRec.FBlendMode;
  15837. end;
  15838.  
  15839. procedure TBlit.SetBlendMode(const Value: TRenderType);
  15840. begin
  15841.   FBlitRec.FBlendMode := Value;
  15842. end;
  15843.  
  15844. function TBlit.GetAnimSpeed: Double;
  15845. begin
  15846.   Result := FBlitRec.FAnimSpeed;
  15847. end;
  15848.  
  15849. procedure TBlit.SetAnimSpeed(const Value: Double);
  15850. begin
  15851.   FBlitRec.FAnimSpeed := Value;
  15852. end;
  15853.  
  15854. function TBlit.StoreAnimSpeed: Boolean;
  15855. begin
  15856.   Result := FBlitRec.FAnimSpeed <> 0;
  15857. end;
  15858.  
  15859. function TBlit.GetZ: Integer;
  15860. begin
  15861.   Result := FBlitRec.FZ;
  15862. end;
  15863.  
  15864. procedure TBlit.SetZ(const Value: Integer);
  15865. begin
  15866.   FBlitRec.FZ := Value;
  15867. end;
  15868.  
  15869. function TBlit.GetMirror: Boolean;
  15870. begin
  15871.   Result := FBlitRec.FMirror;
  15872. end;
  15873.  
  15874. procedure TBlit.SetMirror(const Value: Boolean);
  15875. begin
  15876.   FBlitRec.FMirror := Value;
  15877. end;
  15878.  
  15879. function TBlit.GetX: Double;
  15880. begin
  15881.   Result := FBlitRec.FX;
  15882. end;
  15883.  
  15884. procedure TBlit.SetX(const Value: Double);
  15885. begin
  15886.   FBlitRec.FX := Value;
  15887. end;
  15888.  
  15889. function TBlit.GetVisible: Boolean;
  15890. begin
  15891.   Result := FBlitRec.FVisible;
  15892. end;
  15893.  
  15894. procedure TBlit.SetVisible(const Value: Boolean);
  15895. begin
  15896.   FBlitRec.FVisible := Value;
  15897. end;
  15898.  
  15899. function TBlit.GetY: Double;
  15900. begin
  15901.   Result := FBlitRec.FY;
  15902. end;
  15903.  
  15904. procedure TBlit.SetY(const Value: Double);
  15905. begin
  15906.   FBlitRec.FY := Value;
  15907. end;
  15908.  
  15909. function TBlit.GetAlpha: Byte;
  15910. begin
  15911.   Result := FBlitRec.FAlpha;
  15912. end;
  15913.  
  15914. procedure TBlit.SetAlpha(const Value: Byte);
  15915. begin
  15916.   FBlitRec.FAlpha := Value;
  15917. end;
  15918.  
  15919. function TBlit.GetEnergy: Single;
  15920. begin
  15921.   Result := FBlitRec.FEnergy;
  15922. end;
  15923.  
  15924. procedure TBlit.SetEnergy(const Value: Single);
  15925. begin
  15926.   FBlitRec.FEnergy := Value;
  15927. end;
  15928.  
  15929. function TBlit.StoreEnergy: Boolean;
  15930. begin
  15931.   Result := FBlitRec.FEnergy <> 0;
  15932. end;
  15933.  
  15934. function TBlit.GetCollisioned: Boolean;
  15935. begin
  15936.   Result := FBlitRec.FCollisioned;
  15937. end;
  15938.  
  15939. procedure TBlit.SetCollisioned(const Value: Boolean);
  15940. begin
  15941.   FBlitRec.FCollisioned := Value;
  15942. end;
  15943.  
  15944. function TBlit.GetAnimLooped: Boolean;
  15945. begin
  15946.   Result := FBlitRec.FAnimLooped;
  15947. end;
  15948.  
  15949. procedure TBlit.SetAnimLooped(const Value: Boolean);
  15950. begin
  15951.   FBlitRec.FAnimLooped := Value;
  15952. end;
  15953.  
  15954. function TBlit.GetHeight: Integer;
  15955. begin
  15956.   Result := FBlitRec.FHeight;
  15957. end;
  15958.  
  15959. procedure TBlit.SetHeight(const Value: Integer);
  15960. begin
  15961.   FBlitRec.FHeight := Value;
  15962. end;
  15963.  
  15964. function TBlit.GetScale: Double;
  15965. begin
  15966.   Result := FBlitRec.FScale;
  15967. end;
  15968.  
  15969. procedure TBlit.SetScale(const Value: Double);
  15970. begin
  15971.   FBlitRec.FScale := Value;
  15972. end;
  15973.  
  15974. function TBlit.StoreScale: Boolean;
  15975. begin
  15976.   Result := FBlitRec.FScale <> 1.0;
  15977. end;
  15978.  
  15979. function TBlit.GetAnimCount: Integer;
  15980. begin
  15981.   Result := FBlitRec.FAnimCount;
  15982. end;
  15983.  
  15984. procedure TBlit.SetAnimCount(const Value: Integer);
  15985. begin
  15986.   FBlitRec.FAnimCount := Value;
  15987. end;
  15988.  
  15989. function TBlit.GetTextureFilter: TD2DTextureFilter;
  15990. begin
  15991.   Result := FBlitRec.FTextureFilter;
  15992. end;
  15993.  
  15994. procedure TBlit.SetTextureFilter(const Value: TD2DTextureFilter);
  15995. begin
  15996.   FBlitRec.FTextureFilter := Value;
  15997. end;
  15998.  
  15999. function TBlit.GetBoundsRect: TRect;
  16000. begin
  16001.   Result := Bounds(Round(WorldX), Round(WorldY), Width, Height);
  16002. end;
  16003.  
  16004. function TBlit.GetClientRect: TRect;
  16005. begin
  16006.   Result := Bounds(0, 0, Width, Height);
  16007. end;
  16008.  
  16009. function TBlit.GetBlitAt(X, Y: Integer): TBlit;
  16010.  
  16011.   procedure BlitAt(X, Y: Double; Blit: TBlit);
  16012.   var
  16013.     i: Integer;
  16014.     X2, Y2: Double;
  16015.   begin
  16016.     if Blit.Visible and PointInRect(Point(Round(X), Round(Y)),
  16017.       Bounds(Round(Blit.X), Round(Blit.Y), Blit.Width, Blit.Width)) then
  16018.     begin
  16019.       if (Result = nil) or (Blit.Z > Result.Z) then
  16020.         Result := Blit; {uniquelly - where will be store last blit}
  16021.     end;
  16022.  
  16023.     X2 := X - Blit.X;
  16024.     Y2 := Y - Blit.Y;
  16025.     for i := 0 to Blit.Engine.FTraces.Count - 1 do
  16026.       BlitAt(X2, Y2, Blit.Engine.FTraces.Items[i].FBlit);
  16027.   end;
  16028.  
  16029. var
  16030.   i: Integer;
  16031.   X2, Y2: Double;
  16032. begin
  16033.   Result := nil;
  16034.  
  16035.   X2 := X - Self.X;
  16036.   Y2 := Y - Self.Y;
  16037.   for i := 0 to Engine.FTraces.Count - 1 do
  16038.     BlitAt(X2, Y2, Engine.FTraces.Items[i].FBlit);
  16039. end;
  16040.  
  16041. procedure TBlit.SetPathLen(Len: Integer);
  16042. var I, L: Integer;
  16043. begin
  16044.   {$IFDEF VER4UP}
  16045.   if Length(FPathArr) <> Len then
  16046.   {$ELSE}
  16047.   if FPathLen <> Len then
  16048.   {$ENDIF}
  16049.   begin
  16050.     L := Len;
  16051.     if Len <= 0 then L := 0;
  16052.     {$IFDEF VER4UP}
  16053.     SetLength(FPathArr, L);
  16054.     for I := Low(FPathArr) to High(FPathArr) do begin
  16055.       FillChar(FPathArr[i], SizeOf(FPathArr), 0);
  16056.       FPathArr[i].StayOn := 25;
  16057.     end;
  16058.     {$ELSE}
  16059.     FPathLen := L;
  16060.     if FPathArr = nil then
  16061.       FPAthArr := AllocMem(FPathLen * SizeOf(TPath))
  16062.     else
  16063.       {alokuj pamet}
  16064.       ReallocMem(FPathArr, FPathLen * SizeOf(TPath));
  16065.     if Assigned(FPathArr) then begin
  16066.       FillChar(FPathArr^, FPathLen * SizeOf(TPath), 0);
  16067.       for I := 0 to FPathLen do
  16068.         FPathArr[i].StayOn := 25;
  16069.     end
  16070.     {$ENDIF}
  16071.   end;
  16072. end;
  16073.  
  16074. function TBlit.IsPathEmpty: Boolean;
  16075. begin
  16076.   {$IFNDEF VER4UP}
  16077.   Result := FPathLen = 0;
  16078.   {$ELSE}
  16079.   Result := Length(FPathArr) = 0;
  16080.   {$ENDIF}
  16081. end;
  16082.  
  16083. function TBlit.GetPathCount: Integer;
  16084. begin
  16085.   {$IFNDEF VER4UP}
  16086.   Result := FPathLen;
  16087.   {$ELSE}
  16088.   Result := Length(FPathArr);
  16089.   {$ENDIF}
  16090. end;
  16091.  
  16092. function TBlit.GetPath(index: Integer): TPath;
  16093. begin
  16094.   {$IFDEF VER4UP}
  16095.   if (index >= Low(FPathArr)) and (index <= High(FPathArr)) then
  16096.   {$ELSE}
  16097.   if (index >= 0) and (index < FPathLen) then
  16098.   {$ENDIF}
  16099.     Result := FPathArr[index]
  16100.   else
  16101.     raise Exception.Create('Bad path index!');
  16102. end;
  16103.  
  16104. procedure TBlit.SetPath(index: Integer; const Value: TPath);
  16105. begin
  16106.   {$IFDEF VER4UP}
  16107.   if (index >= Low(FPathArr)) and (index <= High(FPathArr)) then
  16108.   {$ELSE}
  16109.   if (index >= 0) and (index < FPathLen) then
  16110.   {$ENDIF}
  16111.     FPathArr[index] := Value
  16112.   else
  16113.     raise Exception.Create('Bad path index!');
  16114. end;
  16115.  
  16116. procedure TBlit.ReadPaths(Stream: TStream);
  16117. var
  16118.   PathLen: Integer;
  16119. begin
  16120.   {nacti delku}
  16121.   Stream.ReadBuffer(PathLen, SizeOf(PathLen));
  16122.   SetPathLen(PathLen);
  16123.   Stream.ReadBuffer(FPathArr[0], PathLen * SizeOf(TPath));
  16124. end;
  16125.  
  16126. procedure TBlit.WritePaths(Stream: TStream);
  16127. var
  16128.   PathLen: Integer;
  16129. begin
  16130.   PathLen := GetPathCount;
  16131.   Stream.WriteBuffer(PathLen, SizeOf(PathLen));
  16132.   Stream.WriteBuffer(FPathArr[0], PathLen * SizeOf(TPath));
  16133. end;
  16134.  
  16135. procedure TBlit.DefineProperties(Filer: TFiler);
  16136. begin
  16137.   inherited DefineProperties(Filer);
  16138.   Filer.DefineBinaryProperty('Paths', ReadPaths, WritePaths, not IsPathEmpty);
  16139. end;
  16140.  
  16141. procedure TBlit.Assign(Source: TPersistent);
  16142. var I: Integer;
  16143. begin
  16144.   if Source is TBlit then
  16145.   begin
  16146.     {$IFDEF VER4UP}
  16147.     I := Length(TBlit(Source).FPathArr);
  16148.     {$ELSE}
  16149.     I := FPathLen;
  16150.     {$ENDIF}
  16151.     SetPathLen(I);
  16152.     if I > 0 then
  16153.       Move(TBlit(Source).FPathArr[0], FPathArr[0], I * SizeOf(TPath));
  16154.     FBlitRec := TBlit(Source).FBlitRec;
  16155.     FillChar(FBlurImageArr, SizeOf(FBlurImageArr), 0);
  16156.     FActive := TBlit(Source).FActive;
  16157.     FMovingRepeatly := TBlit(Source).FMovingRepeatly;
  16158.     FImage := nil;
  16159.     FOnMove := TBlit(Source).FOnMove;
  16160.     FOnDraw := TBlit(Source).FOnDraw;
  16161.     FOnCollision := TBlit(Source).FOnCollision;
  16162.     FOnGetImage := TBlit(Source).FOnGetImage;
  16163.     FEngine := TBlit(Source).FEngine;
  16164.   end
  16165.   else
  16166.     inherited Assign(Source);
  16167. end;
  16168.  
  16169. function TBlit.GetMovingRepeatly: Boolean;
  16170. begin
  16171.   Result := FMovingRepeatly;
  16172. end;
  16173.  
  16174. procedure TBlit.SetMovingRepeatly(const Value: Boolean);
  16175. begin
  16176.   FMovingRepeatly := Value;
  16177. end;
  16178.  
  16179. function TBlit.GetBustrofedon: Boolean;
  16180. begin
  16181.   Result := FBustrofedon;
  16182. end;
  16183.  
  16184. procedure TBlit.SetBustrofedon(const Value: Boolean);
  16185. begin
  16186.   FBustrofedon := Value;
  16187. end;
  16188.  
  16189. {  utility draw  }
  16190.  
  16191. procedure DXDraw_Draw(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
  16192.   Rect: TRect; Pattern: Integer; TextureFilter: TD2DTextureFilter;
  16193.   MirrorFlip: TRenderMirrorFlipSet;
  16194.   BlendMode: TRenderType; Angle: Single; Alpha: Byte;
  16195.   CenterX: Double; CenterY: Double;
  16196.   Scale: Single); {$IFDEF VER9UP}inline;{$ENDIF}
  16197. var
  16198. //  r: TRect;
  16199.   width, height: Integer;
  16200. begin
  16201.   if not Assigned(DXDraw.Surface) then Exit;
  16202.   if not Assigned(Image) then Exit;
  16203.   if Scale <> 1.0 then begin
  16204.     width := Round(Scale * Image.Width);
  16205.     height := Round(Scale * Image.Height);
  16206.   end
  16207.   else begin
  16208.     width := Image.Width;
  16209.     height := Image.Height;
  16210.   end;
  16211.   //r := Bounds(X, Y, width, height);
  16212.   DXDraw.TextureFilter(TextureFilter);
  16213.   DXDraw.MirrorFlip(MirrorFlip);
  16214.   case BlendMode of
  16215.     rtDraw: begin
  16216.         if Angle = 0 then
  16217.           Image.StretchDraw(DXDraw.Surface, Rect, Pattern)
  16218.         else
  16219.           Image.DrawRotate(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16220.             (Rect.Top + Rect.Bottom) div 2,
  16221.             Width, Height, Pattern, CenterX, CenterY, Angle);
  16222.       end;
  16223.     rtBlend: begin
  16224.         if Angle = 0 then
  16225.           Image.DrawAlpha(DXDraw.Surface, Rect, Pattern, Alpha)
  16226.         else
  16227.           Image.DrawRotateAlpha(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16228.             (Rect.Top + Rect.Bottom) div 2,
  16229.             Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16230.       end;
  16231.     rtAdd: begin
  16232.         if Angle = 0 then
  16233.           Image.DrawAdd(DXDraw.Surface, Rect, Pattern, Alpha)
  16234.         else
  16235.           Image.DrawRotateAdd(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16236.             (Rect.Top + Rect.Bottom) div 2,
  16237.             Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16238.       end;
  16239.     rtSub: begin
  16240.         if Angle = 0 then
  16241.           Image.DrawSub(DXDraw.Surface, Rect, Pattern, Alpha)
  16242.         else
  16243.           Image.DrawRotateSub(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16244.             (Rect.Top + Rect.Bottom) div 2,
  16245.             Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16246.       end;
  16247.   end; {case}
  16248. end;
  16249.  
  16250. procedure DXDraw_Paint(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
  16251.   Rect: TRect; Pattern: Integer; var BlurImageArr: TBlurImageArr; BlurImage: Boolean;
  16252.   TextureFilter: TD2DTextureFilter;
  16253.   MirrorFlip: TRenderMirrorFlipSet;
  16254.   BlendMode: TRenderType;
  16255.   Angle: Single;
  16256.   Alpha: Byte;
  16257.   CenterX: Double; CenterY: Double); {$IFDEF VER9UP}inline;{$ENDIF}
  16258. var
  16259.   rr: TRect;
  16260.   i, width, height: Integer;
  16261. begin
  16262.   if not Assigned(DXDraw.Surface) then Exit;
  16263.   if not Assigned(Image) then Exit;
  16264.   width := Image.Width;
  16265.   height := Image.Height;
  16266.   //rr := Bounds(X, Y, width, height);
  16267.   //DXDraw.MirrorFlip(MirrorFlip);
  16268.   DXDraw.TextureFilter(TextureFilter);
  16269.   case BlendMode of
  16270.     rtDraw: begin
  16271.         if BlurImage then begin
  16272.           for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16273.               DXDraw.MirrorFlip(MirrorFlip);
  16274.               rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Width, Height);
  16275.               if Angle = 0 then
  16276.                 Image.DrawAlpha(DXDraw.Surface, rr, BlurImageArr[i].ePatternIndex, BlurImageArr[i].eIntensity)
  16277.               else
  16278.                 Image.DrawRotateAlpha(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16279.                   (rr.Top + rr.Bottom) div 2,
  16280.                   Width, Height, BlurImageArr[i].ePatternIndex, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16281.               if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16282.             end;
  16283.         end;
  16284.         DXDraw.MirrorFlip(MirrorFlip);
  16285.         if Angle = 0 then
  16286.           Image.StretchDraw(DXDraw.Surface, Rect, Pattern)
  16287.         else
  16288.           Image.DrawRotate(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16289.             (Rect.Top + Rect.Bottom) div 2,
  16290.             Width, Height, Pattern, CenterX, CenterY, Angle);
  16291.       end;
  16292.     rtBlend: begin
  16293.         if BlurImage then begin
  16294.           for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16295.               DXDraw.MirrorFlip(MirrorFlip);
  16296.               rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Width, Height);
  16297.               if Angle = 0 then
  16298.                 Image.DrawAlpha(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
  16299.               else
  16300.                 Image.DrawRotateAlpha(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16301.                   (rr.Top + rr.Bottom) div 2,
  16302.                   Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16303.               if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16304.             end;
  16305.         end;
  16306.         DXDraw.MirrorFlip(MirrorFlip);
  16307.         if Angle = 0 then
  16308.           Image.DrawAlpha(DXDraw.Surface, Rect, Pattern, Alpha)
  16309.         else
  16310.           Image.DrawRotateAlpha(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16311.             (Rect.Top + Rect.Bottom) div 2,
  16312.             Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16313.       end;
  16314.     rtAdd: begin
  16315.         if BlurImage then begin
  16316.           for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16317.               DXDraw.MirrorFlip(MirrorFlip);
  16318.               rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Width, Height);
  16319.               if Angle = 0 then
  16320.                 Image.DrawAdd(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
  16321.               else
  16322.                 Image.DrawRotateAdd(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16323.                   (rr.Top + rr.Bottom) div 2,
  16324.                   Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16325.               if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16326.             end;
  16327.         end;
  16328.         DXDraw.MirrorFlip(MirrorFlip);
  16329.         if Angle = 0 then
  16330.           Image.DrawAdd(DXDraw.Surface, Rect, Pattern, Alpha)
  16331.         else
  16332.           Image.DrawRotateAdd(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16333.             (Rect.Top + Rect.Bottom) div 2,
  16334.             Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16335.       end;
  16336.     rtSub: begin
  16337.         if BlurImage then begin
  16338.           for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16339.               DXDraw.MirrorFlip(MirrorFlip);
  16340.               rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Width, Height);
  16341.               if Angle = 0 then
  16342.                 Image.DrawSub(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
  16343.               else
  16344.                 Image.DrawRotateSub(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16345.                   (rr.Top + rr.Bottom) div 2,
  16346.                   Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16347.               if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16348.             end;
  16349.         end;
  16350.         DXDraw.MirrorFlip(MirrorFlip);
  16351.         if Angle = 0 then
  16352.           Image.DrawSub(DXDraw.Surface, Rect, Pattern, Alpha)
  16353.         else
  16354.           Image.DrawRotateSub(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16355.             (Rect.Top + Rect.Bottom) div 2,
  16356.             Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16357.       end;
  16358.   end; {case}
  16359. end;
  16360.  
  16361. procedure DXDraw_Render(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
  16362.   Rect: TRect; Pattern: Integer; var BlurImageArr: TBlurImageArr; BlurImage: Boolean;
  16363.   TextureFilter: TD2DTextureFilter; MirrorFlip: TRenderMirrorFlipSet;
  16364.   BlendMode: TRenderType;
  16365.   Angle: Single;
  16366.   Alpha: Byte;
  16367.   CenterX: Double; CenterY: Double;
  16368.   Scale: Single;
  16369.   WaveType: TWaveType;
  16370.   Amplitude: Integer; AmpLength: Integer; Phase: Integer); {$IFDEF VER9UP}inline;{$ENDIF}
  16371. var
  16372.   rr: TRect;
  16373.   i, width, height: Integer;
  16374. begin
  16375.   if not Assigned(DXDraw.Surface) then Exit;
  16376.   if not Assigned(Image) then Exit;
  16377.   if Scale <> 1.0 then begin
  16378.     width := Round(Scale * Image.Width);
  16379.     height := Round(Scale * Image.Height);
  16380.   end
  16381.   else begin
  16382.     width := Image.Width;
  16383.     height := Image.Height;
  16384.   end;
  16385.   //r := Bounds(X, Y, width, height);
  16386.   DXDraw.TextureFilter(TextureFilter);
  16387.   DXDraw.MirrorFlip(MirrorFlip);
  16388.   case BlendMode of
  16389.     rtDraw:
  16390.       begin
  16391.         case WaveType of
  16392.           wtWaveNone:
  16393.             begin
  16394.               if BlurImage then begin
  16395.                 for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16396.                     DXDraw.MirrorFlip(MirrorFlip);
  16397.                     rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Round(Scale * Width), Round(Scale * Height));
  16398.                     if Angle = 0 then
  16399.                       Image.DrawAlpha(DXDraw.Surface, rr, BlurImageArr[i].ePatternIndex, BlurImageArr[i].eIntensity)
  16400.                     else
  16401.                       Image.DrawRotateAlpha(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16402.                         (rr.Top + rr.Bottom) div 2,
  16403.                         Width, Height, BlurImageArr[i].ePatternIndex, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16404.                     if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16405.                   end;
  16406.               end;
  16407.               DXDraw.MirrorFlip(MirrorFlip);
  16408.               if Angle = 0 then
  16409.                 Image.StretchDraw(DXDraw.Surface, Rect, Pattern)
  16410.               else
  16411.                 Image.DrawRotate(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16412.                   (Rect.Top + Rect.Bottom) div 2,
  16413.                   Width, Height, Pattern, CenterX, CenterY, Angle);
  16414.             end;
  16415.           wtWaveX: Image.DrawWaveX(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase);
  16416.           wtWaveY: Image.DrawWaveY(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase);
  16417.         end;
  16418.       end;
  16419.     rtBlend: begin
  16420.         case WaveType of
  16421.           wtWaveNone: begin
  16422.               if BlurImage then begin
  16423.                 for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16424.                     DXDraw.MirrorFlip(MirrorFlip);
  16425.                     rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Round(Scale * Width), Round(Scale * Height));
  16426.                     if Angle = 0 then
  16427.                       Image.DrawAlpha(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
  16428.                     else
  16429.                       Image.DrawRotateAlpha(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16430.                         (rr.Top + rr.Bottom) div 2,
  16431.                         Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16432.                     if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16433.                   end;
  16434.               end;
  16435.               DXDraw.MirrorFlip(MirrorFlip);
  16436.               if Angle = 0 then
  16437.                 Image.DrawAlpha(DXDraw.Surface, Rect, Pattern, Alpha)
  16438.               else
  16439.                 Image.DrawRotateAlpha(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16440.                   (Rect.Top + Rect.Bottom) div 2,
  16441.                   Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16442.             end;
  16443.           wtWaveX: Image.DrawWaveXAlpha(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
  16444.           wtWaveY: Image.DrawWaveYAlpha(DXDraw.Surface, Round(Rect.Top), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
  16445.         end;
  16446.       end;
  16447.     rtAdd: begin
  16448.         case WaveType of
  16449.           wtWaveNone: begin
  16450.               if BlurImage then begin
  16451.                 for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16452.                     DXDraw.MirrorFlip(MirrorFlip);
  16453.                     rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Round(Scale * Width), Round(Scale * Height));
  16454.                     if Angle = 0 then
  16455.                       Image.DrawAdd(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
  16456.                     else
  16457.                       Image.DrawRotateAdd(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16458.                         (rr.Top + rr.Bottom) div 2,
  16459.                         Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16460.                     if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16461.                   end;
  16462.               end;
  16463.               DXDraw.MirrorFlip(MirrorFlip);
  16464.               if Angle = 0 then
  16465.                 Image.DrawAdd(DXDraw.Surface, Rect, Pattern, Alpha)
  16466.               else
  16467.                 Image.DrawRotateAdd(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16468.                   (Rect.Top + Rect.Bottom) div 2,
  16469.                   Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16470.             end;
  16471.           wtWaveX: Image.DrawWaveXAdd(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
  16472.           wtWaveY: Image.DrawWaveYAdd(DXDraw.Surface, Round(Rect.Top), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
  16473.         end;
  16474.       end;
  16475.     rtSub: begin
  16476.         case WaveType of
  16477.           wtWaveNone: begin
  16478.               if BlurImage then begin
  16479.                 for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
  16480.                     DXDraw.MirrorFlip(MirrorFlip);
  16481.                     rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Round(Scale * Width), Round(Scale * Height));
  16482.                     if Angle = 0 then
  16483.                       Image.DrawSub(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
  16484.                     else
  16485.                       Image.DrawRotateSub(DXDraw.Surface, (rr.Left + rr.Right) div 2,
  16486.                         (rr.Top + rr.Bottom) div 2,
  16487.                         Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
  16488.                     if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
  16489.                   end;
  16490.               end;
  16491.               DXDraw.MirrorFlip(MirrorFlip);
  16492.               if Angle = 0 then
  16493.                 Image.DrawSub(DXDraw.Surface, Rect, Pattern, Alpha)
  16494.               else
  16495.                 Image.DrawRotateSub(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
  16496.                   (Rect.Top + Rect.Bottom) div 2,
  16497.                   Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
  16498.             end;
  16499.           wtWaveX: Image.DrawWaveXSub(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
  16500.           wtWaveY: Image.DrawWaveYSub(DXDraw.Surface, Round(Rect.Top), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
  16501.         end;
  16502.       end;
  16503.   end; {case}
  16504. end;
  16505.  
  16506. initialization
  16507.   _DXTextureImageLoadFuncList := TList.Create;
  16508.   TDXTextureImage.RegisterLoadFunc(DXTextureImage_LoadDXTextureImageFunc); //delete Mr.Kawasaki
  16509.   TDXTextureImage.RegisterLoadFunc(DXTextureImage_LoadBitmapFunc);
  16510. finalization
  16511.   TDXTextureImage.UnRegisterLoadFunc(DXTextureImage_LoadDXTextureImageFunc); //delete Mr.Kawasaki
  16512.   TDXTextureImage.UnRegisterLoadFunc(DXTextureImage_LoadBitmapFunc);
  16513.   _DXTextureImageLoadFuncList.Free;
  16514.   { driver free }
  16515.   DirectDrawDrivers.Free;
  16516.   {$IFDEF _DMO_}DirectDrawDriversEx.Free;{$ENDIF}
  16517. end.