Subversion Repositories spacemission

Rev

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

Rev Author Line No. Line
4 daniel-mar 1
(*******************************************************************************
2
                       EXTEND UNIT DXDRAWS FROM DELPHIX PACK
1 daniel-mar 3
 
4 daniel-mar 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
 
1 daniel-mar 95
interface
96
 
97
{$INCLUDE DelphiXcfg.inc}
98
 
99
uses
100
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
4 daniel-mar 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}
1 daniel-mar 123
 
4 daniel-mar 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
 
1 daniel-mar 140
type
141
 
4 daniel-mar 142
  {  TRenderType  }
143
 
144
  TRenderType = (rtDraw, rtBlend, rtAdd, rtSub);
145
 
146
  {  TRenderMirrorFlip  }
147
 
148
  TRenderMirrorFlip = (rmfMirror, rmfFlip);
149
  TRenderMirrorFlipSet = set of TRenderMirrorFlip;
150
 
1 daniel-mar 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
4 daniel-mar 166
    {$IFDEF D3D_deprecated}
1 daniel-mar 167
    FIDDraw: IDirectDraw;
168
    FIDDraw4: IDirectDraw4;
4 daniel-mar 169
    {$ENDIF}
1 daniel-mar 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;
4 daniel-mar 178
    function GetDisplayMode: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
179
    {$IFDEF D3D_deprecated}
1 daniel-mar 180
    function GetIDDraw: IDirectDraw;
181
    function GetIDDraw4: IDirectDraw4;
4 daniel-mar 182
    {$ENDIF}
1 daniel-mar 183
    function GetIDDraw7: IDirectDraw7;
4 daniel-mar 184
    {$IFDEF D3D_deprecated}
1 daniel-mar 185
    function GetIDraw: IDirectDraw;
186
    function GetIDraw4: IDirectDraw4;
4 daniel-mar 187
    {$ENDIF}
1 daniel-mar 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;
4 daniel-mar 198
    {$IFDEF _DMO_}class function DriversEx: TDirectXDriversEx;{$ENDIF}
1 daniel-mar 199
    property ClipperCount: Integer read GetClipperCount;
200
    property Clippers[Index: Integer]: TDirectDrawClipper read GetClipper;
4 daniel-mar 201
    property DisplayMode: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF} read GetDisplayMode;
1 daniel-mar 202
    property DriverCaps: TDDCaps read FDriverCaps;
203
    property HELCaps: TDDCaps read FHELCaps;
4 daniel-mar 204
    {$IFDEF D3D_deprecated}
1 daniel-mar 205
    property IDDraw: IDirectDraw read GetIDDraw;
206
    property IDDraw4: IDirectDraw4 read GetIDDraw4;
4 daniel-mar 207
    {$ENDIF}
1 daniel-mar 208
    property IDDraw7: IDirectDraw7 read GetIDDraw7;
4 daniel-mar 209
    {$IFDEF D3D_deprecated}
1 daniel-mar 210
    property IDraw: IDirectDraw read GetIDraw;
211
    property IDraw4: IDirectDraw4 read GetIDraw4;
4 daniel-mar 212
    {$ENDIF}
1 daniel-mar 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;
4 daniel-mar 279
 
1 daniel-mar 280
  {  TDirectDrawSurface  }
281
 
282
  TDirectDrawSurface = class(TDirectX)
283
  private
284
    FCanvas: TDirectDrawSurfaceCanvas;
285
    FHasClipper: Boolean;
286
    FDDraw: TDirectDraw;
4 daniel-mar 287
    {$IFDEF D3D_deprecated}
1 daniel-mar 288
    FIDDSurface: IDirectDrawSurface;
289
    FIDDSurface4: IDirectDrawSurface4;
4 daniel-mar 290
    {$ENDIF}
1 daniel-mar 291
    FIDDSurface7: IDirectDrawSurface7;
292
    FSystemMemory: Boolean;
293
    FStretchDrawClipper: IDirectDrawClipper;
4 daniel-mar 294
    FSurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 295
    FGammaControl: IDirectDrawGammaControl;
4 daniel-mar 296
    FLockSurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 297
    FLockCount: Integer;
4 daniel-mar 298
    FIsLocked: Boolean;
299
    FModified: Boolean;
300
    FCaption: TCaption;
301
    DIB_COLMATCH: TDIB;
1 daniel-mar 302
    function GetBitCount: Integer;
303
    function GetCanvas: TDirectDrawSurfaceCanvas;
304
    function GetClientRect: TRect;
305
    function GetHeight: Integer;
4 daniel-mar 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}
1 daniel-mar 312
    function GetISurface: IDirectDrawSurface;
313
    function GetISurface4: IDirectDrawSurface4;
4 daniel-mar 314
    {$ENDIF}
1 daniel-mar 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);
4 daniel-mar 320
    {$IFDEF D3D_deprecated}
1 daniel-mar 321
    procedure SetIDDSurface(Value: IDirectDrawSurface);
322
    procedure SetIDDSurface4(Value: IDirectDrawSurface4);
4 daniel-mar 323
    {$ENDIF}
1 daniel-mar 324
    procedure SetIDDSurface7(Value: IDirectDrawSurface7);
325
    procedure SetPalette(Value: TDirectDrawPalette);
326
    procedure SetPixel(X, Y: Integer; Value: Longint);
327
    procedure SetTransparentColor(Col: Longint);
4 daniel-mar 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}
1 daniel-mar 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;
4 daniel-mar 350
      const DF: TDDBltFX; Source: TDirectDrawSurface): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
1 daniel-mar 351
    function BltFast(X, Y: Integer; const SrcRect: TRect;
4 daniel-mar 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;
1 daniel-mar 368
    procedure StretchDraw(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
4 daniel-mar 369
      Transparent: Boolean = True); overload;
1 daniel-mar 370
    procedure StretchDraw(const DestRect: TRect; Source: TDirectDrawSurface;
4 daniel-mar 371
      Transparent: Boolean = True); overload;
372
  {$ELSE}
1 daniel-mar 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);
4 daniel-mar 377
  {$ENDIF}
1 daniel-mar 378
    procedure DrawAdd(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
4 daniel-mar 379
      Transparent: Boolean; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
1 daniel-mar 380
    procedure DrawAlpha(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
381
      Transparent: Boolean; Alpha: Integer);
382
    procedure DrawSub(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
4 daniel-mar 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}
1 daniel-mar 393
    procedure DrawRotate(X, Y, Width, Height: Integer; const SrcRect: TRect;
4 daniel-mar 394
      Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: single);
1 daniel-mar 395
    procedure DrawRotateAdd(X, Y, Width, Height: Integer; const SrcRect: TRect;
4 daniel-mar 396
      Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: single;
397
      Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
1 daniel-mar 398
    procedure DrawRotateAlpha(X, Y, Width, Height: Integer; const SrcRect: TRect;
4 daniel-mar 399
      Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: single;
1 daniel-mar 400
      Alpha: Integer);
401
    procedure DrawRotateSub(X, Y, Width, Height: Integer; const SrcRect: TRect;
4 daniel-mar 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}
1 daniel-mar 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;
4 daniel-mar 425
      Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
1 daniel-mar 426
    procedure DrawWaveXAlpha(X, Y, Width, Height: Integer; const SrcRect: TRect;
427
      Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
4 daniel-mar 428
      Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
1 daniel-mar 429
    procedure DrawWaveXSub(X, Y, Width, Height: Integer; const SrcRect: TRect;
430
      Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
4 daniel-mar 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}
1 daniel-mar 461
    procedure Fill(DevColor: Longint);
462
    procedure FillRect(const Rect: TRect; DevColor: Longint);
4 daniel-mar 463
    procedure FillRectAdd(const DestRect: TRect; Color: TColor; Alpha: Byte{$IFDEF VER4UP} = 128{$ENDIF});
1 daniel-mar 464
    procedure FillRectAlpha(const DestRect: TRect; Color: TColor; Alpha: Integer);
4 daniel-mar 465
    procedure FillRectSub(const DestRect: TRect; Color: TColor; Alpha: Byte{$IFDEF VER4UP} = 128{$ENDIF});
466
    {Load}
1 daniel-mar 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);
4 daniel-mar 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;
1 daniel-mar 479
    function Lock(const Rect: TRect; var SurfaceDesc: TDDSurfaceDesc): Boolean;
4 daniel-mar 480
    {$ENDIF}
1 daniel-mar 481
    procedure UnLock;
482
    function Restore: Boolean;
4 daniel-mar 483
    property IsLocked: Boolean read FIsLocked;
1 daniel-mar 484
    procedure SetSize(AWidth, AHeight: Integer);
4 daniel-mar 485
    property Modified: Boolean read FModified write FModified;
1 daniel-mar 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;
4 daniel-mar 494
    {$IFDEF D3D_deprecated}
1 daniel-mar 495
    property IDDSurface: IDirectDrawSurface read GetIDDSurface write SetIDDSurface;
496
    property IDDSurface4: IDirectDrawSurface4 read GetIDDSurface4 write SetIDDSurface4;
4 daniel-mar 497
    {$ENDIF}
1 daniel-mar 498
    property IDDSurface7: IDirectDrawSurface7 read GetIDDSurface7 write SetIDDSurface7;
4 daniel-mar 499
    {$IFDEF D3D_deprecated}
1 daniel-mar 500
    property ISurface: IDirectDrawSurface read GetISurface;
501
    property ISurface4: IDirectDrawSurface4 read GetISurface4;
4 daniel-mar 502
    {$ENDIF}
1 daniel-mar 503
    property ISurface7: IDirectDrawSurface7 read GetISurface7;
504
    property Palette: TDirectDrawPalette write SetPalette;
505
    property Pixels[X, Y: Integer]: Longint read GetPixel write SetPixel;
4 daniel-mar 506
    property Pixel[X, Y: Integer]: LongInt read Peek write Poke;
507
    property SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF} read FSurfaceDesc;
1 daniel-mar 508
    property SystemMemory: Boolean read FSystemMemory write FSystemMemory;
509
    property TransparentColor: Longint write SetTransparentColor;
510
    property Width: Integer read GetWidth;
4 daniel-mar 511
    property Caption: TCaption read FCaption write FCaption;
1 daniel-mar 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);
4 daniel-mar 548
    function SetSize(AWidth, AHeight, ABitCount{$IFNDEF D3D_deprecated}, ARefreshRate, AFlags{$ENDIF}: Integer): Boolean;
1 daniel-mar 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
4 daniel-mar 559
    property BitCount: Integer read FBitCount write SetBitCount default 16;
1 daniel-mar 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
 
4 daniel-mar 574
  { TD2D HW acceleration}
575
 
576
  TD2D = class;
577
 
578
  {  TTracerCollection  }
579
 
580
  TTraces = class;
581
 
1 daniel-mar 582
  {  TCustomDXDraw  }
583
 
4 daniel-mar 584
  TD2DTextureFilter = (D2D_POINT, D2D_LINEAR, D2D_FLATCUBIC, D2D_GAUSSIANCUBIC, D2D_ANISOTROPIC);
585
 
586
 
1 daniel-mar 587
  TDXDrawOption = (doFullScreen, doNoWindowChange, doAllowReboot, doWaitVBlank,
588
    doAllowPalette256, doSystemMemory, doStretch, doCenter, doFlip,
4 daniel-mar 589
    {$IFDEF D3D_deprecated}do3D, doDirectX7Mode,{$ENDIF} {$IFDEF D3DRM} doRetainedMode,{$ENDIF}
590
    doHardware, doSelectDriver, doZBuffer);
1 daniel-mar 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
 
4 daniel-mar 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
 
1 daniel-mar 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;
4 daniel-mar 637
    {$IFNDEF D3D_deprecated}
638
    FDeviceTypeSet: TD3DDeviceTypeSet;{$ENDIF}
639
    {$IFDEF _DMO_}FAdapters: TDirectXDriversEx;{$ENDIF}
1 daniel-mar 640
    FClipper: TDirectDrawClipper;
641
    FPalette: TDirectDrawPalette;
642
    FPrimary: TDirectDrawSurface;
643
    FSurface: TDirectDrawSurface;
644
    FSurfaceWidth: Integer;
645
    FSurfaceHeight: Integer;
646
    { Direct3D }
4 daniel-mar 647
    {$IFDEF D3D_deprecated}
1 daniel-mar 648
    FD3D: IDirect3D;
649
    FD3D2: IDirect3D2;
650
    FD3D3: IDirect3D3;
4 daniel-mar 651
    {$ENDIF}
1 daniel-mar 652
    FD3D7: IDirect3D7;
4 daniel-mar 653
    {$IFDEF D3D_deprecated}
1 daniel-mar 654
    FD3DDevice: IDirect3DDevice;
655
    FD3DDevice2: IDirect3DDevice2;
656
    FD3DDevice3: IDirect3DDevice3;
4 daniel-mar 657
    {$ENDIF}
1 daniel-mar 658
    FD3DDevice7: IDirect3DDevice7;
4 daniel-mar 659
{$IFDEF D3DRM}
1 daniel-mar 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;
4 daniel-mar 669
{$ENDIF}
1 daniel-mar 670
    FZBuffer: TDirectDrawSurface;
4 daniel-mar 671
    FD2D: TD2D;
672
    FOnUpdateTextures: TOnUpdateTextures;
673
    FTraces: TTraces;
674
    FOnRender: TNotifyEvent;
1 daniel-mar 675
    procedure FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
4 daniel-mar 676
    function GetCanDraw: Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
1 daniel-mar 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;
4 daniel-mar 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;
1 daniel-mar 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;
4 daniel-mar 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;
1 daniel-mar 709
  public
710
    ColorTable: TRGBQuads;
711
    DefColorTable: TRGBQuads;
4 daniel-mar 712
    //
713
    function Fade2Black(colorfrom: Integer): Longint;
714
    function Fade2White(colorfrom: Integer): Longint;
715
    //
1 daniel-mar 716
    constructor Create(AOwner: TComponent); override;
717
    destructor Destroy; override;
718
    class function Drivers: TDirectXDrivers;
4 daniel-mar 719
    {$IFDEF _DMO_}class function DriversEx: TDirectXDriversEx;{$ENDIF}
1 daniel-mar 720
    procedure Finalize;
721
    procedure Flip;
722
    procedure Initialize;
4 daniel-mar 723
    procedure Render(LagCount: Integer{$IFDEF VER4UP} = 0{$ENDIF});
1 daniel-mar 724
    procedure Restore;
725
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
726
    procedure SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
4 daniel-mar 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;
1 daniel-mar 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;
4 daniel-mar 748
{$IFDEF D3DRM}property Camera: IDirect3DRMFrame read FCamera; {$ENDIF}
1 daniel-mar 749
    property CanDraw: Boolean read GetCanDraw;
750
    property CanPaletteAnimation: Boolean read GetCanPaletteAnimation;
751
    property Clipper: TDirectDrawClipper read FClipper;
752
    property Color;
4 daniel-mar 753
    {$IFDEF D3D_deprecated}
1 daniel-mar 754
    property D3D: IDirect3D read FD3D;
755
    property D3D2: IDirect3D2 read FD3D2;
756
    property D3D3: IDirect3D3 read FD3D3;
4 daniel-mar 757
    {$ENDIF}
1 daniel-mar 758
    property D3D7: IDirect3D7 read FD3D7;
4 daniel-mar 759
    {$IFDEF D3D_deprecated}
1 daniel-mar 760
    property D3DDevice: IDirect3DDevice read FD3DDevice;
761
    property D3DDevice2: IDirect3DDevice2 read FD3DDevice2;
762
    property D3DDevice3: IDirect3DDevice3 read FD3DDevice3;
4 daniel-mar 763
    {$ENDIF}
1 daniel-mar 764
    property D3DDevice7: IDirect3DDevice7 read FD3DDevice7;
4 daniel-mar 765
    {$IFNDEF D3D_deprecated}
766
    property D3DDeviceTypeSet: TD3DDeviceTypeSet read FDeviceTypeSet;{$ENDIF}
767
{$IFDEF D3DRM}
1 daniel-mar 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;
4 daniel-mar 774
{$ENDIF}
1 daniel-mar 775
    property DDraw: TDirectDraw read FDDraw;
776
    property Display: TDXDrawDisplay read FDisplay write SetDisplay;
4 daniel-mar 777
    {$IFDEF _DMO_}property Adapter: TDirectXDriversEx read FAdapters write FAdapters;{$ENDIF}
1 daniel-mar 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;
4 daniel-mar 790
{$IFDEF D3DRM}property Scene: IDirect3DRMFrame read FScene; {$ENDIF}
1 daniel-mar 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;
4 daniel-mar 794
{$IFDEF D3DRM}property Viewport: IDirect3DRMViewport read FViewport; {$ENDIF}
1 daniel-mar 795
    property ZBuffer: TDirectDrawSurface read FZBuffer;
4 daniel-mar 796
    property D2D1: TD2D read FD2D; {public object is here}
797
    property Traces: TTraces read FTraces write SetTraces;
1 daniel-mar 798
  end;
799
 
800
  {  TDXDraw  }
801
 
802
  TDXDraw = class(TCustomDXDraw)
803
  published
4 daniel-mar 804
    {$IFDEF _DMO_}property Adapter;{$ENDIF}
1 daniel-mar 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;
4 daniel-mar 818
    property OnUpdateTextures;
819
    property OnRender;
1 daniel-mar 820
 
821
    property Align;
4 daniel-mar 822
{$IFDEF VER4UP}property Anchors; {$ENDIF}
823
{$IFDEF VER4UP}property Constraints; {$ENDIF}
1 daniel-mar 824
    property DragCursor;
825
    property DragMode;
826
    property Enabled;
827
    property ParentShowHint;
828
    property PopupMenu;
829
    property ShowHint;
830
    property TabOrder;
831
    property TabStop;
4 daniel-mar 832
    property Traces;
1 daniel-mar 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;
4 daniel-mar 847
{$IFDEF VER9UP}
848
    property OnMouseWheel;
849
    property OnMouseWheelUp;
850
    property OnMouseWheelDown;
851
{$ENDIF}
852
{$IFDEF VER4UP}property OnResize; {$ENDIF}
1 daniel-mar 853
    property OnStartDrag;
854
  end;
855
 
856
  {  EDX3DError  }
857
 
858
  EDX3DError = class(Exception);
859
 
4 daniel-mar 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
 
1 daniel-mar 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;
4 daniel-mar 1177
{$IFDEF D3DRM}FCamera: IDirect3DRMFrame; {$ENDIF}
1178
    {$IFDEF D3D_deprecated}
1 daniel-mar 1179
    FD3D: IDirect3D;
1180
    FD3D2: IDirect3D2;
1181
    FD3D3: IDirect3D3;
4 daniel-mar 1182
    {$ENDIF}
1 daniel-mar 1183
    FD3D7: IDirect3D7;
4 daniel-mar 1184
    {$IFDEF D3D_deprecated}
1 daniel-mar 1185
    FD3DDevice: IDirect3DDevice;
1186
    FD3DDevice2: IDirect3DDevice2;
1187
    FD3DDevice3: IDirect3DDevice3;
4 daniel-mar 1188
    {$ENDIF}
1 daniel-mar 1189
    FD3DDevice7: IDirect3DDevice7;
4 daniel-mar 1190
{$IFDEF D3DRM}
1 daniel-mar 1191
    FD3DRM: IDirect3DRM;
1192
    FD3DRM2: IDirect3DRM2;
1193
    FD3DRM3: IDirect3DRM3;
1194
    FD3DRMDevice: IDirect3DRMDevice;
1195
    FD3DRMDevice2: IDirect3DRMDevice2;
1196
    FD3DRMDevice3: IDirect3DRMDevice3;
4 daniel-mar 1197
{$ENDIF}
1 daniel-mar 1198
    FDXDraw: TCustomDXDraw;
1199
    FInitFlag: Boolean;
1200
    FInitialized: Boolean;
1201
    FNowOptions: TDX3DOptions;
1202
    FOnFinalize: TNotifyEvent;
1203
    FOnInitialize: TNotifyEvent;
1204
    FOptions: TDX3DOptions;
4 daniel-mar 1205
{$IFDEF D3DRM}FScene: IDirect3DRMFrame; {$ENDIF}
1 daniel-mar 1206
    FSurface: TDirectDrawSurface;
1207
    FSurfaceHeight: Integer;
1208
    FSurfaceWidth: Integer;
4 daniel-mar 1209
{$IFDEF D3DRM}FViewport: IDirect3DRMViewport; {$ENDIF}
1 daniel-mar 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);
4 daniel-mar 1219
    procedure SetOptions(Value: TDX3DOptions); virtual; {TridenT}
1 daniel-mar 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;
4 daniel-mar 1232
{$IFDEF D3DRM}property Camera: IDirect3DRMFrame read FCamera; {$ENDIF}
1 daniel-mar 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;
4 daniel-mar 1238
    {$IFDEF D3D_deprecated}
1 daniel-mar 1239
    property D3DDevice: IDirect3DDevice read FD3DDevice;
1240
    property D3DDevice2: IDirect3DDevice2 read FD3DDevice2;
1241
    property D3DDevice3: IDirect3DDevice3 read FD3DDevice3;
4 daniel-mar 1242
    {$ENDIF}
1 daniel-mar 1243
    property D3DDevice7: IDirect3DDevice7 read FD3DDevice7;
4 daniel-mar 1244
{$IFDEF D3DRM}
1 daniel-mar 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;
4 daniel-mar 1251
{$ENDIF}
1 daniel-mar 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;
4 daniel-mar 1258
{$IFDEF D3DRM}property Scene: IDirect3DRMFrame read FScene; {$ENDIF}
1 daniel-mar 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;
4 daniel-mar 1262
{$IFDEF D3DRM}property Viewport: IDirect3DRMViewport read FViewport; {$ENDIF}
1 daniel-mar 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;
4 daniel-mar 1278
{$ENDIF}
1 daniel-mar 1279
 
1280
  {  EDirect3DTextureError  }
1281
 
1282
  EDirect3DTextureError = class(Exception);
4 daniel-mar 1283
 
1 daniel-mar 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;
4 daniel-mar 1296
    FTexture: {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF};
1 daniel-mar 1297
    FTransparentColor: TColor;
1298
    procedure Clear;
1299
    procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
1300
    function GetHandle: TD3DTextureHandle;
1301
    function GetSurface: TDirectDrawSurface;
4 daniel-mar 1302
    function GetTexture: {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF};
1 daniel-mar 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;
4 daniel-mar 1311
    property Texture: {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF} read GetTexture;
1 daniel-mar 1312
  end;
1313
 
4 daniel-mar 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
 
1 daniel-mar 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);
4 daniel-mar 1460
    procedure LoadSubTexture(Dest: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF}; SrcImage: TDXTextureImage);
1 daniel-mar 1461
    procedure SetColorKey;
1462
    procedure SetDIB(DIB: TDIB);
4 daniel-mar 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;
1 daniel-mar 1470
  protected
1471
    procedure DoRestoreSurface; virtual;
1472
  public
4 daniel-mar 1473
    constructor Create(ADXDraw: TCustomDXDraw; Graphic: TObject; AutoFreeGraphic: Boolean{$IFDEF VER4UP} = False{$ENDIF});
1 daniel-mar 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;
4 daniel-mar 1480
    property Height: Integer read GetHeight;
1481
    property Width: Integer read GetWidth;
1 daniel-mar 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
 
4 daniel-mar 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}
1 daniel-mar 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;
4 daniel-mar 1604
{$ENDIF}
1 daniel-mar 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;
4 daniel-mar 1634
    function GetPatternCount: Integer; {$IFDEF VER9UP}inline;{$ENDIF}
1 daniel-mar 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;
4 daniel-mar 1641
    procedure UpdateTag;
1 daniel-mar 1642
    procedure Assign(Source: TPersistent); override;
1643
    procedure Draw(Dest: TDirectDrawSurface; X, Y: Integer; PatternIndex: Integer);
4 daniel-mar 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);
1 daniel-mar 1657
    procedure StretchDraw(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer);
1658
    procedure DrawAdd(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
4 daniel-mar 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});
1 daniel-mar 1662
    procedure DrawAlpha(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
4 daniel-mar 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});
1 daniel-mar 1666
    procedure DrawSub(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
4 daniel-mar 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}
1 daniel-mar 1671
    procedure DrawRotate(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
4 daniel-mar 1672
      CenterX, CenterY: Double; Angle: single);
1 daniel-mar 1673
    procedure DrawRotateAdd(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
4 daniel-mar 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});
1 daniel-mar 1679
    procedure DrawRotateAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
4 daniel-mar 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});
1 daniel-mar 1685
    procedure DrawRotateSub(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
4 daniel-mar 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}
1 daniel-mar 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;
4 daniel-mar 1695
      amp, Len, ph: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
1 daniel-mar 1696
    procedure DrawWaveXAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
4 daniel-mar 1697
      amp, Len, ph: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
1 daniel-mar 1698
    procedure DrawWaveXSub(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
4 daniel-mar 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});
1 daniel-mar 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;
4 daniel-mar 1749
  public
1 daniel-mar 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);
4 daniel-mar 1756
    procedure InitializeImages(DXDraw: TCustomDXDraw; Id : Integer);
1 daniel-mar 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;
4 daniel-mar 1818
    procedure Initialize(const SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF});
1 daniel-mar 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
 
4 daniel-mar 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
 
1 daniel-mar 2339
implementation
2340
 
4 daniel-mar 2341
uses DXConsts{$IFDEF DXR_deprecated}, DXRender{$ENDIF}, D3DUtils;
2342
 
2343
function DXDirectDrawEnumerate(lpCallback: {$IFDEF UNICODE}TDDEnumCallbackW{$ELSE}TDDEnumCallbackA{$ENDIF};
2344
  lpContext: Pointer): HRESULT;
1 daniel-mar 2345
type
4 daniel-mar 2346
  TDirectDrawEnumerate = function(lpCallback: {$IFDEF UNICODE}TDDEnumCallbackW{$ELSE}TDDEnumCallbackA{$ENDIF};
1 daniel-mar 2347
    lpContext: Pointer): HRESULT; stdcall;
2348
begin
4 daniel-mar 2349
  Result := TDirectDrawEnumerate(DXLoadLibrary('DDraw.dll', {$IFDEF UNICODE}'DirectDrawEnumerateW'{$ELSE}'DirectDrawEnumerateA'{$ENDIF}))
1 daniel-mar 2350
    (lpCallback, lpContext);
2351
end;
2352
 
2353
var
2354
  DirectDrawDrivers: TDirectXDrivers;
4 daniel-mar 2355
  {$IFDEF _DMO_}DirectDrawDriversEx: TDirectXDriversEx;{$ENDIF}
2356
  D2D: TD2D = nil; {for internal use only, }
2357
  RenderError: Boolean = false;
1 daniel-mar 2358
 
2359
function EnumDirectDrawDrivers: TDirectXDrivers;
2360
 
4 daniel-mar 2361
  function DDENUMCALLBACK(lpGuid: PGUID; lpstrDescription: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF};
2362
    lpstrModule: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF}; lpContext: Pointer): BOOL; stdcall;
1 daniel-mar 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
4 daniel-mar 2374
  if DirectDrawDrivers = nil then
1 daniel-mar 2375
  begin
2376
    DirectDrawDrivers := TDirectXDrivers.Create;
4 daniel-mar 2377
    try
1 daniel-mar 2378
      DXDirectDrawEnumerate(@DDENUMCALLBACK, DirectDrawDrivers);
2379
    except
2380
      DirectDrawDrivers.Free;
2381
      raise;
2382
    end;
2383
  end;
2384
 
2385
  Result := DirectDrawDrivers;
2386
end;
2387
 
4 daniel-mar 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
 
1 daniel-mar 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
 
4 daniel-mar 2514
  {$IFDEF D3D_deprecated}
1 daniel-mar 2515
  if DirectX7Mode then
4 daniel-mar 2516
  begin {$ENDIF}
1 daniel-mar 2517
    { DirectX 7 }
4 daniel-mar 2518
    if TDirectDrawCreateEx(DXLoadLibrary('DDraw.dll', 'DirectDrawCreateEx'))(GUID, FIDDraw7, IID_IDirectDraw7, nil) <> DD_OK then
1 daniel-mar 2519
      raise EDirectDrawError.CreateFmt(SCannotInitialized, [SDirectDraw]);
4 daniel-mar 2520
    {$IFDEF D3D_deprecated}
1 daniel-mar 2521
    try
2522
      FIDDraw := FIDDraw7 as IDirectDraw;
2523
      FIDDraw4 := FIDDraw7 as IDirectDraw4;
2524
    except
2525
      raise EDirectDrawError.Create(SSinceDirectX7);
2526
    end;
4 daniel-mar 2527
    {$ENDIF}
2528
  {$IFDEF D3D_deprecated}end else
1 daniel-mar 2529
  begin
4 daniel-mar 2530
    if TDirectDrawCreate(DXLoadLibrary('DDraw.dll', 'DirectDrawCreate'))(GUID, FIDDraw, nil) <> DD_OK then
1 daniel-mar 2531
      raise EDirectDrawError.CreateFmt(SCannotInitialized, [SDirectDraw]);
2532
    try
2533
      FIDDraw4 := FIDDraw as IDirectDraw4;
2534
    except
2535
      raise EDirectDrawError.Create(SSinceDirectX6);
2536
    end;
4 daniel-mar 2537
  end;{$ENDIF}
1 daniel-mar 2538
 
2539
  FDriverCaps.dwSize := SizeOf(FDriverCaps);
2540
  FHELCaps.dwSize := SizeOf(FHELCaps);
4 daniel-mar 2541
  {$IFDEF D3D_deprecated}FIDDraw{$ELSE}FIDDraw7{$ENDIF}.GetCaps(@FDriverCaps, @FHELCaps);
1 daniel-mar 2542
end;
2543
 
2544
destructor TDirectDraw.Destroy;
2545
begin
4 daniel-mar 2546
  while SurfaceCount > 0 do
2547
    Surfaces[SurfaceCount - 1].Free;
1 daniel-mar 2548
 
4 daniel-mar 2549
  while PaletteCount > 0 do
2550
    Palettes[PaletteCount - 1].Free;
1 daniel-mar 2551
 
4 daniel-mar 2552
  while ClipperCount > 0 do
2553
    Clippers[ClipperCount - 1].Free;
1 daniel-mar 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
 
4 daniel-mar 2566
{$IFDEF _DMO_}
2567
class function TDirectDraw.DriversEx: TDirectXDriversEx;
2568
begin
2569
  Result := EnumDirectDrawDriversEx;
2570
end;
2571
{$ENDIF}
2572
 
1 daniel-mar 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
 
4 daniel-mar 2583
function TDirectDraw.GetDisplayMode: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 2584
begin
2585
  Result.dwSize := SizeOf(Result);
4 daniel-mar 2586
  DXResult := {$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.GetDisplayMode(Result);
2587
  if DXResult <> DD_OK then
1 daniel-mar 2588
    FillChar(Result, SizeOf(Result), 0);
2589
end;
4 daniel-mar 2590
{$IFDEF D3D_deprecated}
1 daniel-mar 2591
function TDirectDraw.GetIDDraw: IDirectDraw;
2592
begin
4 daniel-mar 2593
  if Self <> nil then
1 daniel-mar 2594
    Result := FIDDraw
2595
  else
2596
    Result := nil;
2597
end;
2598
 
2599
function TDirectDraw.GetIDDraw4: IDirectDraw4;
2600
begin
4 daniel-mar 2601
  if Self <> nil then
1 daniel-mar 2602
    Result := FIDDraw4
2603
  else
2604
    Result := nil;
2605
end;
4 daniel-mar 2606
{$ENDIF}
1 daniel-mar 2607
function TDirectDraw.GetIDDraw7: IDirectDraw7;
2608
begin
4 daniel-mar 2609
  if Self <> nil then
1 daniel-mar 2610
    Result := FIDDraw7
2611
  else
2612
    Result := nil;
2613
end;
4 daniel-mar 2614
{$IFDEF D3D_deprecated}
1 daniel-mar 2615
function TDirectDraw.GetIDraw: IDirectDraw;
2616
begin
2617
  Result := IDDraw;
4 daniel-mar 2618
  if Result = nil then
1 daniel-mar 2619
    raise EDirectDrawError.CreateFmt(SNotMade, ['IDirectDraw']);
2620
end;
2621
 
2622
function TDirectDraw.GetIDraw4: IDirectDraw4;
2623
begin
2624
  Result := IDDraw4;
4 daniel-mar 2625
  if Result = nil then
1 daniel-mar 2626
    raise EDirectDrawError.CreateFmt(SNotMade, ['IDirectDraw4']);
2627
end;
4 daniel-mar 2628
{$ENDIF}
1 daniel-mar 2629
function TDirectDraw.GetIDraw7: IDirectDraw7;
2630
begin
2631
  Result := IDDraw7;
4 daniel-mar 2632
  if Result = nil then
1 daniel-mar 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
 
4 daniel-mar 2677
  FDDraw.DXResult := FDDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.CreatePalette(Caps, @Entries, TempPalette, nil);
1 daniel-mar 2678
  FDXResult := FDDraw.DXResult;
4 daniel-mar 2679
  Result := FDDraw.DXResult = DD_OK;
1 daniel-mar 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);
4 daniel-mar 2711
    if DIB.Size > 0 then
1 daniel-mar 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
4 daniel-mar 2721
  if IDDPalette <> nil then
1 daniel-mar 2722
  begin
2723
    DXResult := IPalette.GetEntries(0, StartIndex, NumEntries, @Entries);
4 daniel-mar 2724
    Result := DXResult = DD_OK;
1 daniel-mar 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
4 daniel-mar 2736
  if Self <> nil then
1 daniel-mar 2737
    Result := FIDDPalette
2738
  else
2739
    Result := nil;
2740
end;
2741
 
2742
function TDirectDrawPalette.GetIPalette: IDirectDrawPalette;
2743
begin
2744
  Result := IDDPalette;
4 daniel-mar 2745
  if Result = nil then
1 daniel-mar 2746
    raise EDirectDrawPaletteError.CreateFmt(SNotMade, ['IDirectDrawPalette']);
2747
end;
2748
 
2749
function TDirectDrawPalette.SetEntries(StartIndex, NumEntries: Integer;
2750
  const Entries): Boolean;
2751
begin
4 daniel-mar 2752
  if IDDPalette <> nil then
1 daniel-mar 2753
  begin
2754
    DXResult := IPalette.SetEntries(0, StartIndex, NumEntries, @Entries);
4 daniel-mar 2755
    Result := DXResult = DD_OK;
1 daniel-mar 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
4 daniel-mar 2767
  if FIDDPalette = Value then Exit;
1 daniel-mar 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
 
4 daniel-mar 2779
  FDDraw.DXResult := FDDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.CreateClipper(0, FIDDClipper, nil);
2780
  if FDDraw.DXResult <> DD_OK then
1 daniel-mar 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
4 daniel-mar 2792
  if Self <> nil then
1 daniel-mar 2793
    Result := FIDDClipper
2794
  else
2795
    Result := nil;
2796
end;
2797
 
2798
function TDirectDrawClipper.GetIClipper: IDirectDrawClipper;
2799
begin
2800
  Result := IDDClipper;
4 daniel-mar 2801
  if Result = nil then
1 daniel-mar 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);
4 daniel-mar 2815
  for i := Low(Rects) to High(Rects) do
1 daniel-mar 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);
4 daniel-mar 2823
    end;
1 daniel-mar 2824
  end;
2825
 
4 daniel-mar 2826
  GetMem(RgnData, SizeOf(TRgnDataHeader) + SizeOf(TRect) * (High(Rects) - Low(Rects) + 1));
1 daniel-mar 2827
  try
2828
    with RgnData^.rdh do
2829
    begin
2830
      dwSize := SizeOf(TRgnDataHeader);
2831
      iType := RDH_RECTANGLES;
4 daniel-mar 2832
      nCount := High(Rects) - Low(Rects) + 1;
2833
      nRgnSize := nCount * SizeOf(TRect);
1 daniel-mar 2834
      rcBound := BoundsRect;
2835
    end;
4 daniel-mar 2836
    for i := Low(Rects) to High(Rects) do
2837
      PArrayRect(@RgnData^.Buffer)^[i - Low(Rects)] := Rects[i];
1 daniel-mar 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
4 daniel-mar 2851
  if FIDDClipper = Value then Exit;
1 daniel-mar 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
4 daniel-mar 2872
  FSurface.DXResult := FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetDC(FDC);
2873
  if FSurface.DXResult = DD_OK then
1 daniel-mar 2874
    Handle := FDC;
2875
end;
2876
 
2877
procedure TDirectDrawSurfaceCanvas.Release;
2878
begin
4 daniel-mar 2879
  if (FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) and (FDC <> 0) then
1 daniel-mar 2880
  begin
2881
    Handle := 0;
4 daniel-mar 2882
    FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF}.ReleaseDC(FDC);
1 daniel-mar 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);
4 daniel-mar 2894
  DIB_COLMATCH := TDIB.Create;
1 daniel-mar 2895
end;
2896
 
2897
destructor TDirectDrawSurface.Destroy;
2898
begin
4 daniel-mar 2899
  DIB_COLMATCH.Free;
1 daniel-mar 2900
  FCanvas.Free;
4 daniel-mar 2901
  {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil;
1 daniel-mar 2902
  FDDraw.FSurfaces.Remove(Self);
2903
  inherited Destroy;
2904
end;
4 daniel-mar 2905
{$IFDEF D3D_deprecated}
1 daniel-mar 2906
function TDirectDrawSurface.GetIDDSurface: IDirectDrawSurface;
2907
begin
4 daniel-mar 2908
  if Self <> nil then
1 daniel-mar 2909
    Result := FIDDSurface
2910
  else
2911
    Result := nil;
2912
end;
2913
 
2914
function TDirectDrawSurface.GetIDDSurface4: IDirectDrawSurface4;
2915
begin
4 daniel-mar 2916
  if Self <> nil then
1 daniel-mar 2917
    Result := FIDDSurface4
2918
  else
2919
    Result := nil;
2920
end;
4 daniel-mar 2921
{$ENDIF}
1 daniel-mar 2922
function TDirectDrawSurface.GetIDDSurface7: IDirectDrawSurface7;
2923
begin
4 daniel-mar 2924
  if Self <> nil then
1 daniel-mar 2925
    Result := FIDDSurface7
2926
  else
2927
    Result := nil;
2928
end;
4 daniel-mar 2929
{$IFDEF D3D_deprecated}
1 daniel-mar 2930
function TDirectDrawSurface.GetISurface: IDirectDrawSurface;
2931
begin
2932
  Result := IDDSurface;
4 daniel-mar 2933
  if Result = nil then
1 daniel-mar 2934
    raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface']);
2935
end;
2936
 
2937
function TDirectDrawSurface.GetISurface4: IDirectDrawSurface4;
2938
begin
2939
  Result := IDDSurface4;
4 daniel-mar 2940
  if Result = nil then
1 daniel-mar 2941
    raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface4']);
2942
end;
4 daniel-mar 2943
{$ENDIF}
1 daniel-mar 2944
function TDirectDrawSurface.GetISurface7: IDirectDrawSurface7;
2945
begin
2946
  Result := IDDSurface7;
4 daniel-mar 2947
  if Result = nil then
1 daniel-mar 2948
    raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface7']);
2949
end;
4 daniel-mar 2950
{$IFDEF D3D_deprecated}
1 daniel-mar 2951
procedure TDirectDrawSurface.SetIDDSurface(Value: IDirectDrawSurface);
2952
var
2953
  Clipper: IDirectDrawClipper;
2954
begin
4 daniel-mar 2955
  if Value = nil then Exit;
2956
  if Value as IDirectDrawSurface = FIDDSurface then Exit;
1 daniel-mar 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
 
4 daniel-mar 2968
  if Value <> nil then
1 daniel-mar 2969
  begin
2970
    FIDDSurface := Value as IDirectDrawSurface;
2971
    FIDDSurface4 := Value as IDirectDrawSurface4;
4 daniel-mar 2972
    if FDDraw.FIDDraw7 <> nil then FIDDSurface7 := Value as IDirectDrawSurface7;
1 daniel-mar 2973
 
4 daniel-mar 2974
    FHasClipper := (FIDDSurface.GetClipper(Clipper) = DD_OK) and (Clipper <> nil);
1 daniel-mar 2975
 
2976
    FSurfaceDesc.dwSize := SizeOf(FSurfaceDesc);
2977
    FIDDSurface.GetSurfaceDesc(FSurfaceDesc);
2978
 
4 daniel-mar 2979
    if FDDraw.DriverCaps.dwCaps2 and DDCAPS2_PRIMARYGAMMA <> 0 then
1 daniel-mar 2980
      FIDDSurface.QueryInterface(IID_IDirectDrawGammaControl, FGammaControl);
2981
  end;
2982
end;
2983
 
2984
procedure TDirectDrawSurface.SetIDDSurface4(Value: IDirectDrawSurface4);
2985
begin
4 daniel-mar 2986
  if Value = nil then
1 daniel-mar 2987
    SetIDDSurface(nil)
2988
  else
2989
    SetIDDSurface(Value as IDirectDrawSurface);
2990
end;
4 daniel-mar 2991
{$ENDIF}
1 daniel-mar 2992
procedure TDirectDrawSurface.SetIDDSurface7(Value: IDirectDrawSurface7);
4 daniel-mar 2993
{$IFNDEF D3D_deprecated}
2994
var
2995
  Clipper: IDirectDrawClipper;
2996
{$ENDIF}
1 daniel-mar 2997
begin
4 daniel-mar 2998
  {$IFDEF D3D_deprecated}
2999
  if Value = nil then
1 daniel-mar 3000
    SetIDDSurface(nil)
3001
  else
3002
    SetIDDSurface(Value as IDirectDrawSurface);
4 daniel-mar 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}
1 daniel-mar 3027
end;
3028
 
3029
procedure TDirectDrawSurface.Assign(Source: TPersistent);
3030
var
4 daniel-mar 3031
  TempSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface{$ELSE}IDirectDrawSurface7{$ENDIF};
1 daniel-mar 3032
begin
4 daniel-mar 3033
  if Source = nil then
3034
    {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil
1 daniel-mar 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
4 daniel-mar 3041
    if TDirectDrawSurface(Source).{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} = nil then
3042
      {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil
1 daniel-mar 3043
    else begin
4 daniel-mar 3044
      FDDraw.DXResult := FDDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.DuplicateSurface(TDirectDrawSurface(Source).{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF},
1 daniel-mar 3045
        TempSurface);
4 daniel-mar 3046
      if FDDraw.DXResult = 0 then
1 daniel-mar 3047
      begin
4 daniel-mar 3048
        {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := TempSurface;
1 daniel-mar 3049
      end;
3050
    end;
3051
  end else
3052
    inherited Assign(Source);
3053
end;
3054
 
3055
procedure TDirectDrawSurface.AssignTo(Dest: TPersistent);
3056
begin
4 daniel-mar 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
1 daniel-mar 3071
  if Dest is TDIB then
3072
  begin
4 daniel-mar 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
1 daniel-mar 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
4 daniel-mar 3089
  if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
1 daniel-mar 3090
  begin
4 daniel-mar 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;
1 daniel-mar 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
4 daniel-mar 3100
  if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
1 daniel-mar 3101
  begin
4 daniel-mar 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;
1 daniel-mar 3104
  end else
3105
    Result := False;
3106
end;
3107
 
3108
function TDirectDrawSurface.ColorMatch(Col: TColor): Integer;
3109
var
3110
  i, oldc: Integer;
3111
begin
4 daniel-mar 3112
  if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
1 daniel-mar 3113
  begin
3114
    oldc := Pixels[0, 0];
3115
 
3116
      i := ColorToRGB(Col);
4 daniel-mar 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;
1 daniel-mar 3121
 
3122
      with Canvas do
4 daniel-mar 3123
      try
3124
        Draw(0, 0, DIB_COLMATCH);
3125
      finally
1 daniel-mar 3126
        Release;
3127
      end;
4 daniel-mar 3128
 
1 daniel-mar 3129
    Result := Pixels[0, 0];
3130
    Pixels[0, 0] := oldc;
3131
  end else
3132
    Result := 0;
3133
end;
3134
 
4 daniel-mar 3135
{$IFDEF D3D_deprecated}
3136
function TDirectDrawSurface.CreateSurface(SurfaceDesc: TDDSurfaceDesc): Boolean;
1 daniel-mar 3137
var
3138
  TempSurface: IDirectDrawSurface;
3139
begin
3140
  IDDSurface := nil;
3141
 
3142
  FDDraw.DXResult := FDDraw.IDraw.CreateSurface(SurfaceDesc, TempSurface, nil);
3143
  FDXResult := FDDraw.DXResult;
4 daniel-mar 3144
  Result := FDDraw.DXResult = DD_OK;
1 daniel-mar 3145
  if Result then
3146
  begin
3147
    IDDSurface := TempSurface;
3148
    TransparentColor := 0;
3149
  end;
3150
end;
4 daniel-mar 3151
{$ENDIF}
3152
{$IFDEF VER4UP}
3153
function TDirectDrawSurface.CreateSurface(SurfaceDesc: TDDSurfaceDesc2): Boolean;
1 daniel-mar 3154
var
4 daniel-mar 3155
  TempSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF};
1 daniel-mar 3156
begin
4 daniel-mar 3157
  {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil;
3158
  FDDraw.DXResult := FDDraw.{$IFDEF D3D_deprecated}IDraw4{$ELSE}IDraw7{$ENDIF}.CreateSurface(SurfaceDesc, TempSurface, nil);
1 daniel-mar 3159
  FDXResult := FDDraw.DXResult;
4 daniel-mar 3160
  Result := FDDraw.DXResult = DD_OK;
1 daniel-mar 3161
  if Result then
3162
  begin
4 daniel-mar 3163
    {$IFDEF D3D_deprecated}IDDSurface4{$ELSE}IDDSurface7{$ENDIF} := TempSurface;
1 daniel-mar 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 =
4 daniel-mar 3173
  (DDBLTFAST_NOCOLORKEY or DDBLTFAST_WAIT, DDBLTFAST_SRCCOLORKEY or DDBLTFAST_WAIT);
1 daniel-mar 3174
  BltFlags: array[Boolean] of Integer =
4 daniel-mar 3175
  (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
3176
{$IFDEF DXR_deprecated}var
1 daniel-mar 3177
  DestRect: TRect;
3178
  DF: TDDBltFX;
3179
  Clipper: IDirectDrawClipper;
4 daniel-mar 3180
  i: Integer;{$ENDIF}
1 daniel-mar 3181
begin
4 daniel-mar 3182
  if Source <> nil then
1 daniel-mar 3183
  begin
4 daniel-mar 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
1 daniel-mar 3187
    begin
4 daniel-mar 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
1 daniel-mar 3199
      {  Mirror  }
4 daniel-mar 3200
      if ((X + Abs(SrcRect.Left - SrcRect.Right)) <= 0) or
3201
        ((Y + Abs(SrcRect.Top - SrcRect.Bottom)) <= 0) then Exit;
1 daniel-mar 3202
 
3203
      DF.dwsize := SizeOf(DF);
3204
      DF.dwDDFX := 0;
3205
 
4 daniel-mar 3206
      if SrcRect.Left > SrcRect.Right then
1 daniel-mar 3207
      begin
3208
        i := SrcRect.Left; SrcRect.Left := SrcRect.Right; SrcRect.Right := i;
3209
        DF.dwDDFX := DF.dwDDFX or DDBLTFX_MIRRORLEFTRIGHT;
3210
      end;
3211
 
4 daniel-mar 3212
      if SrcRect.Top > SrcRect.Bottom then
1 daniel-mar 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
4 daniel-mar 3219
        DestRect := Bounds(X, Y, Right - Left, Bottom - Top);
1 daniel-mar 3220
 
3221
      if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
3222
      begin
4 daniel-mar 3223
        if DF.dwDDFX and DDBLTFX_MIRRORLEFTRIGHT <> 0 then
1 daniel-mar 3224
        begin
3225
          i := SrcRect.Left;
4 daniel-mar 3226
          SrcRect.Left := Source.Width - SrcRect.Right;
3227
          SrcRect.Right := Source.Width - i;
1 daniel-mar 3228
        end;
3229
 
4 daniel-mar 3230
        if DF.dwDDFX and DDBLTFX_MIRRORUPDOWN <> 0 then
1 daniel-mar 3231
        begin
3232
          i := SrcRect.Top;
4 daniel-mar 3233
          SrcRect.Top := Source.Height - SrcRect.Bottom;
3234
          SrcRect.Bottom := Source.Height - i;
1 daniel-mar 3235
        end;
4 daniel-mar 3236
 
1 daniel-mar 3237
        Blt(DestRect, SrcRect, BltFlags[Transparent] or DDBLT_DDFX, df, Source);
3238
      end;
3239
    end else
3240
    begin
3241
      with SrcRect do
4 daniel-mar 3242
        DestRect := Bounds(X, Y, Right - Left, Bottom - Top);
1 daniel-mar 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);
4 daniel-mar 3254
          if DXResult = DDERR_BLTFASTCANTCLIP then
1 daniel-mar 3255
          begin
4 daniel-mar 3256
            {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetClipper(Clipper);
3257
            if Clipper <> nil then FHasClipper := True;
1 daniel-mar 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;
4 daniel-mar 3266
    {$ENDIF}
1 daniel-mar 3267
  end;
3268
end;
3269
 
4 daniel-mar 3270
{$IFDEF VER4UP}
1 daniel-mar 3271
procedure TDirectDrawSurface.Draw(X, Y: Integer; Source: TDirectDrawSurface; Transparent: Boolean);
3272
const
3273
  BltFastFlags: array[Boolean] of Integer =
4 daniel-mar 3274
  (DDBLTFAST_NOCOLORKEY or DDBLTFAST_WAIT, DDBLTFAST_SRCCOLORKEY or DDBLTFAST_WAIT);
1 daniel-mar 3275
  BltFlags: array[Boolean] of Integer =
4 daniel-mar 3276
  (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
1 daniel-mar 3277
var
3278
  DestRect, SrcRect: TRect;
4 daniel-mar 3279
  {$IFDEF DXR_deprecated}DF: TDDBltFX;
3280
  Clipper: IDirectDrawClipper;{$ENDIF}
1 daniel-mar 3281
begin
4 daniel-mar 3282
  if Source <> nil then
1 daniel-mar 3283
  begin
3284
    SrcRect := Source.ClientRect;
3285
    DestRect := Bounds(X, Y, Source.Width, Source.Height);
4 daniel-mar 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}
1 daniel-mar 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);
4 daniel-mar 3303
        if DXResult = DDERR_BLTFASTCANTCLIP then
1 daniel-mar 3304
        begin
4 daniel-mar 3305
          {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetClipper(Clipper);
3306
          if Clipper <> nil then FHasClipper := True;
1 daniel-mar 3307
 
3308
          DF.dwsize := SizeOf(DF);
3309
          DF.dwDDFX := 0;
3310
          Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
3311
        end;
3312
      end;
3313
    end;
4 daniel-mar 3314
    {$ENDIF}
1 daniel-mar 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 =
4 daniel-mar 3323
  (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
3324
{$IFDEF DXR_deprecated}var
1 daniel-mar 3325
  DF: TDDBltFX;
3326
  OldClipper: IDirectDrawClipper;
4 daniel-mar 3327
  Clipper: TDirectDrawClipper;{$ENDIF}
1 daniel-mar 3328
begin
4 daniel-mar 3329
  if Source <> nil then
1 daniel-mar 3330
  begin
4 daniel-mar 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}
1 daniel-mar 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
4 daniel-mar 3347
      if FStretchDrawClipper = nil then
1 daniel-mar 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
 
4 daniel-mar 3358
      {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetClipper(OldClipper);
3359
      {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetClipper(FStretchDrawClipper);
1 daniel-mar 3360
      DF.dwsize := SizeOf(DF);
3361
      DF.dwDDFX := 0;
3362
      Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
4 daniel-mar 3363
      {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetClipper(nil);
1 daniel-mar 3364
    end;
4 daniel-mar 3365
    {$ENDIF}
1 daniel-mar 3366
  end;
3367
end;
3368
 
4 daniel-mar 3369
{$IFDEF VER4UP}
1 daniel-mar 3370
procedure TDirectDrawSurface.StretchDraw(const DestRect: TRect; Source: TDirectDrawSurface;
3371
  Transparent: Boolean);
3372
const
4 daniel-mar 3373
  BltFlags: array[Boolean] of Integer = (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
1 daniel-mar 3374
var
4 daniel-mar 3375
  {$IFDEF DXR_deprecated}DF: TDDBltFX;
1 daniel-mar 3376
  OldClipper: IDirectDrawClipper;
4 daniel-mar 3377
  Clipper: TDirectDrawClipper;{$ENDIF}
1 daniel-mar 3378
  SrcRect: TRect;
4 daniel-mar 3379
begin
3380
  if Source <> nil then
1 daniel-mar 3381
  begin
4 daniel-mar 3382
    if (DestRect.Bottom <= DestRect.Top) or (DestRect.Right <= DestRect.Left) then Exit;
1 daniel-mar 3383
    SrcRect := Source.ClientRect;
3384
 
4 daniel-mar 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
1 daniel-mar 3391
    begin
3392
      DF.dwsize := SizeOf(DF);
3393
      DF.dwDDFX := 0;
3394
      Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
3395
    end else
3396
    begin
4 daniel-mar 3397
      if FStretchDrawClipper = nil then
1 daniel-mar 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
 
4 daniel-mar 3408
      {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetClipper(FStretchDrawClipper);
1 daniel-mar 3409
      try
3410
        DF.dwsize := SizeOf(DF);
3411
        DF.dwDDFX := 0;
3412
        Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
3413
      finally
4 daniel-mar 3414
        {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetClipper(nil);
1 daniel-mar 3415
      end;
3416
    end;
4 daniel-mar 3417
    {$ENDIF}
1 daniel-mar 3418
  end;
4 daniel-mar 3419
end;
1 daniel-mar 3420
{$ENDIF}
3421
 
3422
procedure TDirectDrawSurface.DrawAdd(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
3423
  Transparent: Boolean; Alpha: Integer);
4 daniel-mar 3424
{$IFDEF DXR_deprecated}var
3425
  Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 3426
  DestSurface, SrcSurface: TDXR_Surface;
4 daniel-mar 3427
  Blend: TDXR_Blend;{$ENDIF}
1 daniel-mar 3428
begin
4 daniel-mar 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;
1 daniel-mar 3433
 
4 daniel-mar 3434
  if Alpha <= 0 then Exit;
1 daniel-mar 3435
 
4 daniel-mar 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
1 daniel-mar 3442
  begin
3443
    try
4 daniel-mar 3444
      if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
1 daniel-mar 3445
      begin
3446
        try
4 daniel-mar 3447
          if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
1 daniel-mar 3448
          begin
3449
            Blend := DXR_BLEND_ONE1;
3450
          end else
4 daniel-mar 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;
1 daniel-mar 3458
 
3459
          dxrCopyRectBlend(DestSurface, SrcSurface,
3460
            DestRect, SrcRect, Blend, Alpha, Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
3461
        finally
4 daniel-mar 3462
          dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
1 daniel-mar 3463
        end;
3464
      end;
3465
    finally
4 daniel-mar 3466
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 3467
    end;
3468
  end;
4 daniel-mar 3469
  {$ENDIF}
1 daniel-mar 3470
end;
3471
 
3472
procedure TDirectDrawSurface.DrawAlpha(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
3473
  Transparent: Boolean; Alpha: Integer);
4 daniel-mar 3474
{$IFDEF DXR_deprecated}var
3475
  Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 3476
  DestSurface, SrcSurface: TDXR_Surface;
4 daniel-mar 3477
  Blend: TDXR_Blend;{$ENDIF}
1 daniel-mar 3478
begin
4 daniel-mar 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;
1 daniel-mar 3483
 
4 daniel-mar 3484
  if Alpha <= 0 then Exit;
1 daniel-mar 3485
 
4 daniel-mar 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
1 daniel-mar 3492
  begin
3493
    try
4 daniel-mar 3494
      if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
1 daniel-mar 3495
      begin
3496
        try
4 daniel-mar 3497
          if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
1 daniel-mar 3498
          begin
3499
            Blend := DXR_BLEND_ONE1;
3500
          end else
4 daniel-mar 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;
1 daniel-mar 3508
 
3509
          dxrCopyRectBlend(DestSurface, SrcSurface,
3510
            DestRect, SrcRect, Blend, Alpha, Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
3511
        finally
4 daniel-mar 3512
          dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
1 daniel-mar 3513
        end;
3514
      end;
3515
    finally
4 daniel-mar 3516
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 3517
    end;
3518
  end;
4 daniel-mar 3519
  {$ENDIF}
1 daniel-mar 3520
end;
3521
 
3522
procedure TDirectDrawSurface.DrawSub(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
3523
  Transparent: Boolean; Alpha: Integer);
4 daniel-mar 3524
{$IFDEF DXR_deprecated}var
3525
  Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 3526
  DestSurface, SrcSurface: TDXR_Surface;
4 daniel-mar 3527
  Blend: TDXR_Blend;{$ENDIF}
1 daniel-mar 3528
begin
4 daniel-mar 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;
1 daniel-mar 3533
 
4 daniel-mar 3534
  if Alpha <= 0 then Exit;
1 daniel-mar 3535
 
4 daniel-mar 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
1 daniel-mar 3542
  begin
3543
    try
4 daniel-mar 3544
      if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
1 daniel-mar 3545
      begin
3546
        try
4 daniel-mar 3547
          if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
1 daniel-mar 3548
          begin
3549
            Blend := DXR_BLEND_ONE1;
3550
          end else
4 daniel-mar 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;
1 daniel-mar 3558
 
3559
          dxrCopyRectBlend(DestSurface, SrcSurface,
3560
            DestRect, SrcRect, Blend, Alpha, Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
3561
        finally
4 daniel-mar 3562
          dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
1 daniel-mar 3563
        end;
3564
      end;
3565
    finally
4 daniel-mar 3566
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 3567
    end;
3568
  end;
4 daniel-mar 3569
  {$ENDIF}
1 daniel-mar 3570
end;
3571
 
4 daniel-mar 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
 
1 daniel-mar 3630
procedure TDirectDrawSurface.DrawRotate(X, Y, Width, Height: Integer; const SrcRect: TRect;
4 daniel-mar 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}
1 daniel-mar 3635
begin
4 daniel-mar 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;
1 daniel-mar 3640
 
4 daniel-mar 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
1 daniel-mar 3647
  begin
3648
    try
4 daniel-mar 3649
      if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
1 daniel-mar 3650
      begin
3651
        try
3652
          dxrDrawRotateBlend(DestSurface, SrcSurface,
4 daniel-mar 3653
            X, Y, Width, Height, SrcRect, CenterX, CenterY, round(Angle), DXR_BLEND_ONE1, 0,
1 daniel-mar 3654
            Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
3655
        finally
4 daniel-mar 3656
          dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
1 daniel-mar 3657
        end;
3658
      end;
3659
    finally
4 daniel-mar 3660
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 3661
    end;
3662
  end;
4 daniel-mar 3663
  {$ENDIF}
1 daniel-mar 3664
end;
3665
 
3666
procedure TDirectDrawSurface.DrawRotateAdd(X, Y, Width, Height: Integer; const SrcRect: TRect;
4 daniel-mar 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};
1 daniel-mar 3670
  DestSurface, SrcSurface: TDXR_Surface;
4 daniel-mar 3671
  Blend: TDXR_Blend; {$ENDIF}
1 daniel-mar 3672
begin
4 daniel-mar 3673
  if Alpha <= 0 then Exit;
1 daniel-mar 3674
 
4 daniel-mar 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;
1 daniel-mar 3679
 
4 daniel-mar 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
1 daniel-mar 3686
  begin
3687
    try
4 daniel-mar 3688
      if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
1 daniel-mar 3689
      begin
3690
        try
4 daniel-mar 3691
          if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
1 daniel-mar 3692
          begin
3693
            Blend := DXR_BLEND_ONE1;
3694
          end else
4 daniel-mar 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;
1 daniel-mar 3702
 
3703
          dxrDrawRotateBlend(DestSurface, SrcSurface,
4 daniel-mar 3704
            X, Y, Width, Height, SrcRect, CenterX, CenterY, round(Angle), Blend, Alpha,
1 daniel-mar 3705
            Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
3706
        finally
4 daniel-mar 3707
          dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
1 daniel-mar 3708
        end;
3709
      end;
3710
    finally
4 daniel-mar 3711
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 3712
    end;
3713
  end;
4 daniel-mar 3714
  {$ENDIF}
1 daniel-mar 3715
end;
3716
 
3717
procedure TDirectDrawSurface.DrawRotateAlpha(X, Y, Width, Height: Integer; const SrcRect: TRect;
4 daniel-mar 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};
1 daniel-mar 3721
  DestSurface, SrcSurface: TDXR_Surface;
4 daniel-mar 3722
  Blend: TDXR_Blend; {$ENDIF}
1 daniel-mar 3723
begin
4 daniel-mar 3724
  if Alpha <= 0 then Exit;
1 daniel-mar 3725
 
4 daniel-mar 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;
1 daniel-mar 3730
 
4 daniel-mar 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
1 daniel-mar 3737
  begin
3738
    try
4 daniel-mar 3739
      if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
1 daniel-mar 3740
      begin
3741
        try
4 daniel-mar 3742
          if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
1 daniel-mar 3743
          begin
3744
            Blend := DXR_BLEND_ONE1;
3745
          end else
4 daniel-mar 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;
1 daniel-mar 3753
 
3754
          dxrDrawRotateBlend(DestSurface, SrcSurface,
4 daniel-mar 3755
            X, Y, Width, Height, SrcRect, CenterX, CenterY, round(Angle), Blend, Alpha,
1 daniel-mar 3756
            Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
3757
        finally
4 daniel-mar 3758
          dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
1 daniel-mar 3759
        end;
3760
      end;
3761
    finally
4 daniel-mar 3762
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 3763
    end;
3764
  end;
4 daniel-mar 3765
  {$ENDIF}
1 daniel-mar 3766
end;
3767
 
3768
procedure TDirectDrawSurface.DrawRotateSub(X, Y, Width, Height: Integer; const SrcRect: TRect;
4 daniel-mar 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};
1 daniel-mar 3772
  DestSurface, SrcSurface: TDXR_Surface;
4 daniel-mar 3773
  Blend: TDXR_Blend;{$ENDIF}
1 daniel-mar 3774
begin
4 daniel-mar 3775
  if Alpha <= 0 then Exit;
1 daniel-mar 3776
 
4 daniel-mar 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;
1 daniel-mar 3781
 
4 daniel-mar 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
1 daniel-mar 3788
  begin
3789
    try
4 daniel-mar 3790
      if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
1 daniel-mar 3791
      begin
3792
        try
4 daniel-mar 3793
          if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
1 daniel-mar 3794
          begin
3795
            Blend := DXR_BLEND_ONE1;
3796
          end else
4 daniel-mar 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;
1 daniel-mar 3804
 
3805
          dxrDrawRotateBlend(DestSurface, SrcSurface,
4 daniel-mar 3806
            X, Y, Width, Height, SrcRect, CenterX, CenterY, round(Angle), Blend, Alpha,
1 daniel-mar 3807
            Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
3808
        finally
4 daniel-mar 3809
          dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
1 daniel-mar 3810
        end;
3811
      end;
3812
    finally
4 daniel-mar 3813
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 3814
    end;
3815
  end;
4 daniel-mar 3816
  {$ENDIF}
1 daniel-mar 3817
end;
3818
 
4 daniel-mar 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
 
1 daniel-mar 3889
procedure TDirectDrawSurface.DrawWaveX(X, Y, Width, Height: Integer; const SrcRect: TRect;
3890
  Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer);
4 daniel-mar 3891
{$IFDEF DXR_deprecated}var
3892
  Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
3893
  DestSurface, SrcSurface: TDXR_Surface;{$ENDIF}
1 daniel-mar 3894
begin
4 daniel-mar 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;
1 daniel-mar 3899
 
4 daniel-mar 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
1 daniel-mar 3906
  begin
3907
    try
4 daniel-mar 3908
      if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
1 daniel-mar 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
4 daniel-mar 3915
          dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
1 daniel-mar 3916
        end;
3917
      end;
3918
    finally
4 daniel-mar 3919
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 3920
    end;
3921
  end;
4 daniel-mar 3922
  {$ENDIF}
1 daniel-mar 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);
4 daniel-mar 3927
{$IFDEF DXR_deprecated}var
3928
  Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 3929
  DestSurface, SrcSurface: TDXR_Surface;
4 daniel-mar 3930
  Blend: TDXR_Blend;{$ENDIF}
1 daniel-mar 3931
begin
4 daniel-mar 3932
  if Alpha <= 0 then Exit;
1 daniel-mar 3933
 
4 daniel-mar 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;
1 daniel-mar 3938
 
4 daniel-mar 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
1 daniel-mar 3945
  begin
3946
    try
4 daniel-mar 3947
      if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
1 daniel-mar 3948
      begin
3949
        try
4 daniel-mar 3950
          if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
1 daniel-mar 3951
          begin
3952
            Blend := DXR_BLEND_ONE1;
3953
          end else
4 daniel-mar 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;
1 daniel-mar 3961
 
3962
          dxrDrawWaveXBlend(DestSurface, SrcSurface,
3963
            X, Y, Width, Height, SrcRect, amp, Len, ph, Blend, Alpha,
3964
            Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
3965
        finally
4 daniel-mar 3966
          dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
1 daniel-mar 3967
        end;
3968
      end;
3969
    finally
4 daniel-mar 3970
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 3971
    end;
3972
  end;
4 daniel-mar 3973
  {$ENDIF}
1 daniel-mar 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);
4 daniel-mar 3978
{$IFDEF DXR_deprecated}
1 daniel-mar 3979
var
4 daniel-mar 3980
  Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 3981
  DestSurface, SrcSurface: TDXR_Surface;
4 daniel-mar 3982
  Blend: TDXR_Blend;{$ENDIF}
1 daniel-mar 3983
begin
4 daniel-mar 3984
  if Alpha <= 0 then Exit;
1 daniel-mar 3985
 
4 daniel-mar 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;
1 daniel-mar 3990
 
4 daniel-mar 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
1 daniel-mar 3997
  begin
3998
    try
4 daniel-mar 3999
      if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
1 daniel-mar 4000
      begin
4001
        try
4 daniel-mar 4002
          if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
1 daniel-mar 4003
          begin
4004
            Blend := DXR_BLEND_ONE1;
4005
          end else
4 daniel-mar 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;
1 daniel-mar 4013
 
4014
          dxrDrawWaveXBlend(DestSurface, SrcSurface,
4015
            X, Y, Width, Height, SrcRect, amp, Len, ph, Blend, Alpha,
4016
            Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
4017
        finally
4 daniel-mar 4018
          dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
1 daniel-mar 4019
        end;
4020
      end;
4021
    finally
4 daniel-mar 4022
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 4023
    end;
4024
  end;
4 daniel-mar 4025
  {$ENDIF}
1 daniel-mar 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);
4 daniel-mar 4030
{$IFDEF DXR_deprecated}
1 daniel-mar 4031
var
4 daniel-mar 4032
  Src_ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 4033
  DestSurface, SrcSurface: TDXR_Surface;
4 daniel-mar 4034
  Blend: TDXR_Blend;{$ENDIF}
1 daniel-mar 4035
begin
4 daniel-mar 4036
  if Alpha <= 0 then Exit;
1 daniel-mar 4037
 
4 daniel-mar 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;
1 daniel-mar 4042
 
4 daniel-mar 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
1 daniel-mar 4049
  begin
4050
    try
4 daniel-mar 4051
      if dxrDDSurfaceLock2(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, Src_ddsd, SrcSurface) then
1 daniel-mar 4052
      begin
4053
        try
4 daniel-mar 4054
          if DestSurface.ColorType = DXR_COLORTYPE_INDEXED then
1 daniel-mar 4055
          begin
4056
            Blend := DXR_BLEND_ONE1;
4057
          end else
4 daniel-mar 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;
1 daniel-mar 4065
 
4066
          dxrDrawWaveXBlend(DestSurface, SrcSurface,
4067
            X, Y, Width, Height, SrcRect, amp, Len, ph, Blend, Alpha,
4068
            Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
4069
        finally
4 daniel-mar 4070
          dxrDDSurfaceUnLock(Source.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, SrcSurface)
1 daniel-mar 4071
        end;
4072
      end;
4073
    finally
4 daniel-mar 4074
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 4075
    end;
4076
  end;
4 daniel-mar 4077
  {$ENDIF}
1 daniel-mar 4078
end;
4079
 
4 daniel-mar 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
 
1 daniel-mar 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
 
4 daniel-mar 4167
procedure TDirectDrawSurface.FillRectAdd(const DestRect: TRect; Color: TColor; Alpha: Byte);
4168
{$IFDEF DXR_deprecated}var
4169
  DestSurface: TDXR_Surface;{$ENDIF}
1 daniel-mar 4170
begin
4 daniel-mar 4171
  if Color and $FFFFFF = 0 then Exit;
4172
  if (Self.Width = 0) or (Self.Height = 0) then Exit;
1 daniel-mar 4173
  if SurfaceDesc.ddpfPixelFormat.dwFlags and (DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
4 daniel-mar 4174
    DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8) <> 0 then Exit;
1 daniel-mar 4175
 
4 daniel-mar 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
1 daniel-mar 4182
  begin
4183
    try
4184
      dxrFillRectColorBlend(DestSurface, DestRect, DXR_BLEND_ONE1_ADD_ONE2, ColorToRGB(Color));
4185
    finally
4 daniel-mar 4186
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 4187
    end;
4188
  end;
4 daniel-mar 4189
  {$ENDIF}
1 daniel-mar 4190
end;
4 daniel-mar 4191
 
1 daniel-mar 4192
procedure TDirectDrawSurface.FillRectAlpha(const DestRect: TRect; Color: TColor;
4193
  Alpha: Integer);
4 daniel-mar 4194
{$IFDEF DXR_deprecated}var
4195
  DestSurface: TDXR_Surface;{$ENDIF}
1 daniel-mar 4196
begin
4 daniel-mar 4197
  if (Self.Width = 0) or (Self.Height = 0) then Exit;
1 daniel-mar 4198
  if SurfaceDesc.ddpfPixelFormat.dwFlags and (DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
4 daniel-mar 4199
    DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8) <> 0 then Exit;
1 daniel-mar 4200
 
4 daniel-mar 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
1 daniel-mar 4207
  begin
4208
    try
4209
      dxrFillRectColorBlend(DestSurface, DestRect, DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2, ColorToRGB(Color) or (Byte(Alpha) shl 24));
4210
    finally
4 daniel-mar 4211
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 4212
    end;
4 daniel-mar 4213
  end;{$ENDIF}
1 daniel-mar 4214
end;
4215
 
4 daniel-mar 4216
procedure TDirectDrawSurface.FillRectSub(const DestRect: TRect; Color: TColor; Alpha: Byte);
4217
{$IFDEF DXR_deprecated}var
4218
  DestSurface: TDXR_Surface;{$ENDIF}
1 daniel-mar 4219
begin
4 daniel-mar 4220
  if Color and $FFFFFF = 0 then Exit;
4221
  if (Self.Width = 0) or (Self.Height = 0) then Exit;
1 daniel-mar 4222
  if SurfaceDesc.ddpfPixelFormat.dwFlags and (DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
4 daniel-mar 4223
    DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8) <> 0 then Exit;
1 daniel-mar 4224
 
4 daniel-mar 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
1 daniel-mar 4231
  begin
4232
    try
4233
      dxrFillRectColorBlend(DestSurface, DestRect, DXR_BLEND_ONE2_SUB_ONE1, ColorToRGB(Color));
4234
    finally
4 daniel-mar 4235
      dxrDDSurfaceUnLock({$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, DestSurface)
1 daniel-mar 4236
    end;
4 daniel-mar 4237
  end;{$ENDIF}
1 daniel-mar 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
4 daniel-mar 4247
  if FCanvas = nil then
1 daniel-mar 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
4 daniel-mar 4270
  ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 4271
begin
4272
  Result := 0;
4 daniel-mar 4273
  if ({$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) and (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then
1 daniel-mar 4274
    if Lock(PRect(nil)^, ddsd) then
4275
    begin
4276
      try
4277
        case ddsd.ddpfPixelFormat.dwRGBBitCount of
4 daniel-mar 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)^;
1 daniel-mar 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
4 daniel-mar 4322
  if AWidth = 0 then
4323
    AWidth := SrcRect.Right - SrcRect.Left;
4324
  if AHeight = 0 then
4325
    AHeight := SrcRect.Bottom - SrcRect.Top;
1 daniel-mar 4326
 
4327
  SetSize(AWidth, AHeight);
4328
 
4329
  with SrcRect do
4330
    if Graphic is TDIB then
4331
    begin
4332
      with Canvas do
4 daniel-mar 4333
      try
1 daniel-mar 4334
        StretchBlt(Handle, 0, 0, AWidth, AHeight, TDIB(Graphic).Canvas.Handle,
4 daniel-mar 4335
          Left, Top, Right - Left, Bottom - Top, SRCCOPY);
4336
      finally
1 daniel-mar 4337
        Release;
4338
      end;
4 daniel-mar 4339
    end else if (Right - Left = AWidth) and (Bottom - Top = AHeight) then
1 daniel-mar 4340
    begin
4341
      with Canvas do
4 daniel-mar 4342
      try
1 daniel-mar 4343
        Draw(-Left, -Top, Graphic);
4 daniel-mar 4344
      finally
1 daniel-mar 4345
        Release;
4346
      end;
4347
    end else
4348
    begin
4349
      Temp := TDIB.Create;
4350
      try
4 daniel-mar 4351
        Temp.SetSize(Right - Left, Bottom - Top, 24);
1 daniel-mar 4352
        Temp.Canvas.Draw(-Left, -Top, Graphic);
4353
 
4354
        with Canvas do
4 daniel-mar 4355
        try
1 daniel-mar 4356
          StretchDraw(Bounds(0, 0, AWidth, AHeight), Temp);
4 daniel-mar 4357
        finally
1 daniel-mar 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);
4 daniel-mar 4386
    if DIB.Size > 0 then
1 daniel-mar 4387
      LoadFromGraphic(DIB);
4388
  finally
4 daniel-mar 4389
    DIB.Free;
1 daniel-mar 4390
  end;
4391
end;
4392
 
4 daniel-mar 4393
function TDirectDrawSurface.Lock(const Rect: TRect; var SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF}): Boolean;
1 daniel-mar 4394
begin
4395
  Result := False;
4 daniel-mar 4396
  if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} = nil then Exit;
1 daniel-mar 4397
 
4 daniel-mar 4398
  if FLockCount > 0 then Exit;
4399
  FIsLocked := False;
1 daniel-mar 4400
  FLockSurfaceDesc.dwSize := SizeOf(FLockSurfaceDesc);
4401
 
4 daniel-mar 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;
1 daniel-mar 4407
 
4408
  Inc(FLockCount);
4409
  SurfaceDesc := FLockSurfaceDesc;
4 daniel-mar 4410
  FIsLocked := True;
1 daniel-mar 4411
  Result := True;
4412
end;
4 daniel-mar 4413
 
4414
{$IFDEF VER4UP}
4415
function TDirectDrawSurface.Lock(var SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF}): Boolean;
1 daniel-mar 4416
begin
4417
  Result := False;
4 daniel-mar 4418
  FIsLocked := False;
4419
  if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} = nil then Exit;
1 daniel-mar 4420
 
4 daniel-mar 4421
  if FLockCount = 0 then
1 daniel-mar 4422
  begin
4423
    FLockSurfaceDesc.dwSize := SizeOf(FLockSurfaceDesc);
4 daniel-mar 4424
    DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.Lock(nil, FLockSurfaceDesc, DDLOCK_WAIT, 0);
4425
    if DXResult <> DD_OK then Exit;
1 daniel-mar 4426
  end;
4427
 
4428
  Inc(FLockCount);
4429
  SurfaceDesc := FLockSurfaceDesc;
4 daniel-mar 4430
  FIsLocked := True;
1 daniel-mar 4431
  Result := True;
4432
end;
4 daniel-mar 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;
1 daniel-mar 4447
{$ENDIF}
4448
 
4449
procedure TDirectDrawSurface.UnLock;
4450
begin
4 daniel-mar 4451
  if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} = nil then Exit;
1 daniel-mar 4452
 
4 daniel-mar 4453
  if FLockCount > 0 then
1 daniel-mar 4454
  begin
4455
    Dec(FLockCount);
4 daniel-mar 4456
    if FLockCount = 0 then begin
4457
      DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.UnLock(FLockSurfaceDesc.lpSurface);
4458
      FIsLocked := False;
4459
    end;
1 daniel-mar 4460
  end;
4461
end;
4462
 
4463
function TDirectDrawSurface.Restore: Boolean;
4464
begin
4 daniel-mar 4465
  if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
1 daniel-mar 4466
  begin
4 daniel-mar 4467
    DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}._Restore;
4468
    Result := DXResult = DD_OK;
1 daniel-mar 4469
  end else
4470
    Result := False;
4471
end;
4472
 
4473
procedure TDirectDrawSurface.SetClipper(Value: TDirectDrawClipper);
4474
begin
4 daniel-mar 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);
1 daniel-mar 4478
end;
4479
 
4480
procedure TDirectDrawSurface.SetColorKey(Flags: DWORD; const Value: TDDColorKey);
4481
begin
4 daniel-mar 4482
  if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
4483
    DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetColorKey(Flags, @Value);
1 daniel-mar 4484
end;
4485
 
4486
procedure TDirectDrawSurface.SetPalette(Value: TDirectDrawPalette);
4487
begin
4 daniel-mar 4488
  if {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
4489
    DXResult := {$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetPalette(Value.IDDPalette);
1 daniel-mar 4490
end;
4491
 
4492
procedure TDirectDrawSurface.SetPixel(X, Y: Integer; Value: Longint);
4493
var
4 daniel-mar 4494
  ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 4495
  P: PByte;
4496
begin
4 daniel-mar 4497
  if ({$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) and (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then
1 daniel-mar 4498
    if Lock(PRect(nil)^, ddsd) then
4499
    begin
4500
      try
4501
        case ddsd.ddpfPixelFormat.dwRGBBitCount of
4 daniel-mar 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;
1 daniel-mar 4525
        end;
4526
      finally
4527
        UnLock;
4528
      end;
4529
    end;
4530
end;
4531
 
4532
procedure TDirectDrawSurface.SetSize(AWidth, AHeight: Integer);
4533
var
4 daniel-mar 4534
  ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 4535
begin
4 daniel-mar 4536
  if (AWidth <= 0) or (AHeight <= 0) then
1 daniel-mar 4537
  begin
4 daniel-mar 4538
    {$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil;
1 daniel-mar 4539
    Exit;
4540
  end;
4541
 
4 daniel-mar 4542
  FillChar(ddsd, SizeOf(ddsd), 0);
1 daniel-mar 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.  }
4 daniel-mar 4557
  if ddsd.ddsCaps.dwCaps and DDSCAPS_SYSTEMMEMORY = 0 then
1 daniel-mar 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
 
4 daniel-mar 4579
{additional pixel routines like turbopixels}
4580
 
4581
procedure TDirectDrawSurface.PutPixel8(x, y, color: Integer); assembler;
4582
{ on entry:  self = eax, x = edx,   y = ecx,   color = ? }
4583
asm
4584
  push esi                              // must maintain esi
4585
  mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface// set to surface
4586
  add esi,edx                           // add x
4587
  mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.dwwidth]  // eax = pitch
4588
  mul ecx                               // eax = pitch * y
4589
  add esi,eax                           // esi = pixel offset
4590
  mov ecx, color
4591
  mov ds:[esi],cl                       // set pixel (lo byte of ecx)
4592
  pop esi                               // restore esi
4593
  //ret                                   // return
4594
end;
4595
 
4596
procedure TDirectDrawSurface.PutPixel16(x, y, color: Integer); assembler;
4597
{ on entry:  self = eax, x = edx,   y = ecx,   color = ? }
4598
asm
4599
  push esi
4600
  mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
4601
  shl edx,1
4602
  add esi,edx
4603
  mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
4604
  mul ecx
4605
  add esi,eax
4606
  mov ecx, color
4607
  mov ds:[esi],cx
4608
  pop esi
4609
  //ret
4610
end;
4611
 
4612
procedure TDirectDrawSurface.PutPixel24(x, y, color: Integer); assembler;
4613
{ on entry:  self = eax, x = edx,   y = ecx,   color = ? }
4614
asm
4615
  push esi
4616
  mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
4617
  imul edx,3
4618
  add esi,edx
4619
  mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
4620
  mul ecx
4621
  add esi,eax
4622
  mov eax,ds:[esi]
4623
  and eax,$FF000000
4624
  mov ecx, color
4625
  or  ecx,eax
4626
  mov ds:[esi+1],ecx
4627
  pop esi
4628
  //ret
4629
end;
4630
 
4631
procedure TDirectDrawSurface.PutPixel32(x, y, color: Integer); assembler;
4632
{ on entry:  self = eax, x = edx,   y = ecx,   color = ? }
4633
asm
4634
  push esi
4635
  mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
4636
  shl edx,2
4637
  add esi,edx
4638
  mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
4639
  mul ecx
4640
  add esi,eax
4641
  mov ecx, color
4642
  mov ds:[esi],ecx
4643
  pop esi
4644
  //ret
4645
end;
4646
 
4647
procedure TDirectDrawSurface.Poke(X, Y: Integer; const Value: LongInt);
4648
begin
4649
  if (X < 0) or (X > (Width - 1)) or
4650
    (Y < 0) or (Y > (Height - 1)) or not FIsLocked then Exit;
4651
  case Bitcount of
4652
    8: PutPixel8(x, y, value);
4653
    16: PutPixel16(x, y, value);
4654
    24: PutPixel24(x, y, value);
4655
    32: PutPixel32(x, y, value);
4656
  end;
4657
end;
4658
 
4659
function TDirectDrawSurface.GetPixel8(x, y: Integer): Integer; assembler;
4660
{ on entry:  self = eax, x = edx,   y = ecx,   result = eax }
4661
asm
4662
  push esi                              // myst maintain esi
4663
  mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface        // set to surface
4664
  add esi,edx                           // add x
4665
  mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]         // eax = pitch
4666
  mul ecx                               // eax = pitch * y
4667
  add esi,eax                           // esi = pixel offset
4668
  mov eax,ds:[esi]                      // eax = color
4669
  and eax,$FF                           // map into 8bit
4670
  pop esi                               // restore esi
4671
  //ret                                   // return
4672
end;
4673
 
4674
function TDirectDrawSurface.GetPixel16(x, y: Integer): Integer; assembler;
4675
{ on entry:  self = eax, x = edx,   y = ecx,   result = eax }
4676
asm
4677
  push esi
4678
  mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
4679
  shl edx,1
4680
  add esi,edx
4681
  mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
4682
  mul ecx
4683
  add esi,eax
4684
  mov eax,ds:[esi]
4685
  and eax,$FFFF                         // map into 16bit
4686
  pop esi
4687
  //ret
4688
end;
4689
 
4690
function TDirectDrawSurface.GetPixel24(x, y: Integer): Integer; assembler;
4691
{ on entry:  self = eax, x = edx,   y = ecx,   result = eax }
4692
asm
4693
  push esi
4694
  mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
4695
  imul edx,3
4696
  add esi,edx
4697
  mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
4698
  mul ecx
4699
  add esi,eax
4700
  mov eax,ds:[esi]
4701
  and eax,$FFFFFF                       // map into 24bit
4702
  pop esi
4703
  //ret
4704
end;
4705
 
4706
function TDirectDrawSurface.GetPixel32(x, y: Integer): Integer; assembler;
4707
{ on entry:  self = eax, x = edx,   y = ecx,   result = eax }
4708
asm
4709
  push esi
4710
  mov esi,TDirectDrawSurface[eax].FLockSurfaceDesc.lpSurface
4711
  shl edx,2
4712
  add esi,edx
4713
  mov eax,[TDirectDrawSurface[eax].FLockSurfaceDesc.lpitch]
4714
  mul ecx
4715
  add esi,eax
4716
  mov eax,ds:[esi]
4717
  pop esi
4718
  //ret
4719
end;
4720
 
4721
function TDirectDrawSurface.Peek(X, Y: Integer): LongInt;
4722
begin
4723
  Result := 0;
4724
  if (X < 0) or (X > (Width - 1)) or
4725
    (Y < 0) or (Y > (Height - 1)) or not FIsLocked then Exit;
4726
  case Bitcount of
4727
    8: Result := GetPixel8(x, y);
4728
    16: Result := GetPixel16(x, y);
4729
    24: Result := GetPixel24(x, y);
4730
    32: Result := GetPixel32(x, y);
4731
  end;
4732
end;
4733
 
4734
procedure TDirectDrawSurface.PokeLine(X1, Y1, X2, Y2: Integer; Color: cardinal);
4735
var
4736
  i, deltax, deltay, numpixels,
4737
    d, dinc1, dinc2,
4738
    x, xinc1, xinc2,
4739
    y, yinc1, yinc2: Integer;
4740
begin
4741
  if not FIsLocked then {$IFDEF VER4UP}Lock{$ELSE}LockSurface{$ENDIF}; //force lock the surface
4742
  { Calculate deltax and deltay for initialisation }
4743
  deltax := abs(x2 - x1);
4744
  deltay := abs(y2 - y1);
4745
 
4746
  { Initialise all vars based on which is the independent variable }
4747
  if deltax >= deltay then
4748
  begin
4749
    { x is independent variable }
4750
    numpixels := deltax + 1;
4751
    d := (2 * deltay) - deltax;
4752
 
4753
    dinc1 := deltay shl 1;
4754
    dinc2 := (deltay - deltax) shl 1;
4755
    xinc1 := 1;
4756
    xinc2 := 1;
4757
    yinc1 := 0;
4758
    yinc2 := 1;
4759
  end
4760
  else
4761
  begin
4762
    { y is independent variable }
4763
    numpixels := deltay + 1;
4764
    d := (2 * deltax) - deltay;
4765
    dinc1 := deltax shl 1;
4766
    dinc2 := (deltax - deltay) shl 1;
4767
    xinc1 := 0;
4768
    xinc2 := 1;
4769
    yinc1 := 1;
4770
    yinc2 := 1;
4771
  end;
4772
  { Make sure x and y move in the right directions }
4773
  if x1 > x2 then
4774
  begin
4775
    xinc1 := -xinc1;
4776
    xinc2 := -xinc2;
4777
  end;
4778
  if y1 > y2 then
4779
  begin
4780
    yinc1 := -yinc1;
4781
    yinc2 := -yinc2;
4782
  end;
4783
  x := x1;
4784
  y := y1;
4785
  { Draw the pixels }
4786
  for i := 1 to numpixels do
4787
  begin
4788
    if (x > 0) and (x < (Width - 1)) and (y > 0) and (y < (Height - 1)) then
4789
      Pixel[x, y] := Color;
4790
    if d < 0 then
4791
    begin
4792
      Inc(d, dinc1);
4793
      Inc(x, xinc1);
4794
      Inc(y, yinc1);
4795
    end
4796
    else
4797
    begin
4798
      Inc(d, dinc2);
4799
      Inc(x, xinc2);
4800
      Inc(y, yinc2);
4801
    end;
4802
  end;
4803
end;
4804
 
4805
procedure TDirectDrawSurface.PokeLinePolar(x, y: Integer; angle, length: extended; Color: cardinal);
4806
var
4807
  xp, yp: Integer;
4808
begin
4809
  xp := round(sin(angle * pi / 180) * length) + x;
4810
  yp := round(cos(angle * pi / 180) * length) + y;
4811
  PokeLine(x, y, xp, yp, Color);
4812
end;
4813
 
4814
procedure TDirectDrawSurface.PokeBox(xs, ys, xd, yd: Integer; Color: cardinal);
4815
begin
4816
  pokeline(xs, ys, xd, ys, color);
4817
  pokeline(xs, ys, xs, yd, color);
4818
  pokeline(xd, ys, xd, yd, color);
4819
  pokeline(xs, yd, xd, yd, color);
4820
end;
4821
 
4822
procedure TDirectDrawSurface.PokeBlendPixel(const X, Y: Integer; aColor: cardinal; Alpha: byte);
4823
var
4824
  cr, cg, cb: byte;
4825
  ar, ag, ab: byte;
4826
begin
4827
  LoadRGB(aColor, ar, ag, ab);
4828
  LoadRGB(Pixel[x, y], cr, cg, cb);
4829
  Pixel[x, y] := SaveRGB((Alpha * (aR - cr) shr 8) + cr, // R alpha
4830
    (Alpha * (aG - cg) shr 8) + cg, // G alpha
4831
    (Alpha * (aB - cb) shr 8) + cb); // B alpha
4832
end;
4833
 
4834
function Conv24to16(Color: Integer): Word; register;
4835
asm
4836
  mov ecx,eax
4837
  shl eax,24
4838
  shr eax,27
4839
  shl eax,11
4840
  mov edx,ecx
4841
  shl edx,16
4842
  shr edx,26
4843
  shl edx,5
4844
  or eax,edx
4845
  mov edx,ecx
4846
  shl edx,8
4847
  shr edx,27
4848
  or eax,edx
4849
end;
4850
 
4851
procedure TDirectDrawSurface.PokeWuLine(X1, Y1, X2, Y2, aColor: Integer);
4852
var DeltaX, DeltaY, Loop, Start, Finish: Integer;
4853
  Dx, Dy, DyDx: Single; // fractional parts
4854
  Color16: DWord;
4855
begin
4856
  DeltaX := Abs(X2 - X1); // Calculate DeltaX and DeltaY for initialization
4857
  DeltaY := Abs(Y2 - Y1);
4858
  if (DeltaX = 0) or (DeltaY = 0) then
4859
  begin // straight lines
4860
    PokeLine(X1, Y1, X2, Y2, aColor);
4861
    Exit;
4862
  end;
4863
  if BitCount = 16 then
4864
    Color16 := Conv24to16(aColor)
4865
  else
4866
    Color16 := aColor;
4867
  if DeltaX > DeltaY then // horizontal or vertical
4868
  begin
4869
  { determine rise and run }
4870
    if Y2 > Y1 then DyDx := -(DeltaY / DeltaX)
4871
    else DyDx := DeltaY / DeltaX;
4872
    if X2 < X1 then
4873
    begin
4874
      Start := X2; // right to left
4875
      Finish := X1;
4876
      Dy := Y2;
4877
    end else
4878
    begin
4879
      Start := X1; // left to right
4880
      Finish := X2;
4881
      Dy := Y1;
4882
      DyDx := -DyDx; // inverse slope
4883
    end;
4884
    for Loop := Start to Finish do
4885
    begin
4886
      PokeBlendPixel(Loop, Trunc(Dy), Color16, Trunc((1 - Frac(Dy)) * 255));
4887
      PokeBlendPixel(Loop, Trunc(Dy) + 1, Color16, Trunc(Frac(Dy) * 255));
4888
      Dy := Dy + DyDx; // next point
4889
    end;
4890
  end else
4891
  begin
4892
   { determine rise and run }
4893
    if X2 > X1 then DyDx := -(DeltaX / DeltaY)
4894
    else DyDx := DeltaX / DeltaY;
4895
    if Y2 < Y1 then
4896
    begin
4897
      Start := Y2; // right to left
4898
      Finish := Y1;
4899
      Dx := X2;
4900
    end else
4901
    begin
4902
      Start := Y1; // left to right
4903
      Finish := Y2;
4904
      Dx := X1;
4905
      DyDx := -DyDx; // inverse slope
4906
    end;
4907
    for Loop := Start to Finish do
4908
    begin
4909
      PokeBlendPixel(Trunc(Dx), Loop, Color16, Trunc((1 - Frac(Dx)) * 255));
4910
      PokeBlendPixel(Trunc(Dx), Loop, Color16, Trunc(Frac(Dx) * 255));
4911
      Dx := Dx + DyDx; // next point
4912
    end;
4913
  end;
4914
end;
4915
 
4916
procedure TDirectDrawSurface.Noise(Oblast: TRect; Density: Byte);
4917
var
4918
  dx, dy: Integer;
4919
  Dens: byte;
4920
begin
4921
  {noise}
4922
  case Density of
4923
    0..2: Dens := 3;
4924
    255: Dens := 254;
4925
  else
4926
    Dens := Density;
4927
  end;
4928
  if Dens >= Oblast.Right then
4929
    Dens := Oblast.Right div 3;
4930
  dy := Oblast.Top;
4931
  while dy <= Oblast.Bottom do begin
4932
    dx := Oblast.Left;
4933
    while dx <= Oblast.Right do begin
4934
      inc(dx, random(dens));
4935
      if dx <= Oblast.Right then
4936
        Pixel[dx, dy] := not Pixel[dx, dy];
4937
    end;
4938
    inc(dy);
4939
  end;
4940
end;
4941
 
4942
function Conv16to24(Color: Word): Integer; register;
4943
asm
4944
 xor edx,edx
4945
 mov dx,ax
4946
 
4947
 mov eax,edx
4948
 shl eax,27
4949
 shr eax,8
4950
 
4951
 mov ecx,edx
4952
 shr ecx,5
4953
 shl ecx,26
4954
 shr ecx,16
4955
 or eax,ecx
4956
 
4957
 mov ecx,edx
4958
 shr ecx,11
4959
 shl ecx,27
4960
 shr ecx,24
4961
 or eax,ecx
4962
end;
4963
 
4964
procedure GetRGB(Color: cardinal; var R, G, B: Byte); {$IFDEF VER9UP}inline; {$ENDIF}
4965
begin
4966
  R := Color;
4967
  G := Color shr 8;
4968
  B := Color shr 16;
4969
end;
4970
 
4971
procedure TDirectDrawSurface.LoadRGB(Color: cardinal; var R, G, B: Byte);
4972
var grB: Byte;
4973
begin
4974
  grB := 1;
4975
  if FLockSurfaceDesc.ddpfPixelFormat.dwGBitMask = 2016 then grB := 0; // 565
4976
  case BitCount of
4977
    15, 16: begin
4978
        R := (color shr (11 - grB)) shl 3;
4979
        if grB = 0 then
4980
          G := ((color and 2016) shr 5) shl 2
4981
        else
4982
          G := ((color and 992) shr 5) shl 3;
4983
        B := (color and 31) shl 3;
4984
      end;
4985
  else
4986
    GetRGB(Color, R, G, B);
4987
  end;
4988
end;
4989
 
4990
function TDirectDrawSurface.SaveRGB(const R, G, B: Byte): cardinal;
4991
begin
4992
  case BitCount of
4993
    15, 16: begin
4994
        Result := Conv24to16(RGB(R, G, B));
4995
      end;
4996
  else
4997
    Result := RGB(R, G, B);
4998
  end;
4999
end;
5000
 
5001
procedure TDirectDrawSurface.Blur;
5002
var
5003
  x, y, tr, tg, tb: Integer;
5004
  r, g, b: byte;
5005
begin
5006
  for y := 1 to GetHeight - 1 do
5007
    for x := 1 to GetWidth - 1 do begin
5008
      LoadRGB(peek(x, y), r, g, b);
5009
      tr := r;
5010
      tg := g;
5011
      tb := b;
5012
      LoadRGB(peek(x, y + 1), r, g, b);
5013
      Inc(tr, r);
5014
      Inc(tg, g);
5015
      Inc(tb, b);
5016
      LoadRGB(peek(x, y - 1), r, g, b);
5017
      Inc(tr, r);
5018
      Inc(tg, g);
5019
      Inc(tb, b);
5020
      LoadRGB(peek(x - 1, y), r, g, b);
5021
      Inc(tr, r);
5022
      Inc(tg, g);
5023
      Inc(tb, b);
5024
      LoadRGB(peek(x + 1, y), r, g, b);
5025
      Inc(tr, r);
5026
      Inc(tg, g);
5027
      Inc(tb, b);
5028
      tr := tr shr 2;
5029
      tg := tg shr 2;
5030
      tb := tb shr 2;
5031
      Poke(x, y, savergb(tr, tg, tb));
5032
    end;
5033
end;
5034
 
5035
procedure TDirectDrawSurface.PokeCircle(X, Y, Radius, Color: Integer);
5036
var
5037
  a, af, b, bf, c,
5038
    target, r2: Integer;
5039
begin
5040
  Target := 0;
5041
  A := Radius;
5042
  B := 0;
5043
  R2 := Sqr(Radius);
5044
 
5045
  while a >= B do
5046
  begin
5047
    b := Round(Sqrt(R2 - Sqr(A)));
5048
    c := target; target := b; b := c;
5049
    while B < Target do
5050
    begin
5051
      Af := (120 * a) div 100;
5052
      Bf := (120 * b) div 100;
5053
      pixel[x + af, y + b] := color;
5054
      pixel[x + bf, y + a] := color;
5055
      pixel[x - af, y + b] := color;
5056
      pixel[x - bf, y + a] := color;
5057
      pixel[x - af, y - b] := color;
5058
      pixel[x - bf, y - a] := color;
5059
      pixel[x + af, y - b] := color;
5060
      pixel[x + bf, y - a] := color;
5061
      B := B + 1;
5062
    end;
5063
    A := A - 1;
5064
  end;
5065
end;
5066
 
5067
function RGBToBGR(Color: cardinal): cardinal;
5068
begin
5069
  result := (LoByte(LoWord(Color)) shr 3 shl 11) or // Red
5070
    (HiByte((Color)) shr 2 shl 5) or // Green
5071
    (LoByte(HiWord(Color)) shr 3); // Blue
5072
end;
5073
 
5074
procedure TDirectDrawSurface.PokeVLine(x, y1, y2: Integer; Color: cardinal);
5075
var
5076
  y: Integer;
5077
  NColor: cardinal;
5078
  r, g, b: byte;
5079
begin
5080
  if y1 < 0 then y1 := 0;
5081
  if y2 >= Height then y2 := Height - 1;
5082
  GetRGB(Color, r, g, b);
5083
  NColor := RGBToBGR(rgb(r, g, b));
5084
  for y := y1 to y2 do
5085
  begin
5086
    pixel[x, y] := NColor;
5087
  end;
5088
end;
5089
 
5090
procedure TDirectDrawSurface.PokeFilledEllipse(exc, eyc, ea, eb, color: Integer);
5091
var x, y: Integer; aa, aa2, bb, bb2, d, dx, dy: LongInt;
5092
begin
5093
  x := 0;
5094
  y := eb;
5095
  aa := LongInt(ea) * ea;
5096
  aa2 := 2 * aa;
5097
  bb := LongInt(eb) * eb;
5098
  bb2 := 2 * bb;
5099
  d := bb - aa * eb + aa div 4;
5100
  dx := 0;
5101
  dy := aa2 * eb;
5102
  PokevLine(exc, eyc - y, eyc + y, color);
5103
  while (dx < dy) do begin
5104
    if (d > 0) then begin
5105
      dec(y); dec(dy, aa2); dec(d, dy);
5106
    end;
5107
    inc(x); inc(dx, bb2); inc(d, bb + dx);
5108
    PokevLine(exc - x, eyc - y, eyc + y, color);
5109
    PokevLine(exc + x, eyc - y, eyc + y, color);
5110
  end;
5111
  inc(d, (3 * (aa - bb) div 2 - (dx + dy)) div 2);
5112
  while (y >= 0) do begin
5113
    if (d < 0) then begin
5114
      inc(x); inc(dx, bb2); inc(d, bb + dx);
5115
      PokevLine(exc - x, eyc - y, eyc + y, color);
5116
      PokevLine(exc + x, eyc - y, eyc + y, color);
5117
    end;
5118
    dec(y); dec(dy, aa2); inc(d, aa - dy);
5119
  end;
5120
end;
5121
 
5122
procedure TDirectDrawSurface.DoRotate(cent1, cent2, angle: Integer; coord1, coord2: Real; Color: word);
5123
var coord1t, coord2t: Real;
5124
  c1, c2: Integer;
5125
begin
5126
  coord1t := coord1 - cent1;
5127
  coord2t := coord2 - cent2;
5128
  coord1 := coord1t * cos(angle * pi / 180) - coord2t * sin(angle * pi / 180);
5129
  coord2 := coord1t * sin(angle * pi / 180) + coord2t * cos(angle * pi / 180);
5130
  coord1 := coord1 + cent1;
5131
  coord2 := coord2 + cent2;
5132
  c1 := round(coord1);
5133
  c2 := round(coord2);
5134
  pixel[c1, c2] := Color;
5135
end;
5136
 
5137
procedure TDirectDrawSurface.PokeEllipse(exc, eyc, ea, eb, angle, Color: Integer);
5138
var
5139
  elx, ely: Integer;
5140
  aa, aa2, bb, bb2, d, dx, dy: LongInt;
5141
  x, y: real;
5142
begin
5143
  elx := 0;
5144
  ely := eb;
5145
  aa := LongInt(ea) * ea;
5146
  aa2 := 2 * aa;
5147
  bb := LongInt(eb) * eb;
5148
  bb2 := 2 * bb;
5149
  d := bb - aa * eb + aa div 4;
5150
  dx := 0;
5151
  dy := aa2 * eb;
5152
  x := exc;
5153
  y := eyc - ely;
5154
  dorotate(exc, eyc, angle, x, y, Color);
5155
  x := exc;
5156
  y := eyc + ely;
5157
  dorotate(exc, eyc, angle, x, y, Color);
5158
  x := exc - ea;
5159
  y := eyc;
5160
  dorotate(exc, eyc, angle, x, y, Color);
5161
  x := exc + ea;
5162
  y := eyc;
5163
  dorotate(exc, eyc, angle, x, y, Color);
5164
  while (dx < dy) do begin
5165
    if (d > 0) then begin Dec(ely); Dec(dy, aa2); Dec(d, dy); end;
5166
    Inc(elx); Inc(dx, bb2); Inc(d, bb + dx);
5167
    x := exc + elx; y := eyc + ely;
5168
    dorotate(exc, eyc, angle, x, y, Color);
5169
    x := exc - elx; y := eyc + ely;
5170
    dorotate(exc, eyc, angle, x, y, Color);
5171
    x := exc + elx; y := eyc - ely;
5172
    dorotate(exc, eyc, angle, x, y, Color);
5173
    x := exc - elx; y := eyc - ely;
5174
    dorotate(exc, eyc, angle, x, y, Color);
5175
  end;
5176
  Inc(d, (3 * (aa - bb) div 2 - (dx + dy)) div 2);
5177
  while (ely > 0) do begin
5178
    if (d < 0) then begin Inc(elx); Inc(dx, bb2); Inc(d, bb + dx); end;
5179
    Dec(ely); Dec(dy, aa2); Inc(d, aa - dy);
5180
    x := exc + elx; y := eyc + ely;
5181
    dorotate(exc, eyc, angle, x, y, Color);
5182
    x := exc - elx; y := eyc + ely;
5183
    dorotate(exc, eyc, angle, x, y, Color);
5184
    x := exc + elx; y := eyc - ely;
5185
    dorotate(exc, eyc, angle, x, y, Color);
5186
    x := exc - elx; y := eyc - ely;
5187
    dorotate(exc, eyc, angle, x, y, Color);
5188
  end;
5189
end;
5190
 
5191
procedure TDirectDrawSurface.MirrorFlip(Value: TRenderMirrorFlipSet);
5192
begin
5193
  if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Self) then
5194
    D2D.MirrorFlip := Value;
5195
end;
5196
 
1 daniel-mar 5197
{  TDXDrawDisplayMode  }
5198
 
5199
function TDXDrawDisplayMode.GetBitCount: Integer;
5200
begin
5201
  Result := FSurfaceDesc.ddpfPixelFormat.dwRGBBitCount;
5202
end;
5203
 
5204
function TDXDrawDisplayMode.GetHeight: Integer;
5205
begin
5206
  Result := FSurfaceDesc.dwHeight;
5207
end;
5208
 
5209
function TDXDrawDisplayMode.GetWidth: Integer;
5210
begin
5211
  Result := FSurfaceDesc.dwWidth;
5212
end;
5213
 
5214
{  TDXDrawDisplay  }
5215
 
5216
constructor TDXDrawDisplay.Create(ADXDraw: TCustomDXDraw);
5217
begin
5218
  inherited Create;
5219
  FDXDraw := ADXDraw;
5220
  FModes := TCollection.Create(TDXDrawDisplayMode);
5221
  FWidth := 640;
5222
  FHeight := 480;
4 daniel-mar 5223
  FBitCount := 16;
5224
  FFixedBitCount := False; //True;
1 daniel-mar 5225
  FFixedRatio := True;
4 daniel-mar 5226
  FFixedSize := True; //False;
1 daniel-mar 5227
end;
5228
 
5229
destructor TDXDrawDisplay.Destroy;
5230
begin
5231
  FModes.Free;
5232
  inherited Destroy;
5233
end;
5234
 
5235
procedure TDXDrawDisplay.Assign(Source: TPersistent);
5236
begin
5237
  if Source is TDXDrawDisplay then
5238
  begin
4 daniel-mar 5239
    if Source <> Self then
1 daniel-mar 5240
    begin
5241
      FBitCount := TDXDrawDisplay(Source).BitCount;
5242
      FHeight := TDXDrawDisplay(Source).Height;
5243
      FWidth := TDXDrawDisplay(Source).Width;
5244
 
5245
      FFixedBitCount := TDXDrawDisplay(Source).FFixedBitCount;
5246
      FFixedRatio := TDXDrawDisplay(Source).FFixedRatio;
5247
      FFixedSize := TDXDrawDisplay(Source).FFixedSize;
5248
    end;
5249
  end else
5250
    inherited Assign(Source);
5251
end;
5252
 
5253
function TDXDrawDisplay.GetCount: Integer;
5254
begin
4 daniel-mar 5255
  if FModes.Count = 0 then
1 daniel-mar 5256
    LoadDisplayModes;
5257
  Result := FModes.Count;
5258
end;
5259
 
5260
function TDXDrawDisplay.GetMode: TDXDrawDisplayMode;
5261
var
5262
  i: Integer;
4 daniel-mar 5263
  ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 5264
begin
5265
  Result := nil;
4 daniel-mar 5266
  if FDXDraw.DDraw <> nil then
1 daniel-mar 5267
  begin
5268
    ddsd := FDXDraw.DDraw.DisplayMode;
5269
    with ddsd do
5270
      i := IndexOf(dwWidth, dwHeight, ddpfPixelFormat.dwRGBBitCount);
4 daniel-mar 5271
    if i <> -1 then
1 daniel-mar 5272
      Result := Modes[i];
5273
  end;
4 daniel-mar 5274
  if Result = nil then
1 daniel-mar 5275
    raise EDirectDrawError.Create(SDisplayModeCannotAcquired);
5276
end;
5277
 
5278
function TDXDrawDisplay.GetMode2(Index: Integer): TDXDrawDisplayMode;
5279
begin
4 daniel-mar 5280
  if FModes.Count = 0 then
1 daniel-mar 5281
    LoadDisplayModes;
5282
  Result := TDXDrawDisplayMode(FModes.Items[Index]);
5283
end;
5284
 
5285
function TDXDrawDisplay.IndexOf(Width, Height, BitCount: Integer): Integer;
5286
var
5287
  i: Integer;
5288
begin
5289
  Result := -1;
4 daniel-mar 5290
  for i := 0 to Count - 1 do
5291
    if (Modes[i].Width = Width) and (Modes[i].Height = Height) and (Modes[i].BitCount = BitCount) then
1 daniel-mar 5292
    begin
5293
      Result := i;
5294
      Exit;
5295
    end;
5296
end;
5297
 
5298
procedure TDXDrawDisplay.LoadDisplayModes;
5299
 
5300
  function EnumDisplayModesProc(const lpTDDSurfaceDesc: TDDSurfaceDesc;
5301
    lpContext: Pointer): HRESULT; stdcall;
5302
  begin
5303
    with TDXDrawDisplayMode.Create(TCollection(lpContext)) do
5304
      FSurfaceDesc := lpTDDSurfaceDesc;
5305
    Result := DDENUMRET_OK;
5306
  end;
5307
 
5308
  function Compare(Item1, Item2: TDXDrawDisplayMode): Integer;
5309
  begin
4 daniel-mar 5310
    if Item1.Width <> Item2.Width then
5311
      Result := Item1.Width - Item2.Width
5312
    else if Item1.Height <> Item2.Height then
5313
      Result := Item1.Height - Item2.Height
1 daniel-mar 5314
    else
4 daniel-mar 5315
      Result := Item1.BitCount - Item2.BitCount;
1 daniel-mar 5316
  end;
5317
 
5318
var
5319
  DDraw: TDirectDraw;
5320
  TempList: TList;
5321
  i: Integer;
5322
begin
5323
  FModes.Clear;
5324
 
4 daniel-mar 5325
  if FDXDraw.DDraw <> nil then
1 daniel-mar 5326
  begin
4 daniel-mar 5327
    FDXDraw.DDraw.DXResult := FDXDraw.DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}
5328
      .EnumDisplayModes(0, {$IFDEF D3D_deprecated}PDDSurfaceDesc{$ELSE}PDDSurfaceDesc2{$ENDIF}(nil),
1 daniel-mar 5329
      FModes, @EnumDisplayModesProc);
5330
  end else
5331
  begin
5332
    DDraw := TDirectDraw.Create(PGUID(FDXDraw.FDriver));
5333
    try
4 daniel-mar 5334
      DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}
5335
      .EnumDisplayModes(0, {$IFDEF D3D_deprecated}PDDSurfaceDesc{$ELSE}PDDSurfaceDesc2{$ENDIF}(nil),
5336
      FModes, @EnumDisplayModesProc);
1 daniel-mar 5337
    finally
5338
      DDraw.Free;
5339
    end;
5340
  end;
4 daniel-mar 5341
 
1 daniel-mar 5342
  TempList := TList.Create;
5343
  try
4 daniel-mar 5344
    for i := 0 to FModes.Count - 1 do
1 daniel-mar 5345
      TempList.Add(FModes.Items[i]);
5346
    TempList.Sort(@Compare);
4 daniel-mar 5347
 
5348
    for i := FModes.Count - 1 downto 0 do
1 daniel-mar 5349
      TDXDrawDisplayMode(TempList[i]).Index := i;
5350
  finally
5351
    TempList.Free;
5352
  end;
5353
end;
5354
 
4 daniel-mar 5355
function TDXDrawDisplay.SetSize(AWidth, AHeight, ABitCount{$IFNDEF D3D_deprecated}, ARefreshRate, AFlags{$ENDIF}: Integer): Boolean;
1 daniel-mar 5356
begin
5357
  Result := False;
4 daniel-mar 5358
  if FDXDraw.DDraw <> nil then
1 daniel-mar 5359
  begin
4 daniel-mar 5360
    FDXDraw.DDraw.DXResult := FDXDraw.DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}
5361
      .SetDisplayMode(AWidth, AHeight, ABitCount{$IFNDEF D3D_deprecated}, ARefreshRate, AFlags{$ENDIF});
5362
    Result := FDXDraw.DDraw.DXResult = DD_OK;
1 daniel-mar 5363
 
5364
    if Result then
5365
    begin
5366
      FWidth := AWidth;
5367
      FHeight := AHeight;
5368
      FBitCount := ABitCount;
5369
    end;
5370
  end;
5371
end;
5372
 
5373
function TDXDrawDisplay.DynSetSize(AWidth, AHeight, ABitCount: Integer): Boolean;
5374
 
4 daniel-mar 5375
  {$IFNDEF D3D_deprecated}
5376
  function GetDefaultRefreshRate: Integer;
5377
  begin
5378
    Result := 60;
5379
  end;
5380
  {$ENDIF}
5381
 
1 daniel-mar 5382
  function TestBitCount(BitCount, ABitCount: Integer): Boolean;
5383
  begin
4 daniel-mar 5384
    if (BitCount > 8) and (ABitCount > 8) then
1 daniel-mar 5385
    begin
5386
      Result := True;
5387
    end else
5388
    begin
4 daniel-mar 5389
      Result := BitCount >= ABitCount;
1 daniel-mar 5390
    end;
5391
  end;
5392
 
5393
  function SetSize2(Ratio: Boolean): Boolean;
5394
  var
4 daniel-mar 5395
    DWidth, DHeight, DBitCount{$IFNDEF D3D_deprecated}, DRRate, DFlags{$ENDIF}, i: Integer;
1 daniel-mar 5396
    Flag: Boolean;
5397
  begin
5398
    Result := False;
5399
 
5400
    DWidth := Maxint;
5401
    DHeight := Maxint;
5402
    DBitCount := ABitCount;
4 daniel-mar 5403
    {$IFNDEF D3D_deprecated}
5404
    DRRate := GetDefaultRefreshRate;
5405
    DFlags := 0;
5406
    {$ENDIF}
1 daniel-mar 5407
    Flag := False;
4 daniel-mar 5408
    for i := 0 to Count - 1 do
1 daniel-mar 5409
      with Modes[i] do
5410
      begin
4 daniel-mar 5411
        if ((DWidth >= Width) and (DHeight >= Width) and
5412
          ((not Ratio) or (Width / Height = AWidth / AHeight)) and
5413
          ((FFixedSize and (Width = AWidth) and (Height = Height)) or
5414
          ((not FFixedSize) and (Width >= AWidth) and (Height >= AHeight))) and
1 daniel-mar 5415
 
4 daniel-mar 5416
          ((FFixedBitCount and (BitCount = ABitCount)) or
1 daniel-mar 5417
          ((not FFixedBitCount) and TestBitCount(BitCount, ABitCount)))) then
5418
        begin
5419
          DWidth := Width;
5420
          DHeight := Height;
5421
          DBitCount := BitCount;
5422
          Flag := True;
5423
        end;
5424
      end;
5425
 
5426
    if Flag then
5427
    begin
4 daniel-mar 5428
      if (DBitCount <> ABitCount) then
1 daniel-mar 5429
      begin
4 daniel-mar 5430
        if IndexOf(DWidth, DHEight, ABitCount) <> -1 then
1 daniel-mar 5431
          DBitCount := ABitCount;
5432
      end;
5433
 
4 daniel-mar 5434
      Result := SetSize(DWidth, DHeight, DBitCount{$IFNDEF D3D_deprecated}, DRRate, DFlags{$ENDIF});
1 daniel-mar 5435
    end;
5436
  end;
5437
 
5438
begin
5439
  Result := False;
5440
 
4 daniel-mar 5441
  if (AWidth <= 0) or (AHeight <= 0) or (not (ABitCount in [8, 16, 24, 32])) then Exit;
1 daniel-mar 5442
 
5443
  {  The change is attempted by the size of default.  }
4 daniel-mar 5444
  if SetSize(AWidth, AHeight, ABitCount{$IFNDEF D3D_deprecated}, GetDefaultRefreshRate, 0{$ENDIF}) then
1 daniel-mar 5445
  begin
5446
    Result := True;
5447
    Exit;
5448
  end;
5449
 
5450
  {  The change is attempted by the screen ratio fixation.  }
5451
  if FFixedRatio then
5452
    if SetSize2(True) then
5453
    begin
5454
      Result := True;
5455
      Exit;
5456
    end;
5457
 
5458
  {  The change is unconditionally attempted.  }
5459
  if SetSize2(False) then
5460
  begin
5461
    Result := True;
5462
    Exit;
5463
  end;
5464
end;
5465
 
5466
procedure TDXDrawDisplay.SetBitCount(Value: Integer);
5467
begin
5468
  if not (Value in [8, 16, 24, 32]) then
5469
    raise EDirectDrawError.Create(SInvalidDisplayBitCount);
5470
  FBitCount := Value;
5471
end;
5472
 
5473
procedure TDXDrawDisplay.SetHeight(Value: Integer);
5474
begin
5475
  FHeight := Max(Value, 0);
5476
end;
5477
 
5478
procedure TDXDrawDisplay.SetWidth(Value: Integer);
5479
begin
5480
  FWidth := Max(Value, 0);
5481
end;
5482
 
5483
{  TCustomDXDraw  }
5484
 
5485
function BPPToDDBD(BPP: DWORD): DWORD;
5486
begin
5487
  case BPP of
5488
    1: Result := DDBD_1;
5489
    2: Result := DDBD_2;
5490
    4: Result := DDBD_4;
5491
    8: Result := DDBD_8;
5492
    16: Result := DDBD_16;
5493
    24: Result := DDBD_24;
5494
    32: Result := DDBD_32;
5495
  else
5496
    Result := 0;
5497
  end;
5498
end;
5499
 
5500
procedure FreeZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface);
5501
begin
4 daniel-mar 5502
  if ZBuffer <> nil then
1 daniel-mar 5503
  begin
4 daniel-mar 5504
    if (Surface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) and (ZBuffer.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) then
5505
      Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.DeleteAttachedSurface(0, ZBuffer.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF});
1 daniel-mar 5506
    ZBuffer.Free; ZBuffer := nil;
5507
  end;
5508
end;
5509
 
5510
type
5511
  TInitializeDirect3DOption = (idoSelectDriver, idoOptimizeDisplayMode,
4 daniel-mar 5512
    idoHardware, {$IFDEF D3DRM}idoRetainedMode,{$ENDIF} idoZBuffer);
1 daniel-mar 5513
 
5514
  TInitializeDirect3DOptions = set of TInitializeDirect3DOption;
5515
 
5516
procedure Direct3DInitializing(Options: TInitializeDirect3DOptions;
4 daniel-mar 5517
  var BitCount: Integer; var Driver: PGUID; var DriverGUID: TGUID{$IFNDEF D3D_deprecated}; var D3DDeviceTypeSet: TD3DDeviceTypeSet{$ENDIF});
1 daniel-mar 5518
type
5519
  PDirect3DInitializingRecord = ^TDirect3DInitializingRecord;
5520
  TDirect3DInitializingRecord = record
5521
    Options: TInitializeDirect3DOptions;
5522
    Driver: ^PGUID;
5523
    DriverGUID: PGUID;
5524
    BitCount: Integer;
5525
 
5526
    Flag: Boolean;
5527
    DriverCaps: TDDCaps;
5528
    HELCaps: TDDCaps;
4 daniel-mar 5529
    {$IFDEF D3D_deprecated}
1 daniel-mar 5530
    HWDeviceDesc: TD3DDeviceDesc;
5531
    HELDeviceDesc: TD3DDeviceDesc;
5532
    DeviceDesc: TD3DDeviceDesc;
4 daniel-mar 5533
    {$ELSE}
5534
    DeviceDesc: TD3DDeviceDesc7;
5535
    {$ENDIF}
1 daniel-mar 5536
    D3DFlag: Boolean;
4 daniel-mar 5537
    {$IFDEF D3D_deprecated}
1 daniel-mar 5538
    HWDeviceDesc2: TD3DDeviceDesc;
5539
    HELDeviceDesc2: TD3DDeviceDesc;
5540
    DeviceDesc2: TD3DDeviceDesc;
4 daniel-mar 5541
    {$ELSE}
5542
    DeviceDesc2: TD3DDeviceDesc7;
5543
    {$ENDIF}
1 daniel-mar 5544
  end;
5545
 
4 daniel-mar 5546
  {$IFDEF D3D_deprecated}
5547
  function EnumDeviceCallBack(lpGuid: PGUID; // nil for the default device
5548
      lpDeviceDescription: PAnsiChar; lpDeviceName: PAnsiChar;
5549
      var lpD3DHWDeviceDesc: TD3DDeviceDesc;
5550
      var lpD3DHELDeviceDesc: TD3DDeviceDesc;
5551
      rec: PDirect3DInitializingRecord) : HResult; stdcall;
1 daniel-mar 5552
 
5553
    procedure UseThisDevice;
5554
    begin
5555
      rec.D3DFlag := True;
5556
      rec.HWDeviceDesc2 := lpD3DHWDeviceDesc;
5557
      rec.HELDeviceDesc2 := lpD3DHELDeviceDesc;
5558
      rec.DeviceDesc2 := lpD3DHWDeviceDesc;
5559
    end;
5560
 
5561
  begin
5562
    Result := D3DENUMRET_OK;
5563
 
4 daniel-mar 5564
    if lpD3DHWDeviceDesc.dcmColorModel = 0 then Exit;
1 daniel-mar 5565
 
5566
    if idoOptimizeDisplayMode in rec.Options then
5567
    begin
4 daniel-mar 5568
      if (lpD3DHWDeviceDesc.dwDeviceRenderBitDepth and (DDBD_16 or DDBD_24 or DDBD_32)) = 0 then Exit;
5569
    end
5570
    else
1 daniel-mar 5571
    begin
4 daniel-mar 5572
      if (lpD3DHWDeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then Exit;
1 daniel-mar 5573
    end;
5574
 
5575
    UseThisDevice;
5576
  end;
4 daniel-mar 5577
  {$ELSE}
5578
  function EnumDeviceCallBack(lpDeviceDescription: PAnsiChar; lpDeviceName: PAnsiChar;
5579
      const lpD3DDeviceDesc: TD3DDeviceDesc7; rec: PDirect3DInitializingRecord) : HResult; stdcall;
5580
  begin
5581
    Result := D3DENUMRET_OK;
1 daniel-mar 5582
 
4 daniel-mar 5583
    maxVideoBlockSize := Min(lpD3DDeviceDesc.dwMaxTextureWidth, lpD3DDeviceDesc.dwMaxTextureHeight);
5584
    SurfaceDivWidth := lpD3DDeviceDesc.dwMaxTextureWidth;
5585
    SurfaceDivHeight := lpD3DDeviceDesc.dwMaxTextureHeight;
5586
 
5587
    //if lpD3DHWDeviceDesc.dcmColorModel = 0 then Exit;
5588
    if idoOptimizeDisplayMode in rec.Options then
5589
    begin
5590
      if (lpD3DDeviceDesc.dwDeviceRenderBitDepth and (DDBD_16 or DDBD_24 or DDBD_32)) = 0 then Exit;
5591
    end
5592
    else
5593
    begin
5594
      if (lpD3DDeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then Exit;
5595
    end;
5596
 
5597
    rec.D3DFlag := True;
5598
    rec.DeviceDesc2 := lpD3DDeviceDesc;
5599
  end;
5600
  {$ENDIF}
5601
 
5602
  function EnumDirectDrawDriverCallback(lpGUID: PGUID; lpDriverDescription: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF};
5603
    lpDriverName: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF}; rec: PDirect3DInitializingRecord): HRESULT; stdcall;
1 daniel-mar 5604
  var
5605
    DDraw: TDirectDraw;
4 daniel-mar 5606
    {$IFDEF D3D_deprecated}
1 daniel-mar 5607
    Direct3D: IDirect3D;
4 daniel-mar 5608
    {$ENDIF}
1 daniel-mar 5609
    Direct3D7: IDirect3D7;
5610
 
5611
    function CountBitMask(i: DWORD; const Bits: array of DWORD): DWORD;
5612
    var
5613
      j: Integer;
5614
    begin
5615
      Result := 0;
5616
 
4 daniel-mar 5617
      for j := Low(Bits) to High(Bits) do
1 daniel-mar 5618
      begin
4 daniel-mar 5619
        if i and Bits[j] <> 0 then
1 daniel-mar 5620
          Inc(Result);
5621
      end;
5622
    end;
5623
 
5624
    function CompareCountBitMask(i, i2: DWORD; const Bits: array of DWORD): Integer;
5625
    var
5626
      j, j2: DWORD;
5627
    begin
5628
      j := CountBitMask(i, Bits);
5629
      j2 := CountBitMask(i2, Bits);
5630
 
4 daniel-mar 5631
      if j < j2 then
1 daniel-mar 5632
        Result := -1
4 daniel-mar 5633
      else if i > j2 then
1 daniel-mar 5634
        Result := 1
5635
      else
5636
        Result := 0;
5637
    end;
5638
 
5639
    function CountBit(i: DWORD): DWORD;
5640
    var
5641
      j: Integer;
5642
    begin
5643
      Result := 0;
5644
 
4 daniel-mar 5645
      for j := 0 to 31 do
5646
        if i and (1 shl j) <> 0 then
1 daniel-mar 5647
          Inc(Result);
5648
    end;
5649
 
5650
    function CompareCountBit(i, i2: DWORD): Integer;
5651
    begin
4 daniel-mar 5652
      Result := CountBit(i) - CountBit(i2);
5653
      if Result < 0 then Result := -1;
5654
      if Result > 0 then Result := 1;
1 daniel-mar 5655
    end;
5656
 
5657
    function FindDevice: Boolean;
5658
    begin
5659
      {  The Direct3D driver is examined.  }
5660
      rec.D3DFlag := False;
4 daniel-mar 5661
      try
5662
        {$IFDEF D3D_deprecated}Direct3D{$ELSE}Direct3D7{$ENDIF}.EnumDevices(@EnumDeviceCallBack, rec) {= DD_OK}
5663
      except
5664
        on E: Exception do
5665
        begin
5666
          rec.D3DFlag := False;
5667
          // eventually catch  exception to automatic log
5668
          Log(E.Message {$IFNDEF VER4UP}, ChangefileExt(ParamStr(0), '.log'){$ENDIF});
5669
          //and cannot continue !!!
5670
          Result := False;
5671
          Exit;
5672
        end;
5673
      end;
1 daniel-mar 5674
      Result := rec.D3DFlag;
5675
 
5676
      if not Result then Exit;
5677
 
5678
      {  Comparison of DirectDraw driver.  }
5679
      if not rec.Flag then
5680
      begin
4 daniel-mar 5681
        {$IFDEF D3D_deprecated}
1 daniel-mar 5682
        rec.HWDeviceDesc := rec.HWDeviceDesc2;
5683
        rec.HELDeviceDesc := rec.HELDeviceDesc2;
5684
        rec.DeviceDesc := rec.DeviceDesc2;
4 daniel-mar 5685
        {$ENDIF}
1 daniel-mar 5686
        rec.Flag := True;
4 daniel-mar 5687
      end
5688
      else
1 daniel-mar 5689
      begin
5690
        {  Comparison of hardware. (One with large number of functions to support is chosen.  }
5691
        Result := False;
5692
 
4 daniel-mar 5693
        if DDraw.DriverCaps.dwVidMemTotal < rec.DriverCaps.dwVidMemTotal then Exit;
5694
        {$IFDEF D3D_deprecated}
5695
        if CompareCountBitMask(DDraw.DriverCaps.ddscaps.dwCaps, rec.DriverCaps.ddscaps.dwCaps, [DDSCAPS_TEXTURE, DDSCAPS_ZBUFFER, DDSCAPS_MIPMAP]) +
5696
          CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwMiscCaps, rec.HWDeviceDesc2.dpcLineCaps.dwMiscCaps) +
5697
          CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwRasterCaps, rec.HWDeviceDesc2.dpcLineCaps.dwRasterCaps) +
5698
          CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwAlphaCmpCaps, rec.HWDeviceDesc2.dpcLineCaps.dwAlphaCmpCaps) +
5699
          CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwSrcBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwSrcBlendCaps) +
5700
          CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwDestBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwDestBlendCaps) +
5701
          CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwShadeCaps, rec.HWDeviceDesc2.dpcLineCaps.dwShadeCaps) +
5702
          CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureCaps) +
5703
          CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureFilterCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureFilterCaps) +
5704
          CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureBlendCaps) +
5705
          CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureAddressCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureAddressCaps) < 0 then Exit;
5706
        {$ENDIF}
1 daniel-mar 5707
        Result := True;
5708
      end;
5709
    end;
5710
 
5711
  begin
5712
    Result := DDENUMRET_OK;
5713
 
5714
    DDraw := TDirectDraw.Create(lpGUID);
5715
    try
4 daniel-mar 5716
      if (DDraw.DriverCaps.dwCaps and DDCAPS_3D <> 0) and
5717
        (DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE <> 0) then
1 daniel-mar 5718
      begin
4 daniel-mar 5719
        try
5720
        if DDraw.IDDraw7 <> nil then
1 daniel-mar 5721
          Direct3D7 := DDraw.IDraw7 as IDirect3D7
4 daniel-mar 5722
        {$IFDEF D3D_deprecated}
1 daniel-mar 5723
        else
4 daniel-mar 5724
          Direct3D := DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF} as IDirect3D
5725
        {$ENDIF};
5726
        except
5727
          on E: Exception do
5728
            log(E.Message {$IFNDEF VER4UP}, ChangefileExt(ParamStr(0), '.log'){$ENDIF});
5729
        end;
1 daniel-mar 5730
        try
5731
          if FindDevice then
5732
          begin
5733
            rec.DriverCaps := DDraw.DriverCaps;
5734
            rec.HELCaps := DDraw.HELCaps;
5735
 
4 daniel-mar 5736
            if lpGUID = nil then
1 daniel-mar 5737
              rec.Driver := nil
4 daniel-mar 5738
            else
5739
            begin
1 daniel-mar 5740
              rec.DriverGUID^ := lpGUID^;
5741
              rec.Driver^ := @rec.DriverGUID;
5742
            end;
5743
          end;
5744
        finally
4 daniel-mar 5745
          {$IFDEF D3D_deprecated}
1 daniel-mar 5746
          Direct3D := nil;
4 daniel-mar 5747
          {$ENDIF}
1 daniel-mar 5748
          Direct3D7 := nil;
5749
        end;
5750
      end;
5751
    finally
5752
      DDraw.Free;
5753
    end;
5754
  end;
5755
 
5756
var
5757
  rec: TDirect3DInitializingRecord;
5758
  DDraw: TDirectDraw;
4 daniel-mar 5759
  {$IFNDEF D3D_deprecated}
5760
  devGUID: Tguid;
5761
  {$ENDIF}
1 daniel-mar 5762
begin
5763
  FillChar(rec, SizeOf(rec), 0);
5764
  rec.BitCount := BitCount;
5765
  rec.Options := Options;
5766
 
5767
  {  Driver selection   }
5768
  if idoSelectDriver in Options then
5769
  begin
5770
    rec.Flag := False;
5771
    rec.Options := Options;
5772
    rec.Driver := @Driver;
5773
    rec.DriverGUID := @DriverGUID;
4 daniel-mar 5774
    DXDirectDrawEnumerate(@EnumDirectDrawDriverCallback, @rec);
5775
  end
5776
  else
1 daniel-mar 5777
  begin
5778
    DDraw := TDirectDraw.Create(Driver);
5779
    try
5780
      rec.DriverCaps := DDraw.DriverCaps;
5781
      rec.HELCaps := DDraw.HELCaps;
5782
 
5783
      rec.D3DFlag := False;
4 daniel-mar 5784
      (DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF} as IDirect3D).EnumDevices(@EnumDeviceCallBack, @rec);
1 daniel-mar 5785
      if rec.D3DFlag then
4 daniel-mar 5786
        {$IFDEF D3D_deprecated}
1 daniel-mar 5787
        rec.DeviceDesc := rec.DeviceDesc2;
4 daniel-mar 5788
        {$ELSE}
5789
        rec.DeviceDesc := rec.DeviceDesc2;
5790
        {$ENDIF}
1 daniel-mar 5791
    finally
5792
      DDraw.Free;
5793
    end;
5794
    rec.Flag := True;
5795
  end;
5796
 
5797
  {  Display mode optimization  }
5798
  if rec.Flag and (idoOptimizeDisplayMode in Options) then
5799
  begin
4 daniel-mar 5800
    if (rec.DeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then
1 daniel-mar 5801
    begin
4 daniel-mar 5802
      if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_16 <> 0 then
1 daniel-mar 5803
        rec.BitCount := 16
4 daniel-mar 5804
      else
5805
      if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_24 <> 0 then
1 daniel-mar 5806
        rec.BitCount := 24
4 daniel-mar 5807
      else if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_32 <> 0 then
1 daniel-mar 5808
        rec.BitCount := 32;
5809
    end;
5810
  end;
5811
 
4 daniel-mar 5812
  {test type of device}
5813
  {$IFNDEF D3D_deprecated}
5814
  D3DDeviceTypeSet := [];
5815
 
5816
  Move(rec.DeviceDesc2.deviceGUID, devGUID, Sizeof(TGUID) );
5817
 
5818
  if CompareMem(@devGUID, @IID_IDirect3DTnLHalDevice, Sizeof(TGUID)) then
5819
    D3DDeviceTypeSet := D3DDeviceTypeSet + [dtTnLHAL];
5820
 
5821
  if CompareMem(@devGUID, @IID_IDirect3DHALDEVICE, Sizeof(TGUID)) then
5822
    D3DDeviceTypeSet := D3DDeviceTypeSet + [dtHAL];
5823
 
5824
  if CompareMem(@devGUID, @IID_IDirect3DMMXDevice, Sizeof(TGUID)) then
5825
    D3DDeviceTypeSet := D3DDeviceTypeSet + [dtMMX];
5826
 
5827
  if CompareMem(@devGUID, @IID_IDirect3DRGBDevice, Sizeof(TGUID)) then
5828
    D3DDeviceTypeSet := D3DDeviceTypeSet + [dtRGB];
5829
 
5830
  if CompareMem(@devGUID, @IID_IDirect3DRampDevice, Sizeof(TGUID)) then
5831
    D3DDeviceTypeSet := D3DDeviceTypeSet + [dtRamp];
5832
 
5833
  if CompareMem(@devGUID, @IID_IDirect3DRefDevice, Sizeof(TGUID)) then
5834
    D3DDeviceTypeSet := D3DDeviceTypeSet + [dtRef];
5835
  {$ENDIF}
1 daniel-mar 5836
  BitCount := rec.BitCount;
5837
end;
5838
 
5839
procedure Direct3DInitializing_DXDraw(Options: TInitializeDirect3DOptions;
5840
  DXDraw: TCustomDXDraw);
5841
var
5842
  BitCount: Integer;
5843
  Driver: PGUID;
5844
  DriverGUID: TGUID;
4 daniel-mar 5845
  {$IFNDEF D3D_deprecated}
5846
  D3DDeviceTypeSet: TD3DDeviceTypeSet;
5847
  {$ENDIF}
1 daniel-mar 5848
begin
5849
  BitCount := DXDraw.Display.BitCount;
5850
  Driver := DXDraw.Driver;
4 daniel-mar 5851
  Direct3DInitializing(Options, BitCount, Driver, DriverGUID{$IFNDEF D3D_deprecated}, D3DDeviceTypeSet{$ENDIF});
1 daniel-mar 5852
  DXDraw.Driver := Driver;
5853
  DXDraw.Display.BitCount := BitCount;
4 daniel-mar 5854
  {$IFNDEF D3D_deprecated}
5855
  DXDraw.FDeviceTypeSet := D3DDeviceTypeSet;
5856
  {$ENDIF}
1 daniel-mar 5857
end;
5858
 
4 daniel-mar 5859
{$IFDEF D3D_deprecated}
1 daniel-mar 5860
procedure InitializeDirect3D(Surface: TDirectDrawSurface;
5861
  var ZBuffer: TDirectDrawSurface;
5862
  out D3D: IDirect3D;
5863
  out D3D2: IDirect3D2;
5864
  out D3D3: IDirect3D3;
5865
  out D3DDevice: IDirect3DDevice;
5866
  out D3DDevice2: IDirect3DDevice2;
5867
  out D3DDevice3: IDirect3DDevice3;
4 daniel-mar 5868
{$IFDEF D3DRM}
1 daniel-mar 5869
  var D3DRM: IDirect3DRM;
5870
  var D3DRM2: IDirect3DRM2;
5871
  var D3DRM3: IDirect3DRM3;
5872
  out D3DRMDevice: IDirect3DRMDevice;
5873
  out D3DRMDevice2: IDirect3DRMDevice2;
5874
  out D3DRMDevice3: IDirect3DRMDevice3;
5875
  out Viewport: IDirect3DRMViewport;
5876
  var Scene: IDirect3DRMFrame;
5877
  var Camera: IDirect3DRMFrame;
4 daniel-mar 5878
{$ENDIF}
1 daniel-mar 5879
  var NowOptions: TInitializeDirect3DOptions);
5880
type
5881
  TInitializeDirect3DRecord = record
5882
    Flag: Boolean;
5883
    BitCount: Integer;
5884
    HWDeviceDesc: TD3DDeviceDesc;
5885
    HELDeviceDesc: TD3DDeviceDesc;
5886
    DeviceDesc: TD3DDeviceDesc;
5887
    Hardware: Boolean;
5888
    Options: TInitializeDirect3DOptions;
5889
    GUID: TGUID;
5890
    SupportHardware: Boolean;
5891
  end;
5892
 
5893
  function CreateZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface;
5894
    const DeviceDesc: TD3DDeviceDesc; Hardware: Boolean): Boolean;
5895
  const
5896
    MemPosition: array[Boolean] of Integer = (DDSCAPS_SYSTEMMEMORY, DDSCAPS_VIDEOMEMORY);
5897
  var
5898
    ZBufferBitDepth: Integer;
5899
    ddsd: TDDSurfaceDesc;
5900
  begin
5901
    Result := False;
5902
    FreeZBufferSurface(Surface, ZBuffer);
5903
 
4 daniel-mar 5904
    if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_16 <> 0 then
1 daniel-mar 5905
      ZBufferBitDepth := 16
4 daniel-mar 5906
    else
5907
    if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_24 <> 0 then
1 daniel-mar 5908
      ZBufferBitDepth := 24
4 daniel-mar 5909
    else
5910
    if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_32 <> 0 then
1 daniel-mar 5911
      ZBufferBitDepth := 32
5912
    else
5913
      ZBufferBitDepth := 0;
5914
 
4 daniel-mar 5915
    if ZBufferBitDepth <> 0 then
1 daniel-mar 5916
    begin
5917
      with ddsd do
5918
      begin
5919
        dwSize := SizeOf(ddsd);
5920
        Surface.ISurface.GetSurfaceDesc(ddsd);
5921
        dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT or DDSD_ZBUFFERBITDEPTH;
5922
        ddsCaps.dwCaps := DDSCAPS_ZBUFFER or MemPosition[Hardware];
5923
        dwHeight := Surface.Height;
5924
        dwWidth := Surface.Width;
5925
        dwZBufferBitDepth := ZBufferBitDepth;
5926
      end;
5927
 
5928
      ZBuffer := TDirectDrawSurface.Create(Surface.DDraw);
5929
      if ZBuffer.CreateSurface(ddsd) then
5930
      begin
4 daniel-mar 5931
        if Surface.ISurface.AddAttachedSurface(ZBuffer.ISurface) <> DD_OK then
1 daniel-mar 5932
        begin
5933
          ZBuffer.Free; ZBuffer := nil;
5934
          Exit;
5935
        end;
5936
        Result := True;
5937
      end else
5938
      begin
5939
        ZBuffer.Free; ZBuffer := nil;
5940
        Exit;
5941
      end;
5942
    end;
5943
  end;
5944
 
5945
  function EnumDeviceCallBack(const lpGuid: TGUID; lpDeviceDescription, lpDeviceName: PChar;
5946
    const lpD3DHWDeviceDesc, lpD3DHELDeviceDesc: TD3DDeviceDesc;
5947
    lpUserArg: Pointer): HRESULT; stdcall;
5948
  var
5949
    dev: ^TD3DDeviceDesc;
5950
    Hardware: Boolean;
5951
    rec: ^TInitializeDirect3DRecord;
5952
 
5953
    procedure UseThisDevice;
5954
    begin
5955
      rec.Flag := True;
5956
      rec.GUID := lpGUID;
5957
      rec.HWDeviceDesc := lpD3DHWDeviceDesc;
5958
      rec.HELDeviceDesc := lpD3DHELDeviceDesc;
5959
      rec.DeviceDesc := dev^;
5960
      rec.Hardware := Hardware;
5961
    end;
5962
 
5963
  begin
5964
    Result := D3DENUMRET_OK;
5965
    rec := lpUserArg;
5966
 
4 daniel-mar 5967
    Hardware := lpD3DHWDeviceDesc.dcmColorModel <> 0;
1 daniel-mar 5968
    if Hardware then
5969
      dev := @lpD3DHWDeviceDesc
5970
    else
5971
      dev := @lpD3DHELDeviceDesc;
5972
 
5973
    if (Hardware) and (not rec.SupportHardware) then Exit;
4 daniel-mar 5974
    if dev.dcmColorModel <> D3DCOLOR_RGB then Exit;
1 daniel-mar 5975
    if CompareMem(@lpGUID, @IID_IDirect3DRefDevice, SizeOf(TGUID)) then Exit;
5976
 
5977
    {  Bit depth test.  }
4 daniel-mar 5978
    if (dev.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then Exit;
1 daniel-mar 5979
 
5980
    if Hardware then
5981
    begin
5982
      {  Hardware  }
5983
      UseThisDevice;
5984
    end else
5985
    begin
5986
      {  Software  }
5987
      if not rec.Hardware then
5988
        UseThisDevice;
5989
    end;
5990
  end;
5991
 
5992
var
5993
  Hardware: Boolean;
5994
  SupportHardware: Boolean;
5995
  D3DDeviceGUID: TGUID;
5996
  Options: TInitializeDirect3DOptions;
5997
 
5998
  procedure InitDevice;
5999
  var
6000
    rec: TInitializeDirect3DRecord;
6001
  begin
6002
    {  Device search  }
6003
    rec.Flag := False;
6004
    rec.BitCount := Surface.BitCount;
6005
    rec.Hardware := False;
6006
    rec.Options := Options;
6007
    rec.SupportHardware := SupportHardware;
6008
 
6009
    D3D3.EnumDevices(@EnumDeviceCallBack, @rec);
6010
    if not rec.Flag then
6011
      raise EDXDrawError.Create(S3DDeviceNotFound);
6012
 
6013
    Hardware := rec.Hardware;
6014
    D3DDeviceGUID := rec.GUID;
6015
 
6016
    if Hardware then
6017
      NowOptions := NowOptions + [idoHardware];
6018
 
6019
    {  Z buffer making  }
6020
    NowOptions := NowOptions - [idoZBuffer];
6021
    if idoZBuffer in Options then
6022
    begin
6023
      if CreateZBufferSurface(Surface, ZBuffer, rec.DeviceDesc, Hardware) then
6024
        NowOptions := NowOptions + [idoZBuffer];
6025
    end;
6026
  end;
4 daniel-mar 6027
{$IFDEF D3DRM}
1 daniel-mar 6028
type
4 daniel-mar 6029
  TDirect3DRMCreate = function(out lplpDirect3DRM: IDirect3DRM): HRESULT; stdcall;
6030
{$ENDIF}
1 daniel-mar 6031
begin
6032
  try
6033
    Options := NowOptions;
6034
    NowOptions := [];
6035
 
6036
    D3D3 := Surface.DDraw.IDraw as IDirect3D3;
6037
    D3D2 := D3D3 as IDirect3D2;
6038
    D3D := D3D3 as IDirect3D;
6039
 
6040
    {  Whether hardware can be used is tested.  }
4 daniel-mar 6041
    SupportHardware := (Surface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_VIDEOMEMORY <> 0) and
6042
      (idoHardware in Options) and (Surface.DDraw.DriverCaps.dwCaps and DDCAPS_3D <> 0);
1 daniel-mar 6043
 
4 daniel-mar 6044
    if Surface.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE = 0 then
1 daniel-mar 6045
      SupportHardware := False;
6046
 
6047
    {  Direct3D  }
6048
    InitDevice;
6049
 
4 daniel-mar 6050
    if D3D3.CreateDevice(D3DDeviceGUID, Surface.ISurface4, D3DDevice3, nil) <> D3D_OK then
1 daniel-mar 6051
    begin
6052
      SupportHardware := False;
6053
      InitDevice;
4 daniel-mar 6054
      if D3D3.CreateDevice(D3DDeviceGUID, Surface.ISurface4, D3DDevice3, nil) <> D3D_OK then
1 daniel-mar 6055
        raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DDevice3']);
6056
    end;
6057
 
6058
    if SupportHardware then NowOptions := NowOptions + [idoHardware];
6059
 
6060
    D3DDevice2 := D3DDevice3 as IDirect3DDevice2;
6061
    D3DDevice := D3DDevice3 as IDirect3DDevice;
6062
 
6063
    with D3DDevice3 do
6064
    begin
6065
      SetRenderState(TD3DRenderStateType(D3DRENDERSTATE_DITHERENABLE), 1);
4 daniel-mar 6066
      SetRenderState(TD3DRenderStateType(D3DRENDERSTATE_ZENABLE), Ord(ZBuffer <> nil));
6067
      SetRenderState(TD3DRenderStateType(D3DRENDERSTATE_ZWRITEENABLE), Ord(ZBuffer <> nil));
1 daniel-mar 6068
    end;
4 daniel-mar 6069
{$IFDEF D3DRM}
1 daniel-mar 6070
    {  Direct3D Retained Mode}
6071
    if idoRetainedMode in Options then
6072
    begin
6073
      NowOptions := NowOptions + [idoRetainedMode];
4 daniel-mar 6074
      if D3DRM = nil then
1 daniel-mar 6075
      begin
4 daniel-mar 6076
        if TDirect3DRMCreate(DXLoadLibrary('D3DRM.dll', 'Direct3DRMCreate'))(D3DRM) <> D3DRM_OK then
1 daniel-mar 6077
          raise EDXDrawError.CreateFmt(SCannotInitialized, [SDirect3DRM]);
6078
        D3DRM2 := D3DRM as IDirect3DRM2;
6079
        D3DRM3 := D3DRM as IDirect3DRM3;
6080
      end;
6081
 
4 daniel-mar 6082
      if D3DRM3.CreateDeviceFromD3D(D3D2, D3DDevice2, D3DRMDevice3) <> D3DRM_OK then
1 daniel-mar 6083
        raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DRMDevice2']);
6084
 
6085
      D3DRMDevice3.SetBufferCount(2);
6086
      D3DRMDevice := D3DRMDevice3 as IDirect3DRMDevice;
6087
      D3DRMDevice2 := D3DRMDevice3 as IDirect3DRMDevice2;
6088
 
6089
      {  Rendering state setting  }
6090
      D3DRMDevice.SetQuality(D3DRMLIGHT_ON or D3DRMFILL_SOLID or D3DRMSHADE_GOURAUD);
6091
      D3DRMDevice.SetTextureQuality(D3DRMTEXTURE_NEAREST);
6092
      D3DRMDevice.SetDither(True);
6093
 
4 daniel-mar 6094
      if Surface.BitCount = 8 then
1 daniel-mar 6095
      begin
6096
        D3DRMDevice.SetShades(8);
6097
        D3DRM.SetDefaultTextureColors(64);
6098
        D3DRM.SetDefaultTextureShades(32);
6099
      end else
6100
      begin
6101
        D3DRM.SetDefaultTextureColors(64);
6102
        D3DRM.SetDefaultTextureShades(32);
6103
      end;
6104
 
6105
      {  Frame making  }
4 daniel-mar 6106
      if Scene = nil then
1 daniel-mar 6107
      begin
6108
        D3DRM.CreateFrame(nil, Scene);
6109
        D3DRM.CreateFrame(Scene, Camera);
6110
        Camera.SetPosition(Camera, 0, 0, 0);
6111
      end;
6112
 
6113
      {  Viewport making  }
6114
      D3DRM.CreateViewport(D3DRMDevice, Camera, 0, 0,
6115
        Surface.Width, Surface.Height, Viewport);
6116
      Viewport.SetBack(5000.0);
6117
    end;
4 daniel-mar 6118
{$ENDIF}
6119
   except
1 daniel-mar 6120
    FreeZBufferSurface(Surface, ZBuffer);
6121
    D3D := nil;
6122
    D3D2 := nil;
6123
    D3D3 := nil;
6124
    D3DDevice := nil;
6125
    D3DDevice2 := nil;
6126
    D3DDevice3 := nil;
4 daniel-mar 6127
{$IFDEF D3DRM}
1 daniel-mar 6128
    D3DRM := nil;
6129
    D3DRM2 := nil;
6130
    D3DRMDevice := nil;
6131
    D3DRMDevice2 := nil;
6132
    Viewport := nil;
6133
    Scene := nil;
6134
    Camera := nil;
4 daniel-mar 6135
{$ENDIF}
1 daniel-mar 6136
    raise;
6137
  end;
6138
end;
4 daniel-mar 6139
{$ENDIF}
1 daniel-mar 6140
 
6141
procedure InitializeDirect3D7(Surface: TDirectDrawSurface;
6142
  var ZBuffer: TDirectDrawSurface;
6143
  out D3D7: IDirect3D7;
6144
  out D3DDevice7: IDirect3DDevice7;
6145
  var NowOptions: TInitializeDirect3DOptions);
6146
type
6147
  TInitializeDirect3DRecord = record
6148
    Flag: Boolean;
6149
    BitCount: Integer;
6150
    DeviceDesc: TD3DDeviceDesc7;
6151
    Hardware: Boolean;
6152
    Options: TInitializeDirect3DOptions;
6153
    SupportHardware: Boolean;
6154
  end;
6155
 
6156
  function CreateZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface;
6157
    const DeviceDesc: TD3DDeviceDesc7; Hardware: Boolean): Boolean;
6158
  const
6159
    MemPosition: array[Boolean] of Integer = (DDSCAPS_SYSTEMMEMORY, DDSCAPS_VIDEOMEMORY);
6160
  var
6161
    ZBufferBitDepth: Integer;
4 daniel-mar 6162
    ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 6163
  begin
6164
    Result := False;
6165
    FreeZBufferSurface(Surface, ZBuffer);
6166
 
4 daniel-mar 6167
    if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_16 <> 0 then
1 daniel-mar 6168
      ZBufferBitDepth := 16
4 daniel-mar 6169
    else if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_24 <> 0 then
1 daniel-mar 6170
      ZBufferBitDepth := 24
4 daniel-mar 6171
    else if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_32 <> 0 then
1 daniel-mar 6172
      ZBufferBitDepth := 32
6173
    else
6174
      ZBufferBitDepth := 0;
6175
 
4 daniel-mar 6176
    if ZBufferBitDepth <> 0 then
1 daniel-mar 6177
    begin
6178
      with ddsd do
6179
      begin
6180
        dwSize := SizeOf(ddsd);
4 daniel-mar 6181
        Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetSurfaceDesc(ddsd);
1 daniel-mar 6182
        dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT or DDSD_ZBUFFERBITDEPTH;
6183
        ddsCaps.dwCaps := DDSCAPS_ZBUFFER or MemPosition[Hardware];
6184
        dwHeight := Surface.Height;
6185
        dwWidth := Surface.Width;
4 daniel-mar 6186
        {$IFDEF D3D_deprecated}
1 daniel-mar 6187
        dwZBufferBitDepth := ZBufferBitDepth;
4 daniel-mar 6188
        {$ELSE}
6189
        ddpfPixelFormat.dwFlags := DDPF_ZBUFFER;
6190
        ddpfPixelFormat.dwZBufferBitDepth := ZBufferBitDepth;
6191
        ddpfPixelFormat.dwStencilBitDepth := 0;
6192
        ddpfPixelFormat.dwZBitMask := (1 shl ZBufferBitDepth) - 1;
6193
        ddpfPixelFormat.dwStencilBitMask := 0;
6194
        ddpfPixelFormat.dwLuminanceAlphaBitMask := 0;
6195
        {$ENDIF}
1 daniel-mar 6196
      end;
6197
 
6198
      ZBuffer := TDirectDrawSurface.Create(Surface.DDraw);
6199
      if ZBuffer.CreateSurface(ddsd) then
6200
      begin
4 daniel-mar 6201
        if Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.AddAttachedSurface(ZBuffer.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}) <> DD_OK then
1 daniel-mar 6202
        begin
6203
          ZBuffer.Free; ZBuffer := nil;
6204
          Exit;
6205
        end;
6206
        Result := True;
6207
      end else
6208
      begin
6209
        ZBuffer.Free; ZBuffer := nil;
6210
        Exit;
6211
      end;
6212
    end;
6213
  end;
6214
 
6215
  function EnumDeviceCallBack(lpDeviceDescription, lpDeviceName: PChar;
6216
    const lpTD3DDeviceDesc: TD3DDeviceDesc7; lpUserArg: Pointer): HRESULT; stdcall;
6217
  var
6218
    Hardware: Boolean;
6219
    rec: ^TInitializeDirect3DRecord;
6220
 
6221
    procedure UseThisDevice;
6222
    begin
6223
      rec.Flag := True;
6224
      rec.DeviceDesc := lpTD3DDeviceDesc;
6225
      rec.Hardware := Hardware;
6226
    end;
6227
 
6228
  begin
6229
    Result := D3DENUMRET_OK;
6230
    rec := lpUserArg;
6231
 
4 daniel-mar 6232
    Hardware := lpTD3DDeviceDesc.dwDevCaps and D3DDEVCAPS_HWRASTERIZATION <> 0;
1 daniel-mar 6233
 
6234
    if Hardware and (not rec.SupportHardware) then Exit;
6235
    if CompareMem(@lpTD3DDeviceDesc.deviceGUID, @IID_IDirect3DRefDevice, SizeOf(TGUID)) then Exit;
6236
 
6237
    {  Bit depth test.  }
4 daniel-mar 6238
    if (lpTD3DDeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount)) = 0 then Exit;
1 daniel-mar 6239
 
6240
    if Hardware then
6241
    begin
6242
      {  Hardware  }
6243
      UseThisDevice;
6244
    end else
6245
    begin
6246
      {  Software  }
6247
      if not rec.Hardware then
6248
        UseThisDevice;
6249
    end;
6250
  end;
6251
 
6252
var
6253
  Hardware: Boolean;
6254
  SupportHardware: Boolean;
6255
  D3DDeviceGUID: TGUID;
6256
  Options: TInitializeDirect3DOptions;
6257
 
6258
  procedure InitDevice;
6259
  var
6260
    rec: TInitializeDirect3DRecord;
6261
  begin
6262
    {  Device search  }
6263
    rec.Flag := False;
6264
    rec.BitCount := Surface.BitCount;
6265
    rec.Hardware := False;
6266
    rec.Options := Options;
6267
    rec.SupportHardware := SupportHardware;
6268
 
6269
    D3D7.EnumDevices(@EnumDeviceCallBack, @rec);
6270
    if not rec.Flag then
6271
      raise EDXDrawError.Create(S3DDeviceNotFound);
6272
 
6273
    Hardware := rec.Hardware;
6274
    D3DDeviceGUID := rec.DeviceDesc.deviceGUID;
6275
 
6276
    if Hardware then
6277
      NowOptions := NowOptions + [idoHardware];
6278
 
6279
    {  Z buffer making  }
6280
    NowOptions := NowOptions - [idoZBuffer];
6281
    if idoZBuffer in Options then
6282
    begin
6283
      if CreateZBufferSurface(Surface, ZBuffer, rec.DeviceDesc, Hardware) then
6284
        NowOptions := NowOptions + [idoZBuffer];
6285
    end;
6286
  end;
6287
 
6288
begin
4 daniel-mar 6289
 
1 daniel-mar 6290
  try
4 daniel-mar 6291
    Options := NowOptions {$IFDEF D3DRM}- [idoRetainedMode]{$ENDIF};
1 daniel-mar 6292
    NowOptions := [];
6293
 
6294
    D3D7 := Surface.DDraw.IDraw7 as IDirect3D7;
6295
 
6296
    {  Whether hardware can be used is tested.  }
4 daniel-mar 6297
    SupportHardware := (Surface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_VIDEOMEMORY <> 0) and
6298
      (idoHardware in Options) and (Surface.DDraw.DriverCaps.dwCaps and DDCAPS_3D <> 0) and
6299
      (Surface.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE <> 0);
1 daniel-mar 6300
 
6301
    {  Direct3D  }
6302
    InitDevice;
6303
 
4 daniel-mar 6304
    if D3D7.CreateDevice(D3DDeviceGUID, Surface.ISurface7, D3DDevice7) <> D3D_OK then
1 daniel-mar 6305
    begin
6306
      SupportHardware := False;
6307
      InitDevice;
4 daniel-mar 6308
      if D3D7.CreateDevice(D3DDeviceGUID, Surface.ISurface7, D3DDevice7) <> D3D_OK then
1 daniel-mar 6309
        raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DDevice7']);
6310
    end;
6311
 
6312
    if SupportHardware then NowOptions := NowOptions + [idoHardware];
6313
  except
6314
    FreeZBufferSurface(Surface, ZBuffer);
6315
    D3D7 := nil;
6316
    D3DDevice7 := nil;
6317
    raise;
6318
  end;
6319
end;
6320
type
6321
 
4 daniel-mar 6322
{  TDXDrawDriver  }
6323
 
1 daniel-mar 6324
  TDXDrawDriver = class
6325
  private
6326
    FDXDraw: TCustomDXDraw;
6327
    constructor Create(ADXDraw: TCustomDXDraw); virtual;
6328
    destructor Destroy; override;
6329
    procedure Finalize; virtual;
6330
    procedure Flip; virtual; abstract;
6331
    procedure Initialize; virtual; abstract;
6332
    procedure Initialize3D;
6333
    function SetSize(AWidth, AHeight: Integer): Boolean; virtual;
6334
    function Restore: Boolean;
6335
  end;
6336
 
6337
  TDXDrawDriverBlt = class(TDXDrawDriver)
6338
  private
6339
    procedure Flip; override;
6340
    procedure Initialize; override;
6341
    procedure InitializeSurface;
6342
    function SetSize(AWidth, AHeight: Integer): Boolean; override;
6343
  end;
6344
 
6345
  TDXDrawDriverFlip = class(TDXDrawDriver)
6346
  private
6347
    procedure Flip; override;
6348
    procedure Initialize; override;
6349
  end;
6350
 
4 daniel-mar 6351
procedure TCustomDXDraw.MirrorFlip(Value: TRenderMirrorFlipSet);
6352
begin
6353
  if CheckD3 then
6354
    FD2D.MirrorFlip := Value;
6355
end;
6356
 
6357
procedure TCustomDXDraw.SaveTextures(path: string);
6358
begin
6359
  if CheckD3 then
6360
    FD2D.SaveTextures(path)
6361
end;
1 daniel-mar 6362
{  TDXDrawDriver  }
6363
 
6364
constructor TDXDrawDriver.Create(ADXDraw: TCustomDXDraw);
6365
var
6366
  AOptions: TInitializeDirect3DOptions;
6367
begin
6368
  inherited Create;
6369
  FDXDraw := ADXDraw;
6370
 
6371
  {  Driver selection and Display mode optimizationn }
4 daniel-mar 6372
  if FDXDraw.FOptions * [doFullScreen, doSystemMemory, {$IFDEF D3D_deprecated}do3D,{$ENDIF} doHardware] =
6373
    [doFullScreen, {$IFDEF D3D_deprecated}do3D,{$ENDIF} doHardware] then
1 daniel-mar 6374
  begin
6375
    AOptions := [];
6376
    with FDXDraw do
6377
    begin
6378
      if doSelectDriver in Options then AOptions := AOptions + [idoSelectDriver];
6379
      if not FDXDraw.Display.FixedBitCount then AOptions := AOptions + [idoOptimizeDisplayMode];
6380
 
6381
      if doHardware in Options then AOptions := AOptions + [idoHardware];
4 daniel-mar 6382
      {$IFDEF D3DRM}if doRetainedMode in Options then AOptions := AOptions + [idoRetainedMode];{$ENDIF}
1 daniel-mar 6383
      if doZBuffer in Options then AOptions := AOptions + [idoZBuffer];
6384
    end;
6385
 
6386
    Direct3DInitializing_DXDraw(AOptions, FDXDraw);
6387
  end;
6388
 
4 daniel-mar 6389
  if FDXDraw.Options * [doFullScreen, doHardware, doSystemMemory] = [doFullScreen, doHardware] then
6390
    FDXDraw.FDDraw := TDirectDraw.CreateEx(PGUID(FDXDraw.FDriver), {$IFDEF D3D_deprecated}doDirectX7Mode in FDXDraw.Options{$ELSE}True{$ENDIF})
1 daniel-mar 6391
  else
4 daniel-mar 6392
    FDXDraw.FDDraw := TDirectDraw.CreateEx(nil, {$IFDEF D3D_deprecated}doDirectX7Mode in FDXDraw.Options{$ELSE}True{$ENDIF});
1 daniel-mar 6393
end;
6394
 
6395
procedure TDXDrawDriver.Initialize3D;
6396
const
4 daniel-mar 6397
  DXDrawOptions3D = [doHardware, {$IFDEF D3DRM}doRetainedMode,{$ENDIF} doSelectDriver, doZBuffer];
1 daniel-mar 6398
var
6399
  AOptions: TInitializeDirect3DOptions;
6400
begin
6401
  AOptions := [];
6402
  with FDXDraw do
6403
  begin
6404
    if doHardware in FOptions then AOptions := AOptions + [idoHardware];
4 daniel-mar 6405
    {$IFDEF D3DRM}if doRetainedMode in FNowOptions then AOptions := AOptions + [idoRetainedMode];{$ENDIF}
1 daniel-mar 6406
    if doSelectDriver in FOptions then AOptions := AOptions + [idoSelectDriver];
6407
    if doZBuffer in FOptions then AOptions := AOptions + [idoZBuffer];
4 daniel-mar 6408
    {$IFDEF D3D_deprecated}
1 daniel-mar 6409
    if doDirectX7Mode in FOptions then
6410
    begin
6411
      InitializeDirect3D7(FSurface, FZBuffer, FD3D7, FD3DDevice7, AOptions);
6412
    end else
6413
    begin
6414
      InitializeDirect3D(FSurface, FZBuffer, FD3D, FD3D2, FD3D3, FD3DDevice, FD3DDevice2, FD3DDevice3,
4 daniel-mar 6415
        {$IFDEF D3DRM}
6416
        FD3DRM, FD3DRM2, FD3DRM3, FD3DRMDevice, FD3DRMDevice2, FD3DRMDevice3, FViewport, FScene, FCamera,
6417
        {$ENDIF}
6418
        AOptions);
1 daniel-mar 6419
    end;
4 daniel-mar 6420
    {$ELSE}
6421
    InitializeDirect3D7(FSurface, FZBuffer, FD3D7, FD3DDevice7, AOptions);
6422
    {$ENDIF}
1 daniel-mar 6423
    FNowOptions := FNowOptions - DXDrawOptions3D;
6424
    if idoHardware in AOptions then FNowOptions := FNowOptions + [doHardware];
4 daniel-mar 6425
    {$IFDEF D3DRM}if idoRetainedMode in AOptions then FNowOptions := FNowOptions + [doRetainedMode];{$ENDIF}
1 daniel-mar 6426
    if idoSelectDriver in AOptions then FNowOptions := FNowOptions + [doSelectDriver];
6427
    if idoZBuffer in AOptions then FNowOptions := FNowOptions + [doZBuffer];
6428
  end;
6429
end;
6430
 
6431
destructor TDXDrawDriver.Destroy;
6432
begin
6433
  Finalize;
6434
  FDXDraw.FDDraw.Free;
6435
  inherited Destroy;
6436
end;
6437
 
6438
procedure TDXDrawDriver.Finalize;
6439
begin
6440
  with FDXDraw do
6441
  begin
4 daniel-mar 6442
    {$IFDEF D3DRM}
1 daniel-mar 6443
    FViewport := nil;
6444
    FCamera := nil;
6445
    FScene := nil;
6446
 
6447
    FD3DRMDevice := nil;
6448
    FD3DRMDevice2 := nil;
6449
    FD3DRMDevice3 := nil;
4 daniel-mar 6450
    FD3DRM3 := nil;
6451
    FD3DRM2 := nil;
6452
    FD3DRM := nil;
6453
    {$ENDIF}
6454
    {$IFDEF D3D_deprecated}
1 daniel-mar 6455
    FD3DDevice := nil;
6456
    FD3DDevice2 := nil;
6457
    FD3DDevice3 := nil;
4 daniel-mar 6458
    {$ENDIF}
1 daniel-mar 6459
    FD3DDevice7 := nil;
4 daniel-mar 6460
    {$IFDEF D3D_deprecated}
1 daniel-mar 6461
    FD3D := nil;
6462
    FD3D2 := nil;
6463
    FD3D3 := nil;
4 daniel-mar 6464
    {$ENDIF}
1 daniel-mar 6465
    FD3D7 := nil;
6466
 
6467
    FreeZBufferSurface(FSurface, FZBuffer);
6468
 
4 daniel-mar 6469
    FClipper.Free; FClipper := nil;
6470
    FPalette.Free; FPalette := nil;
6471
    FSurface.Free; FSurface := nil;
6472
    FPrimary.Free; FPrimary := nil;
1 daniel-mar 6473
 
6474
  end;
6475
end;
6476
 
6477
function TDXDrawDriver.Restore: Boolean;
6478
begin
6479
  Result := FDXDraw.FPrimary.Restore and FDXDraw.FSurface.Restore;
6480
  if Result then
6481
  begin
6482
    FDXDraw.FPrimary.Fill(0);
6483
    FDXDraw.FSurface.Fill(0);
6484
  end;
6485
end;
6486
 
6487
function TDXDrawDriver.SetSize(AWidth, AHeight: Integer): Boolean;
6488
begin
6489
  Result := False;
6490
end;
6491
 
6492
{  TDXDrawDriverBlt  }
6493
 
6494
function TDXDrawRGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads;
6495
  AllowPalette256: Boolean): TPaletteEntries;
6496
var
6497
  Entries: TPaletteEntries;
6498
  dc: THandle;
6499
  i: Integer;
6500
begin
6501
  Result := RGBQuadsToPaletteEntries(RGBQuads);
6502
 
6503
  if not AllowPalette256 then
6504
  begin
6505
    dc := GetDC(0);
4 daniel-mar 6506
    try
6507
      GetSystemPaletteEntries(dc, 0, 256, Entries);
6508
    finally
6509
      ReleaseDC(0, dc);
6510
    end;
1 daniel-mar 6511
 
4 daniel-mar 6512
    for i := 0 to 9 do
1 daniel-mar 6513
      Result[i] := Entries[i];
6514
 
4 daniel-mar 6515
    for i := 256 - 10 to 255 do
1 daniel-mar 6516
      Result[i] := Entries[i];
6517
  end;
6518
 
4 daniel-mar 6519
  for i := 0 to 255 do
1 daniel-mar 6520
    Result[i].peFlags := D3DPAL_READONLY;
6521
end;
6522
 
6523
procedure TDXDrawDriverBlt.Flip;
6524
var
6525
  pt: TPoint;
6526
  Dest: TRect;
6527
  DF: TDDBltFX;
6528
begin
6529
  pt := FDXDraw.ClientToScreen(Point(0, 0));
6530
 
6531
  if doStretch in FDXDraw.NowOptions then
6532
  begin
6533
    Dest := Bounds(pt.x, pt.y, FDXDraw.Width, FDXDraw.Height);
6534
  end else
6535
  begin
6536
    if doCenter in FDXDraw.NowOptions then
6537
    begin
4 daniel-mar 6538
      Inc(pt.x, (FDXDraw.Width - FDXDraw.FSurface.Width) div 2);
6539
      Inc(pt.y, (FDXDraw.Height - FDXDraw.FSurface.Height) div 2);
1 daniel-mar 6540
    end;
6541
 
6542
    Dest := Bounds(pt.x, pt.y, FDXDraw.FSurface.Width, FDXDraw.FSurface.Height);
6543
  end;
6544
 
6545
  if doWaitVBlank in FDXDraw.NowOptions then
4 daniel-mar 6546
    FDXDraw.FDDraw.DXResult := FDXDraw.FDDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.WaitForVerticalBlank(DDWAITVB_BLOCKBEGIN, 0);
1 daniel-mar 6547
 
4 daniel-mar 6548
  FillChar(DF, SizeOf(DF), 0);
1 daniel-mar 6549
  DF.dwsize := SizeOf(DF);
6550
  DF.dwDDFX := 0;
6551
 
6552
  FDXDraw.FPrimary.Blt(Dest, FDXDraw.FSurface.ClientRect, DDBLT_WAIT, df, FDXDraw.FSurface);
6553
end;
6554
 
6555
procedure TDXDrawDriverBlt.Initialize;
4 daniel-mar 6556
{$IFDEF D3D_deprecated}
1 daniel-mar 6557
const
6558
  PrimaryDesc: TDDSurfaceDesc = (
4 daniel-mar 6559
    dwSize: SizeOf(PrimaryDesc);
6560
    dwFlags: DDSD_CAPS;
6561
    ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE)
6562
    );
6563
{$ENDIF}
1 daniel-mar 6564
var
6565
  Entries: TPaletteEntries;
6566
  PaletteCaps: Integer;
4 daniel-mar 6567
  {$IFNDEF D3D_deprecated}
6568
  PrimaryDesc: TDDSurfaceDesc2;
6569
  {$ENDIF}
1 daniel-mar 6570
begin
4 daniel-mar 6571
  {$IFNDEF D3D_deprecated}
6572
  FillChar(PrimaryDesc, SizeOf(PrimaryDesc), 0);
6573
  PrimaryDesc.dwSize := SizeOf(PrimaryDesc);
6574
  PrimaryDesc.dwFlags := DDSD_CAPS;
6575
  PrimaryDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
6576
  {$ENDIF}
1 daniel-mar 6577
  {  Surface making  }
6578
  FDXDraw.FPrimary := TDirectDrawSurface.Create(FDXDraw.FDDraw);
6579
  if not FDXDraw.FPrimary.CreateSurface(PrimaryDesc) then
6580
    raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawPrimarySurface]);
6581
 
6582
  FDXDraw.FSurface := TDirectDrawSurface.Create(FDXDraw.FDDraw);
6583
 
6584
  {  Clipper making  }
6585
  FDXDraw.FClipper := TDirectDrawClipper.Create(FDXDraw.FDDraw);
6586
  FDXDraw.FClipper.Handle := FDXDraw.Handle;
6587
  FDXDraw.FPrimary.Clipper := FDXDraw.FClipper;
6588
 
6589
  {  Palette making  }
6590
  PaletteCaps := DDPCAPS_8BIT or DDPCAPS_INITIALIZE;
6591
  if doAllowPalette256 in FDXDraw.NowOptions then
6592
    PaletteCaps := PaletteCaps or DDPCAPS_ALLOW256;
6593
 
6594
  FDXDraw.FPalette := TDirectDrawPalette.Create(FDXDraw.FDDraw);
6595
  Entries := TDXDrawRGBQuadsToPaletteEntries(FDXDraw.ColorTable,
6596
    doAllowPalette256 in FDXDraw.NowOptions);
6597
  FDXDraw.FPalette.CreatePalette(PaletteCaps, Entries);
6598
 
6599
  FDXDraw.FPrimary.Palette := FDXDraw.Palette;
6600
 
6601
  InitializeSurface;
6602
end;
6603
 
6604
procedure TDXDrawDriverBlt.InitializeSurface;
6605
var
4 daniel-mar 6606
  ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 6607
begin
4 daniel-mar 6608
  FDXDraw.FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil;
1 daniel-mar 6609
 
6610
  {  Surface making  }
6611
  FDXDraw.FNowOptions := FDXDraw.FNowOptions - [doSystemMemory];
6612
 
6613
  FillChar(ddsd, SizeOf(ddsd), 0);
6614
  with ddsd do
6615
  begin
6616
    dwSize := SizeOf(ddsd);
6617
    dwFlags := DDSD_WIDTH or DDSD_HEIGHT or DDSD_CAPS;
6618
    dwWidth := Max(FDXDraw.FSurfaceWidth, 1);
6619
    dwHeight := Max(FDXDraw.FSurfaceHeight, 1);
6620
    ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
6621
    if doSystemMemory in FDXDraw.Options then
6622
      ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
4 daniel-mar 6623
    {$IFDEF D3D_deprecated}if do3D in FDXDraw.FNowOptions then{$ENDIF}
1 daniel-mar 6624
      ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_3DDEVICE;
6625
  end;
6626
 
6627
  if not FDXDraw.FSurface.CreateSurface(ddsd) then
6628
  begin
6629
    ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
6630
    if not FDXDraw.FSurface.CreateSurface(ddsd) then
6631
      raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
6632
  end;
6633
 
4 daniel-mar 6634
  if FDXDraw.FSurface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_VIDEOMEMORY = 0 then
1 daniel-mar 6635
    FDXDraw.FNowOptions := FDXDraw.FNowOptions + [doSystemMemory];
6636
 
6637
  FDXDraw.FSurface.Palette := FDXDraw.Palette;
6638
  FDXDraw.FSurface.Fill(0);
6639
 
4 daniel-mar 6640
  {$IFDEF D3D_deprecated}if do3D in FDXDraw.FNowOptions then{$ENDIF}
1 daniel-mar 6641
    Initialize3D;
6642
end;
6643
 
6644
function TDXDrawDriverBlt.SetSize(AWidth, AHeight: Integer): Boolean;
6645
begin
6646
  Result := True;
6647
 
6648
  FDXDraw.FSurfaceWidth := Max(AWidth, 1);
6649
  FDXDraw.FSurfaceHeight := Max(AHeight, 1);
6650
 
6651
  Inc(FDXDraw.FOffNotifyRestore);
6652
  try
6653
    FDXDraw.NotifyEventList(dxntFinalizeSurface);
6654
 
6655
    if FDXDraw.FCalledDoInitializeSurface then
6656
    begin
6657
      FDXDraw.FCalledDoInitializeSurface := False;
6658
      FDXDraw.DoFinalizeSurface;
4 daniel-mar 6659
    end;
6660
 
1 daniel-mar 6661
    InitializeSurface;
6662
 
6663
    FDXDraw.NotifyEventList(dxntInitializeSurface);
6664
    FDXDraw.FCalledDoInitializeSurface := True; FDXDraw.DoInitializeSurface;
6665
  finally
6666
    Dec(FDXDraw.FOffNotifyRestore);
6667
  end;
6668
end;
6669
 
6670
{  TDXDrawDriverFlip  }
6671
 
6672
procedure TDXDrawDriverFlip.Flip;
4 daniel-mar 6673
begin
6674
  if (FDXDraw.FForm <> nil) and (FDXDraw.FForm.Active) then
6675
    FDXDraw.FPrimary.DXResult := FDXDraw.FPrimary.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.Flip(nil, DDFLIP_WAIT)
1 daniel-mar 6676
  else
6677
    FDXDraw.FPrimary.DXResult := 0;
6678
end;
6679
 
6680
procedure TDXDrawDriverFlip.Initialize;
4 daniel-mar 6681
{$IFDEF D3D_deprecated}
1 daniel-mar 6682
const
6683
  DefPrimaryDesc: TDDSurfaceDesc = (
4 daniel-mar 6684
    dwSize: SizeOf(DefPrimaryDesc);
6685
    dwFlags: DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
6686
    dwBackBufferCount: 1;
6687
    ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX)
6688
    );
1 daniel-mar 6689
  BackBufferCaps: TDDSCaps = (dwCaps: DDSCAPS_BACKBUFFER);
4 daniel-mar 6690
{$ENDIF}
1 daniel-mar 6691
var
4 daniel-mar 6692
  PrimaryDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 6693
  PaletteCaps: Integer;
6694
  Entries: TPaletteEntries;
4 daniel-mar 6695
  DDSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface{$ELSE}IDirectDrawSurface7{$ENDIF};
6696
  {$IFNDEF D3D_deprecated}
6697
  BackBufferCaps: TDDSCaps2;
6698
  {$ENDIF}
1 daniel-mar 6699
begin
6700
  {  Surface making  }
4 daniel-mar 6701
  {$IFDEF D3D_deprecated}
1 daniel-mar 6702
  PrimaryDesc := DefPrimaryDesc;
4 daniel-mar 6703
  {$ELSE}
6704
  FillChar(PrimaryDesc, SizeOf(PrimaryDesc), 0);
6705
  PrimaryDesc.dwSize := SizeOf(PrimaryDesc);
6706
  PrimaryDesc.dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
6707
  PrimaryDesc.dwBackBufferCount := 1;
6708
  PrimaryDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX;
6709
  FillChar(BackBufferCaps, SizeOf(BackBufferCaps), 0);
6710
  BackBufferCaps.dwCaps := DDSCAPS_BACKBUFFER;
6711
  {$ENDIF}
6712
  {$IFDEF D3D_deprecated}if do3D in FDXDraw.FNowOptions then{$ENDIF}
1 daniel-mar 6713
    PrimaryDesc.ddsCaps.dwCaps := PrimaryDesc.ddsCaps.dwCaps or DDSCAPS_3DDEVICE;
6714
 
6715
  FDXDraw.FPrimary := TDirectDrawSurface.Create(FDXDraw.FDDraw);
6716
  if not FDXDraw.FPrimary.CreateSurface(PrimaryDesc) then
6717
    raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawPrimarySurface]);
6718
 
6719
  FDXDraw.FSurface := TDirectDrawSurface.Create(FDXDraw.FDDraw);
4 daniel-mar 6720
  if FDXDraw.FPrimary.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetAttachedSurface(BackBufferCaps, DDSurface) = DD_OK then
6721
    FDXDraw.FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := DDSurface;
1 daniel-mar 6722
 
6723
  FDXDraw.FNowOptions := FDXDraw.FNowOptions - [doSystemMemory];
4 daniel-mar 6724
  if FDXDraw.FSurface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_SYSTEMMEMORY <> 0 then
1 daniel-mar 6725
    FDXDraw.FNowOptions := FDXDraw.FNowOptions + [doSystemMemory];
6726
 
6727
  {  Clipper making of dummy  }
6728
  FDXDraw.FClipper := TDirectDrawClipper.Create(FDXDraw.FDDraw);
6729
 
6730
  {  Palette making  }
6731
  PaletteCaps := DDPCAPS_8BIT;
6732
  if doAllowPalette256 in FDXDraw.Options then
6733
    PaletteCaps := PaletteCaps or DDPCAPS_ALLOW256;
6734
 
6735
  FDXDraw.FPalette := TDirectDrawPalette.Create(FDXDraw.FDDraw);
6736
  Entries := TDXDrawRGBQuadsToPaletteEntries(FDXDraw.ColorTable,
6737
    doAllowPalette256 in FDXDraw.NowOptions);
6738
  FDXDraw.FPalette.CreatePalette(PaletteCaps, Entries);
4 daniel-mar 6739
 
1 daniel-mar 6740
  FDXDraw.FPrimary.Palette := FDXDraw.Palette;
6741
  FDXDraw.FSurface.Palette := FDXDraw.Palette;
6742
 
4 daniel-mar 6743
  {$IFDEF D3D_deprecated}if do3D in FDXDraw.FNowOptions then{$ENDIF}
1 daniel-mar 6744
    Initialize3D;
4 daniel-mar 6745
 
1 daniel-mar 6746
end;
6747
 
6748
constructor TCustomDXDraw.Create(AOwner: TComponent);
6749
var
6750
  Entries: TPaletteEntries;
6751
  dc: THandle;
6752
begin
6753
  FNotifyEventList := TList.Create;
6754
  inherited Create(AOwner);
6755
  FAutoInitialize := True;
6756
  FDisplay := TDXDrawDisplay.Create(Self);
4 daniel-mar 6757
  {$IFDEF _DMO_}FAdapters := EnumDirectDrawDriversEx;{$ENDIF}
6758
  Options := [doAllowReboot, doWaitVBlank, doCenter, {$IFDEF D3D_deprecated}doDirectX7Mode, do3D,{$ENDIF}
6759
    doHardware, doSelectDriver];
1 daniel-mar 6760
 
6761
  FAutoSize := True;
6762
 
6763
  dc := GetDC(0);
4 daniel-mar 6764
  try
6765
    GetSystemPaletteEntries(dc, 0, 256, Entries);
6766
  finally
6767
    ReleaseDC(0, dc);
6768
  end;
1 daniel-mar 6769
 
6770
  ColorTable := PaletteEntriesToRGBQuads(Entries);
6771
  DefColorTable := ColorTable;
6772
 
6773
  Width := 100;
6774
  Height := 100;
6775
  ParentColor := False;
4 daniel-mar 6776
  Color := clBlack; //clBtnFace; // FIX
6777
 
6778
  FD2D := TD2D.Create(Self);
6779
  D2D := FD2D; {as loopback}
6780
  FTraces := TTraces.Create(Self);
1 daniel-mar 6781
end;
6782
 
6783
destructor TCustomDXDraw.Destroy;
6784
begin
6785
  Finalize;
6786
  NotifyEventList(dxntDestroying);
6787
  FDisplay.Free;
4 daniel-mar 6788
  {$IFDEF _DMO_}FAdapters := nil;{$ENDIF}
1 daniel-mar 6789
  FSubClass.Free; FSubClass := nil;
6790
  FNotifyEventList.Free;
4 daniel-mar 6791
  FD2D.Free;
6792
  FD2D := nil;
6793
  D2D := nil;
6794
  FTraces.Free;
1 daniel-mar 6795
  inherited Destroy;
6796
end;
6797
 
6798
class function TCustomDXDraw.Drivers: TDirectXDrivers;
6799
begin
6800
  Result := EnumDirectDrawDrivers;
6801
end;
6802
 
4 daniel-mar 6803
{$IFDEF _DMO_}
6804
class function TCustomDXDraw.DriversEx: TDirectXDriversEx;
6805
begin
6806
  Result := EnumDirectDrawDriversEx;
6807
end;
6808
{$ENDIF}
6809
 
1 daniel-mar 6810
type
6811
  PDXDrawNotifyEvent = ^TDXDrawNotifyEvent;
6812
 
6813
procedure TCustomDXDraw.RegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
6814
var
6815
  Event: PDXDrawNotifyEvent;
6816
begin
6817
  UnRegisterNotifyEvent(NotifyEvent);
6818
 
6819
  New(Event);
6820
  Event^ := NotifyEvent;
6821
  FNotifyEventList.Add(Event);
6822
 
6823
  NotifyEvent(Self, dxntSetSurfaceSize);
6824
 
6825
  if Initialized then
6826
  begin
6827
    NotifyEvent(Self, dxntInitialize);
6828
    if FCalledDoInitializeSurface then
6829
      NotifyEvent(Self, dxntInitializeSurface);
4 daniel-mar 6830
    if FOffNotifyRestore = 0 then
1 daniel-mar 6831
      NotifyEvent(Self, dxntRestore);
6832
  end;
6833
end;
6834
 
6835
procedure TCustomDXDraw.UnRegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
6836
var
6837
  Event: PDXDrawNotifyEvent;
6838
  i: Integer;
6839
begin
4 daniel-mar 6840
  for i := 0 to FNotifyEventList.Count - 1 do
1 daniel-mar 6841
  begin
6842
    Event := FNotifyEventList[i];
6843
    if (TMethod(Event^).Code = TMethod(NotifyEvent).Code) and
6844
      (TMethod(Event^).Data = TMethod(NotifyEvent).Data) then
6845
    begin
6846
      FreeMem(Event);
6847
      FNotifyEventList.Delete(i);
6848
 
6849
      if FCalledDoInitializeSurface then
6850
        NotifyEvent(Self, dxntFinalizeSurface);
6851
      if Initialized then
6852
        NotifyEvent(Self, dxntFinalize);
6853
 
6854
      Break;
6855
    end;
6856
  end;
6857
end;
6858
 
6859
procedure TCustomDXDraw.NotifyEventList(NotifyType: TDXDrawNotifyType);
6860
var
6861
  i: Integer;
6862
begin
4 daniel-mar 6863
  for i := FNotifyEventList.Count - 1 downto 0 do
1 daniel-mar 6864
    PDXDrawNotifyEvent(FNotifyEventList[i])^(Self, NotifyType);
6865
end;
6866
 
6867
procedure TCustomDXDraw.FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
6868
 
6869
  procedure FlipToGDISurface;
6870
  begin
4 daniel-mar 6871
    if Initialized and (FNowOptions * [doFullScreen, doFlip] = [doFullScreen, doFlip]) then
6872
      DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.FlipToGDISurface;
1 daniel-mar 6873
  end;
6874
 
6875
begin
6876
  case Message.Msg of
6877
    {CM_ACTIVATE:
6878
        begin
6879
          DefWindowProc(Message);
6880
          if AutoInitialize and (not FInitalized2) then
6881
            Initialize;
6882
          Exit;
6883
        end;   }
6884
    WM_WINDOWPOSCHANGED:
4 daniel-mar 6885
      begin
6886
        if TWMWindowPosChanged(Message).WindowPos^.flags and SWP_SHOWWINDOW <> 0 then
1 daniel-mar 6887
        begin
4 daniel-mar 6888
          DefWindowProc(Message);
6889
          if AutoInitialize and (not FInitialized2) then
6890
            Initialize;
6891
          Exit;
1 daniel-mar 6892
        end;
4 daniel-mar 6893
      end;
6894
(*
6895
    WM_ACTIVATEAPP:
6896
      begin
6897
        if TWMActivateApp(Message).Active then
1 daniel-mar 6898
        begin
4 daniel-mar 6899
          FActive := True;
6900
          DoActivate;
6901
//          PostMessage(FHandle, CM_ACTIVATE, 0, 0)
6902
        end
6903
        else
6904
        begin
6905
          FActive := False;
6906
          DoDeactivate;
6907
//          PostMessage(FHandle, CM_DEACTIVATE, 0, 0);
1 daniel-mar 6908
        end;
4 daniel-mar 6909
      end;
6910
*)
6911
    WM_ACTIVATE:
6912
      begin
6913
        if TWMActivate(Message).Active = WA_INACTIVE then
6914
          FlipToGDISurface;
6915
      end;
1 daniel-mar 6916
    WM_INITMENU:
4 daniel-mar 6917
      begin
6918
        FlipToGDISurface;
6919
      end;
1 daniel-mar 6920
    WM_DESTROY:
4 daniel-mar 6921
      begin
6922
        Finalize;
6923
      end;
6924
    WM_ENTERSIZEMOVE:
6925
      begin
6926
        if not (csLoading in ComponentState) then
1 daniel-mar 6927
          Finalize;
4 daniel-mar 6928
      end;
6929
    WM_EXITSIZEMOVE:
6930
      begin
6931
        if not (csLoading in ComponentState) then
6932
          Initialize;
6933
      end;
6934
//    SW_RESTORE, SW_MAXIMIZE:
6935
//        begin
6936
//          {force finalize/initialize loop}
6937
//          if not AutoInitialize or not (csLoading in ComponentState) then begin
6938
//            Finalize;
6939
//            Initialize;
6940
//          end;
6941
//        end;
6942
  end;
1 daniel-mar 6943
  DefWindowProc(Message);
6944
end;
6945
 
6946
procedure TCustomDXDraw.DoFinalize;
6947
begin
6948
  if Assigned(FOnFinalize) then FOnFinalize(Self);
6949
end;
6950
 
6951
procedure TCustomDXDraw.DoFinalizeSurface;
6952
begin
6953
  if Assigned(FOnFinalizeSurface) then FOnFinalizeSurface(Self);
6954
end;
6955
 
6956
procedure TCustomDXDraw.DoInitialize;
6957
begin
4 daniel-mar 6958
  {$IFDEF _DMO_}
6959
  {erase items for following refresh}
6960
  if Assigned(FAdapters) then FAdapters.Clear;
6961
  EnumDirectDrawDriversEx;
6962
  {$ENDIF}
1 daniel-mar 6963
  if Assigned(FOnInitialize) then FOnInitialize(Self);
4 daniel-mar 6964
  {$IFNDEF DXR_deprecated}
6965
   {$IFDEF D3D_deprecated}
6966
    if not (do3D in Options) then
6967
      Options := Options + [do3D];
6968
   {$ENDIF}
6969
  {$ENDIF}
1 daniel-mar 6970
end;
6971
 
6972
procedure TCustomDXDraw.DoInitializeSurface;
6973
begin
4 daniel-mar 6974
  {.06 added for better initialization}
6975
  if Assigned(FD2D) then
6976
    RenderError := FD2D.D2DInitializeSurface;
6977
 
1 daniel-mar 6978
  if Assigned(FOnInitializeSurface) then FOnInitializeSurface(Self);
6979
end;
6980
 
6981
procedure TCustomDXDraw.DoInitializing;
6982
begin
6983
  if Assigned(FOnInitializing) then FOnInitializing(Self);
6984
end;
6985
 
6986
procedure TCustomDXDraw.DoRestoreSurface;
6987
begin
6988
  if Assigned(FOnRestoreSurface) then FOnRestoreSurface(Self);
6989
end;
6990
 
6991
procedure TCustomDXDraw.Finalize;
6992
begin
6993
  if FInternalInitialized then
6994
  begin
6995
    FSurfaceWidth := SurfaceWidth;
6996
    FSurfaceHeight := SurfaceHeight;
6997
 
6998
    FDisplay.FModes.Clear;
6999
 
7000
    FUpdating := True;
7001
    try
7002
      try
7003
        try
7004
          if FCalledDoInitializeSurface then
7005
          begin
7006
            FCalledDoInitializeSurface := False;
7007
            DoFinalizeSurface;
7008
          end;
7009
        finally
7010
          NotifyEventList(dxntFinalizeSurface);
7011
        end;
7012
      finally
7013
        try
7014
          if FCalledDoInitialize then
7015
          begin
7016
            FCalledDoInitialize := False;
7017
            DoFinalize;
7018
          end;
7019
        finally
7020
          NotifyEventList(dxntFinalize);
7021
        end;
7022
      end;
7023
    finally
7024
      FInternalInitialized := False;
7025
      FInitialized := False;
7026
 
7027
      SetOptions(FOptions);
7028
 
7029
      FDXDrawDriver.Free; FDXDrawDriver := nil;
7030
      FUpdating := False;
7031
    end;
7032
  end;
4 daniel-mar 7033
  if AsSigned(FD2D) then
7034
    FD2D.Free;
7035
  FD2D := nil;
7036
  D2D := nil
1 daniel-mar 7037
end;
7038
 
7039
procedure TCustomDXDraw.Flip;
7040
begin
7041
  if Initialized and (not FUpdating) then
7042
  begin
4 daniel-mar 7043
    if TryRestore and (not RenderError) then
1 daniel-mar 7044
      TDXDrawDriver(FDXDrawDriver).Flip;
7045
  end;
4 daniel-mar 7046
  RenderError := false;
1 daniel-mar 7047
end;
7048
 
7049
function TCustomDXDraw.GetCanDraw: Boolean;
7050
begin
4 daniel-mar 7051
  {$IFNDEF DXR_deprecated}
7052
  {$IFDEF D3D_deprecated}
7053
  if not (do3D in Options) then
7054
    Options := Options + [do3D];
7055
  {$ENDIF}
7056
  {$ENDIF}
7057
  Result := Initialized and (not FUpdating) and (Surface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) and
1 daniel-mar 7058
    TryRestore;
7059
end;
7060
 
7061
function TCustomDXDraw.GetCanPaletteAnimation: Boolean;
7062
begin
7063
  Result := Initialized and (not FUpdating) and (doFullScreen in FNowOptions)
4 daniel-mar 7064
    and (DDraw.DisplayMode.ddpfPixelFormat.dwRGBBitCount <= 8);
1 daniel-mar 7065
end;
7066
 
7067
function TCustomDXDraw.GetSurfaceHeight: Integer;
7068
begin
4 daniel-mar 7069
  if Surface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
1 daniel-mar 7070
    Result := Surface.Height
7071
  else
7072
    Result := FSurfaceHeight;
7073
end;
7074
 
7075
function TCustomDXDraw.GetSurfaceWidth: Integer;
7076
begin
4 daniel-mar 7077
  if Surface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
1 daniel-mar 7078
    Result := Surface.Width
7079
  else
7080
    Result := FSurfaceWidth;
7081
end;
7082
 
7083
procedure TCustomDXDraw.Loaded;
7084
begin
7085
  inherited Loaded;
7086
 
7087
  if AutoSize then
7088
  begin
7089
    FSurfaceWidth := Width;
7090
    FSurfaceHeight := Height;
7091
  end;
7092
 
7093
  NotifyEventList(dxntSetSurfaceSize);
7094
 
7095
  if FAutoInitialize and (not (csDesigning in ComponentState)) then
4 daniel-mar 7096
  begin
7097
    if {(not (doFullScreen in FOptions)) or }(FSubClass = nil) then
1 daniel-mar 7098
      Initialize;
7099
  end;
7100
end;
7101
 
7102
procedure TCustomDXDraw.Initialize;
7103
begin
7104
  FInitialized2 := True;
7105
 
7106
  Finalize;
7107
 
4 daniel-mar 7108
  if FForm = nil then
1 daniel-mar 7109
    raise EDXDrawError.Create(SNoForm);
7110
 
7111
  try
7112
    DoInitializing;
7113
 
7114
    {  Initialization.  }
7115
    FUpdating := True;
7116
    try
7117
      FInternalInitialized := True;
7118
 
7119
      NotifyEventList(dxntInitializing);
7120
 
7121
      {  DirectDraw initialization.  }
7122
      if doFlip in FNowOptions then
7123
        FDXDrawDriver := TDXDrawDriverFlip.Create(Self)
7124
      else
7125
        FDXDrawDriver := TDXDrawDriverBlt.Create(Self);
7126
 
7127
      {  Window handle setting.  }
7128
      SetCooperativeLevel;
7129
 
7130
      {  Set display mode.  }
7131
      if doFullScreen in FNowOptions then
7132
      begin
7133
        if not Display.DynSetSize(Display.Width, Display.Height, Display.BitCount) then
7134
          raise EDXDrawError.CreateFmt(SDisplaymodeChange, [Display.Width, Display.Height, Display.BitCount]);
7135
      end;
7136
 
7137
      {  Resource initialization.  }
7138
      if AutoSize then
7139
      begin
7140
        FSurfaceWidth := Width;
7141
        FSurfaceHeight := Height;
7142
      end;
7143
 
7144
      TDXDrawDriver(FDXDrawDriver).Initialize;
7145
    finally
7146
      FUpdating := False;
7147
    end;
7148
  except
7149
    Finalize;
7150
    raise;
7151
  end;
7152
 
7153
  FInitialized := True;
7154
 
7155
  Inc(FOffNotifyRestore);
7156
  try
7157
    NotifyEventList(dxntSetSurfaceSize);
7158
    NotifyEventList(dxntInitialize);
7159
    FCalledDoInitialize := True; DoInitialize;
7160
 
7161
    NotifyEventList(dxntInitializeSurface);
7162
    FCalledDoInitializeSurface := True; DoInitializeSurface;
7163
  finally
7164
    Dec(FOffNotifyRestore);
7165
  end;
7166
 
4 daniel-mar 7167
  if not Assigned(FD2D) then begin
7168
    FD2D := TD2D.Create(Self);
7169
    D2D := FD2D; {as loopback}
7170
  end;
7171
 
1 daniel-mar 7172
  Restore;
7173
end;
7174
 
7175
procedure TCustomDXDraw.Paint;
7176
var
7177
  Old: TDXDrawOptions;
7178
  w, h: Integer;
7179
  s: string;
7180
begin
7181
  inherited Paint;
7182
  if (csDesigning in ComponentState) then
7183
  begin
7184
    Canvas.Brush.Style := bsClear;
7185
    Canvas.Pen.Color := clBlack;
7186
    Canvas.Pen.Style := psDash;
7187
    Canvas.Rectangle(0, 0, Width, Height);
7188
 
7189
    Canvas.Pen.Style := psSolid;
7190
    Canvas.Pen.Color := clGray;
7191
    Canvas.MoveTo(0, 0);
7192
    Canvas.LineTo(Width, Height);
7193
 
7194
    Canvas.MoveTo(0, Height);
7195
    Canvas.LineTo(Width, 0);
7196
 
7197
    s := Format('(%s)', [ClassName]);
7198
 
7199
    w := Canvas.TextWidth(s);
7200
    h := Canvas.TextHeight(s);
7201
 
7202
    Canvas.Brush.Style := bsSolid;
7203
    Canvas.Brush.Color := clBtnFace;
4 daniel-mar 7204
    Canvas.TextOut(Width div 2 - w div 2, Height div 2 - h div 2, s);
1 daniel-mar 7205
  end else
7206
  begin
7207
    Old := FNowOptions;
7208
    try
7209
      FNowOptions := FNowOptions - [doWaitVBlank];
7210
      Flip;
4 daniel-mar 7211
    finally
1 daniel-mar 7212
      FNowOptions := Old;
4 daniel-mar 7213
    end;
7214
    if (Parent <> nil) and (Initialized) and (Surface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_VIDEOMEMORY <> 0) then
7215
      Parent.Invalidate;
1 daniel-mar 7216
  end;
7217
end;
7218
 
7219
function TCustomDXDraw.PaletteChanged(Foreground: Boolean): Boolean;
7220
begin
7221
  if Foreground then
7222
  begin
7223
    Restore;
7224
    Result := True;
7225
  end else
7226
    Result := False;
7227
end;
7228
 
4 daniel-mar 7229
procedure TCustomDXDraw.Render(LagCount: Integer{$IFDEF VER4UP} = 0{$ENDIF});
7230
var I: Integer;
1 daniel-mar 7231
begin
4 daniel-mar 7232
{$IFDEF D3DRM}
7233
  if FInitialized and {$IFDEF D3D_deprecated}(do3D in FNowOptions) and{$ENDIF} (doRetainedMode in FNowOptions) then
1 daniel-mar 7234
  begin
7235
    asm FInit end;
7236
    FViewport.Clear;
7237
    FViewport.Render(FScene);
7238
    FD3DRMDevice.Update;
7239
    asm FInit end;
7240
  end;
4 daniel-mar 7241
{$ENDIF}
7242
  {traces}
7243
  if FTraces.Count > 0 then
7244
    for I := 0 to FTraces.Count - 1 do
7245
      if FTraces.Items[I].Active then
7246
        FTraces.Items[I].Render(LagCount);
7247
  {own rendering event}
7248
  if Assigned(FOnRender) then
7249
    FOnRender(Self);
1 daniel-mar 7250
end;
7251
 
7252
procedure TCustomDXDraw.Restore;
7253
begin
7254
  if Initialized and (not FUpdating) then
7255
  begin
7256
    FUpdating := True;
7257
    try
7258
      if TDXDrawDriver(FDXDrawDriver).Restore then
7259
      begin
7260
        Primary.Palette := Palette;
7261
        Surface.Palette := Palette;
7262
 
7263
        SetColorTable(DefColorTable);
7264
        NotifyEventList(dxntRestore);
7265
        DoRestoreSurface;
7266
        SetColorTable(ColorTable);
7267
      end;
7268
    finally
7269
      FUpdating := False;
7270
    end;
7271
  end;
7272
end;
7273
 
7274
procedure TCustomDXDraw.SetAutoSize(Value: Boolean);
7275
begin
4 daniel-mar 7276
  if FAutoSize <> Value then
1 daniel-mar 7277
  begin
7278
    FAutoSize := Value;
7279
    if FAutoSize then
7280
      SetSize(Width, Height);
7281
  end;
7282
end;
7283
 
7284
procedure TCustomDXDraw.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
7285
begin
7286
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
7287
  if FAutoSize and (not FUpdating) then
7288
    SetSize(AWidth, AHeight);
7289
end;
7290
 
4 daniel-mar 7291
procedure TCustomDXDraw.BeginScene;
7292
begin
7293
  if CheckD3 then
7294
    FD2D.BeginScene
7295
end;
7296
 
7297
procedure TCustomDXDraw.EndScene;
7298
begin
7299
  if CheckD3 then
7300
    FD2D.EndScene
7301
end;
7302
 
7303
function TCustomDXDraw.CheckD3: Boolean;
7304
begin
7305
  Result := {$IFDEF D3D_deprecated}(do3D in Options) and{$ENDIF} (doHardware in Options) and AsSigned(FD2D);
7306
end;
7307
 
7308
function TCustomDXDraw.CheckD3D(Dest: TDirectDrawSurface): Boolean;
7309
begin
7310
  Result := CheckD3 and (FD2D.FDDraw.FSurface = Dest)
7311
end;
7312
 
7313
procedure TCustomDXDraw.ClearStack;
7314
begin
7315
  if CheckD3 then
7316
    FD2D.D2DTextures.D2DPruneAllTextures;
7317
end;
7318
 
7319
procedure TCustomDXDraw.UpdateTextures;
7320
var Changed: Boolean;
7321
begin
7322
  if CheckD3 then begin
7323
    if Assigned(FOnUpdateTextures) then begin
7324
      Changed := False;
7325
      FOnUpdateTextures(FD2D.FD2DTexture, Changed);
7326
      if Changed then FD2D.D2DUpdateTextures;
7327
    end
7328
  end;
7329
end;
7330
 
7331
procedure TCustomDXDraw.TextureFilter(Grade: TD2DTextureFilter);
7332
begin
7333
  if CheckD3 then
7334
    FD2D.TextureFilter := Grade;
7335
end;
7336
 
7337
procedure TCustomDXDraw.AntialiasFilter(Grade: TD3DAntialiasMode);
7338
begin
7339
  if CheckD3 then
7340
    FD2D.AntialiasFilter := Grade;
7341
end;
7342
 
7343
// ***** fade effects
7344
// do not use in dxtimer cycle
7345
 
7346
function TCustomDXDraw.Fade2Color(colorfrom, colorto: LongInt): LongInt;
7347
var i, r1, r2, g1, g2, b1, b2: Integer;
7348
begin
7349
  r1 := GetRValue(colorfrom);
7350
  r2 := GetRValue(colorto);
7351
  g1 := GetGValue(colorfrom);
7352
  g2 := GetGValue(colorto);
7353
  b1 := GetBValue(colorfrom);
7354
  b2 := GetBValue(colorto);
7355
  if r1 < r2 then
7356
  begin
7357
    for i := r1 to r2 do
7358
    begin
7359
      Surface.Fill(RGB(i, g1, b1));
7360
      Flip;
7361
    end;
7362
  end
7363
  else
7364
  begin
7365
    for i := r1 downto r2 do
7366
    begin
7367
      Surface.Fill(RGB(i, g1, b1));
7368
      Flip;
7369
    end;
7370
  end;
7371
 
7372
  if g1 < g2 then
7373
  begin
7374
    for i := g1 to g2 do
7375
    begin
7376
      Surface.Fill(RGB(r2, i, b1));
7377
      Flip;
7378
    end;
7379
  end
7380
  else
7381
  begin
7382
    for i := g1 downto g2 do
7383
    begin
7384
      Surface.Fill(RGB(r2, i, b1));
7385
      Flip;
7386
    end;
7387
  end;
7388
  if b1 < b2 then
7389
  begin
7390
    for i := b1 to b2 do
7391
    begin
7392
      Surface.Fill(RGB(r2, g2, i));
7393
      Flip;
7394
    end;
7395
  end
7396
  else
7397
  begin
7398
    for i := b1 downto b2 do
7399
    begin
7400
      Surface.Fill(RGB(r2, g2, i));
7401
      Flip;
7402
    end;
7403
  end;
7404
  Result := colorto;
7405
end;
7406
 
7407
function TCustomDXDraw.Fade2Black(colorfrom: LongInt): LongInt;
7408
var i, r, g, b: Integer;
7409
begin
7410
  r := GetRValue(colorfrom);
7411
  g := GetGValue(colorfrom);
7412
  b := GetBValue(colorfrom);
7413
  for i := r downto 0 do
7414
  begin
7415
    Surface.Fill(RGB(i, g, b));
7416
    Flip;
7417
  end;
7418
  for i := g downto 0 do
7419
  begin
7420
    Surface.Fill(RGB(0, i, b));
7421
    Flip;
7422
  end;
7423
  for i := g downto 0 do
7424
  begin
7425
    Surface.Fill(RGB(0, 0, i));
7426
    Flip;
7427
  end;
7428
  Result := 0;
7429
end;
7430
 
7431
function TCustomDXDraw.Fade2White(colorfrom: LongInt): LongInt;
7432
var i, r, g, b: Integer;
7433
begin
7434
  r := GetRValue(colorfrom);
7435
  g := GetGValue(colorfrom);
7436
  b := GetBValue(colorfrom);
7437
  for i := r to 255 do
7438
  begin
7439
    Surface.Fill(RGB(i, g, b));
7440
    Flip;
7441
  end;
7442
  for i := g to 255 do
7443
  begin
7444
    Surface.Fill(RGB(255, i, b));
7445
    Flip;
7446
  end;
7447
  for i := b to 255 do
7448
  begin
7449
    Surface.Fill(RGB(255, 255, i));
7450
    Flip;
7451
  end;
7452
  Result := RGB(255, 255, 255);
7453
end;
7454
 
7455
function TCustomDXDraw.Grey2Fade(shadefrom, shadeto: Integer): Integer;
7456
var i: Integer;
7457
begin
7458
  if shadefrom < shadeto then
7459
  begin
7460
    for i := shadefrom to shadeto do
7461
    begin
7462
      Surface.Fill(RGB(i, i, i));
7463
      Flip;
7464
    end;
7465
  end
7466
  else
7467
  begin
7468
    for i := shadefrom downto shadeto do
7469
    begin
7470
      Surface.Fill(RGB(i, i, i));
7471
      Flip;
7472
    end;
7473
  end;
7474
  Result := shadeto;
7475
end;
7476
 
7477
function TCustomDXDraw.FadeGrey2Screen(oldcolor, newcolour: LongInt): LongInt;
7478
begin
7479
  result := Grey2Fade(oldcolor, newcolour);
7480
end;
7481
 
7482
function TCustomDXDraw.Fade2Screen(oldcolor, newcolour: LongInt): LongInt;
7483
begin
7484
  result := Fade2Color(oldcolor, newcolour);
7485
end;
7486
 
7487
function TCustomDXDraw.White2Screen(oldcolor: Integer): LongInt;
7488
begin
7489
  result := Fade2Color(oldcolor, RGB(255, 255, 255));
7490
end;
7491
 
7492
function TCustomDXDraw.Black2Screen(oldcolor: Integer): LongInt;
7493
begin
7494
  result := Fade2Color(oldcolor, RGB(0, 0, 0));
7495
end;
7496
 
7497
procedure TCustomDXDraw.GrabImage(iX, iY, iWidth, iHeight: Integer; ddib: TDIB);
7498
var ts, td: trect;
7499
begin
7500
  ddib.SetSize(iWidth, iHeight, 24);
7501
  ts.left := iX;
7502
  ts.top := iY;
7503
  ts.right := iX + iWidth - 1;
7504
  ts.bottom := iY + iHeight - 1;
7505
  td.left := 0;
7506
  td.top := 0;
7507
  td.right := iWidth;
7508
  td.bottom := iHeight;
7509
  with Surface.Canvas do
7510
  begin
7511
    ddib.Canvas.CopyRect(td, Surface.Canvas, ts);
7512
    Release;
7513
  end;
7514
end;
7515
 
7516
procedure TCustomDXDraw.PasteImage(sdib: TDIB; x, y: Integer);
7517
var
7518
  ts, td: trect;
7519
  w, h: Integer;
7520
begin
7521
  w := sdib.width - 1;
7522
  h := sdib.height - 1;
7523
  ts.left := 0;
7524
  ts.top := 0;
7525
  ts.right := w;
7526
  ts.bottom := h;
7527
  td.left := x;
7528
  td.top := y;
7529
  td.right := x + w;
7530
  td.bottom := y + h;
7531
  with Surface.Canvas do
7532
  begin
7533
    CopyRect(td, sdib.Canvas, ts);
7534
    release;
7535
  end;
7536
end;
7537
 
7538
// *****
7539
 
1 daniel-mar 7540
procedure TCustomDXDraw.SetColorTable(const ColorTable: TRGBQuads);
7541
var
7542
  Entries: TPaletteEntries;
7543
begin
4 daniel-mar 7544
  if Initialized and (Palette <> nil) then
1 daniel-mar 7545
  begin
7546
    Entries := TDXDrawRGBQuadsToPaletteEntries(ColorTable,
7547
      doAllowPalette256 in FNowOptions);
7548
    Palette.SetEntries(0, 256, Entries);
7549
  end;
7550
end;
7551
 
7552
procedure TCustomDXDraw.SetCooperativeLevel;
7553
var
7554
  Flags: Integer;
7555
  Control: TWinControl;
7556
begin
7557
  Control := FForm;
4 daniel-mar 7558
  if Control = nil then
1 daniel-mar 7559
    Control := Self;
7560
 
7561
  if doFullScreen in FNowOptions then
7562
  begin
4 daniel-mar 7563
    Flags := DDSCL_FULLSCREEN or DDSCL_EXCLUSIVE or DDSCL_ALLOWMODEX{$IFDEF DXDOUBLEPRECISION} or DDSCL_FPUPRESERVE{$ENDIF};
1 daniel-mar 7564
    if doNoWindowChange in FNowOptions then
7565
      Flags := Flags or DDSCL_NOWINDOWCHANGES;
7566
    if doAllowReboot in FNowOptions then
7567
      Flags := Flags or DDSCL_ALLOWREBOOT;
7568
  end else
4 daniel-mar 7569
    Flags := DDSCL_NORMAL{$IFDEF DXDOUBLEPRECISION} or DDSCL_FPUPRESERVE{$ENDIF};
1 daniel-mar 7570
 
4 daniel-mar 7571
  DDraw.DXResult := DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.SetCooperativeLevel(Control.Handle, Flags);
1 daniel-mar 7572
end;
7573
 
7574
procedure TCustomDXDraw.SetDisplay(Value: TDXDrawDisplay);
7575
begin
7576
  FDisplay.Assign(Value);
7577
end;
7578
 
7579
procedure TCustomDXDraw.SetDriver(Value: PGUID);
7580
begin
7581
  if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
7582
  begin
7583
    FDriverGUID := Value^;
7584
    FDriver := @FDriverGUID;
7585
  end else
7586
    FDriver := Value;
7587
end;
7588
 
7589
procedure TCustomDXDraw.SetOptions(Value: TDXDrawOptions);
7590
const
4 daniel-mar 7591
  InitOptions = [doFullScreen, doNoWindowChange, doAllowReboot,
7592
    doAllowPalette256, doSystemMemory, doFlip,
7593
    {$IFDEF D3D_deprecated}doDirectX7Mode, do3D,{$ENDIF}{$IFDEF D3DRM} doRetainedMode, {$ENDIF}
7594
    doHardware, doSelectDriver, doZBuffer];
1 daniel-mar 7595
var
7596
  OldOptions: TDXDrawOptions;
7597
begin
7598
  FOptions := Value;
7599
 
7600
  if Initialized then
7601
  begin
7602
    OldOptions := FNowOptions;
4 daniel-mar 7603
    FNowOptions := FNowOptions * InitOptions + (FOptions - InitOptions);
7604
    {$IFDEF D3D_deprecated}
1 daniel-mar 7605
    if not (do3D in FNowOptions) then
4 daniel-mar 7606
      FNowOptions := FNowOptions - [doHardware, {$IFDEF D3DRM}doRetainedMode,{$ENDIF} doSelectDriver, doZBuffer];
7607
    {$ENDIF}
1 daniel-mar 7608
  end else
7609
  begin
7610
    FNowOptions := FOptions;
7611
 
7612
    if not (doFullScreen in FNowOptions) then
7613
      FNowOptions := FNowOptions - [doNoWindowChange, doAllowReBoot, doAllowPalette256, doFlip];
4 daniel-mar 7614
    {$IFDEF D3D_deprecated}
1 daniel-mar 7615
    if not (do3D in FNowOptions) then
4 daniel-mar 7616
      FNowOptions := FNowOptions - [doDirectX7Mode, {$IFDEF D3DRM}doRetainedMode,{$ENDIF} doHardware, doSelectDriver, doZBuffer];
7617
    {$ENDIF}
1 daniel-mar 7618
    if doSystemMemory in FNowOptions then
7619
      FNowOptions := FNowOptions - [doFlip];
4 daniel-mar 7620
    {$IFDEF D3DRM}
1 daniel-mar 7621
    if doDirectX7Mode in FNowOptions then
7622
      FNowOptions := FNowOptions - [doRetainedMode];
4 daniel-mar 7623
    {$ENDIF}
1 daniel-mar 7624
    FNowOptions := FNowOptions - [doHardware];
7625
  end;
7626
end;
7627
 
7628
procedure TCustomDXDraw.SetParent(AParent: TWinControl);
7629
var
7630
  Control: TWinControl;
7631
begin
7632
  inherited SetParent(AParent);
7633
 
7634
  FForm := nil;
7635
  FSubClass.Free; FSubClass := nil;
7636
 
7637
  if not (csDesigning in ComponentState) then
7638
  begin
7639
    Control := Parent;
4 daniel-mar 7640
    while (Control <> nil) and (not (Control is TCustomForm)) do
1 daniel-mar 7641
      Control := Control.Parent;
4 daniel-mar 7642
    if Control <> nil then
1 daniel-mar 7643
    begin
7644
      FForm := TCustomForm(Control);
7645
      FSubClass := TControlSubClass.Create(Control, FormWndProc);
7646
    end;
7647
  end;
7648
end;
7649
 
7650
procedure TCustomDXDraw.SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
7651
begin
4 daniel-mar 7652
  if ((ASurfaceWidth <> SurfaceWidth) or (ASurfaceHeight <> SurfaceHeight)) and
1 daniel-mar 7653
    (not FUpdating) then
7654
  begin
7655
    if Initialized then
7656
    begin
7657
      try
7658
        if not TDXDrawDriver(FDXDrawDriver).SetSize(ASurfaceWidth, ASurfaceHeight) then
7659
          Exit;
7660
      except
7661
        Finalize;
7662
        raise;
7663
      end;
7664
    end else
7665
    begin
7666
      FSurfaceWidth := ASurfaceWidth;
7667
      FSurfaceHeight := ASurfaceHeight;
7668
    end;
7669
 
7670
    NotifyEventList(dxntSetSurfaceSize);
7671
  end;
7672
end;
7673
 
7674
procedure TCustomDXDraw.SetSurfaceHeight(Value: Integer);
7675
begin
4 daniel-mar 7676
  if ComponentState * [csReading, csLoading] = [] then
1 daniel-mar 7677
    SetSize(SurfaceWidth, Value)
7678
  else
7679
    FSurfaceHeight := Value;
7680
end;
7681
 
7682
procedure TCustomDXDraw.SetSurfaceWidth(Value: Integer);
7683
begin
4 daniel-mar 7684
  if ComponentState * [csReading, csLoading] = [] then
1 daniel-mar 7685
    SetSize(Value, SurfaceHeight)
7686
  else
7687
    FSurfaceWidth := Value;
7688
end;
7689
 
7690
function TCustomDXDraw.TryRestore: Boolean;
7691
begin
7692
  Result := False;
7693
 
4 daniel-mar 7694
  if Initialized and (not FUpdating) and (Primary.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil) then
1 daniel-mar 7695
  begin
4 daniel-mar 7696
    if (Primary.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DDERR_SURFACELOST) or
7697
      (Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DDERR_SURFACELOST) then
1 daniel-mar 7698
    begin
4 daniel-mar 7699
      if Assigned(FD2D) and Assigned(FD2D.FD2DTexture) then FD2D.FD2DTexture.D2DPruneAllTextures;//<-Add Mr.Kawasaki
1 daniel-mar 7700
      Restore;
4 daniel-mar 7701
      Result := (Primary.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DD_OK) and (Surface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DD_OK);
1 daniel-mar 7702
    end else
7703
      Result := True;
7704
  end;
7705
end;
7706
 
4 daniel-mar 7707
procedure TCustomDXDraw.SetTraces(const Value: TTraces);
7708
begin
7709
  FTraces.Assign(Value);
7710
end;
7711
 
1 daniel-mar 7712
procedure TCustomDXDraw.UpdatePalette;
7713
begin
7714
  if Initialized and (doWaitVBlank in FNowOptions) then
7715
  begin
4 daniel-mar 7716
    if FDDraw.FDriverCaps.dwPalCaps and DDPCAPS_VSYNC = 0 then
7717
      FDDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.WaitForVerticalBlank(DDWAITVB_BLOCKBEGIN, 0);
7718
  end;
1 daniel-mar 7719
 
7720
  SetColorTable(ColorTable);
7721
end;
7722
 
7723
procedure TCustomDXDraw.WMCreate(var Message: TMessage);
7724
begin
7725
  inherited;
7726
  if Initialized and (not FUpdating) then
7727
  begin
4 daniel-mar 7728
    if Clipper <> nil then
1 daniel-mar 7729
      Clipper.Handle := Handle;
7730
    SetCooperativeLevel;
7731
  end;
7732
end;
7733
 
4 daniel-mar 7734
{$IFDEF DX3D_deprecated}
7735
 
1 daniel-mar 7736
{  TCustomDX3D  }
7737
 
7738
constructor TCustomDX3D.Create(AOwner: TComponent);
7739
begin
7740
  inherited Create(AOwner);
7741
  Options := [toHardware, toRetainedMode, toSelectDriver];
7742
  FSurfaceWidth := 320;
7743
  FSurfaceHeight := 240;
7744
end;
7745
 
7746
destructor TCustomDX3D.Destroy;
7747
begin
7748
  DXDraw := nil;
7749
  inherited Destroy;
7750
end;
7751
 
7752
procedure TCustomDX3D.DoFinalize;
7753
begin
7754
  if Assigned(FOnFinalize) then FOnFinalize(Self);
7755
end;
7756
 
7757
procedure TCustomDX3D.DoInitialize;
7758
begin
7759
  if Assigned(FOnInitialize) then FOnInitialize(Self);
7760
end;
7761
 
7762
procedure TCustomDX3D.Finalize;
7763
begin
7764
  if FInitialized then
7765
  begin
7766
    try
7767
      if FInitFlag then
7768
      begin
7769
        FInitFlag := False;
7770
        DoFinalize;
7771
      end;
7772
    finally
7773
      FInitialized := False;
7774
 
7775
      SetOptions(FOptions);
4 daniel-mar 7776
      {$IFDEF D3DRM}
1 daniel-mar 7777
      FViewport := nil;
7778
      FCamera := nil;
7779
      FScene := nil;
7780
 
7781
      FD3DRMDevice := nil;
7782
      FD3DRMDevice2 := nil;
7783
      FD3DRMDevice3 := nil;
4 daniel-mar 7784
      {$ENDIF}
7785
      {$IFDEF D3D_deprecated}
1 daniel-mar 7786
      FD3DDevice := nil;
7787
      FD3DDevice2 := nil;
7788
      FD3DDevice3 := nil;
4 daniel-mar 7789
      {$ENDIF}
1 daniel-mar 7790
      FD3DDevice7 := nil;
4 daniel-mar 7791
      {$IFDEF D3D_deprecated}
1 daniel-mar 7792
      FD3D := nil;
7793
      FD3D2 := nil;
7794
      FD3D3 := nil;
4 daniel-mar 7795
      {$ENDIF}
1 daniel-mar 7796
      FD3D7 := nil;
7797
 
7798
      FreeZBufferSurface(FSurface, FZBuffer);
7799
 
4 daniel-mar 7800
      FSurface.Free; FSurface := nil;
7801
      {$IFDEF D3DRM}
1 daniel-mar 7802
      FD3DRM3 := nil;
7803
      FD3DRM2 := nil;
7804
      FD3DRM := nil;
4 daniel-mar 7805
      {$ENDIF}
1 daniel-mar 7806
    end;
7807
  end;
7808
end;
7809
 
7810
procedure TCustomDX3D.Initialize;
7811
var
7812
  ddsd: TDDSurfaceDesc;
7813
  AOptions: TInitializeDirect3DOptions;
7814
begin
7815
  Finalize;
7816
  try
7817
    FInitialized := True;
7818
 
7819
    {  Make surface.  }
7820
    FillChar(ddsd, SizeOf(ddsd), 0);
7821
    ddsd.dwSize := SizeOf(ddsd);
7822
    ddsd.dwFlags := DDSD_WIDTH or DDSD_HEIGHT or DDSD_CAPS;
7823
    ddsd.dwWidth := Max(FSurfaceWidth, 1);
7824
    ddsd.dwHeight := Max(FSurfaceHeight, 1);
7825
    ddsd.ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN or DDSCAPS_3DDEVICE;
7826
    if toSystemMemory in FNowOptions then
7827
      ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY
7828
    else
7829
      ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_VIDEOMEMORY;
7830
 
7831
    FSurface := TDirectDrawSurface.Create(FDXDraw.DDraw);
7832
    if not FSurface.CreateSurface(ddsd) then
7833
    begin
7834
      ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps and (not DDSCAPS_VIDEOMEMORY) or DDSCAPS_SYSTEMMEMORY;
7835
      if not FSurface.CreateSurface(ddsd) then
7836
        raise EDX3DError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
7837
    end;
7838
 
7839
    AOptions := [];
7840
 
7841
    if toHardware in FNowOptions then AOptions := AOptions + [idoHardware];
7842
    if toRetainedMode in FNowOptions then AOptions := AOptions + [idoRetainedMode];
7843
    if toSelectDriver in FNowOptions then AOptions := AOptions + [idoSelectDriver];
7844
    if toZBuffer in FNowOptions then AOptions := AOptions + [idoZBuffer];
7845
 
7846
    if doDirectX7Mode in FDXDraw.NowOptions then
7847
    begin
7848
      InitializeDirect3D7(FSurface, FZBuffer, FD3D7, FD3DDevice7, AOptions);
7849
    end else
7850
    begin
7851
      InitializeDirect3D(FSurface, FZBuffer, FD3D, FD3D2, FD3D3, FD3DDevice, FD3DDevice2, FD3DDevice3,
4 daniel-mar 7852
{$IFDEF D3DRM}FD3DRM, FD3DRM2, FD3DRM3, FD3DRMDevice, FD3DRMDevice2, FD3DRMDevice3, FViewport, FScene, FCamera, {$ENDIF}
7853
        AOptions);
1 daniel-mar 7854
    end;
7855
 
7856
    FNowOptions := [];
7857
 
7858
    if idoHardware in AOptions then FNowOptions := FNowOptions + [toHardware];
7859
    if idoRetainedMode in AOptions then FNowOptions := FNowOptions + [toRetainedMode];
7860
    if idoSelectDriver in AOptions then FNowOptions := FNowOptions + [toSelectDriver];
7861
    if idoZBuffer in AOptions then FNowOptions := FNowOptions + [toZBuffer];
7862
  except
7863
    Finalize;
7864
    raise;
7865
  end;
7866
 
7867
  FInitFlag := True; DoInitialize;
7868
end;
7869
 
7870
procedure TCustomDX3D.Render;
7871
begin
4 daniel-mar 7872
{$IFDEF D3DRM}
1 daniel-mar 7873
  if FInitialized and (toRetainedMode in FNowOptions) then
7874
  begin
7875
    asm FInit end;
7876
    FViewport.Clear;
7877
    FViewport.Render(FScene);
7878
    FD3DRMDevice.Update;
7879
    asm FInit end;
7880
  end;
4 daniel-mar 7881
{$ENDIF}
1 daniel-mar 7882
end;
7883
 
7884
function TCustomDX3D.GetCanDraw: Boolean;
7885
begin
4 daniel-mar 7886
  Result := Initialized and (Surface.IDDSurface <> nil) and
7887
    (Surface.ISurface.IsLost = DD_OK);
1 daniel-mar 7888
end;
7889
 
7890
function TCustomDX3D.GetSurfaceHeight: Integer;
7891
begin
4 daniel-mar 7892
  if FSurface.IDDSurface <> nil then
1 daniel-mar 7893
    Result := FSurface.Height
7894
  else
7895
    Result := FSurfaceHeight;
7896
end;
7897
 
7898
function TCustomDX3D.GetSurfaceWidth: Integer;
7899
begin
4 daniel-mar 7900
  if FSurface.IDDSurface <> nil then
1 daniel-mar 7901
    Result := FSurface.Width
7902
  else
7903
    Result := FSurfaceWidth;
7904
end;
7905
 
7906
procedure TCustomDX3D.SetAutoSize(Value: Boolean);
7907
begin
4 daniel-mar 7908
  if FAutoSize <> Value then
1 daniel-mar 7909
  begin
7910
    FAutoSize := Value;
4 daniel-mar 7911
    if FAutoSize and (DXDraw <> nil) then
1 daniel-mar 7912
      SetSize(DXDraw.SurfaceWidth, DXDraw.SurfaceHeight);
7913
  end;
7914
end;
7915
 
7916
procedure TCustomDX3D.SetOptions(Value: TDX3DOptions);
7917
const
7918
  DX3DOptions = [toRetainedMode, toSystemMemory, toHardware, toSelectDriver, toZBuffer];
7919
  InitOptions = [toSystemMemory, toHardware, toSelectDriver, toZBuffer];
7920
var
7921
  OldOptions: TDX3DOptions;
7922
begin
7923
  FOptions := Value;
7924
 
7925
  if Initialized then
7926
  begin
7927
    OldOptions := FNowOptions;
4 daniel-mar 7928
    FNowOptions := FNowOptions * InitOptions + FOptions * (DX3DOptions - InitOptions);
1 daniel-mar 7929
  end else
7930
  begin
7931
    FNowOptions := FOptions;
7932
 
4 daniel-mar 7933
    if (FDXDraw <> nil) and (doDirectX7Mode in FDXDraw.FNowOptions) then
1 daniel-mar 7934
      FNowOptions := FNowOptions - [toRetainedMode];
7935
  end;
7936
end;
7937
 
7938
procedure TCustomDX3D.SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
7939
begin
4 daniel-mar 7940
  if (ASurfaceWidth <> SurfaceWidth) or (ASurfaceHeight <> SurfaceHeight) then
1 daniel-mar 7941
  begin
7942
    FSurfaceWidth := ASurfaceWidth;
7943
    FSurfaceHeight := ASurfaceHeight;
7944
 
7945
    if Initialized then
7946
      Initialize;
7947
  end;
7948
end;
7949
 
7950
procedure TCustomDX3D.SetSurfaceHeight(Value: Integer);
7951
begin
4 daniel-mar 7952
  if ComponentState * [csReading, csLoading] = [] then
1 daniel-mar 7953
    SetSize(SurfaceWidth, Value)
7954
  else
7955
    FSurfaceHeight := Value;
7956
end;
7957
 
7958
procedure TCustomDX3D.SetSurfaceWidth(Value: Integer);
7959
begin
4 daniel-mar 7960
  if ComponentState * [csReading, csLoading] = [] then
1 daniel-mar 7961
    SetSize(Value, SurfaceHeight)
7962
  else
7963
    FSurfaceWidth := Value;
7964
end;
7965
 
7966
procedure TCustomDX3D.Notification(AComponent: TComponent;
7967
  Operation: TOperation);
7968
begin
7969
  inherited Notification(AComponent, Operation);
4 daniel-mar 7970
  if (Operation = opRemove) and (FDXDraw = AComponent) then
1 daniel-mar 7971
    DXDraw := nil;
7972
end;
7973
 
7974
procedure TCustomDX3D.DXDrawNotifyEvent(Sender: TCustomDXDraw;
7975
  NotifyType: TDXDrawNotifyType);
7976
var
7977
  AOptions: TInitializeDirect3DOptions;
7978
begin
7979
  case NotifyType of
7980
    dxntDestroying:
4 daniel-mar 7981
      begin
7982
        DXDraw := nil;
7983
      end;
1 daniel-mar 7984
    dxntInitializing:
4 daniel-mar 7985
      begin
7986
        if (FDXDraw.FOptions * [do3D, doFullScreen] = [doFullScreen])
7987
          and (FOptions * [toSystemMemory, toSelectDriver] = [toSelectDriver]) then
1 daniel-mar 7988
        begin
4 daniel-mar 7989
          AOptions := [];
7990
          with FDXDraw do
1 daniel-mar 7991
          begin
4 daniel-mar 7992
            if doHardware in Options then AOptions := AOptions + [idoHardware];
7993
            if doRetainedMode in Options then AOptions := AOptions + [idoRetainedMode];
7994
            if doSelectDriver in Options then AOptions := AOptions + [idoSelectDriver];
7995
            if doZBuffer in Options then AOptions := AOptions + [idoZBuffer];
7996
          end;
1 daniel-mar 7997
 
4 daniel-mar 7998
          Direct3DInitializing_DXDraw(AOptions, FDXDraw);
1 daniel-mar 7999
        end;
4 daniel-mar 8000
      end;
1 daniel-mar 8001
    dxntInitialize:
4 daniel-mar 8002
      begin
8003
        Initialize;
8004
      end;
1 daniel-mar 8005
    dxntFinalize:
4 daniel-mar 8006
      begin
8007
        Finalize;
8008
      end;
1 daniel-mar 8009
    dxntRestore:
4 daniel-mar 8010
      begin
8011
        FSurface.Restore;
8012
        if FZBuffer <> nil then
8013
          FZBuffer.Restore;
8014
        FSurface.Palette := FDXDraw.Palette;
8015
      end;
1 daniel-mar 8016
    dxntSetSurfaceSize:
4 daniel-mar 8017
      begin
8018
        if AutoSize then
8019
          SetSize(Sender.SurfaceWidth, Sender.SurfaceHeight);
8020
      end;
1 daniel-mar 8021
  end;
8022
end;
8023
 
8024
procedure TCustomDX3D.SetDXDraw(Value: TCustomDXDraw);
8025
begin
4 daniel-mar 8026
  if FDXDraw <> Value then
1 daniel-mar 8027
  begin
4 daniel-mar 8028
    if FDXDraw <> nil then
1 daniel-mar 8029
      FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
8030
 
8031
    FDXDraw := Value;
8032
 
4 daniel-mar 8033
    if FDXDraw <> nil then
1 daniel-mar 8034
      FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
8035
  end;
8036
end;
8037
 
4 daniel-mar 8038
{$ENDIF}
8039
 
1 daniel-mar 8040
{  TDirect3DTexture  }
8041
 
8042
constructor TDirect3DTexture.Create(Graphic: TGraphic; DXDraw: TComponent);
8043
var
8044
  i: Integer;
8045
begin
8046
  inherited Create;
8047
  FDXDraw := DXDraw;
8048
  FGraphic := Graphic;
8049
 
8050
  {  The palette is acquired.  }
8051
  i := GetPaletteEntries(FGraphic.Palette, 0, 256, FPaletteEntries);
8052
  case i of
4 daniel-mar 8053
    1..2: FBitCount := 1;
8054
    3..16: FBitCount := 4;
1 daniel-mar 8055
    17..256: FBitCount := 8;
8056
  else
8057
    FBitCount := 24;
8058
  end;
8059
 
8060
  if FDXDraw is TCustomDXDraw then
8061
  begin
8062
    with (FDXDraw as TCustomDXDraw) do
8063
    begin
4 daniel-mar 8064
      if (not Initialized) {$IFDEF D3D_deprecated}or (not (do3D in NowOptions)){$ENDIF} then
1 daniel-mar 8065
        raise EDirect3DTextureError.CreateFmt(SNotMade, [FDXDraw.ClassName]);
8066
    end;
8067
    FSurface := TDirectDrawSurface.Create((FDXDraw as TCustomDXDraw).Surface.DDraw);
8068
    (FDXDraw as TCustomDXDraw).RegisterNotifyEvent(DXDrawNotifyEvent);
4 daniel-mar 8069
  end
8070
  else
8071
{$IFDEF DX3D_deprecated}
8072
    if FDXDraw is TCustomDX3D then
1 daniel-mar 8073
    begin
4 daniel-mar 8074
      with (FDXDraw as TDX3D) do
8075
      begin
8076
        if not Initialized then
8077
          raise EDirect3DTextureError.CreateFmt(SNotMade, [FDXDraw.ClassName]);
8078
      end;
1 daniel-mar 8079
 
4 daniel-mar 8080
      FSurface := TDirectDrawSurface.Create((FDXDraw as TCustomDX3D).Surface.DDraw);
8081
      (FDXDraw as TCustomDX3D).FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
8082
    end else
8083
{$ENDIF}
8084
      raise EDirect3DTextureError.CreateFmt(SNotSupported, [FDXDraw.ClassName]);
1 daniel-mar 8085
end;
8086
 
8087
destructor TDirect3DTexture.Destroy;
8088
begin
8089
  if FDXDraw is TCustomDXDraw then
8090
  begin
8091
    (FDXDraw as TCustomDXDraw).UnRegisterNotifyEvent(DXDrawNotifyEvent);
4 daniel-mar 8092
  end
8093
{$IFDEF DX3D_deprecated}
8094
  else if FDXDraw is TCustomDX3D then
1 daniel-mar 8095
  begin
8096
    (FDXDraw as TCustomDX3D).FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
4 daniel-mar 8097
  end
8098
{$ENDIF};
1 daniel-mar 8099
  Clear;
8100
  FSurface.Free;
8101
  inherited Destroy;
8102
end;
8103
 
8104
procedure TDirect3DTexture.Clear;
8105
begin
8106
  FHandle := 0;
8107
  FTexture := nil;
4 daniel-mar 8108
  FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := nil;
1 daniel-mar 8109
end;
8110
 
8111
function TDirect3DTexture.GetHandle: TD3DTextureHandle;
8112
begin
4 daniel-mar 8113
  if FTexture = nil then
1 daniel-mar 8114
    Restore;
8115
  Result := FHandle;
8116
end;
8117
 
8118
function TDirect3DTexture.GetSurface: TDirectDrawSurface;
8119
begin
4 daniel-mar 8120
  if FTexture = nil then
1 daniel-mar 8121
    Restore;
8122
  Result := FSurface;
8123
end;
8124
 
4 daniel-mar 8125
function TDirect3DTexture.GetTexture: {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF};
1 daniel-mar 8126
begin
4 daniel-mar 8127
  if FTexture = nil then
1 daniel-mar 8128
    Restore;
8129
  Result := FTexture;
8130
end;
8131
 
8132
procedure TDirect3DTexture.SetTransparentColor(Value: TColor);
8133
begin
4 daniel-mar 8134
  if FTransparentColor <> Value then
1 daniel-mar 8135
  begin
8136
    FTransparentColor := Value;
8137
 
4 daniel-mar 8138
    if FSurface <> nil then
1 daniel-mar 8139
      FSurface.TransparentColor := FSurface.ColorMatch(Value);
8140
  end;
8141
end;
8142
 
8143
procedure TDirect3DTexture.Restore;
8144
 
8145
  function EnumTextureFormatCallback(const ddsd: TDDSurfaceDesc;
8146
    lParam: Pointer): HRESULT; stdcall;
8147
  var
8148
    tex: TDirect3DTexture;
8149
 
8150
    procedure UseThisFormat;
8151
    begin
8152
      tex.FFormat := ddsd;
8153
      tex.FEnumFormatFlag := True;
8154
    end;
8155
 
8156
  begin
8157
    Result := DDENUMRET_OK;
8158
    tex := lParam;
8159
 
4 daniel-mar 8160
    if ddsd.ddpfPixelFormat.dwFlags and (DDPF_ALPHA or DDPF_ALPHAPIXELS) <> 0 then
1 daniel-mar 8161
      Exit;
8162
 
8163
    if not tex.FEnumFormatFlag then
8164
    begin
8165
      {  When called first,  this format is unconditionally selected.  }
8166
      UseThisFormat;
8167
    end else
8168
    begin
4 daniel-mar 8169
      if (tex.FBitCount <= 8) and (ddsd.ddpfPixelFormat.dwRGBBitCount >= tex.FBitCount) and
8170
        (ddsd.ddpfPixelFormat.dwRGBBitCount >= 8) and
8171
        (ddsd.ddpfPixelFormat.dwFlags and DDPF_RGB <> 0) then
1 daniel-mar 8172
      begin
4 daniel-mar 8173
        if tex.FFormat.ddpfPixelFormat.dwRGBBitCount > ddsd.ddpfPixelFormat.dwRGBBitCount then
1 daniel-mar 8174
          UseThisFormat;
8175
      end else
8176
      begin
4 daniel-mar 8177
        if (tex.FFormat.ddpfPixelFormat.dwRGBBitCount > ddsd.ddpfPixelFormat.dwRGBBitCount) and
8178
          (ddsd.ddpfPixelFormat.dwRGBBitCount > 8) and
8179
          (ddsd.ddpfPixelFormat.dwFlags and DDPF_RGB <> 0) then
1 daniel-mar 8180
          UseThisFormat;
8181
      end;
8182
    end;
8183
  end;
8184
 
8185
  function GetBitCount(i: Integer): Integer;
8186
  var
8187
    j: Integer;
8188
  begin
4 daniel-mar 8189
    for j := 32 downto 1 do
8190
      if (1 shl j) and i <> 0 then
1 daniel-mar 8191
      begin
8192
        Result := j;
4 daniel-mar 8193
        if 1 shl j <> i then
1 daniel-mar 8194
          Dec(Result);
8195
        Exit;
8196
      end;
8197
    Result := 0;
8198
  end;
8199
 
8200
  function CreateHalftonePalette(R, G, B: Integer): TPaletteEntries;
8201
  var
8202
    i: Integer;
8203
  begin
4 daniel-mar 8204
    for i := 0 to 255 do
1 daniel-mar 8205
      with Result[i] do
8206
      begin
4 daniel-mar 8207
        peRed := ((i shr (G + B - 1)) and (1 shl R - 1)) * 255 div (1 shl R - 1);
8208
        peGreen := ((i shr (B - 1)) and (1 shl G - 1)) * 255 div (1 shl G - 1);
8209
        peBlue := ((i shr 0) and (1 shl B - 1)) * 255 div (1 shl B - 1);
1 daniel-mar 8210
        peFlags := 0;
8211
      end;
8212
  end;
8213
 
8214
var
4 daniel-mar 8215
  ddsd: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
1 daniel-mar 8216
  Palette: TDirectDrawPalette;
8217
  PaletteCaps: Integer;
8218
  TempSurface: TDirectDrawSurface;
8219
  Width2, Height2: Integer;
4 daniel-mar 8220
  D3DDevice: {$IFDEF D3D_deprecated}IDirect3DDevice{$ELSE}IDirect3DDevice7{$ENDIF};
1 daniel-mar 8221
  Hardware: Boolean;
8222
  DDraw: TDirectDraw;
8223
begin
8224
  Clear;
8225
  try
8226
    DDraw := nil;
8227
    Hardware := False;
8228
    if FDXDraw is TCustomDXDraw then
8229
    begin
8230
      DDraw := (FDXDraw as TCustomDXDraw).DDraw;
4 daniel-mar 8231
      D3DDevice := (FDXDraw as TCustomDXDraw).{$IFDEF D3D_deprecated}D3DDevice{$ELSE}D3DDevice7{$ENDIF};
1 daniel-mar 8232
      Hardware := doHardware in (FDXDraw as TCustomDXDraw).NowOptions;
4 daniel-mar 8233
    end
8234
    {$IFDEF DX3D_deprecated}
8235
    else if FDXDraw is TCustomDX3D then
1 daniel-mar 8236
    begin
8237
      DDraw := (FDXDraw as TCustomDX3D).Surface.DDraw;
8238
      D3DDevice := (FDXDraw as TCustomDX3D).D3DDevice;
8239
      Hardware := toHardware in (FDXDraw as TCustomDX3D).NowOptions;
4 daniel-mar 8240
    end
8241
    {$ENDIF};
1 daniel-mar 8242
 
4 daniel-mar 8243
    if (DDraw = nil) or (D3DDevice = nil) then Exit;
1 daniel-mar 8244
 
8245
    {  The size of texture is arranged in the size of the square of two.  }
8246
    Width2 := Max(1 shl GetBitCount(FGraphic.Width), 1);
8247
    Height2 := Max(1 shl GetBitCount(FGraphic.Height), 1);
8248
 
8249
    {  Selection of format of texture.  }
8250
    FEnumFormatFlag := False;
8251
    D3DDevice.EnumTextureFormats(@EnumTextureFormatCallback, Self);
8252
 
8253
    TempSurface := TDirectDrawSurface.Create(FSurface.DDraw);
8254
    try
8255
      {  Make source surface.  }
8256
      with ddsd do
8257
      begin
8258
        dwSize := SizeOf(ddsd);
8259
        dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
8260
        ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_SYSTEMMEMORY;
8261
        dwWidth := Width2;
8262
        dwHeight := Height2;
8263
        ddpfPixelFormat := FFormat.ddpfPixelFormat;
8264
      end;
8265
 
8266
      if not TempSurface.CreateSurface(ddsd) then
8267
        raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
8268
 
8269
      {  Make surface.  }
8270
      with ddsd do
8271
      begin
8272
        dwSize := SizeOf(ddsd);
8273
        dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
8274
        if Hardware then
8275
          ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_VIDEOMEMORY
8276
        else
8277
          ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_SYSTEMMEMORY;
8278
        ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_ALLOCONLOAD;
8279
        dwWidth := Width2;
8280
        dwHeight := Height2;
8281
        ddpfPixelFormat := FFormat.ddpfPixelFormat;
8282
      end;
8283
 
8284
      if not FSurface.CreateSurface(ddsd) then
8285
        raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
8286
 
8287
      {  Make palette.  }
4 daniel-mar 8288
      if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8 <> 0 then
1 daniel-mar 8289
      begin
8290
        PaletteCaps := DDPCAPS_8BIT or DDPCAPS_ALLOW256;
4 daniel-mar 8291
        if FBitCount = 24 then
1 daniel-mar 8292
          CreateHalftonePalette(3, 3, 2);
4 daniel-mar 8293
      end else if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4 <> 0 then
1 daniel-mar 8294
      begin
8295
        PaletteCaps := DDPCAPS_4BIT;
4 daniel-mar 8296
        if FBitCount = 24 then
1 daniel-mar 8297
          CreateHalftonePalette(1, 2, 1);
4 daniel-mar 8298
      end else if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1 <> 0 then
1 daniel-mar 8299
      begin
8300
        PaletteCaps := DDPCAPS_1BIT;
4 daniel-mar 8301
        if FBitCount = 24 then
1 daniel-mar 8302
        begin
8303
          FPaletteEntries[0] := RGBQuadToPaletteEntry(RGBQuad(0, 0, 0));
8304
          FPaletteEntries[1] := RGBQuadToPaletteEntry(RGBQuad(255, 255, 255));
8305
        end;
8306
      end else
8307
        PaletteCaps := 0;
8308
 
4 daniel-mar 8309
      if PaletteCaps <> 0 then
1 daniel-mar 8310
      begin
8311
        Palette := TDirectDrawPalette.Create(DDraw);
8312
        try
8313
          Palette.CreatePalette(PaletteCaps, FPaletteEntries);
8314
          TempSurface.Palette := Palette;
8315
          FSurface.Palette := Palette;
8316
        finally
8317
          Palette.Free;
8318
        end;
8319
      end;
8320
 
8321
      {  The image is loaded into source surface.  }
8322
      with TempSurface.Canvas do
8323
      begin
8324
        StretchDraw(TempSurface.ClientRect, FGraphic);
8325
        Release;
8326
      end;
8327
 
8328
      {  Source surface is loaded into surface.  }
4 daniel-mar 8329
      FTexture := FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF} as {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF};
8330
      FTexture.Load(TempSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF} as {$IFDEF D3D_deprecated}IDirect3DTexture{$ELSE}IDirect3DTexture2{$ENDIF});
1 daniel-mar 8331
    finally
8332
      TempSurface.Free;
8333
    end;
8334
 
4 daniel-mar 8335
    if FTexture.GetHandle(D3DDevice as {$IFDEF D3D_deprecated}IDirect3DDevice{$ELSE}IDirect3DDevice2{$ENDIF}, FHandle) <> D3D_OK then
1 daniel-mar 8336
      raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
8337
 
8338
    FSurface.TransparentColor := FSurface.ColorMatch(FTransparentColor);
8339
  except
8340
    Clear;
8341
    raise;
8342
  end;
8343
end;
8344
 
8345
procedure TDirect3DTexture.DXDrawNotifyEvent(Sender: TCustomDXDraw;
8346
  NotifyType: TDXDrawNotifyType);
8347
begin
8348
  case NotifyType of
8349
    dxntInitializeSurface:
4 daniel-mar 8350
      begin
8351
        Restore;
8352
      end;
1 daniel-mar 8353
    dxntRestore:
4 daniel-mar 8354
      begin
8355
        Restore;
8356
      end;
1 daniel-mar 8357
  end;
8358
end;
8359
 
8360
{  TDirect3DTexture2  }
8361
 
8362
constructor TDirect3DTexture2.Create(ADXDraw: TCustomDXDraw; Graphic: TObject;
8363
  AutoFreeGraphic: Boolean);
8364
begin
8365
  inherited Create;
8366
  FSrcImage := Graphic;
8367
  FAutoFreeGraphic := AutoFreeGraphic;
8368
  FNeedLoadTexture := True;
8369
 
8370
  if FSrcImage is TDXTextureImage then
8371
    FImage := TDXTextureImage(FSrcImage)
4 daniel-mar 8372
  else
8373
  if FSrcImage is TDIB then
1 daniel-mar 8374
    SetDIB(TDIB(FSrcImage))
4 daniel-mar 8375
  else
8376
  if FSrcImage is TGraphic then
1 daniel-mar 8377
  begin
8378
    FSrcImage := TDIB.Create;
8379
    try
8380
      TDIB(FSrcImage).Assign(TGraphic(Graphic));
8381
      SetDIB(TDIB(FSrcImage));
8382
    finally
8383
      if FAutoFreeGraphic then
8384
        Graphic.Free;
8385
      FAutoFreeGraphic := True;
8386
    end;
4 daniel-mar 8387
  end
8388
  else
8389
    if FSrcImage is TPicture then
8390
    begin
8391
      FSrcImage := TDIB.Create;
8392
      try
8393
        TDIB(FSrcImage).Assign(TPicture(Graphic).Graphic);
8394
        SetDIB(TDIB(FSrcImage));
8395
      finally
8396
        if FAutoFreeGraphic then
8397
          Graphic.Free;
8398
        FAutoFreeGraphic := True;
8399
      end;
8400
    end
8401
    else
8402
      raise Exception.CreateFmt(SCannotLoadGraphic, [Graphic.ClassName]);
1 daniel-mar 8403
 
4 daniel-mar 8404
  FMipmap := FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap] > 0;
1 daniel-mar 8405
 
8406
  FTransparent := FImage.Transparent;
8407
  case FImage.ImageType of
8408
    DXTextureImageType_PaletteIndexedColor:
8409
      begin
8410
        FTransparentColor := PaletteIndex(dxtDecodeChannel(FImage.idx_index, FImage.TransparentColor));
8411
      end;
8412
    DXTextureImageType_RGBColor:
8413
      begin
8414
        FTransparentColor := RGB(dxtDecodeChannel(FImage.rgb_red, FImage.TransparentColor),
8415
          dxtDecodeChannel(FImage.rgb_green, FImage.TransparentColor),
8416
          dxtDecodeChannel(FImage.rgb_blue, FImage.TransparentColor));
8417
      end;
8418
  end;
8419
 
8420
  SetDXDraw(ADXDraw);
8421
end;
8422
 
8423
constructor TDirect3DTexture2.CreateFromFile(ADXDraw: TCustomDXDraw; const FileName: string);
8424
var
8425
  Image: TObject;
8426
begin
8427
  Image := nil;
8428
  try
8429
    {  TDXTextureImage  }
8430
    Image := TDXTextureImage.Create;
8431
    try
8432
      TDXTextureImage(Image).LoadFromFile(FileName);
8433
    except
8434
      Image.Free;
8435
      Image := nil;
8436
    end;
8437
 
8438
    {  TDIB  }
4 daniel-mar 8439
    if Image = nil then
1 daniel-mar 8440
    begin
8441
      Image := TDIB.Create;
8442
      try
8443
        TDIB(Image).LoadFromFile(FileName);
8444
      except
8445
        Image.Free;
8446
        Image := nil;
8447
      end;
8448
    end;
8449
 
8450
    {  TPicture  }
4 daniel-mar 8451
    if Image = nil then
1 daniel-mar 8452
    begin
8453
      Image := TPicture.Create;
8454
      try
8455
        TPicture(Image).LoadFromFile(FileName);
8456
      except
8457
        Image.Free;
8458
        Image := nil;
8459
        raise;
8460
      end;
8461
    end;
8462
  except
8463
    Image.Free;
8464
    raise;
8465
  end;
8466
 
8467
  Create(ADXDraw, Image, True);
8468
end;
8469
 
8470
constructor TDirect3DTexture2.CreateVideoTexture(ADXDraw: TCustomDXDraw);
8471
begin
8472
  inherited Create;
8473
  SetDXDraw(ADXDraw);
8474
end;
8475
 
8476
destructor TDirect3DTexture2.Destroy;
8477
begin
8478
  Finalize;
8479
 
8480
  SetDXDraw(nil);
8481
 
8482
  if FAutoFreeGraphic then
8483
    FSrcImage.Free;
8484
  FImage2.Free;
8485
  inherited Destroy;
8486
end;
8487
 
8488
procedure TDirect3DTexture2.DXDrawNotifyEvent(Sender: TCustomDXDraw;
8489
  NotifyType: TDXDrawNotifyType);
8490
begin
8491
  case NotifyType of
8492
    dxntDestroying:
4 daniel-mar 8493
      begin
8494
        SetDXDraw(nil);
8495
      end;
1 daniel-mar 8496
    dxntInitializeSurface:
4 daniel-mar 8497
      begin
8498
        Initialize;
8499
      end;
1 daniel-mar 8500
    dxntFinalizeSurface:
4 daniel-mar 8501
      begin
8502
        Finalize;
8503
      end;
1 daniel-mar 8504
    dxntRestore:
4 daniel-mar 8505
      begin
8506
        Load;
8507
      end;
1 daniel-mar 8508
  end;
8509
end;
8510
 
8511
procedure TDirect3DTexture2.SetDXDraw(ADXDraw: TCustomDXDraw);
8512
begin
4 daniel-mar 8513
  if FDXDraw <> ADXDraw then
1 daniel-mar 8514
  begin
4 daniel-mar 8515
    if FDXDraw <> nil then
1 daniel-mar 8516
      FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
8517
 
8518
    FDXDraw := ADXDraw;
8519
 
4 daniel-mar 8520
    if FDXDraw <> nil then
1 daniel-mar 8521
      FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
8522
  end;
8523
end;
8524
 
8525
procedure TDirect3DTexture2.DoRestoreSurface;
8526
begin
8527
  if Assigned(FOnRestoreSurface) then
8528
    FOnRestoreSurface(Self);
8529
end;
8530
 
8531
procedure TDirect3DTexture2.SetDIB(DIB: TDIB);
8532
var
8533
  i: Integer;
8534
begin
4 daniel-mar 8535
  if FImage2 = nil then
1 daniel-mar 8536
    FImage2 := TDXTextureImage.Create;
4 daniel-mar 8537
 
8538
  if DIB.BitCount <= 8 then
1 daniel-mar 8539
  begin
8540
    FImage2.SetImage(DXTextureImageType_PaletteIndexedColor, DIB.Width, DIB.Height, DIB.BitCount,
8541
      DIB.WidthBytes, DIB.NextLine, DIB.PBits, DIB.TopPBits, DIB.Size, False);
8542
 
4 daniel-mar 8543
    FImage2.idx_index := dxtMakeChannel((1 shl DIB.BitCount) - 1, True);
8544
    for i := 0 to 255 do
1 daniel-mar 8545
      FImage2.idx_palette[i] := RGBQuadToPaletteEntry(DIB.ColorTable[i]);
8546
  end else
8547
  begin
8548
    FImage2.SetImage(DXTextureImageType_RGBColor, DIB.Width, DIB.Height, DIB.BitCount,
8549
      DIB.WidthBytes, DIB.NextLine, DIB.PBits, DIB.TopPBits, DIB.Size, False);
8550
 
8551
    FImage2.rgb_red := dxtMakeChannel(DIB.NowPixelFormat.RBitMask, False);
8552
    FImage2.rgb_green := dxtMakeChannel(DIB.NowPixelFormat.GBitMask, False);
8553
    FImage2.rgb_blue := dxtMakeChannel(DIB.NowPixelFormat.BBitMask, False);
8554
 
4 daniel-mar 8555
    i := DIB.NowPixelFormat.RBitCount + DIB.NowPixelFormat.GBitCount + DIB.NowPixelFormat.BBitCount;
8556
    if i < DIB.BitCount then
8557
      FImage2.rgb_alpha := dxtMakeChannel(((1 shl (DIB.BitCount - i)) - 1) shl i, False);
1 daniel-mar 8558
  end;
8559
 
8560
  FImage := FImage2;
8561
end;
8562
 
4 daniel-mar 8563
function TDirect3DTexture2.GetHeight: Integer;
8564
begin
8565
  if Assigned(FImage) then
8566
    Result := FImage.Height
8567
  else
8568
    if Assigned(FImage2) then
8569
      Result := FImage2.Height
8570
    else
8571
      Result := 0;
8572
end;
8573
 
1 daniel-mar 8574
function TDirect3DTexture2.GetIsMipmap: Boolean;
8575
begin
4 daniel-mar 8576
  if FSurface <> nil then
1 daniel-mar 8577
    Result := FUseMipmap
8578
  else
8579
    Result := FMipmap;
8580
end;
8581
 
8582
function TDirect3DTexture2.GetSurface: TDirectDrawSurface;
8583
begin
8584
  Result := FSurface;
4 daniel-mar 8585
  if (Result <> nil) and FNeedLoadTexture then
1 daniel-mar 8586
    Load;
8587
end;
8588
 
8589
function TDirect3DTexture2.GetTransparent: Boolean;
8590
begin
4 daniel-mar 8591
  if FSurface <> nil then
1 daniel-mar 8592
    Result := FUseColorKey
8593
  else
8594
    Result := FTransparent;
8595
end;
8596
 
4 daniel-mar 8597
function TDirect3DTexture2.GetWidth: Integer;
8598
begin
8599
  if Assigned(FImage) then
8600
    Result := FImage.Width
8601
  else
8602
    if Assigned(FImage2) then
8603
      Result := FImage2.Width
8604
    else
8605
      Result := 0;
8606
end;
8607
 
1 daniel-mar 8608
procedure TDirect3DTexture2.SetTransparent(Value: Boolean);
8609
begin
4 daniel-mar 8610
  if FTransparent <> Value then
1 daniel-mar 8611
  begin
8612
    FTransparent := Value;
4 daniel-mar 8613
    if FSurface <> nil then
1 daniel-mar 8614
      SetColorKey;
8615
  end;
8616
end;
8617
 
8618
procedure TDirect3DTexture2.SetTransparentColor(Value: TColorRef);
8619
begin
4 daniel-mar 8620
  if FTransparentColor <> Value then
1 daniel-mar 8621
  begin
8622
    FTransparentColor := Value;
4 daniel-mar 8623
    if (FSurface <> nil) and FTransparent then
1 daniel-mar 8624
      SetColorKey;
8625
  end;
8626
end;
8627
 
8628
procedure TDirect3DTexture2.Finalize;
8629
begin
8630
  FSurface.Free; FSurface := nil;
8631
 
8632
  FUseColorKey := False;
8633
  FUseMipmap := False;
8634
  FNeedLoadTexture := False;
8635
end;
8636
 
8637
const
8638
  DDPF_PALETTEINDEXED = DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
8639
    DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8;
8640
 
8641
procedure TDirect3DTexture2.Initialize;
8642
 
8643
  function GetBitCount(i: Integer): Integer;
8644
  begin
8645
    Result := 31;
4 daniel-mar 8646
    while (i >= 0) and (((1 shl Result) and i) = 0) do Dec(Result);
1 daniel-mar 8647
  end;
8648
 
8649
  function GetMaskBitCount(b: Integer): Integer;
8650
  var
8651
    i: Integer;
8652
  begin
8653
    i := 0;
4 daniel-mar 8654
    while (i < 31) and (((1 shl i) and b) = 0) do Inc(i);
1 daniel-mar 8655
 
8656
    Result := 0;
4 daniel-mar 8657
    while ((1 shl i) and b) <> 0 do
1 daniel-mar 8658
    begin
8659
      Inc(i);
8660
      Inc(Result);
8661
    end;
8662
  end;
8663
 
8664
  function GetPaletteBitCount(const ddpfPixelFormat: TDDPixelFormat): Integer;
8665
  begin
4 daniel-mar 8666
    if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8 <> 0 then
1 daniel-mar 8667
      Result := 8
4 daniel-mar 8668
    else if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4 <> 0 then
1 daniel-mar 8669
      Result := 4
4 daniel-mar 8670
    else if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED2 <> 0 then
1 daniel-mar 8671
      Result := 2
4 daniel-mar 8672
    else if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1 <> 0 then
1 daniel-mar 8673
      Result := 1
8674
    else
8675
      Result := 0;
8676
  end;
8677
 
8678
  function EnumTextureFormatCallback(const lpDDPixFmt: TDDPixelFormat;
8679
    lParam: Pointer): HRESULT; stdcall;
8680
  var
8681
    tex: TDirect3DTexture2;
8682
 
8683
    procedure UseThisFormat;
8684
    begin
8685
      tex.FTextureFormat.ddpfPixelFormat := lpDDPixFmt;
8686
      tex.FEnumTextureFormatFlag := True;
8687
    end;
8688
 
8689
  var
8690
    rgb_red, rgb_green, rgb_blue, rgb_alpha, idx_index: Integer;
8691
    sum1, sum2: Integer;
8692
  begin
8693
    Result := DDENUMRET_OK;
8694
    tex := lParam;
8695
 
8696
    {  Form acquisition of source image  }
8697
    rgb_red := 0;
8698
    rgb_green := 0;
8699
    rgb_blue := 0;
8700
    rgb_alpha := 0;
8701
    idx_index := 0;
8702
 
8703
    case tex.FImage.ImageType of
8704
      DXTextureImageType_RGBColor:
8705
        begin
8706
          {  RGB Color  }
8707
          rgb_red := tex.FImage.rgb_red.bitcount;
8708
          rgb_green := tex.FImage.rgb_green.bitcount;
8709
          rgb_blue := tex.FImage.rgb_blue.bitcount;
8710
          rgb_alpha := tex.FImage.rgb_alpha.bitcount;
8711
          idx_index := 8;
8712
        end;
8713
      DXTextureImageType_PaletteIndexedColor:
8714
        begin
8715
          {  Index Color  }
8716
          rgb_red := 8;
8717
          rgb_green := 8;
8718
          rgb_blue := 8;
8719
          rgb_alpha := tex.FImage.idx_alpha.bitcount;
8720
          idx_index := tex.FImage.idx_index.bitcount;
8721
        end;
8722
    end;
8723
 
8724
    {  The texture examines whether this pixel format can be used.  }
4 daniel-mar 8725
    if lpDDPixFmt.dwFlags and DDPF_RGB = 0 then Exit;
1 daniel-mar 8726
 
8727
    case tex.FImage.ImageType of
8728
      DXTextureImageType_RGBColor:
8729
        begin
4 daniel-mar 8730
          if lpDDPixFmt.dwFlags and DDPF_PALETTEINDEXED <> 0 then Exit;
1 daniel-mar 8731
        end;
8732
      DXTextureImageType_PaletteIndexedColor:
8733
        begin
4 daniel-mar 8734
          if (lpDDPixFmt.dwFlags and DDPF_PALETTEINDEXED <> 0) and
8735
            (GetPaletteBitCount(lpDDPixFmt) < idx_index) then Exit;
1 daniel-mar 8736
        end;
8737
    end;
8738
 
8739
    {  The pixel format which can be used is selected carefully.  }
8740
    if tex.FEnumTextureFormatFlag then
8741
    begin
4 daniel-mar 8742
      if lpDDPixFmt.dwFlags and DDPF_PALETTEINDEXED <> 0 then
1 daniel-mar 8743
      begin
8744
        {  Bit count check  }
4 daniel-mar 8745
        if Abs(Integer(lpDDPixFmt.dwRGBBitCount) - idx_index) >
8746
          Abs(Integer(tex.FTextureFormat.ddpfPixelFormat.dwRGBBitCount) - idx_index) then Exit;
1 daniel-mar 8747
 
8748
        {  Alpha channel check  }
4 daniel-mar 8749
        if rgb_alpha > 0 then Exit;
1 daniel-mar 8750
      end else
4 daniel-mar 8751
        if lpDDPixFmt.dwFlags and DDPF_RGB <> 0 then
8752
        begin
1 daniel-mar 8753
        {  The alpha channel is indispensable.  }
4 daniel-mar 8754
          if (rgb_alpha > 0) and (tex.FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_ALPHAPIXELS = 0) and
8755
            (lpDDPixFmt.dwFlags and DDPF_ALPHAPIXELS <> 0) then
8756
          begin
8757
            UseThisFormat;
8758
            Exit;
8759
          end;
1 daniel-mar 8760
 
8761
        {  Alpha channel check  }
4 daniel-mar 8762
          if (rgb_alpha > 0) and (tex.FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_ALPHAPIXELS <> 0) and
8763
            (lpDDPixFmt.dwFlags and DDPF_ALPHAPIXELS = 0) then
8764
          begin
8765
            Exit;
8766
          end;
1 daniel-mar 8767
 
8768
        {  Bit count check  }
4 daniel-mar 8769
          if tex.FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED = 0 then
8770
          begin
8771
            sum1 := Sqr(GetMaskBitCount(lpDDPixFmt.dwRBitMask) - rgb_red) +
8772
              Sqr(GetMaskBitCount(lpDDPixFmt.dwGBitMask) - rgb_green) +
8773
              Sqr(GetMaskBitCount(lpDDPixFmt.dwBBitMask) - rgb_blue) +
8774
              Sqr(GetMaskBitCount(lpDDPixFmt.dwRGBAlphaBitMask) - rgb_alpha);
1 daniel-mar 8775
 
4 daniel-mar 8776
            sum2 := Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwRBitMask) - rgb_red) +
8777
              Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwGBitMask) - rgb_green) +
8778
              Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwBBitMask) - rgb_blue) +
8779
              Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwRGBAlphaBitMask) - rgb_alpha);
1 daniel-mar 8780
 
4 daniel-mar 8781
            if sum1 > sum2 then Exit;
8782
          end;
1 daniel-mar 8783
        end;
8784
    end;
8785
 
8786
    UseThisFormat;
8787
  end;
8788
 
8789
var
8790
  Width, Height: Integer;
8791
  PaletteCaps: DWORD;
8792
  Palette: IDirectDrawPalette;
4 daniel-mar 8793
  {$IFDEF D3D_deprecated}TempD3DDevDesc: TD3DDeviceDesc;{$ENDIF}
1 daniel-mar 8794
  D3DDevDesc7: TD3DDeviceDesc7;
4 daniel-mar 8795
  TempSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF};
1 daniel-mar 8796
begin
8797
  Finalize;
8798
  try
4 daniel-mar 8799
    if FDXDraw.D3DDevice7 <> nil then
1 daniel-mar 8800
    begin
8801
      FDXDraw.D3DDevice7.GetCaps(D3DDevDesc7);
8802
      FD3DDevDesc.dpcLineCaps.dwTextureCaps := D3DDevDesc7.dpcLineCaps.dwTextureCaps;
8803
      FD3DDevDesc.dpcTriCaps.dwTextureCaps := D3DDevDesc7.dpcTriCaps.dwTextureCaps;
8804
      FD3DDevDesc.dwMinTextureWidth := D3DDevDesc7.dwMinTextureWidth;
8805
      FD3DDevDesc.dwMaxTextureWidth := D3DDevDesc7.dwMaxTextureWidth;
4 daniel-mar 8806
    end
8807
    {$IFDEF D3D_deprecated}
8808
    else
1 daniel-mar 8809
    begin
8810
      FD3DDevDesc.dwSize := SizeOf(FD3DDevDesc);
8811
      TempD3DDevDesc.dwSize := SizeOf(TempD3DDevDesc);
8812
      FDXDraw.D3DDevice3.GetCaps(FD3DDevDesc, TempD3DDevDesc);
4 daniel-mar 8813
    end{$ENDIF};
1 daniel-mar 8814
 
4 daniel-mar 8815
    if FImage <> nil then
1 daniel-mar 8816
    begin
8817
      {  Size adjustment of texture  }
4 daniel-mar 8818
      if FD3DDevDesc.dpcTriCaps.dwTextureCaps and D3DPTEXTURECAPS_POW2 <> 0 then
1 daniel-mar 8819
      begin
8820
        {  The size of the texture is only Sqr(n).  }
8821
        Width := Max(1 shl GetBitCount(FImage.Width), 1);
8822
        Height := Max(1 shl GetBitCount(FImage.Height), 1);
4 daniel-mar 8823
      end
8824
      else
1 daniel-mar 8825
      begin
8826
        Width := FImage.Width;
8827
        Height := FImage.Height;
8828
      end;
8829
 
4 daniel-mar 8830
      if FD3DDevDesc.dpcTriCaps.dwTextureCaps and D3DPTEXTURECAPS_SQUAREONLY <> 0 then
1 daniel-mar 8831
      begin
8832
        {  The size of the texture is only a square.  }
4 daniel-mar 8833
        if Width < Height then Width := Height;
1 daniel-mar 8834
        Height := Width;
8835
      end;
8836
 
4 daniel-mar 8837
      if FD3DDevDesc.dwMinTextureWidth > 0 then
1 daniel-mar 8838
        Width := Max(Width, FD3DDevDesc.dwMinTextureWidth);
8839
 
4 daniel-mar 8840
      if FD3DDevDesc.dwMaxTextureWidth > 0 then
1 daniel-mar 8841
        Width := Min(Width, FD3DDevDesc.dwMaxTextureWidth);
8842
 
4 daniel-mar 8843
      if FD3DDevDesc.dwMinTextureHeight > 0 then
1 daniel-mar 8844
        Height := Max(Height, FD3DDevDesc.dwMinTextureHeight);
8845
 
4 daniel-mar 8846
      if FD3DDevDesc.dwMaxTextureHeight > 0 then
1 daniel-mar 8847
        Height := Min(Height, FD3DDevDesc.dwMaxTextureHeight);
8848
 
8849
      {  Pixel format selection  }
8850
      FEnumTextureFormatFlag := False;
4 daniel-mar 8851
      if FDXDraw.D3DDevice7 <> nil then
1 daniel-mar 8852
        FDXDraw.D3DDevice7.EnumTextureFormats(@EnumTextureFormatCallback, Self)
4 daniel-mar 8853
      {$IFDEF D3D_deprecated}else
8854
        FDXDraw.D3DDevice3.EnumTextureFormats(@EnumTextureFormatCallback, Self){$ENDIF};
1 daniel-mar 8855
 
8856
      if not FEnumTextureFormatFlag then
8857
        raise EDirect3DTextureError.CreateFmt(SCannotInitialized, [STexture]);
8858
 
8859
      {  Is Mipmap surface used ?  }
4 daniel-mar 8860
      FUseMipmap := FMipmap and (FTextureFormat.ddpfPixelFormat.dwRGBBitCount > 8) and
8861
        (FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap] > 0) and (FDXDraw.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_MIPMAP <> 0);
1 daniel-mar 8862
 
8863
      {  Surface form setting  }
8864
      with FTextureFormat do
8865
      begin
8866
        dwSize := SizeOf(FTextureFormat);
8867
        dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
8868
        ddsCaps.dwCaps := DDSCAPS_TEXTURE;
8869
        ddsCaps.dwCaps2 := 0;
8870
        dwWidth := Width;
8871
        dwHeight := Height;
8872
 
8873
        if doHardware in FDXDraw.NowOptions then
8874
          ddsCaps.dwCaps2 := ddsCaps.dwCaps2 or DDSCAPS2_TEXTUREMANAGE
8875
        else
8876
          ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
8877
 
8878
        if FUseMipmap then
8879
        begin
8880
          dwFlags := dwFlags or DDSD_MIPMAPCOUNT;
8881
          ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_MIPMAP or DDSCAPS_COMPLEX;
8882
          dwMipMapCount := FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap];
8883
        end;
8884
      end;
8885
    end;
8886
 
8887
    FSurface := TDirectDrawSurface.Create(FDXDraw.DDraw);
4 daniel-mar 8888
    FSurface.DDraw.DXResult := FSurface.DDraw.{$IFDEF D3D_deprecated}IDraw4{$ELSE}IDraw7{$ENDIF}.CreateSurface(FTextureFormat, TempSurface, nil);
8889
    if FSurface.DDraw.DXResult <> DD_OK then
1 daniel-mar 8890
      raise EDirect3DTextureError.CreateFmt(SCannotInitialized, [STexture]);
4 daniel-mar 8891
    FSurface.{$IFDEF D3D_deprecated}IDDSurface4{$ELSE}IDDSurface7{$ENDIF} := TempSurface;
1 daniel-mar 8892
 
8893
    {  Palette making  }
4 daniel-mar 8894
    if (FImage <> nil) and (FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED <> 0) then
1 daniel-mar 8895
    begin
4 daniel-mar 8896
      if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8 <> 0 then
1 daniel-mar 8897
        PaletteCaps := DDPCAPS_8BIT or DDPCAPS_ALLOW256
4 daniel-mar 8898
      else
8899
      if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4 <> 0 then
1 daniel-mar 8900
        PaletteCaps := DDPCAPS_4BIT
4 daniel-mar 8901
      else
8902
      if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED2 <> 0 then
1 daniel-mar 8903
        PaletteCaps := DDPCAPS_2BIT
4 daniel-mar 8904
      else
8905
      if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1 <> 0 then
1 daniel-mar 8906
        PaletteCaps := DDPCAPS_1BIT
8907
      else
8908
        PaletteCaps := 0;
8909
 
4 daniel-mar 8910
      if PaletteCaps <> 0 then
1 daniel-mar 8911
      begin
4 daniel-mar 8912
        if FDXDraw.DDraw.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.CreatePalette(PaletteCaps, @FImage.idx_palette, Palette, nil) <> 0 then
1 daniel-mar 8913
          Exit;
8914
 
4 daniel-mar 8915
        FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetPalette(Palette);
1 daniel-mar 8916
      end;
8917
    end;
8918
 
8919
    FNeedLoadTexture := True;
8920
  except
8921
    Finalize;
8922
    raise;
8923
  end;
8924
end;
8925
 
8926
procedure TDirect3DTexture2.Load;
8927
const
8928
  MipmapCaps: TDDSCaps2 = (dwCaps: DDSCAPS_TEXTURE or DDSCAPS_MIPMAP);
8929
var
4 daniel-mar 8930
  CurSurface, NextSurface: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF};
1 daniel-mar 8931
  Index: Integer;
8932
  SrcImage: TDXTextureImage;
8933
begin
4 daniel-mar 8934
  if FSurface = nil then
1 daniel-mar 8935
    Initialize;
8936
 
8937
  FNeedLoadTexture := False;
4 daniel-mar 8938
  if FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.IsLost = DDERR_SURFACELOST then
1 daniel-mar 8939
    FSurface.Restore;
8940
 
8941
  {  Color key setting.  }
8942
  SetColorKey;
8943
 
8944
  {  Image loading into surface.  }
4 daniel-mar 8945
  if FImage <> nil then
1 daniel-mar 8946
  begin
8947
    if FSrcImage is TDIB then
8948
      SetDIB(TDIB(FSrcImage));
8949
 
4 daniel-mar 8950
    CurSurface := FSurface.{$IFDEF D3D_deprecated}ISurface4{$ELSE}ISurface7{$ENDIF};
1 daniel-mar 8951
    Index := 0;
4 daniel-mar 8952
    while CurSurface <> nil do
1 daniel-mar 8953
    begin
8954
      SrcImage := FImage;
4 daniel-mar 8955
      if Index > 0 then
1 daniel-mar 8956
      begin
4 daniel-mar 8957
        if Index - 1 >= FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap] then
1 daniel-mar 8958
          Break;
4 daniel-mar 8959
        SrcImage := FImage.SubGroupImages[DXTextureImageGroupType_Mipmap, Index - 1];
1 daniel-mar 8960
      end;
8961
 
8962
      LoadSubTexture(CurSurface, SrcImage);
8963
 
4 daniel-mar 8964
      if CurSurface.GetAttachedSurface(MipmapCaps, NextSurface) = 0 then
1 daniel-mar 8965
        CurSurface := NextSurface
8966
      else
8967
        CurSurface := nil;
8968
 
8969
      Inc(Index);
8970
    end;
4 daniel-mar 8971
  end
8972
  else
1 daniel-mar 8973
    DoRestoreSurface;
8974
end;
8975
 
8976
procedure TDirect3DTexture2.SetColorKey;
8977
var
8978
  ck: TDDColorKey;
8979
begin
8980
  FUseColorKey := False;
8981
 
4 daniel-mar 8982
  if (FSurface <> nil) and FTransparent and (FD3DDevDesc.dpcTriCaps.dwTextureCaps and D3DPTEXTURECAPS_TRANSPARENCY <> 0) then
1 daniel-mar 8983
  begin
8984
    FillChar(ck, SizeOf(ck), 0);
4 daniel-mar 8985
    if FSurface.SurfaceDesc.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED <> 0 then
1 daniel-mar 8986
    begin
4 daniel-mar 8987
      if FTransparentColor shr 24 = $01 then
1 daniel-mar 8988
      begin
8989
        {  Palette index  }
8990
        ck.dwColorSpaceLowValue := FTransparentColor and $FF;
4 daniel-mar 8991
      end
8992
      else
8993
        if FImage <> nil then
8994
        begin
1 daniel-mar 8995
        {  RGB value  }
4 daniel-mar 8996
          ck.dwColorSpaceLowValue := FImage.PaletteIndex(GetRValue(FTransparentColor), GetGValue(FTransparentColor), GetBValue(FTransparentColor));
8997
        end else
8998
          Exit;
8999
    end
9000
    else
1 daniel-mar 9001
    begin
4 daniel-mar 9002
      if (FImage <> nil) and (FImage.ImageType = DXTextureImageType_PaletteIndexedColor) and (FTransparentColor shr 24 = $01) then
1 daniel-mar 9003
      begin
9004
        {  Palette index  }
9005
        ck.dwColorSpaceLowValue :=
9006
          dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwRBitMask, False), FImage.idx_palette[FTransparentColor and $FF].peRed) or
9007
          dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwGBitMask, False), FImage.idx_palette[FTransparentColor and $FF].peGreen) or
9008
          dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwBBitMask, False), FImage.idx_palette[FTransparentColor and $FF].peBlue);
4 daniel-mar 9009
      end
9010
      else
9011
        if FTransparentColor shr 24 = $00 then
9012
        begin
1 daniel-mar 9013
        {  RGB value  }
4 daniel-mar 9014
          ck.dwColorSpaceLowValue :=
9015
            dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwRBitMask, False), GetRValue(FTransparentColor)) or
9016
            dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwGBitMask, False), GetGValue(FTransparentColor)) or
9017
            dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwBBitMask, False), GetBValue(FTransparentColor));
9018
        end
9019
        else
9020
          Exit;
1 daniel-mar 9021
    end;
9022
 
9023
    ck.dwColorSpaceHighValue := ck.dwColorSpaceLowValue;
4 daniel-mar 9024
    FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.SetColorKey(DDCKEY_SRCBLT, @ck);
1 daniel-mar 9025
 
9026
    FUseColorKey := True;
9027
  end;
9028
end;
9029
 
4 daniel-mar 9030
procedure TDirect3DTexture2.LoadSubTexture(Dest: {$IFDEF D3D_deprecated}IDirectDrawSurface4{$ELSE}IDirectDrawSurface7{$ENDIF}; SrcImage: TDXTextureImage);
1 daniel-mar 9031
const
9032
  Mask1: array[0..7] of DWORD = (1, 2, 4, 8, 16, 32, 64, 128);
9033
  Mask2: array[0..3] of DWORD = (3, 12, 48, 192);
9034
  Mask4: array[0..1] of DWORD = ($0F, $F0);
9035
  Shift1: array[0..7] of DWORD = (0, 1, 2, 3, 4, 5, 6, 7);
9036
  Shift2: array[0..3] of DWORD = (0, 2, 4, 6);
9037
  Shift4: array[0..1] of DWORD = (0, 4);
9038
 
9039
  procedure SetPixel(const ddsd: TDDSurfaceDesc2; x, y: Integer; c: DWORD);
9040
  begin
9041
    case ddsd.ddpfPixelFormat.dwRGBBitCount of
4 daniel-mar 9042
      1: PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 8)^ :=
9043
        (PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 8)^ and (not Mask1[x mod 8])) or (c shl Shift1[x mod 8]);
9044
      2: PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 4)^ :=
9045
        (PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 4)^ and (not Mask2[x mod 4])) or (c shl Shift2[x mod 4]);
9046
      4: PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 2)^ :=
9047
        (PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x div 2)^ and (not Mask4[x mod 2])) or (c shl Shift4[x mod 2]);
9048
      8: PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x)^ := c;
9049
      16: PWord(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 2)^ := c;
1 daniel-mar 9050
      24: begin
4 daniel-mar 9051
          PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 3)^ := c shr 0;
9052
          PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 3 + 1)^ := c shr 8;
9053
          PByte(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 3 + 2)^ := c shr 16;
9054
        end;
9055
      32: PDWORD(Integer(ddsd.lpSurface) + ddsd.lPitch * y + x * 4)^ := c;
1 daniel-mar 9056
    end;
9057
  end;
9058
 
9059
  procedure LoadTexture_IndexToIndex;
9060
  var
9061
    ddsd: TDDSurfaceDesc2;
9062
    x, y: Integer;
9063
  begin
9064
    ddsd.dwSize := SizeOf(ddsd);
4 daniel-mar 9065
    if Dest.Lock(nil, ddsd, DDLOCK_WAIT, 0) = 0 then
1 daniel-mar 9066
    begin
9067
      try
4 daniel-mar 9068
        if (SrcImage.idx_index.Mask = DWORD(1 shl ddsd.ddpfPixelFormat.dwRGBBitCount) - 1) and
9069
          (SrcImage.idx_alpha.Mask = 0) and
9070
          (SrcImage.BitCount = Integer(ddsd.ddpfPixelFormat.dwRGBBitCount)) and
9071
          (not SrcImage.PackedPixelOrder)
9072
        then
1 daniel-mar 9073
        begin
4 daniel-mar 9074
          for y := 0 to ddsd.dwHeight - 1 do
9075
            Move(SrcImage.ScanLine[y]^, Pointer(Integer(ddsd.lpSurface) + ddsd.lPitch * y)^, (Integer(ddsd.dwWidth) * SrcImage.BitCount + 7) div 8);
9076
        end
9077
        else
1 daniel-mar 9078
        begin
4 daniel-mar 9079
          for y := 0 to ddsd.dwHeight - 1 do
1 daniel-mar 9080
          begin
4 daniel-mar 9081
            for x := 0 to ddsd.dwWidth - 1 do
1 daniel-mar 9082
              SetPixel(ddsd, x, y, dxtDecodeChannel(SrcImage.idx_index, SrcImage.Pixels[x, y]));
9083
          end;
9084
        end;
9085
      finally
9086
        Dest.UnLock(ddsd.lpSurface);
9087
      end;
9088
    end;
9089
  end;
9090
 
9091
  procedure LoadTexture_IndexToRGB;
9092
  var
9093
    ddsd: TDDSurfaceDesc2;
9094
    x, y: Integer;
9095
    c, cIdx, cA: DWORD;
9096
    dest_red_fmt, dest_green_fmt, dest_blue_fmt, dest_alpha_fmt: TDXTextureImageChannel;
9097
  begin
9098
    ddsd.dwSize := SizeOf(ddsd);
4 daniel-mar 9099
    if Dest.Lock(nil, ddsd, DDLOCK_WAIT, 0) = 0 then
1 daniel-mar 9100
    begin
9101
      try
9102
        dest_red_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRBitMask, False);
9103
        dest_green_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwGBitMask, False);
9104
        dest_blue_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwBBitMask, False);
9105
        dest_alpha_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRGBAlphaBitMask, False);
9106
 
4 daniel-mar 9107
        if SrcImage.idx_alpha.mask <> 0 then
1 daniel-mar 9108
        begin
4 daniel-mar 9109
          for y := 0 to ddsd.dwHeight - 1 do
9110
            for x := 0 to ddsd.dwWidth - 1 do
1 daniel-mar 9111
            begin
9112
              c := SrcImage.Pixels[x, y];
9113
              cIdx := dxtDecodeChannel(SrcImage.idx_index, c);
9114
 
9115
              c := dxtEncodeChannel(dest_red_fmt, SrcImage.idx_palette[cIdx].peRed) or
9116
                dxtEncodeChannel(dest_green_fmt, SrcImage.idx_palette[cIdx].peGreen) or
9117
                dxtEncodeChannel(dest_blue_fmt, SrcImage.idx_palette[cIdx].peBlue) or
9118
                dxtEncodeChannel(dest_alpha_fmt, dxtDecodeChannel(SrcImage.idx_alpha, c));
9119
 
9120
              SetPixel(ddsd, x, y, c);
9121
            end;
4 daniel-mar 9122
        end
9123
        else
1 daniel-mar 9124
        begin
9125
          cA := dxtEncodeChannel(dest_alpha_fmt, 255);
9126
 
4 daniel-mar 9127
          for y := 0 to ddsd.dwHeight - 1 do
9128
            for x := 0 to ddsd.dwWidth - 1 do
1 daniel-mar 9129
            begin
9130
              c := SrcImage.Pixels[x, y];
9131
              cIdx := dxtDecodeChannel(SrcImage.idx_index, c);
9132
 
9133
              c := dxtEncodeChannel(dest_red_fmt, SrcImage.idx_palette[cIdx].peRed) or
9134
                dxtEncodeChannel(dest_green_fmt, SrcImage.idx_palette[cIdx].peGreen) or
9135
                dxtEncodeChannel(dest_blue_fmt, SrcImage.idx_palette[cIdx].peBlue) or cA;
9136
 
9137
              SetPixel(ddsd, x, y, c);
9138
            end;
9139
        end;
9140
      finally
9141
        Dest.UnLock(ddsd.lpSurface);
9142
      end;
9143
    end;
9144
  end;
9145
 
9146
  procedure LoadTexture_RGBToRGB;
9147
  var
9148
    ddsd: TDDSurfaceDesc2;
9149
    x, y: Integer;
9150
    c, cA: DWORD;
9151
    dest_red_fmt, dest_green_fmt, dest_blue_fmt, dest_alpha_fmt: TDXTextureImageChannel;
9152
  begin
9153
    ddsd.dwSize := SizeOf(ddsd);
4 daniel-mar 9154
    if Dest.Lock(nil, ddsd, DDLOCK_WAIT, 0) = 0 then
1 daniel-mar 9155
    begin
9156
      try
9157
        dest_red_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRBitMask, False);
9158
        dest_green_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwGBitMask, False);
9159
        dest_blue_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwBBitMask, False);
9160
        dest_alpha_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRGBAlphaBitMask, False);
9161
 
4 daniel-mar 9162
        if (dest_red_fmt.Mask = SrcImage.rgb_red.Mask) and (dest_green_fmt.Mask = SrcImage.rgb_green.Mask) and
9163
          (dest_blue_fmt.Mask = SrcImage.rgb_blue.Mask) and (dest_alpha_fmt.Mask = SrcImage.rgb_alpha.Mask) and
9164
          (Integer(ddsd.ddpfPixelFormat.dwRGBBitCount) = SrcImage.BitCount) and (not SrcImage.PackedPixelOrder)
9165
        then
1 daniel-mar 9166
        begin
4 daniel-mar 9167
          for y := 0 to ddsd.dwHeight - 1 do
9168
            Move(SrcImage.ScanLine[y]^, Pointer(Integer(ddsd.lpSurface) + ddsd.lPitch * y)^, (Integer(ddsd.dwWidth) * SrcImage.BitCount + 7) div 8);
9169
        end
9170
        else
9171
          if SrcImage.rgb_alpha.mask <> 0 then
9172
          begin
9173
            for y := 0 to ddsd.dwHeight - 1 do
9174
              for x := 0 to ddsd.dwWidth - 1 do
9175
              begin
9176
                c := SrcImage.Pixels[x, y];
1 daniel-mar 9177
 
4 daniel-mar 9178
                c := dxtEncodeChannel(dest_red_fmt, dxtDecodeChannel(SrcImage.rgb_red, c)) or
9179
                  dxtEncodeChannel(dest_green_fmt, dxtDecodeChannel(SrcImage.rgb_green, c)) or
9180
                  dxtEncodeChannel(dest_blue_fmt, dxtDecodeChannel(SrcImage.rgb_blue, c)) or
9181
                  dxtEncodeChannel(dest_alpha_fmt, dxtDecodeChannel(SrcImage.rgb_alpha, c));
1 daniel-mar 9182
 
4 daniel-mar 9183
                SetPixel(ddsd, x, y, c);
9184
              end;
9185
          end
9186
          else
9187
          begin
9188
            cA := dxtEncodeChannel(dest_alpha_fmt, 255);
1 daniel-mar 9189
 
4 daniel-mar 9190
            for y := 0 to ddsd.dwHeight - 1 do
9191
              for x := 0 to ddsd.dwWidth - 1 do
9192
              begin
9193
                c := SrcImage.Pixels[x, y];
1 daniel-mar 9194
 
4 daniel-mar 9195
                c := dxtEncodeChannel(dest_red_fmt, dxtDecodeChannel(SrcImage.rgb_red, c)) or
9196
                  dxtEncodeChannel(dest_green_fmt, dxtDecodeChannel(SrcImage.rgb_green, c)) or
9197
                  dxtEncodeChannel(dest_blue_fmt, dxtDecodeChannel(SrcImage.rgb_blue, c)) or cA;
1 daniel-mar 9198
 
4 daniel-mar 9199
                SetPixel(ddsd, x, y, c);
9200
              end;
9201
          end;
1 daniel-mar 9202
      finally
9203
        Dest.UnLock(ddsd.lpSurface);
9204
      end;
9205
    end;
9206
  end;
9207
 
9208
var
9209
  SurfaceDesc: TDDSurfaceDesc2;
9210
begin
9211
  SurfaceDesc.dwSize := SizeOf(SurfaceDesc);
9212
  Dest.GetSurfaceDesc(SurfaceDesc);
9213
 
4 daniel-mar 9214
  if SurfaceDesc.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED <> 0 then
1 daniel-mar 9215
  begin
9216
    case SrcImage.ImageType of
9217
      DXTextureImageType_PaletteIndexedColor: LoadTexture_IndexToIndex;
4 daniel-mar 9218
      DXTextureImageType_RGBColor: ;
1 daniel-mar 9219
    end;
4 daniel-mar 9220
  end else if SurfaceDesc.ddpfPixelFormat.dwFlags and DDPF_RGB <> 0 then
1 daniel-mar 9221
  begin
9222
    case SrcImage.ImageType of
9223
      DXTextureImageType_PaletteIndexedColor: LoadTexture_IndexToRGB;
4 daniel-mar 9224
      DXTextureImageType_RGBColor: LoadTexture_RGBToRGB;
1 daniel-mar 9225
    end;
9226
  end;
9227
end;
9228
 
4 daniel-mar 9229
{ Support function }
9230
 
9231
function GetWidthBytes(Width, BitCount: Integer): Integer;
9232
begin
9233
  Result := (((Width * BitCount) + 31) div 32) * 4;
9234
end;
9235
 
9236
function dxtEncodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
9237
begin
9238
  Result := ((c shl Channel._rshift) shr Channel._lshift) and Channel.Mask;
9239
end;
9240
 
9241
function dxtDecodeChannel(const Channel: TDXTextureImageChannel; c: DWORD): DWORD;
9242
begin
9243
  Result := ((c and Channel.Mask) shr Channel._rshift) shl Channel._lshift;
9244
  Result := Result or (Result shr Channel._BitCount2);
9245
end;
9246
 
9247
function dxtMakeChannel(Mask: DWORD; indexed: Boolean): TDXTextureImageChannel;
9248
 
9249
  function GetMaskBitCount(b: Integer): Integer;
9250
  var
9251
    i: Integer;
9252
  begin
9253
    i := 0;
9254
    while (i < 31) and (((1 shl i) and b) = 0) do Inc(i);
9255
 
9256
    Result := 0;
9257
    while ((1 shl i) and b) <> 0 do
9258
    begin
9259
      Inc(i);
9260
      Inc(Result);
9261
    end;
9262
  end;
9263
 
9264
  function GetBitCount2(b: Integer): Integer;
9265
  begin
9266
    Result := 0;
9267
    while (Result < 31) and (((1 shl Result) and b) = 0) do Inc(Result);
9268
  end;
9269
 
9270
begin
9271
  Result.BitCount := GetMaskBitCount(Mask);
9272
  Result.Mask := Mask;
9273
 
9274
  if indexed then
9275
  begin
9276
    Result._rshift := GetBitCount2(Mask);
9277
    Result._lshift := 0;
9278
    Result._Mask2 := 1 shl Result.BitCount - 1;
9279
    Result._BitCount2 := 0;
9280
  end
9281
  else
9282
  begin
9283
    Result._rshift := GetBitCount2(Mask) - (8 - Result.BitCount);
9284
    if Result._rshift < 0 then
9285
    begin
9286
      Result._lshift := -Result._rshift;
9287
      Result._rshift := 0;
9288
    end
9289
    else
9290
      Result._lshift := 0;
9291
    Result._Mask2 := (1 shl Result.BitCount - 1) shl (8 - Result.BitCount);
9292
    Result._BitCount2 := 8 - Result.BitCount;
9293
  end;
9294
end;
9295
 
9296
{  TDXTextureImage  }
9297
 
9298
var
9299
  _DXTextureImageLoadFuncList: TList;
9300
 
9301
procedure DXTextureImage_LoadDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage); forward;
9302
procedure DXTextureImage_LoadBitmapFunc(Stream: TStream; Image: TDXTextureImage); forward;
9303
 
9304
function DXTextureImageLoadFuncList: TList;
9305
begin
9306
  if _DXTextureImageLoadFuncList = nil then
9307
  begin
9308
    _DXTextureImageLoadFuncList := TList.Create;
9309
    _DXTextureImageLoadFuncList.Add(@DXTextureImage_LoadDXTextureImageFunc);
9310
    _DXTextureImageLoadFuncList.Add(@DXTextureImage_LoadBitmapFunc);
9311
  end;
9312
  Result := _DXTextureImageLoadFuncList;
9313
end;
9314
 
9315
class procedure TDXTextureImage.RegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
9316
begin
9317
  if DXTextureImageLoadFuncList.IndexOf(@LoadFunc) = -1 then
9318
    DXTextureImageLoadFuncList.Add(@LoadFunc);
9319
end;
9320
 
9321
class procedure TDXTextureImage.UnRegisterLoadFunc(LoadFunc: TDXTextureImageLoadFunc);
9322
begin
9323
  DXTextureImageLoadFuncList.Remove(@LoadFunc);
9324
end;
9325
 
9326
constructor TDXTextureImage.Create;
9327
begin
9328
  inherited Create;
9329
  FSubImage := TList.Create;
9330
end;
9331
 
9332
constructor TDXTextureImage.CreateSub(AOwner: TDXTextureImage);
9333
begin
9334
  Create;
9335
 
9336
  FOwner := AOwner;
9337
  try
9338
    FOwner.FSubImage.Add(Self);
9339
  except
9340
    FOwner := nil;
9341
    raise;
9342
  end;
9343
end;
9344
 
9345
destructor TDXTextureImage.Destroy;
9346
begin
9347
  Clear;
9348
  FSubImage.Free;
9349
  if FOwner <> nil then
9350
    FOwner.FSubImage.Remove(Self);
9351
  inherited Destroy;
9352
end;
9353
 
9354
procedure TDXTextureImage.DoSaveProgress(Progress, ProgressCount: Integer);
9355
begin
9356
  if Assigned(FOnSaveProgress) then
9357
    FOnSaveProgress(Self, Progress, ProgressCount);
9358
end;
9359
 
9360
procedure TDXTextureImage.Assign(Source: TDXTextureImage);
9361
var
9362
  y: Integer;
9363
begin
9364
  SetSize(Source.ImageType, Source.Width, Source.Height, Source.BitCount, Source.WidthBytes);
9365
 
9366
  idx_index := Source.idx_index;
9367
  idx_alpha := Source.idx_alpha;
9368
  idx_palette := Source.idx_palette;
9369
 
9370
  rgb_red := Source.rgb_red;
9371
  rgb_green := Source.rgb_green;
9372
  rgb_blue := Source.rgb_blue;
9373
  rgb_alpha := Source.rgb_alpha;
9374
 
9375
  for y := 0 to Height - 1 do
9376
    Move(Source.ScanLine[y]^, ScanLine[y]^, WidthBytes);
9377
 
9378
  Transparent := Source.Transparent;
9379
  TransparentColor := Source.TransparentColor;
9380
  ImageGroupType := Source.ImageGroupType;
9381
  ImageID := Source.ImageID;
9382
  ImageName := Source.ImageName;
9383
end;
9384
 
9385
procedure TDXTextureImage.ClearImage;
9386
begin
9387
  if FAutoFreeImage then
9388
    FreeMem(FPBits);
9389
 
9390
  FImageType := DXTextureImageType_PaletteIndexedColor;
9391
  FWidth := 0;
9392
  FHeight := 0;
9393
  FBitCount := 0;
9394
  FWidthBytes := 0;
9395
  FNextLine := 0;
9396
  FSize := 0;
9397
  FPBits := nil;
9398
  FTopPBits := nil;
9399
  FAutoFreeImage := False;
9400
end;
9401
 
9402
procedure TDXTextureImage.Clear;
9403
begin
9404
  ClearImage;
9405
 
9406
  while SubImageCount > 0 do
9407
    SubImages[SubImageCount - 1].Free;
9408
 
9409
  FImageGroupType := 0;
9410
  FImageID := 0;
9411
  FImageName := '';
9412
 
9413
  FTransparent := False;
9414
  FTransparentColor := 0;
9415
 
9416
  FillChar(idx_index, SizeOf(idx_index), 0);
9417
  FillChar(idx_alpha, SizeOf(idx_alpha), 0);
9418
  FillChar(idx_palette, SizeOf(idx_palette), 0);
9419
  FillChar(rgb_red, SizeOf(rgb_red), 0);
9420
  FillChar(rgb_green, SizeOf(rgb_green), 0);
9421
  FillChar(rgb_blue, SizeOf(rgb_blue), 0);
9422
  FillChar(rgb_alpha, SizeOf(rgb_alpha), 0);
9423
end;
9424
 
9425
procedure TDXTextureImage.SetImage(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes, NextLine: Integer;
9426
  PBits, TopPBits: Pointer; Size: Integer; AutoFree: Boolean);
9427
begin
9428
  ClearImage;
9429
 
9430
  FAutoFreeImage := AutoFree;
9431
  FImageType := ImageType;
9432
  FWidth := Width;
9433
  FHeight := Height;
9434
  FBitCount := BitCount;
9435
  FWidthBytes := WidthBytes;
9436
  FNextLine := NextLine;
9437
  FSize := Size;
9438
  FPBits := PBits;
9439
  FTopPBits := TopPBits;
9440
end;
9441
 
9442
procedure TDXTextureImage.SetSize(ImageType: TDXTextureImageType; Width, Height, BitCount, WidthBytes: Integer);
9443
var
9444
  APBits: Pointer;
9445
begin
9446
  ClearImage;
9447
 
9448
  if WidthBytes = 0 then
9449
    WidthBytes := GetWidthBytes(Width, BitCount);
9450
 
9451
  GetMem(APBits, WidthBytes * Height);
9452
  SetImage(ImageType, Width, Height, BitCount, WidthBytes,
9453
    WidthBytes, APBits, APBits, WidthBytes * Height, True);
9454
end;
9455
 
9456
function TDXTextureImage.GetScanLine(y: Integer): Pointer;
9457
begin
9458
  Result := Pointer(Integer(FTopPBits) + FNextLine * y);
9459
end;
9460
 
9461
function TDXTextureImage.GetSubGroupImageCount(GroupTypeID: DWORD): Integer;
9462
var
9463
  i: Integer;
9464
begin
9465
  Result := 0;
9466
  for i := 0 to SubImageCount - 1 do
9467
    if SubImages[i].ImageGroupType = GroupTypeID then
9468
      Inc(Result);
9469
end;
9470
 
9471
function TDXTextureImage.GetSubGroupImage(GroupTypeID: DWORD; Index: Integer): TDXTextureImage;
9472
var
9473
  i, j: Integer;
9474
begin
9475
  j := 0;
9476
  for i := 0 to SubImageCount - 1 do
9477
    if SubImages[i].ImageGroupType = GroupTypeID then
9478
    begin
9479
      if j = Index then
9480
      begin
9481
        Result := SubImages[i];
9482
        Exit;
9483
      end;
9484
 
9485
      Inc(j);
9486
    end;
9487
 
9488
  Result := nil;
9489
  SubImages[-1];
9490
end;
9491
 
9492
function TDXTextureImage.GetSubImageCount: Integer;
9493
begin
9494
  Result := 0;
9495
  if Assigned(FSubImage) then
9496
    Result := FSubImage.Count;
9497
end;
9498
 
9499
function TDXTextureImage.GetSubImage(Index: Integer): TDXTextureImage;
9500
begin
9501
  Result := FSubImage[Index];
9502
end;
9503
 
9504
function TDXTextureImage.EncodeColor(R, G, B, A: Byte): DWORD;
9505
begin
9506
  if ImageType = DXTextureImageType_PaletteIndexedColor then
9507
  begin
9508
    Result := dxtEncodeChannel(idx_index, PaletteIndex(R, G, B)) or
9509
      dxtEncodeChannel(idx_alpha, A);
9510
  end
9511
  else
9512
  begin
9513
    Result := dxtEncodeChannel(rgb_red, R) or
9514
      dxtEncodeChannel(rgb_green, G) or
9515
      dxtEncodeChannel(rgb_blue, B) or
9516
      dxtEncodeChannel(rgb_alpha, A);
9517
  end;
9518
end;
9519
 
9520
function TDXTextureImage.PaletteIndex(R, G, B: Byte): DWORD;
9521
var
9522
  i, d, d2: Integer;
9523
begin
9524
  Result := 0;
9525
  if ImageType = DXTextureImageType_PaletteIndexedColor then
9526
  begin
9527
    d := MaxInt;
9528
    for i := 0 to (1 shl idx_index.BitCount) - 1 do
9529
      with idx_palette[i] do
9530
      begin
9531
        d2 := Abs((peRed - R)) * Abs((peRed - R)) + Abs((peGreen - G)) * Abs((peGreen - G)) + Abs((peBlue - B)) * Abs((peBlue - B));
9532
        if d > d2 then
9533
        begin
9534
          d := d2;
9535
          Result := i;
9536
        end;
9537
      end;
9538
  end;
9539
end;
9540
 
9541
const
9542
  Mask1: array[0..7] of DWORD = (1, 2, 4, 8, 16, 32, 64, 128);
9543
  Mask2: array[0..3] of DWORD = (3, 12, 48, 192);
9544
  Mask4: array[0..1] of DWORD = ($0F, $F0);
9545
 
9546
  Shift1: array[0..7] of DWORD = (0, 1, 2, 3, 4, 5, 6, 7);
9547
  Shift2: array[0..3] of DWORD = (0, 2, 4, 6);
9548
  Shift4: array[0..1] of DWORD = (0, 4);
9549
 
9550
type
9551
  PByte3 = ^TByte3;
9552
  TByte3 = array[0..2] of Byte;
9553
 
9554
function TDXTextureImage.GetPixel(x, y: Integer): DWORD;
9555
begin
9556
  Result := 0;
9557
  if (x >= 0) and (x < FWidth) and (y >= 0) and (y < FHeight) then
9558
  begin
9559
    case FBitCount of
9560
      1: begin
9561
          if FPackedPixelOrder then
9562
            Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 3)^ and Mask1[7 - x and 7]) shr Shift1[7 - x and 7]
9563
          else
9564
            Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7];
9565
        end;
9566
      2: begin
9567
          if FPackedPixelOrder then
9568
            Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 2)^ and Mask2[3 - x and 3]) shr Shift2[3 - x and 3]
9569
          else
9570
            Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 2)^ and Mask2[x and 3]) shr Shift2[x and 3];
9571
        end;
9572
      4: begin
9573
          if FPackedPixelOrder then
9574
            Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 1)^ and Mask4[1 - x and 1]) shr Shift4[1 - x and 1]
9575
          else
9576
            Result := (PByte(Integer(FTopPBits) + FNextLine * y + x shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1];
9577
        end;
9578
      8: Result := PByte(Integer(FTopPBits) + FNextLine * y + x)^;
9579
      16: Result := PWord(Integer(FTopPBits) + FNextLine * y + x * 2)^;
9580
      24: PByte3(@Result)^ := PByte3(Integer(FTopPBits) + FNextLine * y + x * 3)^;
9581
      32: Result := PDWORD(Integer(FTopPBits) + FNextLine * y + x * 4)^;
9582
    end;
9583
  end;
9584
end;
9585
 
9586
procedure TDXTextureImage.SetPixel(x, y: Integer; c: DWORD);
9587
var
9588
  P: PByte;
9589
begin
9590
  if (x >= 0) and (x < FWidth) and (y >= 0) and (y < FHeight) then
9591
  begin
9592
    case FBitCount of
9593
      1: begin
9594
          P := Pointer(Integer(FTopPBits) + FNextLine * y + x shr 3);
9595
          if FPackedPixelOrder then
9596
            P^ := (P^ and (not Mask1[7 - x and 7])) or ((c and 1) shl Shift1[7 - x and 7])
9597
          else
9598
            P^ := (P^ and (not Mask1[x and 7])) or ((c and 1) shl Shift1[x and 7]);
9599
        end;
9600
      2: begin
9601
          P := Pointer(Integer(FTopPBits) + FNextLine * y + x shr 2);
9602
          if FPackedPixelOrder then
9603
            P^ := (P^ and (not Mask2[3 - x and 3])) or ((c and 3) shl Shift2[3 - x and 3])
9604
          else
9605
            P^ := (P^ and (not Mask2[x and 3])) or ((c and 3) shl Shift2[x and 3]);
9606
        end;
9607
      4: begin
9608
          P := Pointer(Integer(FTopPBits) + FNextLine * y + x shr 1);
9609
          if FPackedPixelOrder then
9610
            P^ := (P^ and (not Mask4[1 - x and 1])) or ((c and 7) shl Shift4[1 - x and 1])
9611
          else
9612
            P^ := (P^ and (not Mask4[x and 1])) or ((c and 7) shl Shift4[x and 1]);
9613
        end;
9614
      8: PByte(Integer(FTopPBits) + FNextLine * y + x)^ := c;
9615
      16: PWord(Integer(FTopPBits) + FNextLine * y + x * 2)^ := c;
9616
      24: PByte3(Integer(FTopPBits) + FNextLine * y + x * 3)^ := PByte3(@c)^;
9617
      32: PDWORD(Integer(FTopPBits) + FNextLine * y + x * 4)^ := c;
9618
    end;
9619
  end;
9620
end;
9621
 
9622
procedure TDXTextureImage.LoadFromFile(const FileName: string);
9623
var
9624
  Stream: TFileStream;
9625
begin
9626
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
9627
  try
9628
    LoadFromStream(Stream);
9629
  finally
9630
    Stream.Free;
9631
  end;
9632
end;
9633
 
9634
procedure TDXTextureImage.LoadFromStream(Stream: TStream);
9635
var
9636
  i, p: Integer;
9637
begin
9638
  Clear;
9639
 
9640
  p := Stream.Position;
9641
  for i := 0 to DXTextureImageLoadFuncList.Count - 1 do
9642
  begin
9643
    Stream.Position := p;
9644
    try
9645
      TDXTextureImageLoadFunc(DXTextureImageLoadFuncList[i])(Stream, Self);
9646
      Exit;
9647
    except
9648
      Clear;
9649
    end;
9650
  end;
9651
 
9652
  raise EDXTextureImageError.Create(SNotSupportGraphicFile);
9653
end;
9654
 
9655
procedure TDXTextureImage.SaveToFile(const FileName: string);
9656
var
9657
  Stream: TFileStream;
9658
begin
9659
  Stream := TFileStream.Create(FileName, fmCreate);
9660
  try
9661
    SaveToStream(Stream);
9662
  finally
9663
    Stream.Free;
9664
  end;
9665
end;
9666
 
9667
procedure DXTextureImage_SaveDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage); forward;
9668
 
9669
procedure TDXTextureImage.SaveToStream(Stream: TStream);
9670
begin
9671
  DXTextureImage_SaveDXTextureImageFunc(Stream, Self);
9672
end;
9673
 
9674
{  DXTextureImage_LoadDXTextureImageFunc  }
9675
 
9676
const
9677
  DXTextureImageFile_Type = 'dxt:';
9678
  DXTextureImageFile_Version = $100;
9679
 
9680
  DXTextureImageCompress_None = 0;
9681
  DXTextureImageCompress_ZLIB = 1; // ZLIB enabled
9682
 
9683
  DXTextureImageFileCategoryType_Image = $100;
9684
 
9685
  DXTextureImageFileBlockID_EndFile = 0;
9686
  DXTextureImageFileBlockID_EndGroup = 1;
9687
  DXTextureImageFileBlockID_StartGroup = 2;
9688
  DXTextureImageFileBlockID_Image_Format = DXTextureImageFileCategoryType_Image + 1;
9689
  DXTextureImageFileBlockID_Image_PixelData = DXTextureImageFileCategoryType_Image + 2;
9690
  DXTextureImageFileBlockID_Image_GroupInfo = DXTextureImageFileCategoryType_Image + 3;
9691
  DXTextureImageFileBlockID_Image_Name = DXTextureImageFileCategoryType_Image + 4;
9692
  DXTextureImageFileBlockID_Image_TransparentColor = DXTextureImageFileCategoryType_Image + 5;
9693
 
9694
type
9695
  TDXTextureImageFileHeader = packed record
9696
    FileType: array[0..4] of Char;
9697
    ver: DWORD;
9698
  end;
9699
 
9700
  TDXTextureImageFileBlockHeader = packed record
9701
    ID: DWORD;
9702
    Size: Integer;
9703
  end;
9704
 
9705
  TDXTextureImageFileBlockHeader_StartGroup = packed record
9706
    CategoryType: DWORD;
9707
  end;
9708
 
9709
  TDXTextureImageHeader_Image_Format = packed record
9710
    ImageType: TDXTextureImageType;
9711
    Width: DWORD;
9712
    Height: DWORD;
9713
    BitCount: DWORD;
9714
    WidthBytes: DWORD;
9715
  end;
9716
 
9717
  TDXTextureImageHeader_Image_Format_Index = packed record
9718
    idx_index_Mask: DWORD;
9719
    idx_alpha_Mask: DWORD;
9720
    idx_palette: array[0..255] of TPaletteEntry;
9721
  end;
9722
 
9723
  TDXTextureImageHeader_Image_Format_RGB = packed record
9724
    rgb_red_Mask: DWORD;
9725
    rgb_green_Mask: DWORD;
9726
    rgb_blue_Mask: DWORD;
9727
    rgb_alpha_Mask: DWORD;
9728
  end;
9729
 
9730
  TDXTextureImageHeader_Image_GroupInfo = packed record
9731
    ImageGroupType: DWORD;
9732
    ImageID: DWORD;
9733
  end;
9734
 
9735
  TDXTextureImageHeader_Image_PixelData = packed record
9736
    Compress: DWORD;
9737
  end;
9738
 
9739
  TDXTextureImageHeader_Image_TransparentColor = packed record
9740
    Transparent: Boolean;
9741
    TransparentColor: DWORD;
9742
  end;
9743
 
9744
procedure DXTextureImage_LoadDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage);
9745
 
9746
  procedure ReadGroup_Image(Image: TDXTextureImage);
9747
  var
9748
    i: Integer;
9749
    BlockHeader: TDXTextureImageFileBlockHeader;
9750
    NextPos: Integer;
9751
    SubImage: TDXTextureImage;
9752
    Header_StartGroup: TDXTextureImageFileBlockHeader_StartGroup;
9753
    Header_Image_Format: TDXTextureImageHeader_Image_Format;
9754
    Header_Image_Format_Index: TDXTextureImageHeader_Image_Format_Index;
9755
    Header_Image_Format_RGB: TDXTextureImageHeader_Image_Format_RGB;
9756
    Header_Image_GroupInfo: TDXTextureImageHeader_Image_GroupInfo;
9757
    Header_Image_TransparentColor: TDXTextureImageHeader_Image_TransparentColor;
9758
    Header_Image_PixelData: TDXTextureImageHeader_Image_PixelData;
9759
    ImageName: string;
9760
    {$IFDEF DXTextureImage_UseZLIB}
9761
    Decompression: TDecompressionStream;
9762
    {$ENDIF}
9763
  begin
9764
    while True do
9765
    begin
9766
      Stream.ReadBuffer(BlockHeader, SizeOf(BlockHeader));
9767
      NextPos := Stream.Position + BlockHeader.Size;
9768
 
9769
      case BlockHeader.ID of
9770
        DXTextureImageFileBlockID_EndGroup:
9771
          begin
9772
            {  End of group  }
9773
            Break;
9774
          end;
9775
        DXTextureImageFileBlockID_StartGroup:
9776
          begin
9777
            {  Beginning of group  }
9778
            Stream.ReadBuffer(Header_StartGroup, SizeOf(Header_StartGroup));
9779
            case Header_StartGroup.CategoryType of
9780
              DXTextureImageFileCategoryType_Image:
9781
                begin
9782
                  {  Image group  }
9783
                  SubImage := TDXTextureImage.CreateSub(Image);
9784
                  try
9785
                    ReadGroup_Image(SubImage);
9786
                  except
9787
                    SubImage.Free;
9788
                    raise;
9789
                  end;
9790
                end;
9791
            end;
9792
          end;
9793
        DXTextureImageFileBlockID_Image_Format:
9794
          begin
9795
            {  Image information reading (size etc.)  }
9796
            Stream.ReadBuffer(Header_Image_Format, SizeOf(Header_Image_Format));
9797
 
9798
            if (Header_Image_Format.ImageType <> DXTextureImageType_PaletteIndexedColor) and
9799
              (Header_Image_Format.ImageType <> DXTextureImageType_RGBColor)
9800
            then
9801
              raise EDXTextureImageError.Create(SInvalidDXTFile);
9802
 
9803
            Image.SetSize(Header_Image_Format.ImageType, Header_Image_Format.Width, Header_Image_Format.Height,
9804
              Header_Image_Format.BitCount, Header_Image_Format.Widthbytes);
9805
 
9806
            if Header_Image_Format.ImageType = DXTextureImageType_PaletteIndexedColor then
9807
            begin
9808
              {  INDEX IMAGE  }
9809
              Stream.ReadBuffer(Header_Image_Format_Index, SizeOf(Header_Image_Format_Index));
9810
 
9811
              Image.idx_index := dxtMakeChannel(Header_Image_Format_Index.idx_index_Mask, True);
9812
              Image.idx_alpha := dxtMakeChannel(Header_Image_Format_Index.idx_alpha_Mask, False);
9813
 
9814
              for i := 0 to 255 do
9815
                Image.idx_palette[i] := Header_Image_Format_Index.idx_palette[i];
9816
            end
9817
            else
9818
            if Header_Image_Format.ImageType = DXTextureImageType_RGBColor then
9819
            begin
9820
              {  RGB IMAGE  }
9821
              Stream.ReadBuffer(Header_Image_Format_RGB, SizeOf(Header_Image_Format_RGB));
9822
 
9823
              Image.rgb_red := dxtMakeChannel(Header_Image_Format_RGB.rgb_red_Mask, False);
9824
              Image.rgb_green := dxtMakeChannel(Header_Image_Format_RGB.rgb_green_Mask, False);
9825
              Image.rgb_blue := dxtMakeChannel(Header_Image_Format_RGB.rgb_blue_Mask, False);
9826
              Image.rgb_alpha := dxtMakeChannel(Header_Image_Format_RGB.rgb_alpha_Mask, False);
9827
            end;
9828
          end;
9829
        DXTextureImageFileBlockID_Image_Name:
9830
          begin
9831
            {  Name reading  }
9832
            SetLength(ImageName, BlockHeader.Size);
9833
            Stream.ReadBuffer(ImageName[1], BlockHeader.Size);
9834
 
9835
            Image.ImageName := ImageName;
9836
          end;
9837
        DXTextureImageFileBlockID_Image_GroupInfo:
9838
          begin
9839
            {  Image group information reading  }
9840
            Stream.ReadBuffer(Header_Image_GroupInfo, SizeOf(Header_Image_GroupInfo));
9841
 
9842
            Image.ImageGroupType := Header_Image_GroupInfo.ImageGroupType;
9843
            Image.ImageID := Header_Image_GroupInfo.ImageID;
9844
          end;
9845
        DXTextureImageFileBlockID_Image_TransparentColor:
9846
          begin
9847
            {  Transparent color information reading  }
9848
            Stream.ReadBuffer(Header_Image_TransparentColor, SizeOf(Header_Image_TransparentColor));
9849
 
9850
            Image.Transparent := Header_Image_TransparentColor.Transparent;
9851
            Image.TransparentColor := Header_Image_TransparentColor.TransparentColor;
9852
          end;
9853
        DXTextureImageFileBlockID_Image_PixelData:
9854
          begin
9855
            {  Pixel data reading  }
9856
            Stream.ReadBuffer(Header_Image_PixelData, SizeOf(Header_Image_PixelData));
9857
 
9858
            case Header_Image_PixelData.Compress of
9859
              DXTextureImageCompress_None:
9860
                begin
9861
                   {  NO compress  }
9862
                  for i := 0 to Image.Height - 1 do
9863
                    Stream.ReadBuffer(Image.ScanLine[i]^, Header_Image_Format.Widthbytes);
9864
                end;
9865
              {$IFDEF DXTextureImage_UseZLIB}
9866
              DXTextureImageCompress_ZLIB:
9867
                begin
9868
                   {  ZLIB compress enabled  }
9869
                  Decompression := TDecompressionStream.Create(Stream);
9870
                  try
9871
                    for i := 0 to Image.Height - 1 do
9872
                      Decompression.ReadBuffer(Image.ScanLine[i]^, Header_Image_Format.Widthbytes);
9873
                  finally
9874
                    Decompression.Free;
9875
                  end;
9876
                end;
9877
              {$ENDIF}
9878
            else
9879
              raise EDXTextureImageError.CreateFmt('Decompression error (%d)', [Header_Image_PixelData.Compress]);
9880
            end;
9881
          end;
9882
 
9883
      end;
9884
 
9885
      Stream.Seek(NextPos, soFromBeginning);
9886
    end;
9887
  end;
9888
 
9889
var
9890
  FileHeader: TDXTextureImageFileHeader;
9891
  BlockHeader: TDXTextureImageFileBlockHeader;
9892
  Header_StartGroup: TDXTextureImageFileBlockHeader_StartGroup;
9893
  NextPos: Integer;
9894
begin
9895
  {  File header reading  }
9896
  Stream.ReadBuffer(FileHeader, SizeOf(FileHeader));
9897
 
9898
  if FileHeader.FileType <> DXTextureImageFile_Type then
9899
    raise EDXTextureImageError.Create(SInvalidDXTFile);
9900
  if FileHeader.ver <> DXTextureImageFile_Version then
9901
    raise EDXTextureImageError.Create(SInvalidDXTFile);
9902
 
9903
  while True do
9904
  begin
9905
    Stream.ReadBuffer(BlockHeader, SizeOf(BlockHeader));
9906
    NextPos := Stream.Position + BlockHeader.Size;
9907
 
9908
    case BlockHeader.ID of
9909
      DXTextureImageFileBlockID_EndFile:
9910
        begin
9911
          {  End of file  }
9912
          Break;
9913
        end;
9914
      DXTextureImageFileBlockID_StartGroup:
9915
        begin
9916
          {  Beginning of group  }
9917
          Stream.ReadBuffer(Header_StartGroup, SizeOf(Header_StartGroup));
9918
          case Header_StartGroup.CategoryType of
9919
            DXTextureImageFileCategoryType_Image: ReadGroup_Image(Image);
9920
          end;
9921
        end;
9922
    end;
9923
 
9924
    Stream.Seek(NextPos, soFromBeginning);
9925
  end;
9926
end;
9927
 
9928
type
9929
  PDXTextureImageFileBlockHeaderWriter_BlockInfo = ^TDXTextureImageFileBlockHeaderWriter_BlockInfo;
9930
  TDXTextureImageFileBlockHeaderWriter_BlockInfo = record
9931
    BlockID: DWORD;
9932
    StreamPos: Integer;
9933
  end;
9934
 
9935
  TDXTextureImageFileBlockHeaderWriter = class
9936
  private
9937
    FStream: TStream;
9938
    FList: TList;
9939
  public
9940
    constructor Create(Stream: TStream);
9941
    destructor Destroy; override;
9942
    procedure StartBlock(BlockID: DWORD);
9943
    procedure EndBlock;
9944
    procedure WriteBlock(BlockID: DWORD);
9945
    procedure StartGroup(CategoryType: DWORD);
9946
    procedure EndGroup;
9947
  end;
9948
 
9949
constructor TDXTextureImageFileBlockHeaderWriter.Create(Stream: TStream);
9950
begin
9951
  inherited Create;
9952
  FStream := Stream;
9953
  FList := TList.Create;
9954
end;
9955
 
9956
destructor TDXTextureImageFileBlockHeaderWriter.Destroy;
9957
var
9958
  i: Integer;
9959
begin
9960
  for i := 0 to FList.Count - 1 do
9961
    Dispose(PDXTextureImageFileBlockHeaderWriter_BlockInfo(FList[i]));
9962
  FList.Free;
9963
  inherited Destroy;
9964
end;
9965
 
9966
procedure TDXTextureImageFileBlockHeaderWriter.StartBlock(BlockID: DWORD);
9967
var
9968
  BlockInfo: PDXTextureImageFileBlockHeaderWriter_BlockInfo;
9969
  BlockHeader: TDXTextureImageFileBlockHeader;
9970
begin
9971
  New(BlockInfo);
9972
  BlockInfo.BlockID := BlockID;
9973
  BlockInfo.StreamPos := FStream.Position;
9974
  FList.Add(BlockInfo);
9975
 
9976
  BlockHeader.ID := BlockID;
9977
  BlockHeader.Size := 0;
9978
  FStream.WriteBuffer(BlockHeader, SizeOf(BlockHeader));
9979
end;
9980
 
9981
procedure TDXTextureImageFileBlockHeaderWriter.EndBlock;
9982
var
9983
  BlockHeader: TDXTextureImageFileBlockHeader;
9984
  BlockInfo: PDXTextureImageFileBlockHeaderWriter_BlockInfo;
9985
  CurStreamPos: Integer;
9986
begin
9987
  CurStreamPos := FStream.Position;
9988
  try
9989
    BlockInfo := FList[FList.Count - 1];
9990
 
9991
    FStream.Position := BlockInfo.StreamPos;
9992
    BlockHeader.ID := BlockInfo.BlockID;
9993
    BlockHeader.Size := CurStreamPos - (BlockInfo.StreamPos + SizeOf(TDXTextureImageFileBlockHeader));
9994
    FStream.WriteBuffer(BlockHeader, SizeOf(BlockHeader));
9995
  finally
9996
    FStream.Position := CurStreamPos;
9997
 
9998
    Dispose(FList[FList.Count - 1]);
9999
    FList.Count := FList.Count - 1;
10000
  end;
10001
end;
10002
 
10003
procedure TDXTextureImageFileBlockHeaderWriter.WriteBlock(BlockID: DWORD);
10004
var
10005
  BlockHeader: TDXTextureImageFileBlockHeader;
10006
begin
10007
  BlockHeader.ID := BlockID;
10008
  BlockHeader.Size := 0;
10009
  FStream.WriteBuffer(BlockHeader, SizeOf(BlockHeader));
10010
end;
10011
 
10012
procedure TDXTextureImageFileBlockHeaderWriter.StartGroup(CategoryType: DWORD);
10013
var
10014
  Header_StartGroup: TDXTextureImageFileBlockHeader_StartGroup;
10015
begin
10016
  StartBlock(DXTextureImageFileBlockID_StartGroup);
10017
 
10018
  Header_StartGroup.CategoryType := CategoryType;
10019
  FStream.WriteBuffer(Header_StartGroup, SizeOf(Header_StartGroup));
10020
end;
10021
 
10022
procedure TDXTextureImageFileBlockHeaderWriter.EndGroup;
10023
begin
10024
  WriteBlock(DXTextureImageFileBlockID_EndGroup);
10025
  EndBlock;
10026
end;
10027
 
10028
procedure DXTextureImage_SaveDXTextureImageFunc(Stream: TStream; Image: TDXTextureImage);
10029
var
10030
  Progress: Integer;
10031
  ProgressCount: Integer;
10032
  BlockHeaderWriter: TDXTextureImageFileBlockHeaderWriter;
10033
 
10034
  function CalcProgressCount(Image: TDXTextureImage): Integer;
10035
  var
10036
    i: Integer;
10037
  begin
10038
    Result := Image.WidthBytes * Image.Height;
10039
    for i := 0 to Image.SubImageCount - 1 do
10040
      Inc(Result, CalcProgressCount(Image.SubImages[i]));
10041
  end;
10042
 
10043
  procedure AddProgress(Count: Integer);
10044
  begin
10045
    Inc(Progress, Count);
10046
    Image.DoSaveProgress(Progress, ProgressCount);
10047
  end;
10048
 
10049
  procedure WriteGroup_Image(Image: TDXTextureImage);
10050
  var
10051
    i: Integer;
10052
    Header_Image_Format: TDXTextureImageHeader_Image_Format;
10053
    Header_Image_Format_Index: TDXTextureImageHeader_Image_Format_Index;
10054
    Header_Image_Format_RGB: TDXTextureImageHeader_Image_Format_RGB;
10055
    Header_Image_GroupInfo: TDXTextureImageHeader_Image_GroupInfo;
10056
    Header_Image_TransparentColor: TDXTextureImageHeader_Image_TransparentColor;
10057
    Header_Image_PixelData: TDXTextureImageHeader_Image_PixelData;
10058
  {$IFDEF DXTextureImage_UseZLIB}
10059
    Compression: TCompressionStream;
10060
  {$ENDIF}
10061
  begin
10062
    BlockHeaderWriter.StartGroup(DXTextureImageFileCategoryType_Image);
10063
    try
10064
      {  Image format writing  }
10065
      if Image.Size > 0 then
10066
      begin
10067
        Header_Image_Format.ImageType := Image.ImageType;
10068
        Header_Image_Format.Width := Image.Width;
10069
        Header_Image_Format.Height := Image.Height;
10070
        Header_Image_Format.BitCount := Image.BitCount;
10071
        Header_Image_Format.WidthBytes := Image.WidthBytes;
10072
 
10073
        BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_Format);
10074
        try
10075
          Stream.WriteBuffer(Header_Image_Format, SizeOf(Header_Image_Format));
10076
 
10077
          case Image.ImageType of
10078
            DXTextureImageType_PaletteIndexedColor:
10079
              begin
10080
                {  INDEX IMAGE  }
10081
                Header_Image_Format_Index.idx_index_Mask := Image.idx_index.Mask;
10082
                Header_Image_Format_Index.idx_alpha_Mask := Image.idx_alpha.Mask;
10083
                for i := 0 to 255 do
10084
                  Header_Image_Format_Index.idx_palette[i] := Image.idx_palette[i];
10085
 
10086
                Stream.WriteBuffer(Header_Image_Format_Index, SizeOf(Header_Image_Format_Index));
10087
              end;
10088
            DXTextureImageType_RGBColor:
10089
              begin
10090
                {  RGB IMAGE  }
10091
                Header_Image_Format_RGB.rgb_red_Mask := Image.rgb_red.Mask;
10092
                Header_Image_Format_RGB.rgb_green_Mask := Image.rgb_green.Mask;
10093
                Header_Image_Format_RGB.rgb_blue_Mask := Image.rgb_blue.Mask;
10094
                Header_Image_Format_RGB.rgb_alpha_Mask := Image.rgb_alpha.Mask;
10095
 
10096
                Stream.WriteBuffer(Header_Image_Format_RGB, SizeOf(Header_Image_Format_RGB));
10097
              end;
10098
          end;
10099
        finally
10100
          BlockHeaderWriter.EndBlock;
10101
        end;
10102
      end;
10103
 
10104
      {  Image group information writing  }
10105
      BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_GroupInfo);
10106
      try
10107
        Header_Image_GroupInfo.ImageGroupType := Image.ImageGroupType;
10108
        Header_Image_GroupInfo.ImageID := Image.ImageID;
10109
 
10110
        Stream.WriteBuffer(Header_Image_GroupInfo, SizeOf(Header_Image_GroupInfo));
10111
      finally
10112
        BlockHeaderWriter.EndBlock;
10113
      end;
10114
 
10115
      {  Name writing  }
10116
      BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_Name);
10117
      try
10118
        Stream.WriteBuffer(Image.ImageName[1], Length(Image.ImageName));
10119
      finally
10120
        BlockHeaderWriter.EndBlock;
10121
      end;
10122
 
10123
      {  Transparent color writing  }
10124
      BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_TransparentColor);
10125
      try
10126
        Header_Image_TransparentColor.Transparent := Image.Transparent;
10127
        Header_Image_TransparentColor.TransparentColor := Image.TransparentColor;
10128
 
10129
        Stream.WriteBuffer(Header_Image_TransparentColor, SizeOf(Header_Image_TransparentColor));
10130
      finally
10131
        BlockHeaderWriter.EndBlock;
10132
      end;
10133
 
10134
      {  Pixel data writing  }
10135
      if Image.Size > 0 then
10136
      begin
10137
        {  Writing start  }
10138
        BlockHeaderWriter.StartBlock(DXTextureImageFileBlockID_Image_PixelData);
10139
        try
10140
          {  Scan compress type  }
10141
          case Image.FileCompressType of
10142
            DXTextureImageFileCompressType_None:
10143
              begin
10144
                Header_Image_PixelData.Compress := DXTextureImageCompress_None;
10145
              end;
10146
            {$IFDEF DXTextureImage_UseZLIB}
10147
            DXTextureImageFileCompressType_ZLIB:
10148
              begin
10149
                Header_Image_PixelData.Compress := DXTextureImageCompress_ZLIB;
10150
              end;
10151
            {$ENDIF}
10152
          else
10153
            Header_Image_PixelData.Compress := DXTextureImageCompress_None;
10154
          end;
10155
 
10156
          Stream.WriteBuffer(Header_Image_PixelData, SizeOf(Header_Image_PixelData));
10157
 
10158
          case Header_Image_PixelData.Compress of
10159
            DXTextureImageCompress_None:
10160
              begin
10161
                for i := 0 to Image.Height - 1 do
10162
                begin
10163
                  Stream.WriteBuffer(Image.ScanLine[i]^, Image.Widthbytes);
10164
                  AddProgress(Image.Widthbytes);
10165
                end;
10166
              end;
10167
            {$IFDEF DXTextureImage_UseZLIB}
10168
            DXTextureImageCompress_ZLIB:
10169
              begin
10170
                Compression := TCompressionStream.Create(clMax, Stream);
10171
                try
10172
                  for i := 0 to Image.Height - 1 do
10173
                  begin
10174
                    Compression.WriteBuffer(Image.ScanLine[i]^, Image.WidthBytes);
10175
                    AddProgress(Image.Widthbytes);
10176
                  end;
10177
                finally
10178
                  Compression.Free;
10179
                end;
10180
              end;
10181
            {$ENDIF}
10182
          end;
10183
        finally
10184
          BlockHeaderWriter.EndBlock;
10185
        end;
10186
      end;
10187
 
10188
      {  Sub-image writing  }
10189
      for i := 0 to Image.SubImageCount - 1 do
10190
        WriteGroup_Image(Image.SubImages[i]);
10191
    finally
10192
      BlockHeaderWriter.EndGroup;
10193
    end;
10194
  end;
10195
 
10196
var
10197
  FileHeader: TDXTextureImageFileHeader;
10198
begin
10199
  Progress := 0;
10200
  ProgressCount := CalcProgressCount(Image);
10201
 
10202
  {  File header writing  }
10203
  FileHeader.FileType := DXTextureImageFile_Type;
10204
  FileHeader.ver := DXTextureImageFile_Version;
10205
  Stream.WriteBuffer(FileHeader, SizeOf(FileHeader));
10206
 
10207
  {  Image writing  }
10208
  BlockHeaderWriter := TDXTextureImageFileBlockHeaderWriter.Create(Stream);
10209
  try
10210
    {  Image writing  }
10211
    WriteGroup_Image(Image);
10212
 
10213
    {  End of file  }
10214
    BlockHeaderWriter.WriteBlock(DXTextureImageFileBlockID_EndFile);
10215
  finally
10216
    BlockHeaderWriter.Free;
10217
  end;
10218
end;
10219
 
10220
{  DXTextureImage_LoadBitmapFunc  }
10221
 
10222
procedure DXTextureImage_LoadBitmapFunc(Stream: TStream; Image: TDXTextureImage);
10223
type
10224
  TDIBPixelFormat = packed record
10225
    RBitMask, GBitMask, BBitMask: DWORD;
10226
  end;
10227
var
10228
  TopDown: Boolean;
10229
  BF: TBitmapFileHeader;
10230
  BI: TBitmapInfoHeader;
10231
 
10232
  procedure DecodeRGB;
10233
  var
10234
    y: Integer;
10235
  begin
10236
    for y := 0 to Image.Height - 1 do
10237
    begin
10238
      if TopDown then
10239
        Stream.ReadBuffer(Image.ScanLine[y]^, Image.WidthBytes)
10240
      else
10241
        Stream.ReadBuffer(Image.ScanLine[Image.Height - y - 1]^, Image.WidthBytes);
10242
    end;
10243
  end;
10244
 
10245
  procedure DecodeRLE4;
10246
  var
10247
    SrcDataP: Pointer;
10248
    B1, B2, C: Byte;
10249
    Dest, Src, P: PByte;
10250
    X, Y, i: Integer;
10251
  begin
10252
    GetMem(SrcDataP, BI.biSizeImage);
10253
    try
10254
      Stream.ReadBuffer(SrcDataP^, BI.biSizeImage);
10255
 
10256
      Dest := Image.TopPBits;
10257
      Src := SrcDataP;
10258
      X := 0;
10259
      Y := 0;
10260
 
10261
      while True do
10262
      begin
10263
        B1 := Src^; Inc(Src);
10264
        B2 := Src^; Inc(Src);
10265
 
10266
        if B1 = 0 then
10267
        begin
10268
          case B2 of
10269
            0: begin {  End of line  }
10270
                X := 0; Inc(Y);
10271
                Dest := Image.ScanLine[Y];
10272
              end;
10273
            1: Break; {  End of bitmap  }
10274
            2: begin {  Difference of coordinates  }
10275
                Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
10276
                Dest := Image.ScanLine[Y];
10277
              end;
10278
          else
10279
            {  Absolute mode  }
10280
            C := 0;
10281
            for i := 0 to B2 - 1 do
10282
            begin
10283
              if i and 1 = 0 then
10284
              begin
10285
                C := Src^; Inc(Src);
10286
              end
10287
              else
10288
              begin
10289
                C := C shl 4;
10290
              end;
10291
 
10292
              P := Pointer(Integer(Dest) + X shr 1);
10293
              if X and 1 = 0 then
10294
                P^ := (P^ and $0F) or (C and $F0)
10295
              else
10296
                P^ := (P^ and $F0) or ((C and $F0) shr 4);
10297
 
10298
              Inc(X);
10299
            end;
10300
          end;
10301
        end
10302
        else
10303
        begin
10304
          {  Encoding mode  }
10305
          for i := 0 to B1 - 1 do
10306
          begin
10307
            P := Pointer(Integer(Dest) + X shr 1);
10308
            if X and 1 = 0 then
10309
              P^ := (P^ and $0F) or (B2 and $F0)
10310
            else
10311
              P^ := (P^ and $F0) or ((B2 and $F0) shr 4);
10312
 
10313
            Inc(X);
10314
 
10315
            // Swap nibble
10316
            B2 := (B2 shr 4) or (B2 shl 4);
10317
          end;
10318
        end;
10319
 
10320
        {  Word arrangement  }
10321
        Inc(Src, Longint(Src) and 1);
10322
      end;
10323
    finally
10324
      FreeMem(SrcDataP);
10325
    end;
10326
  end;
10327
 
10328
  procedure DecodeRLE8;
10329
  var
10330
    SrcDataP: Pointer;
10331
    B1, B2: Byte;
10332
    Dest, Src: PByte;
10333
    X, Y: Integer;
10334
  begin
10335
    GetMem(SrcDataP, BI.biSizeImage);
10336
    try
10337
      Stream.ReadBuffer(SrcDataP^, BI.biSizeImage);
10338
 
10339
      Dest := Image.TopPBits;
10340
      Src := SrcDataP;
10341
      X := 0;
10342
      Y := 0;
10343
 
10344
      while True do
10345
      begin
10346
        B1 := Src^; Inc(Src);
10347
        B2 := Src^; Inc(Src);
10348
 
10349
        if B1 = 0 then
10350
        begin
10351
          case B2 of
10352
            0: begin {  End of line  }
10353
                X := 0; Inc(Y);
10354
                Dest := Pointer(Longint(Image.TopPBits) + Y * Image.NextLine + X);
10355
              end;
10356
            1: Break; {  End of bitmap  }
10357
            2: begin {  Difference of coordinates  }
10358
                Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
10359
                Dest := Pointer(Longint(Image.TopPBits) + Y * Image.NextLine + X);
10360
              end;
10361
          else
10362
            {  Absolute mode  }
10363
            Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
10364
          end;
10365
        end
10366
        else
10367
        begin
10368
          {  Encoding mode  }
10369
          FillChar(Dest^, B1, B2); Inc(Dest, B1);
10370
        end;
10371
 
10372
        {  Word arrangement  }
10373
        Inc(Src, Longint(Src) and 1);
10374
      end;
10375
    finally
10376
      FreeMem(SrcDataP);
10377
    end;
10378
  end;
10379
 
10380
var
10381
  BC: TBitmapCoreHeader;
10382
  RGBTriples: array[0..255] of TRGBTriple;
10383
  RGBQuads: array[0..255] of TRGBQuad;
10384
  i, PalCount, j: Integer;
10385
  OS2: Boolean;
10386
  PixelFormat: TDIBPixelFormat;
10387
begin
10388
  {  File header reading  }
10389
  i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
10390
  if i = 0 then Exit;
10391
  if i <> SizeOf(TBitmapFileHeader) then
10392
    raise EDXTextureImageError.Create(SInvalidDIB);
10393
 
10394
  {  Is the head 'BM'?  }
10395
  if BF.bfType <> Ord('B') + Ord('M') * $100 then
10396
    raise EDXTextureImageError.Create(SInvalidDIB);
10397
 
10398
  {  Reading of size of header  }
10399
  i := Stream.Read(BI.biSize, 4);
10400
  if i <> 4 then
10401
    raise EDXTextureImageError.Create(SInvalidDIB);
10402
 
10403
  {  Kind check of DIB  }
10404
  OS2 := False;
10405
 
10406
  case BI.biSize of
10407
    SizeOf(TBitmapCoreHeader):
10408
      begin
10409
        {  OS/2 type  }
10410
        Stream.ReadBuffer(Pointer(Integer(@BC) + 4)^, SizeOf(TBitmapCoreHeader) - 4);
10411
 
10412
        FilLChar(BI, SizeOf(BI), 0);
10413
        with BI do
10414
        begin
10415
          biClrUsed := 0;
10416
          biCompression := BI_RGB;
10417
          biBitCount := BC.bcBitCount;
10418
          biHeight := BC.bcHeight;
10419
          biWidth := BC.bcWidth;
10420
        end;
10421
 
10422
        OS2 := True;
10423
      end;
10424
    SizeOf(TBitmapInfoHeader):
10425
      begin
10426
        {  Windows type  }
10427
        Stream.ReadBuffer(Pointer(Integer(@BI) + 4)^, SizeOf(TBitmapInfoHeader) - 4);
10428
      end;
10429
  else
10430
    raise EDXTextureImageError.Create(SInvalidDIB);
10431
  end;
10432
 
10433
  {  Bit mask reading  }
10434
  if BI.biCompression = BI_BITFIELDS then
10435
  begin
10436
    Stream.ReadBuffer(PixelFormat, SizeOf(PixelFormat));
10437
  end
10438
  else
10439
  begin
10440
    if BI.biBitCount = 16 then
10441
    begin
10442
      PixelFormat.RBitMask := $7C00;
10443
      PixelFormat.GBitMask := $03E0;
10444
      PixelFormat.BBitMask := $001F;
10445
    end else if (BI.biBitCount = 24) or (BI.biBitCount = 32) then
10446
    begin
10447
      PixelFormat.RBitMask := $00FF0000;
10448
      PixelFormat.GBitMask := $0300FF00;
10449
      PixelFormat.BBitMask := $000000FF;
10450
    end;
10451
  end;
10452
 
10453
  {  DIB making  }
10454
  if BI.biHeight < 0 then
10455
  begin
10456
    BI.biHeight := -BI.biHeight;
10457
    TopDown := True;
10458
  end
10459
  else
10460
    TopDown := False;
10461
 
10462
  if BI.biBitCount in [1, 4, 8] then
10463
  begin
10464
    Image.SetSize(DXTextureImageType_PaletteIndexedColor, BI.biWidth, BI.biHeight, BI.biBitCount,
10465
      (((BI.biWidth * BI.biBitCount) + 31) div 32) * 4);
10466
 
10467
    Image.idx_index := dxtMakeChannel(1 shl BI.biBitCount - 1, True);
10468
    Image.PackedPixelOrder := True;
10469
  end
10470
  else
10471
  begin
10472
    Image.SetSize(DXTextureImageType_RGBColor, BI.biWidth, BI.biHeight, BI.biBitCount,
10473
      (((BI.biWidth * BI.biBitCount) + 31) div 32) * 4);
10474
 
10475
    Image.rgb_red := dxtMakeChannel(PixelFormat.RBitMask, False);
10476
    Image.rgb_green := dxtMakeChannel(PixelFormat.GBitMask, False);
10477
    Image.rgb_blue := dxtMakeChannel(PixelFormat.BBitMask, False);
10478
 
10479
    j := Image.rgb_red.BitCount + Image.rgb_green.BitCount + Image.rgb_blue.BitCount;
10480
    if j < BI.biBitCount then
10481
      Image.rgb_alpha := dxtMakeChannel((1 shl (BI.biBitCount - j) - 1) shl j, False);
10482
 
10483
    Image.PackedPixelOrder := False;
10484
  end;
10485
 
10486
  {  palette reading  }
10487
  PalCount := BI.biClrUsed;
10488
  if (PalCount = 0) and (BI.biBitCount <= 8) then
10489
    PalCount := 1 shl BI.biBitCount;
10490
  if PalCount > 256 then PalCount := 256;
10491
 
10492
  if OS2 then
10493
  begin
10494
    {  OS/2 type  }
10495
    Stream.ReadBuffer(RGBTriples, SizeOf(TRGBTriple) * PalCount);
10496
    for i := 0 to PalCount - 1 do
10497
    begin
10498
      Image.idx_palette[i].peRed := RGBTriples[i].rgbtRed;
10499
      Image.idx_palette[i].peGreen := RGBTriples[i].rgbtGreen;
10500
      Image.idx_palette[i].peBlue := RGBTriples[i].rgbtBlue;
10501
    end;
10502
  end
10503
  else
10504
  begin
10505
    {  Windows type  }
10506
    Stream.ReadBuffer(RGBQuads, SizeOf(TRGBQuad) * PalCount);
10507
    for i := 0 to PalCount - 1 do
10508
    begin
10509
      Image.idx_palette[i].peRed := RGBQuads[i].rgbRed;
10510
      Image.idx_palette[i].peGreen := RGBQuads[i].rgbGreen;
10511
      Image.idx_palette[i].peBlue := RGBQuads[i].rgbBlue;
10512
    end;
10513
  end;
10514
 
10515
  {  Pixel data reading  }
10516
  case BI.biCompression of
10517
    BI_RGB: DecodeRGB;
10518
    BI_BITFIELDS: DecodeRGB;
10519
    BI_RLE4: DecodeRLE4;
10520
    BI_RLE8: DecodeRLE8;
10521
  else
10522
    raise EDXTextureImageError.Create(SInvalidDIB);
10523
  end;
10524
end;
10525
 
10526
{ TDXTBase }
10527
 
10528
//Note by JB.
10529
//This class is supplement of original Hori's code.
10530
//For use alphablend you can have a bitmap 32 bit RGBA
10531
//when isn't alphachannel present, it works like RGB 24bit
10532
 
10533
//functions required actualized DIB source for works with alphachannel
10534
 
10535
function TDXTBase.GetCompression: TDXTextureImageFileCompressType;
10536
begin
10537
  Result := FParamsFormat.Compress;
10538
end;
10539
 
10540
procedure TDXTBase.SetCompression(const Value: TDXTextureImageFileCompressType);
10541
begin
10542
  FParamsFormat.Compress := Value;
10543
end;
10544
 
10545
function TDXTBase.GetWidth: Integer;
10546
begin
10547
  Result := FParamsFormat.Width;
10548
end;
10549
 
10550
procedure TDXTBase.SetWidth(const Value: Integer);
10551
begin
10552
  FParamsFormat.Width := Value;
10553
end;
10554
 
10555
function TDXTBase.GetMipmap: Integer;
10556
begin
10557
  Result := FParamsFormat.MipmapCount;
10558
end;
10559
 
10560
procedure TDXTBase.SetMipmap(const Value: Integer);
10561
begin
10562
  if Value = -1 then
10563
    FParamsFormat.MipmapCount := MaxInt
10564
  else
10565
    FParamsFormat.MipmapCount := Value;
10566
end;
10567
 
10568
function TDXTBase.GetTransparentColor: TColorRef;
10569
begin
10570
  Result := FParamsFormat.TransparentColor;
10571
end;
10572
 
10573
procedure TDXTBase.SetTransparentColor(const Value: TColorRef);
10574
begin
10575
  FParamsFormat.Transparent := True;
10576
  FParamsFormat.TransparentColor := RGB(Value shr 16, Value shr 8, Value);
10577
end;
10578
 
10579
procedure TDXTBase.SetTransparentColorIndexed(const Value: TColorRef);
10580
begin
10581
  FParamsFormat.TransparentColor := PaletteIndex(Value);
10582
end;
10583
 
10584
function TDXTBase.GetHeight: Integer;
10585
begin
10586
  Result := FParamsFormat.Height;
10587
end;
10588
 
10589
procedure TDXTBase.SetHeight(const Value: Integer);
10590
begin
10591
  FParamsFormat.Height := Value;
10592
end;
10593
 
10594
procedure TDXTBase.SetChannelY(T: TDIB);
10595
begin
10596
 
10597
end;
10598
 
10599
procedure TDXTBase.LoadChannelRGBFromFile(const FileName: string);
10600
begin
10601
  FStrImageFileName := FileName;
10602
  try
10603
    EvaluateChannels([rgbRed, rgbGreen, rgbBlue], '', '');
10604
  finally
10605
    FStrImageFileName := '';
10606
  end;
10607
end;
10608
 
10609
function TDXTBase.LoadFromFile(iFilename: string): Boolean;
10610
begin
10611
  Result := FileExists(iFilename);
10612
  if Result then
10613
  try
10614
    Texture.LoadFromFile(iFileName);
10615
  except
10616
    Result := False;
10617
  end;
10618
end;
10619
 
10620
procedure TDXTBase.LoadChannelAFromFile(const FileName: string);
10621
begin
10622
  FStrImageFileName := FileName;
10623
  try
10624
    EvaluateChannels([rgbAlpha], '', '');
10625
  finally
10626
    FStrImageFileName := '';
10627
  end;
10628
end;
10629
 
10630
constructor TDXTBase.Create;
10631
var
10632
  Channel: TDXTImageChannel;
10633
begin
10634
  FillChar(Channel, SizeOf(Channel), 0);
10635
  FilLChar(FParamsFormat, SizeOf(FParamsFormat), 0);
10636
  FParamsFormat.Compress := DXTextureImageFileCompressType_None;
10637
  FHasImageList := TList.Create;
10638
  for Channel := Low(Channel) to High(Channel) do
10639
    FChannelChangeTable[Channel] := Channel;
10640
  FChannelChangeTable[rgbAlpha] := yuvY;
10641
  FDIB := nil;
10642
  FStrImageFileName := '';
10643
end;
10644
 
10645
procedure TDXTBase.SetChannelRGBA(T: TDIB);
10646
begin
10647
  FDIB := T;
10648
  try
10649
    EvaluateChannels([rgbRed, rgbGreen, rgbBlue, rgbAlpha], '', '');
10650
  finally
10651
    FDIB := nil;
10652
  end;
10653
end;
10654
 
10655
procedure TDXTBase.BuildImage(Image: TDXTextureImage);
10656
type
10657
  TOutputImageChannelInfo2 = record
10658
    Image: TDXTextureImage;
10659
    Channels: TDXTImageChannels;
10660
  end;
10661
var
10662
  cR, cG, cB: Byte;
10663
 
10664
  function GetChannelVal(const Channel: TDXTextureImageChannel; SrcChannel: TDXTImageChannel): DWORD;
10665
  begin
10666
    case SrcChannel of
10667
      rgbRed: Result := dxtEncodeChannel(Channel, cR);
10668
      rgbGreen: Result := dxtEncodeChannel(Channel, cG);
10669
      rgbBlue: Result := dxtEncodeChannel(Channel, cB);
10670
      yuvY: Result := dxtEncodeChannel(Channel, (cR * 306 + cG * 602 + cB * 116) div 1024);
10671
    else Result := 0;
10672
    end;
10673
  end;
10674
 
10675
var
10676
  HasImageChannelList: array[0..Ord(High(TDXTImageChannel)) + 1] of TOutputImageChannelInfo2;
10677
  HasImageChannelListCount: Integer;
10678
  x, y, i: Integer;
10679
  c, c2, c3: DWORD;
10680
  Channel: TDXTImageChannel;
10681
  Flag: Boolean;
10682
 
10683
  SrcImage: TDXTextureImage;
10684
  UseChannels: TDXTImageChannels;
10685
begin
10686
  HasImageChannelListCount := 0;
10687
  for Channel := Low(Channel) to High(Channel) do
10688
    if Channel in FHasChannels then
10689
    begin
10690
      Flag := False;
10691
      for i := 0 to HasImageChannelListCount - 1 do
10692
        if HasImageChannelList[i].Image = FHasChannelImages[Channel].Image then
10693
        begin
10694
          HasImageChannelList[i].Channels := HasImageChannelList[i].Channels + [Channel];
10695
          Flag := True;
10696
          Break;
10697
        end;
10698
      if not Flag then
10699
      begin
10700
        HasImageChannelList[HasImageChannelListCount].Image := FHasChannelImages[Channel].Image;
10701
        HasImageChannelList[HasImageChannelListCount].Channels := [Channel];
10702
        Inc(HasImageChannelListCount);
10703
      end;
10704
    end;
10705
 
10706
  cR := 0;
10707
  cG := 0;
10708
  cB := 0;
10709
 
10710
  if Image.ImageType = DXTextureImageType_PaletteIndexedColor then
10711
  begin
10712
    {  Index color  }
10713
    for y := 0 to Image.Height - 1 do
10714
      for x := 0 to Image.Width - 1 do
10715
      begin
10716
        c := 0;
10717
 
10718
        for i := 0 to HasImageChannelListCount - 1 do
10719
        begin
10720
          SrcImage := HasImageChannelList[i].Image;
10721
          UseChannels := HasImageChannelList[i].Channels;
10722
 
10723
          case SrcImage.ImageType of
10724
            DXTextureImageType_PaletteIndexedColor:
10725
              begin
10726
                c2 := SrcImage.Pixels[x, y];
10727
                c3 := dxtDecodeChannel(SrcImage.idx_index, c2);
10728
 
10729
                if rgbRed in UseChannels then
10730
                  c := c or dxtEncodeChannel(Image.idx_index, c3);
10731
 
10732
                cR := SrcImage.idx_palette[c3].peRed;
10733
                cG := SrcImage.idx_palette[c3].peGreen;
10734
                cB := SrcImage.idx_palette[c3].peBlue;
10735
              end;
10736
            DXTextureImageType_RGBColor:
10737
              begin
10738
                c2 := SrcImage.Pixels[x, y];
10739
 
10740
                cR := dxtDecodeChannel(SrcImage.rgb_red, c2);
10741
                cG := dxtDecodeChannel(SrcImage.rgb_green, c2);
10742
                cB := dxtDecodeChannel(SrcImage.rgb_blue, c2);
10743
              end;
10744
          end;
10745
 
10746
          if rgbAlpha in UseChannels then
10747
            c := c or GetChannelVal(Image.idx_alpha, FChannelChangeTable[rgbAlpha]);
10748
        end;
10749
 
10750
        Image.Pixels[x, y] := c;
10751
      end;
10752
  end
10753
  else
10754
    if Image.ImageType = DXTextureImageType_RGBColor then
10755
    begin
10756
    {  RGB color  }
10757
      for y := 0 to Image.Height - 1 do
10758
        for x := 0 to Image.Width - 1 do
10759
        begin
10760
          c := 0;
10761
 
10762
          for i := 0 to HasImageChannelListCount - 1 do
10763
          begin
10764
            SrcImage := HasImageChannelList[i].Image;
10765
            UseChannels := HasImageChannelList[i].Channels;
10766
 
10767
            case SrcImage.ImageType of
10768
              DXTextureImageType_PaletteIndexedColor:
10769
                begin
10770
                  c2 := SrcImage.Pixels[x, y];
10771
                  c3 := dxtDecodeChannel(SrcImage.idx_index, c2);
10772
 
10773
                  cR := SrcImage.idx_palette[c3].peRed;
10774
                  cG := SrcImage.idx_palette[c3].peGreen;
10775
                  cB := SrcImage.idx_palette[c3].peBlue;
10776
                end;
10777
              DXTextureImageType_RGBColor:
10778
                begin
10779
                  c2 := SrcImage.Pixels[x, y];
10780
 
10781
                  cR := dxtDecodeChannel(SrcImage.rgb_red, c2);
10782
                  cG := dxtDecodeChannel(SrcImage.rgb_green, c2);
10783
                  cB := dxtDecodeChannel(SrcImage.rgb_blue, c2);
10784
                end;
10785
            end;
10786
 
10787
            if rgbRed in UseChannels then
10788
              c := c or GetChannelVal(Image.rgb_red, FChannelChangeTable[rgbRed]);
10789
            if rgbGreen in UseChannels then
10790
              c := c or GetChannelVal(Image.rgb_green, FChannelChangeTable[rgbGreen]);
10791
            if rgbBlue in UseChannels then
10792
              c := c or GetChannelVal(Image.rgb_Blue, FChannelChangeTable[rgbBlue]);
10793
            if rgbAlpha in UseChannels then
10794
              c := c or GetChannelVal(Image.rgb_alpha, FChannelChangeTable[rgbAlpha]);
10795
          end;
10796
 
10797
          Image.Pixels[x, y] := c;
10798
        end;
10799
    end;
10800
end;
10801
 
10802
procedure TDXTBase.SetChannelR(T: TDIB);
10803
begin
10804
  FDIB := T;
10805
  try
10806
    EvaluateChannels([rgbRed], '', '');
10807
  finally
10808
    FDIB := nil;
10809
  end;
10810
end;
10811
 
10812
function GetBitCount(b: Integer): Integer;
10813
begin
10814
  Result := 32;
10815
  while (Result > 0) and (((1 shl (Result - 1)) and b) = 0) do Dec(Result);
10816
end;
10817
 
10818
procedure TDXTBase.CalcOutputBitFormat;
10819
var
10820
  BitCount: DWORD;
10821
  NewWidth, NewHeight, i, j: Integer;
10822
  Channel: TDXTImageChannel;
10823
begin
10824
  {  Size calculation  }
10825
  NewWidth := 1 shl GetBitCount(TDXTextureImage(FHasImageList[0]).Width);
10826
  NewHeight := 1 shl GetBitCount(TDXTextureImage(FHasImageList[0]).Height);
10827
  NewWidth := Max(NewWidth, NewHeight);
10828
  NewHeight := NewWidth;
10829
  if Abs(FParamsFormat.Width - NewWidth) > Abs(FParamsFormat.Width - NewWidth div 2) then
10830
    NewWidth := NewWidth div 2;
10831
  if Abs(FParamsFormat.Height - NewHeight) > Abs(FParamsFormat.Height - NewHeight div 2) then
10832
    NewHeight := NewHeight div 2;
10833
 
10834
  if FParamsFormat.Width = 0 then FParamsFormat.Width := NewWidth;
10835
  if FParamsFormat.Height = 0 then FParamsFormat.Height := NewHeight;
10836
 
10837
  {  Other several calculation  }
10838
  i := Min(FParamsFormat.Width, FParamsFormat.Height);
10839
  j := 0;
10840
  while i > 1 do
10841
  begin
10842
    i := i div 2;
10843
    Inc(j);
10844
  end;
10845
 
10846
  FParamsFormat.MipmapCount := Min(j, FParamsFormat.MipmapCount);
10847
 
10848
  {  Output type calculation  }
10849
  if (FHasChannelImages[rgbRed].Image = FHasChannelImages[rgbGreen].Image) and
10850
    (FHasChannelImages[rgbRed].Image = FHasChannelImages[rgbBlue].Image) and
10851
    (FHasChannelImages[rgbRed].Image <> nil) and
10852
    (FHasChannelImages[rgbRed].Image.ImageType = DXTextureImageType_PaletteIndexedColor) and
10853
 
10854
    (FHasChannelImages[rgbRed].BitCount = 8) and
10855
    (FHasChannelImages[rgbGreen].BitCount = 8) and
10856
    (FHasChannelImages[rgbBlue].BitCount = 8) and
10857
 
10858
    (FChannelChangeTable[rgbRed] = rgbRed) and
10859
    (FChannelChangeTable[rgbGreen] = rgbGreen) and
10860
    (FChannelChangeTable[rgbBlue] = rgbBlue) and
10861
 
10862
    (FParamsFormat.Width = FHasChannelImages[rgbRed].Image.Width) and
10863
    (FParamsFormat.Height = FHasChannelImages[rgbRed].Image.Height) and
10864
 
10865
    (FParamsFormat.MipmapCount = 0)
10866
  then
10867
  begin
10868
    FParamsFormat.ImageType := DXTextureImageType_PaletteIndexedColor;
10869
  end
10870
  else
10871
    FParamsFormat.ImageType := DXTextureImageType_RGBColor;
10872
 
10873
  {  Bit several calculations  }
10874
  FParamsFormat.BitCount := 0;
10875
 
10876
  for Channel := Low(TDXTImageChannel) to High(TDXTImageChannel) do
10877
    if (FHasChannelImages[Channel].Image <> nil) and (FHasChannelImages[Channel].Image.ImageType = DXTextureImageType_PaletteIndexedColor) then
10878
    begin
10879
      FParamsFormat.idx_palette := FHasChannelImages[Channel].Image.idx_palette;
10880
      Break;
10881
    end;
10882
 
10883
  if FParamsFormat.ImageType = DXTextureImageType_PaletteIndexedColor then
10884
  begin
10885
    {  Index channel }
10886
    if rgbRed in FHasChannels then
10887
    begin
10888
      BitCount := FHasChannelImages[rgbRed].BitCount;
10889
      FParamsFormat.idx_index := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, True);
10890
      Inc(FParamsFormat.BitCount, BitCount);
10891
    end;
10892
 
10893
    {  Alpha channel  }
10894
    if rgbAlpha in FHasChannels then
10895
    begin
10896
      BitCount := FHasChannelImages[rgbAlpha].BitCount;
10897
      FParamsFormat.idx_alpha := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
10898
      Inc(FParamsFormat.BitCount, BitCount);
10899
    end;
10900
  end
10901
  else
10902
  begin
10903
    {  B channel }
10904
    if rgbBlue in FHasChannels then
10905
    begin
10906
      BitCount := FHasChannelImages[rgbBlue].BitCount;
10907
      FParamsFormat.rgb_blue := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
10908
      Inc(FParamsFormat.BitCount, BitCount);
10909
    end;
10910
 
10911
    {  G channel }
10912
    if rgbGreen in FHasChannels then
10913
    begin
10914
      BitCount := FHasChannelImages[rgbGreen].BitCount;
10915
      FParamsFormat.rgb_green := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
10916
      Inc(FParamsFormat.BitCount, BitCount);
10917
    end;
10918
 
10919
    {  R channel }
10920
    if rgbRed in FHasChannels then
10921
    begin
10922
      BitCount := FHasChannelImages[rgbRed].BitCount;
10923
      FParamsFormat.rgb_red := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
10924
      Inc(FParamsFormat.BitCount, BitCount);
10925
    end;
10926
 
10927
    {  Alpha channel }
10928
    if rgbAlpha in FHasChannels then
10929
    begin
10930
      BitCount := FHasChannelImages[rgbAlpha].BitCount;
10931
      FParamsFormat.rgb_alpha := dxtMakeChannel(((1 shl BitCount) - 1) shl FParamsFormat.BitCount, False);
10932
      Inc(FParamsFormat.BitCount, BitCount);
10933
    end;
10934
  end;
10935
 
10936
  {  As for the number of bits only either of 1, 2, 4, 8, 16, 24, 32  }
10937
  if FParamsFormat.BitCount in [3] then
10938
    FParamsFormat.BitCount := 4
10939
  else
10940
  if FParamsFormat.BitCount in [5..7] then
10941
    FParamsFormat.BitCount := 8
10942
  else
10943
  if FParamsFormat.BitCount in [9..15] then
10944
    FParamsFormat.BitCount := 16
10945
  else
10946
  if FParamsFormat.BitCount in [17..23] then
10947
    FParamsFormat.BitCount := 24
10948
  else
10949
  if FParamsFormat.BitCount in [25..31] then
10950
    FParamsFormat.BitCount := 32;
10951
 
10952
  {  Transparent color  }
10953
  if (FParamsFormat.ImageType = DXTextureImageType_RGBColor) and (FParamsFormat.TransparentColor shr 24 = $01) then
10954
  begin
10955
    FParamsFormat.TransparentColor := RGB(FParamsFormat.idx_palette[Byte(FParamsFormat.TransparentColor)].peRed,
10956
      FParamsFormat.idx_palette[Byte(FParamsFormat.TransparentColor)].peGreen,
10957
      FParamsFormat.idx_palette[Byte(FParamsFormat.TransparentColor)].peBlue);
10958
  end;
10959
end;
10960
 
10961
procedure TDXTBase.LoadChannelRGBAFromFile(const FileName: string);
10962
begin
10963
  FStrImageFileName := FileName;
10964
  try
10965
    EvaluateChannels([rgbRed, rgbGreen, rgbBlue, rgbAlpha], '', '');
10966
  finally
10967
    FStrImageFileName := '';
10968
  end;
10969
end;
10970
 
10971
procedure TDXTBase.SetChannelB(T: TDIB);
10972
begin
10973
  FDIB := T;
10974
  try
10975
    EvaluateChannels([rgbBlue], '', '');
10976
  finally
10977
    FDIB := nil;
10978
  end;
10979
end;
10980
 
10981
procedure TDXTBase.SetChannelRGB(T: TDIB);
10982
begin
10983
  FDIB := T;
10984
  try
10985
    EvaluateChannels([rgbRed, rgbGreen, rgbBlue], '', '');
10986
  finally
10987
    FDIB := nil;
10988
  end;
10989
end;
10990
 
10991
procedure TDXTBase.SaveToFile(iFilename: string {$IFDEF VER4UP} = ''{$ENDIF});
10992
var
10993
  Image: TDXTextureImage;
10994
begin
10995
  {  Create output stream  }
10996
  Image := Self.Texture;
10997
  if (FHasImageList.Count > 0) and Assigned(Image) then
10998
  begin
10999
    if iFilename <> '' then
11000
      Image.SaveToFile(iFilename)
11001
    else
11002
      Image.SaveToFile(FParamsFormat.Name + '.dxt');
11003
  end;
11004
end;
11005
 
11006
procedure TDXTBase.SetChannelA(T: TDIB);
11007
begin
11008
  FDIB := T;
11009
  try
11010
    EvaluateChannels([rgbAlpha], '', '');
11011
  finally
11012
    FDIB := nil;
11013
  end;
11014
end;
11015
 
11016
procedure TDXTBase.SetChannelG(T: TDIB);
11017
begin
11018
  FDIB := T;
11019
  try
11020
    EvaluateChannels([rgbGreen], '', '');
11021
  finally
11022
    FDIB := nil;
11023
  end;
11024
end;
11025
 
11026
destructor TDXTBase.Destroy;
11027
var I: Integer;
11028
begin
11029
  for I := 0 to FHasImageList.Count - 1 do
11030
    TDXTextureImage(FHasImageList[I]).Free;
11031
  FHasImageList.Free;
11032
  inherited Destroy;
11033
end;
11034
 
11035
function TDXTBase.GetPicture: TDXTextureImage;
11036
var
11037
  MemoryStream: TMemoryStream;
11038
begin
11039
  Result := TDXTextureImage.Create;
11040
  try
11041
    if (FStrImageFileName <> '') and FileExists(FStrImageFileName) then
11042
    begin
11043
      Result.LoadFromFile(FStrImageFileName);
11044
      Result.FImageName := ExtractFilename(FStrImageFileName);
11045
    end
11046
    else
11047
      if Assigned(FDIB) then
11048
      begin
11049
        MemoryStream := TMemoryStream.Create;
11050
        try
11051
          FDIB.SaveToStream(MemoryStream);
11052
          MemoryStream.Position := 0; //reading from 0
11053
          Result.LoadFromStream(MemoryStream);
11054
        finally
11055
          MemoryStream.Free;
11056
        end;
11057
        Result.FImageName := Format('DIB%x', [Integer(Result)]); //supplement name
11058
      end;
11059
  except
11060
    on E: Exception do
11061
    begin
11062
      EDXTBaseError.Create(E.Message);
11063
    end;
11064
  end
11065
end;
11066
 
11067
procedure TDXTBase.Resize(Image: TDXTextureImage; NewWidth, NewHeight: Integer;
11068
  FilterTypeResample: TFilterTypeResample);
11069
  //resize used for Mipmap
11070
var
11071
  DIB: TDIB;
11072
  x, y: Integer;
11073
  c: DWORD;
11074
  MemoryStream: TMemoryStream;
11075
begin
11076
  {  Exit when no resize  }
11077
  if (Image.Width = NewWidth) and (Image.Height = NewHeight) then Exit;
11078
  {  Supplement for image resizing  }
11079
  //raise EDXTBaseError.Create('Invalid image size for texture.');
11080
  {  No image at start  }
11081
  DIB := TDIB.Create; //DIB accept
11082
  try
11083
    DIB.SetSize(Image.Width, Image.Height, Image.BitCount);
11084
    {  of type  }
11085
    for y := 0 to Image.Height - 1 do
11086
      for x := 0 to Image.Width - 1 do
11087
      begin
11088
        if Image.ImageType = DXTextureImageType_PaletteIndexedColor then
11089
        begin
11090
          c := dxtDecodeChannel(Image.idx_index, Image.Pixels[x, y]);
11091
          DIB.Pixels[x, y] := (Image.idx_palette[c].peRed shl 16) or
11092
            (Image.idx_palette[c].peGreen shl 8) or
11093
            Image.idx_palette[c].peBlue;
11094
        end
11095
        else begin
11096
          c := Image.Pixels[x, y];
11097
          DIB.Pixels[x, y] := (dxtDecodeChannel(Image.rgb_red, c) shl 16) or
11098
            (dxtDecodeChannel(Image.rgb_green, c) shl 8) or
11099
            dxtDecodeChannel(Image.rgb_blue, c);
11100
        end;
11101
      end;
11102
 
11103
    {  Resize for 24 bitcount deep }
11104
    Image.SetSize(DXTextureImageType_RGBColor, Width, Height, Image.BitCount, 0);
11105
 
11106
    Image.rgb_red := dxtMakeChannel($FF0000, False);
11107
    Image.rgb_green := dxtMakeChannel($00FF00, False);
11108
    Image.rgb_blue := dxtMakeChannel($0000FF, False);
11109
    Image.rgb_alpha := dxtMakeChannel(0, False);
11110
 
11111
    {  Resample routine DIB based there  }
11112
    DIB.DoResample(Width, Height, FilterTypeResample);
11113
 
11114
    {Image returned through stream}
11115
    Image.ClearImage;
11116
    MemoryStream := TMemoryStream.Create;
11117
    try
11118
      DIB.SaveToStream(MemoryStream);
11119
      MemoryStream.Position := 0; //from first byte
11120
      Image.LoadFromStream(MemoryStream);
11121
    finally
11122
      MemoryStream.Free;
11123
    end;
11124
  finally
11125
    DIB.Free;
11126
  end;
11127
end;
11128
 
11129
procedure TDXTBase.EvaluateChannels
11130
  (const CheckChannelUsed: TDXTImageChannels;
11131
  const CheckChannelChanged, CheckBitCountForChannel: string);
11132
var J: Integer;
11133
  Channel: TDXTImageChannel;
11134
  ChannelBitCount: array[TDXTImageChannel] of Integer;
11135
  ChannelParamName: TDXTImageChannels;
11136
  Image: TDXTextureImage;
11137
  Q: TDXTImageChannel;
11138
begin
11139
  Fillchar(ChannelBitCount, SizeOf(ChannelBitCount), 0);
11140
  ChannelParamName := [];
11141
  {  The channel which you use acquisition  }
11142
  J := 0;
11143
  for Q := rgbRed to rgbAlpha do
11144
  begin
11145
    if Q in CheckChannelUsed then
11146
    begin
11147
      Inc(J);
11148
      Channel := Q;
11149
      if not (Channel in FHasChannels) then
11150
      begin
11151
        if CheckBitCountForChannel <> '' then
11152
          ChannelBitCount[Channel] := StrToInt(Copy(CheckBitCountForChannel, j, 1))
11153
        else
11154
          ChannelBitCount[Channel] := 8; {poke default value}
11155
        if ChannelBitCount[Channel] <> 0 then
11156
          ChannelParamName := ChannelParamName + [Channel];
11157
 
11158
        if CheckChannelChanged <> '' then
11159
        begin
11160
          case UpCase(CheckChannelChanged[j]) of
11161
            'R': FChannelChangeTable[Channel] := rgbRed;
11162
            'G': FChannelChangeTable[Channel] := rgbGreen;
11163
            'B': FChannelChangeTable[Channel] := rgbBlue;
11164
            'Y': FChannelChangeTable[Channel] := yuvY;
11165
            'N': FChannelChangeTable[Channel] := rgbNone;
11166
          else
11167
            raise EDXTBaseError.CreateFmt('Invalid channel type(%s)', [CheckChannelChanged[j]]);
11168
          end;
11169
        end;
11170
      end;
11171
    end;
11172
  end;
11173
  {  Processing of each  }
11174
  if ChannelParamName <> [] then
11175
  begin
11176
    {  Picture load  }
11177
    Image := nil;
11178
    {pokud je image uz nahrany tj. stejneho jmena, pokracuj dale}
11179
    for j := 0 to FHasImageList.Count - 1 do
11180
      if AnsiCompareFileName(TDXTextureImage(FHasImageList[j]).ImageName, FStrImageFileName) = 0 then
11181
      begin
11182
        Image := FHasImageList[j];
11183
        Break;
11184
      end;
11185
    {obrazek neexistuje, musi se dotahnout bud z proudu, souboru nebo odjinut}
11186
    if Image = nil then
11187
    begin
11188
      try
11189
        Image := GetPicture;
11190
      except
11191
        if Assigned(Image) then
11192
        begin
11193
          {$IFNDEF VER5UP}
11194
          Image.Free; Image := nil;
11195
          {$ELSE}
11196
          FreeAndNil(Image);
11197
          {$ENDIF}
11198
        end;
11199
        raise;
11200
      end;
11201
      FHasImageList.Add(Image);
11202
    end;
11203
 
11204
    {  Each channel processing  }
11205
    for Channel := Low(Channel) to High(Channel) do
11206
      if Channel in ChannelParamName then
11207
      begin
11208
        if ChannelBitCount[Channel] >= 0 then
11209
          FHasChannelImages[Channel].BitCount := ChannelBitCount[Channel]
11210
        else
11211
        begin
11212
          case Image.ImageType of
11213
            DXTextureImageType_PaletteIndexedColor:
11214
              begin
11215
                case Channel of
11216
                  rgbRed: FHasChannelImages[Channel].BitCount := 8;
11217
                  rgbGreen: FHasChannelImages[Channel].BitCount := 8;
11218
                  rgbBlue: FHasChannelImages[Channel].BitCount := 8;
11219
                  rgbAlpha: FHasChannelImages[Channel].BitCount := 8;
11220
                end;
11221
              end;
11222
            DXTextureImageType_RGBColor:
11223
              begin
11224
                case Channel of
11225
                  rgbRed: FHasChannelImages[Channel].BitCount := Image.rgb_red.BitCount;
11226
                  rgbGreen: FHasChannelImages[Channel].BitCount := Image.rgb_green.BitCount;
11227
                  rgbBlue: FHasChannelImages[Channel].BitCount := Image.rgb_blue.BitCount;
11228
                  rgbAlpha: FHasChannelImages[Channel].BitCount := 8;
11229
                end;
11230
              end;
11231
          end;
11232
        end;
11233
        if FHasChannelImages[Channel].BitCount = 0 then Continue;
11234
        FHasChannels := FHasChannels + [Channel];
11235
        FHasChannelImages[Channel].Image := Image;
11236
      end;
11237
  end;
11238
end;
11239
 
11240
function TDXTBase.GetTexture: TDXTextureImage;
11241
var
11242
  i, j: Integer;
11243
  SubImage: TDXTextureImage;
11244
  CurWidth, CurHeight: Integer;
11245
begin
11246
  Result := nil;
11247
  if FHasImageList.Count = 0 then
11248
    raise EDXTBaseError.Create('No image found');
11249
 
11250
  {  Output format calculation  }
11251
  CalcOutputBitFormat;
11252
  Result := TDXTextureImage.Create;
11253
  try
11254
    Result.SetSize(FParamsFormat.ImageType, FParamsFormat.Width, FParamsFormat.Height, FParamsFormat.BitCount, 0);
11255
 
11256
    Result.idx_index := FParamsFormat.idx_index;
11257
    Result.idx_alpha := FParamsFormat.idx_alpha;
11258
    Result.idx_palette := FParamsFormat.idx_palette;
11259
 
11260
    Result.rgb_red := FParamsFormat.rgb_red;
11261
    Result.rgb_green := FParamsFormat.rgb_green;
11262
    Result.rgb_blue := FParamsFormat.rgb_blue;
11263
    Result.rgb_alpha := FParamsFormat.rgb_alpha;
11264
 
11265
    Result.ImageName := FParamsFormat.Name;
11266
 
11267
    Result.Transparent := FParamsFormat.Transparent;
11268
    if FParamsFormat.TransparentColor shr 24 = $01 then
11269
      Result.TransparentColor := dxtEncodeChannel(Result.idx_index, PaletteIndex(Byte(FParamsFormat.TransparentColor)))
11270
    else
11271
      Result.TransparentColor := Result.EncodeColor(GetRValue(FParamsFormat.TransparentColor), GetGValue(FParamsFormat.TransparentColor), GetBValue(FParamsFormat.TransparentColor), 0);
11272
 
11273
    BuildImage(Result);
11274
 
11275
    if FParamsFormat.ImageType = DXTextureImageType_RGBColor then
11276
    begin
11277
      BuildImage(Result);
11278
      {  Picture information store here  }
11279
      CurWidth := FParamsFormat.Width;
11280
      CurHeight := FParamsFormat.Height;
11281
      for i := 0 to FParamsFormat.MipmapCount - 1 do
11282
      begin
11283
        CurWidth := CurWidth div 2;
11284
        CurHeight := CurHeight div 2;
11285
        if (CurWidth <= 0) or (CurHeight <= 0) then Break;
11286
        {  Resize calc here }
11287
        for j := 0 to FHasImageList.Count - 1 do
11288
          Resize(FHasImageList[j], CurWidth, CurHeight, ftrTriangle);
11289
 
11290
        SubImage := TDXTextureImage.CreateSub(Result);
11291
        SubImage.SetSize(FParamsFormat.ImageType, CurWidth, CurHeight, FParamsFormat.BitCount, 0);
11292
 
11293
        SubImage.idx_index := FParamsFormat.idx_index;
11294
        SubImage.idx_alpha := FParamsFormat.idx_alpha;
11295
        SubImage.idx_palette := FParamsFormat.idx_palette;
11296
 
11297
        SubImage.rgb_red := FParamsFormat.rgb_red;
11298
        SubImage.rgb_green := FParamsFormat.rgb_green;
11299
        SubImage.rgb_blue := FParamsFormat.rgb_blue;
11300
        SubImage.rgb_alpha := FParamsFormat.rgb_alpha;
11301
 
11302
        SubImage.ImageGroupType := DXTextureImageGroupType_Normal;
11303
        SubImage.ImageID := i;
11304
        SubImage.ImageName := Format('%s - mimap #%d', [Result.ImageName, i + 1]);
11305
 
11306
        BuildImage(SubImage);
11307
      end;
11308
    end;
11309
    Result.FileCompressType := FParamsFormat.Compress;
11310
  except
11311
    on E: Exception do
11312
    begin
11313
      {$IFNDEF VER5UP}
11314
      Result.Free;
11315
      Result := nil;
11316
      {$ELSE}
11317
      FreeAndNil(Result);
11318
      {$ENDIF}
11319
      raise EDXTBaseError.Create(E.Message);
11320
    end;
11321
  end;
11322
end;
11323
 
11324
{ DIB2DTX }
11325
 
11326
procedure dib2dxt(DIBImage: TDIB; out DXTImage: TDXTextureImage{$IFDEF DXTextureImage_UseZLIB}; const Shrink: Boolean = True{$ENDIF});
11327
var
11328
  TexImage: TDXTBase;
11329
  DIB: TDIB;
11330
begin
11331
  TexImage := TDXTBase.Create;
11332
  try
11333
    {$IFDEF DXTextureImage_UseZLIB}
11334
    if Shrink then
11335
    begin
11336
      TexImage.Compression := DXTextureImageFileCompressType_ZLIB;
11337
      TexImage.Mipmap := 4;
11338
    end;
11339
    {$ENDIF}
11340
    try
11341
      if DIBImage.HasAlphaChannel then
11342
      begin
11343
        DIB := DIBImage.RGBChannel;
11344
        TexImage.SetChannelRGB(DIB);
11345
        DIB.Free;
11346
        DIB := DIBImage.AlphaChannel;
11347
        TexImage.SetChannelA(DIB);
11348
        DIB.Free;
11349
      end
11350
      else
11351
        TexImage.SetChannelRGB(DIBImage);
11352
 
11353
      DXTImage := TexImage.Texture;
11354
    except
11355
      if Assigned(DXTImage) then
11356
        DXTImage.Free;
11357
      DXTImage := nil;
11358
    end;
11359
  finally
11360
    TexImage.Free;
11361
  end
11362
end;
11363
 
11364
{$IFDEF D3DRM}
11365
 
1 daniel-mar 11366
{  TDirect3DRMUserVisual  }
11367
 
11368
procedure TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK(lpD3DRMobj: IDirect3DRMObject;
4 daniel-mar 11369
  lpArg: Pointer); cdecl;
1 daniel-mar 11370
begin
11371
  TDirect3DRMUserVisual(lpArg).Free;
11372
end;
11373
 
11374
function TDirect3DRMUserVisual_D3DRMUSERVISUALCALLBACK(lpD3DRMUV: IDirect3DRMUserVisual;
11375
  lpArg: Pointer; lpD3DRMUVreason: TD3DRMUserVisualReason;
4 daniel-mar 11376
  lpD3DRMDev: IDirect3DRMDevice; lpD3DRMview: IDirect3DRMViewport): Integer; cdecl;
1 daniel-mar 11377
begin
11378
  Result := TDirect3DRMUserVisual(lpArg).DoRender(lpD3DRMUVreason, lpD3DRMDev, lpD3DRMview);
11379
end;
11380
 
11381
constructor TDirect3DRMUserVisual.Create(D3DRM: IDirect3DRM);
11382
begin
11383
  inherited Create;
11384
 
11385
  if D3DRM.CreateUserVisual(@TDirect3DRMUserVisual_D3DRMUSERVISUALCALLBACK,
4 daniel-mar 11386
    Self, FUserVisual) <> D3DRM_OK
11387
  then
1 daniel-mar 11388
    raise EDirect3DRMUserVisualError.CreateFmt(SCannotMade, ['IDirect3DRMUserVisual']);
11389
 
11390
  FUserVisual.AddDestroyCallback(@TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK, Self);
11391
end;
11392
 
11393
destructor TDirect3DRMUserVisual.Destroy;
11394
begin
4 daniel-mar 11395
  if FUserVisual <> nil then
1 daniel-mar 11396
    FUserVisual.DeleteDestroyCallback(@TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK, Self);
11397
  FUserVisual := nil;
11398
  inherited Destroy;
11399
end;
11400
 
11401
function TDirect3DRMUserVisual.DoRender(Reason: TD3DRMUserVisualReason;
11402
  D3DRMDev: IDirect3DRMDevice; D3DRMView: IDirect3DRMViewport): HRESULT;
11403
begin
11404
  Result := 0;
11405
end;
4 daniel-mar 11406
{$ENDIF}
1 daniel-mar 11407
 
11408
{  TPictureCollectionItem  }
11409
 
11410
type
11411
  TPictureCollectionItemPattern = class(TCollectionItem)
11412
  private
11413
    FRect: TRect;
11414
    FSurface: TDirectDrawSurface;
11415
  end;
11416
 
11417
constructor TPictureCollectionItem.Create(Collection: TCollection);
11418
begin
11419
  inherited Create(Collection);
11420
  FPicture := TPicture.Create;
11421
  FPatterns := TCollection.Create(TPictureCollectionItemPattern);
11422
  FSurfaceList := TList.Create;
11423
  FTransparent := True;
11424
end;
11425
 
11426
destructor TPictureCollectionItem.Destroy;
11427
begin
11428
  Finalize;
11429
  FPicture.Free;
11430
  FPatterns.Free;
11431
  FSurfaceList.Free;
11432
  inherited Destroy;
11433
end;
11434
 
11435
procedure TPictureCollectionItem.Assign(Source: TPersistent);
11436
var
11437
  PrevInitialized: Boolean;
11438
begin
11439
  if Source is TPictureCollectionItem then
11440
  begin
11441
    PrevInitialized := Initialized;
11442
    Finalize;
11443
 
11444
    FPatternHeight := TPictureCollectionItem(Source).FPatternHeight;
11445
    FPatternWidth := TPictureCollectionItem(Source).FPatternWidth;
11446
    FSkipHeight := TPictureCollectionItem(Source).FSkipHeight;
11447
    FSkipWidth := TPictureCollectionItem(Source).FSkipWidth;
11448
    FSystemMemory := TPictureCollectionItem(Source).FSystemMemory;
11449
    FTransparent := TPictureCollectionItem(Source).FTransparent;
11450
    FTransparentColor := TPictureCollectionItem(Source).FTransparentColor;
11451
 
11452
    FPicture.Assign(TPictureCollectionItem(Source).FPicture);
11453
 
11454
    if PrevInitialized then
11455
      Restore;
11456
  end else
11457
    inherited Assign(Source);
4 daniel-mar 11458
end;
1 daniel-mar 11459
 
11460
procedure TPictureCollectionItem.ClearSurface;
11461
var
11462
  i: Integer;
11463
begin
11464
  FPatterns.Clear;
4 daniel-mar 11465
  for i := 0 to FSurfaceList.Count - 1 do
1 daniel-mar 11466
    TDirectDrawSurface(FSurfaceList[i]).Free;
11467
  FSurfaceList.Clear;
11468
end;
11469
 
11470
function TPictureCollectionItem.GetHeight: Integer;
11471
begin
11472
  Result := FPatternHeight;
4 daniel-mar 11473
  if (Result <= 0) then
1 daniel-mar 11474
    Result := FPicture.Height;
11475
end;
11476
 
11477
function TPictureCollectionItem.GetPictureCollection: TPictureCollection;
11478
begin
11479
  Result := Collection as TPictureCollection;
11480
end;
11481
 
11482
function TPictureCollectionItem.GetPatternRect(Index: Integer): TRect;
11483
begin
4 daniel-mar 11484
  if (Index >= 0) and (index < FPatterns.Count) then
11485
    //Result := (FPatterns.Items[Index] as TPictureCollectionItemPattern).FRect
1 daniel-mar 11486
    Result := TPictureCollectionItemPattern(FPatterns.Items[Index]).FRect
11487
  else
11488
    Result := Rect(0, 0, 0, 0);
11489
end;
11490
 
11491
function TPictureCollectionItem.GetPatternSurface(Index: Integer): TDirectDrawSurface;
11492
begin
4 daniel-mar 11493
  if (Index >= 0) and (index < FPatterns.Count) then
1 daniel-mar 11494
    Result := TPictureCollectionItemPattern(FPatterns.Items[Index]).FSurface
11495
  else
11496
    Result := nil;
11497
end;
11498
 
11499
function TPictureCollectionItem.GetPatternCount: Integer;
11500
var
11501
  XCount, YCount: Integer;
11502
begin
4 daniel-mar 11503
  if FSurfaceList.Count = 0 then
1 daniel-mar 11504
  begin
4 daniel-mar 11505
    if PatternWidth = 0 then PatternWidth := FPicture.Width; //prevent division by zero
11506
    XCount := FPicture.Width div (PatternWidth + SkipWidth);
11507
    if FPicture.Width - XCount * (PatternWidth + SkipWidth) = PatternWidth then
11508
      Inc(XCount);
11509
    if PatternHeight = 0 then PatternHeight := FPicture.Height; //prevent division by zero
11510
    YCount := FPicture.Height div (PatternHeight + SkipHeight);
11511
    if FPicture.Height - YCount * (PatternHeight + SkipHeight) = PatternHeight then
11512
      Inc(YCount);
11513
    Result := XCount * YCount;
1 daniel-mar 11514
  end else
11515
    Result := FPatterns.Count;
11516
end;
11517
 
11518
function TPictureCollectionItem.GetWidth: Integer;
11519
begin
11520
  Result := FPatternWidth;
4 daniel-mar 11521
  if (Result <= 0) then
1 daniel-mar 11522
    Result := FPicture.Width;
11523
end;
4 daniel-mar 11524
 
1 daniel-mar 11525
procedure TPictureCollectionItem.Draw(Dest: TDirectDrawSurface; X, Y,
4 daniel-mar 11526
  PatternIndex: Integer);
1 daniel-mar 11527
begin
4 daniel-mar 11528
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11529
  begin
4 daniel-mar 11530
    {$IFDEF DrawHWAcc}
11531
    with TPictureCollection(Self.GetPictureCollection) do
11532
      if FDXDraw.CheckD3D(Dest) then
11533
      begin
11534
        FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, Bounds(X, Y, Width, Height), PatternIndex, rtDraw{$IFNDEF VER4UP}, $FF{$ENDIF});
11535
      end
11536
      else
11537
    {$ENDIF DrawHWAcc}
11538
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11539
          Dest.Draw(X, Y, FRect, FSurface, Transparent);
1 daniel-mar 11540
  end;
11541
end;
11542
 
4 daniel-mar 11543
procedure TPictureCollectionItem.DrawFlipHV(Dest: TDirectDrawSurface; X, Y,
11544
  PatternIndex: Integer);
11545
var
11546
  flrc: trect;
11547
begin
11548
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
11549
    with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11550
    begin
11551
      flrc.Left := frect.right; flrc.Right := frect.left;
11552
      flrc.Top := fpicture.height - frect.top;
11553
      flrc.Bottom := fpicture.height - frect.bottom;
11554
      Dest.Draw(X, Y, Flrc, FSurface, Transparent);
11555
    end;
11556
end;
11557
 
11558
procedure TPictureCollectionItem.DrawFlipH(Dest: TDirectDrawSurface; X, Y,
11559
  PatternIndex: Integer);
11560
var
11561
  flrc: TRect;
11562
begin
11563
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
11564
    with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11565
    begin
11566
      if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Dest) then
11567
      begin
11568
        flrc := frect;
11569
        Dest.MirrorFlip([rmfMirror]);
11570
      end
11571
      else
11572
      begin
11573
        flrc.Left := fpicture.width - frect.left;
11574
        flrc.Right := fpicture.width - frect.right;
11575
        flrc.Top := frect.Top; flrc.Bottom := frect.Bottom;
11576
      end;
11577
      Dest.Draw(X, Y, Flrc, FSurface, Transparent);
11578
    end;
11579
end;
11580
 
11581
procedure TPictureCollectionItem.DrawFlipV(Dest: TDirectDrawSurface; X, Y,
11582
  PatternIndex: Integer);
11583
var
11584
  flrc: TRect;
11585
begin
11586
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
11587
    with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11588
    begin
11589
      if AsSigned(D2D) and D2D.CanUseD2D and (D2D.FDDraw.Surface = Dest) then
11590
      begin
11591
        flrc := frect;
11592
        Dest.MirrorFlip([rmfFlip]);
11593
      end
11594
      else
11595
      begin
11596
        flrc.Left := frect.left; flrc.Right := frect.right;
11597
        flrc.Top := fpicture.height - frect.top;
11598
        flrc.Bottom := fpicture.height - frect.bottom;
11599
      end;
11600
      Dest.Draw(X, Y, Flrc, FSurface, Transparent);
11601
    end;
11602
end;
11603
 
1 daniel-mar 11604
procedure TPictureCollectionItem.StretchDraw(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer);
11605
begin
4 daniel-mar 11606
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11607
  begin
4 daniel-mar 11608
    {$IFDEF DrawHWAcc}
11609
    with TPictureCollection(Self.GetPictureCollection) do
11610
      if FDXDraw.CheckD3D(Dest) then
11611
      begin
11612
        FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, DestRect, PatternIndex, rtDraw{$IFNDEF VER4UP}, $FF{$ENDIF})
11613
      end
11614
      else
11615
    {$ENDIF DrawHWAcc}
11616
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11617
          Dest.StretchDraw(DestRect, FRect, FSurface, Transparent);
1 daniel-mar 11618
  end;
11619
end;
11620
 
11621
procedure TPictureCollectionItem.DrawAdd(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
11622
  Alpha: Integer);
11623
begin
4 daniel-mar 11624
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11625
  begin
4 daniel-mar 11626
    with TPictureCollection(Self.GetPictureCollection) do
11627
      if FDXDraw.CheckD3D(Dest) then
11628
      begin
11629
        FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, DestRect, PatternIndex, rtAdd, Alpha)
11630
      end
11631
      else
11632
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11633
          Dest.DrawAdd(DestRect, FRect, FSurface, Transparent, Alpha);
1 daniel-mar 11634
  end;
11635
end;
11636
 
4 daniel-mar 11637
procedure TPictureCollectionItem.DrawAddCol(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
11638
  Color: Integer; Alpha: Integer);
11639
begin
11640
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
11641
  begin
11642
    with TPictureCollection(Self.GetPictureCollection) do
11643
      if FDXDraw.CheckD3D(Dest) then
11644
      begin
11645
        FDXDraw.FD2D.D2DRenderCol(Self, DestRect, PatternIndex, Color, rtAdd, Alpha)
11646
      end
11647
      else
11648
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11649
          Dest.DrawAdd(DestRect, FRect, FSurface, Transparent, Alpha);
11650
  end;
11651
end;
11652
 
1 daniel-mar 11653
procedure TPictureCollectionItem.DrawAlpha(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
11654
  Alpha: Integer);
11655
begin
4 daniel-mar 11656
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11657
  begin
4 daniel-mar 11658
    with TPictureCollection(Self.GetPictureCollection) do
11659
      if FDXDraw.CheckD3D(Dest) then
11660
      begin
11661
        FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, DestRect, PatternIndex, rtBlend, Alpha)
11662
      end
11663
      else
11664
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11665
          Dest.DrawAlpha(DestRect, FRect, FSurface, Transparent, Alpha);
1 daniel-mar 11666
  end;
11667
end;
11668
 
11669
procedure TPictureCollectionItem.DrawSub(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
11670
  Alpha: Integer);
11671
begin
4 daniel-mar 11672
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11673
  begin
4 daniel-mar 11674
    with TPictureCollection(Self.GetPictureCollection) do
11675
      if FDXDraw.CheckD3D(Dest) then
11676
      begin
11677
        FDXDraw.FD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Self, DestRect, PatternIndex, rtSub, Alpha)
11678
      end
11679
      else
11680
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11681
          Dest.DrawSub(DestRect, FRect, FSurface, Transparent, Alpha);
1 daniel-mar 11682
  end;
11683
end;
11684
 
4 daniel-mar 11685
procedure TPictureCollectionItem.DrawSubCol(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
11686
  Color: Integer; Alpha: Integer);
11687
begin
11688
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
11689
  begin
11690
    with TPictureCollection(Self.GetPictureCollection) do
11691
      if FDXDraw.CheckD3D(Dest) then
11692
      begin
11693
        FDXDraw.FD2D.D2DRenderCol(Self, DestRect, PatternIndex, Color, rtSub, Alpha)
11694
      end
11695
      else
11696
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11697
          Dest.DrawSub(DestRect, FRect, FSurface, Transparent, Alpha);
11698
  end;
11699
end;
11700
 
1 daniel-mar 11701
procedure TPictureCollectionItem.DrawRotate(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
4 daniel-mar 11702
  CenterX, CenterY: Double; Angle: single);
1 daniel-mar 11703
begin
4 daniel-mar 11704
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11705
  begin
4 daniel-mar 11706
    with TPictureCollection(Self.GetPictureCollection) do
11707
      if FDXDraw.CheckD3D(Dest) then
11708
      begin
11709
        //X,Y................ Center of rotation
11710
        //Width,Height....... Picture
11711
        //PatternIndex....... Piece of picture
11712
        //CenterX,CenterY ... Center of rotation on picture
11713
        //Angle.............. Angle of rotation
11714
        FDXDraw.FD2D.D2DRenderRotate(Self, X, Y, Width, Height, PatternIndex, rtDraw, CenterX, CenterY, Angle{$IFNDEF VER4UP}, $FF{$ENDIF});
11715
      end
11716
      else
11717
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11718
          Dest.DrawRotate(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle);
1 daniel-mar 11719
  end;
11720
end;
11721
 
11722
procedure TPictureCollectionItem.DrawRotateAdd(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
4 daniel-mar 11723
  CenterX, CenterY: Double; Angle: single; Alpha: Integer);
1 daniel-mar 11724
begin
4 daniel-mar 11725
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11726
  begin
4 daniel-mar 11727
    with TPictureCollection(Self.GetPictureCollection) do
11728
      if FDXDraw.CheckD3D(Dest) then
11729
      begin
11730
        FDXDraw.FD2D.D2DRenderRotate(Self, X, Y, Width, Height, PatternIndex, rtAdd, CenterX, CenterY, Angle, Alpha);
11731
      end
11732
      else
11733
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11734
          Dest.DrawRotateAdd(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
1 daniel-mar 11735
  end;
11736
end;
11737
 
11738
procedure TPictureCollectionItem.DrawRotateAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
4 daniel-mar 11739
  CenterX, CenterY: Double; Angle: single; Alpha: Integer);
1 daniel-mar 11740
begin
4 daniel-mar 11741
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11742
  begin
4 daniel-mar 11743
    with TPictureCollection(Self.GetPictureCollection) do
11744
      if FDXDraw.CheckD3D(Dest) then
11745
      begin
11746
        FDXDraw.FD2D.D2DRenderRotate(Self, X, Y, Width, Height, PatternIndex, rtBlend, CenterX, CenterY, Angle, Alpha);
11747
      end
11748
      else
11749
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11750
          Dest.DrawRotateAlpha(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
1 daniel-mar 11751
  end;
11752
end;
11753
 
11754
procedure TPictureCollectionItem.DrawRotateSub(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
4 daniel-mar 11755
  CenterX, CenterY: Double; Angle: single; Alpha: Integer);
1 daniel-mar 11756
begin
4 daniel-mar 11757
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11758
  begin
4 daniel-mar 11759
    with TPictureCollection(Self.GetPictureCollection) do
11760
      if FDXDraw.CheckD3D(Dest) then
11761
      begin
11762
        FDXDraw.FD2D.D2DRenderRotate(Self, X, Y, Width, Height, PatternIndex, rtSub, CenterX, CenterY, Angle, Alpha);
11763
      end
11764
      else
11765
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11766
          Dest.DrawRotateSub(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
1 daniel-mar 11767
  end;
11768
end;
11769
 
11770
procedure TPictureCollectionItem.DrawWaveX(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
11771
  amp, Len, ph: Integer);
11772
begin
4 daniel-mar 11773
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11774
  begin
4 daniel-mar 11775
    with TPictureCollection(Self.GetPictureCollection) do
11776
      if FDXDraw.CheckD3D(Dest) then
11777
      begin
11778
        FDXDraw.FD2D.D2DRenderWaveX(Self, X, Y, Width, Height, PatternIndex, rtDraw,
11779
          Transparent, amp, Len, ph{$IFNDEF VER4UP}, $FF{$ENDIF});
11780
      end
11781
      else
11782
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11783
          Dest.DrawWaveX(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph);
1 daniel-mar 11784
  end;
11785
end;
11786
 
11787
procedure TPictureCollectionItem.DrawWaveXAdd(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
11788
  amp, Len, ph, Alpha: Integer);
11789
begin
4 daniel-mar 11790
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11791
  begin
4 daniel-mar 11792
    with TPictureCollection(Self.GetPictureCollection) do
11793
      if FDXDraw.CheckD3D(Dest) then
11794
      begin
11795
        FDXDraw.FD2D.D2DRenderWaveX(Self, X, Y, Width, Height, PatternIndex, rtAdd,
11796
          Transparent, amp, Len, ph, Alpha);
11797
      end
11798
      else
11799
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11800
          Dest.DrawWaveXAdd(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
1 daniel-mar 11801
  end;
11802
end;
11803
 
11804
procedure TPictureCollectionItem.DrawWaveXAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
11805
  amp, Len, ph, Alpha: Integer);
11806
begin
4 daniel-mar 11807
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11808
  begin
4 daniel-mar 11809
    with TPictureCollection(Self.GetPictureCollection) do
11810
      if FDXDraw.CheckD3D(Dest) then
11811
      begin
11812
        FDXDraw.FD2D.D2DRenderWaveX(Self, X, Y, Width, Height, PatternIndex, rtBlend,
11813
          Transparent, amp, Len, ph, Alpha);
11814
      end
11815
      else
11816
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11817
          Dest.DrawWaveXAlpha(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
1 daniel-mar 11818
  end;
11819
end;
11820
 
11821
procedure TPictureCollectionItem.DrawWaveXSub(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
11822
  amp, Len, ph, Alpha: Integer);
11823
begin
4 daniel-mar 11824
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
1 daniel-mar 11825
  begin
4 daniel-mar 11826
    with TPictureCollection(Self.GetPictureCollection) do
11827
      if FDXDraw.CheckD3D(Dest) then
11828
      begin
11829
        FDXDraw.FD2D.D2DRenderWaveX(Self, X, Y, Width, Height, PatternIndex, rtSub,
11830
          Transparent, amp, Len, ph, Alpha);
11831
      end
11832
      else
11833
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
11834
          Dest.DrawWaveXSub(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
1 daniel-mar 11835
  end;
11836
end;
11837
 
4 daniel-mar 11838
procedure TPictureCollectionItem.DrawWaveYSub(Dest: TDirectDrawSurface; X, Y,
11839
  Width, Height, PatternIndex, amp, Len, ph, Alpha: Integer);
11840
begin
11841
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
11842
  begin
11843
    with TPictureCollection(Self.GetPictureCollection) do
11844
      if FDXDraw.CheckD3D(Dest) then
11845
      begin
11846
        FDXDraw.FD2D.D2DRenderWaveY(Self, X, Y, Width, Height, PatternIndex, rtSub,
11847
          Transparent, amp, Len, ph, Alpha);
11848
      end
11849
      {there is not software version}
11850
  end;
11851
end;
11852
 
11853
procedure TPictureCollectionItem.DrawWaveY(Dest: TDirectDrawSurface; X, Y,
11854
  Width, Height, PatternIndex, amp, Len, ph: Integer);
11855
begin
11856
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
11857
  begin
11858
    with TPictureCollection(Self.GetPictureCollection) do
11859
      if FDXDraw.CheckD3D(Dest) then
11860
      begin
11861
        FDXDraw.FD2D.D2DRenderWaveY(Self, X, Y, Width, Height, PatternIndex, rtDraw,
11862
          Transparent, amp, Len, ph{$IFNDEF VER4UP}, $FF{$ENDIF});
11863
      end
11864
  end;
11865
end;
11866
 
11867
procedure TPictureCollectionItem.DrawWaveYAdd(Dest: TDirectDrawSurface; X, Y,
11868
  Width, Height, PatternIndex, amp, Len, ph, Alpha: Integer);
11869
begin
11870
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
11871
  begin
11872
    with TPictureCollection(Self.GetPictureCollection) do
11873
      if FDXDraw.CheckD3D(Dest) then
11874
      begin
11875
        FDXDraw.FD2D.D2DRenderWaveY(Self, X, Y, Width, Height, PatternIndex, rtAdd,
11876
          Transparent, amp, Len, ph, Alpha);
11877
      end
11878
  end;
11879
end;
11880
 
11881
procedure TPictureCollectionItem.DrawWaveYAlpha(Dest: TDirectDrawSurface; X, Y,
11882
  Width, Height, PatternIndex, amp, Len, ph, Alpha: Integer);
11883
begin
11884
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
11885
  begin
11886
    with TPictureCollection(Self.GetPictureCollection) do
11887
      if FDXDraw.CheckD3D(Dest) then
11888
      begin
11889
        FDXDraw.FD2D.D2DRenderWaveY(Self, X, Y, Width, Height, PatternIndex, rtBlend,
11890
          Transparent, amp, Len, ph, Alpha);
11891
      end
11892
  end;
11893
end;
11894
 
1 daniel-mar 11895
procedure TPictureCollectionItem.Finalize;
11896
begin
11897
  if FInitialized then
11898
  begin
11899
    FInitialized := False;
11900
    ClearSurface;
11901
  end;
11902
end;
11903
 
4 daniel-mar 11904
procedure TPictureCollectionItem.UpdateTag;
11905
 
11906
  function AddSurface(const SrcRect: TRect): TDirectDrawSurface;
11907
  begin
11908
    Result := TDirectDrawSurface.Create(PictureCollection.DXDraw.DDraw);
11909
    FSurfaceList.Add(Result);
11910
 
11911
    Result.SystemMemory := FSystemMemory;
11912
    Result.LoadFromGraphicRect(FPicture.Graphic, 0, 0, SrcRect);
11913
    Result.TransparentColor := Result.ColorMatch(FTransparentColor);
11914
  end;
11915
 
11916
var
11917
  x, y, x2, y2: Integer;
11918
  BlockWidth, BlockHeight, BlockXCount, BlockYCount: Integer;
11919
  Width2, Height2: Integer;
11920
  TempSurface : TDirectDrawSurface;
11921
begin
11922
  if FPicture.Graphic = nil then Exit;
11923
//  ClearSurface;
11924
  Width2 := Width + SkipWidth;
11925
  Height2 := Height + SkipHeight;
11926
 
11927
  if (Width = FPicture.Width) and (Height = FPicture.Height) then
11928
  begin
11929
    with TPictureCollectionItemPattern.Create(FPatterns) do
11930
    begin
11931
     TempSurface := TDirectDrawSurface.Create(PictureCollection.DXDraw.DDraw);
11932
     FSurface := TempSurface;
11933
      FRect := Bounds(0, 0, FPicture.Width, FPicture.Height);
11934
     TempSurface.LoadFromGraphicRect(FPicture.Graphic, 0, 0, FRect);
11935
     TempSurface.SystemMemory := FSystemMemory;
11936
     TempSurface.TransparentColor := TempSurface.ColorMatch(FTransparentColor);
11937
     FSurfaceList.Add(TempSurface);
11938
    end;
11939
  end
11940
 else
11941
 if FSystemMemory then
11942
  begin
11943
    AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
11944
    for y := 0 to (FPicture.Height + SkipHeight) div Height2 - 1 do
11945
      for x := 0 to (FPicture.Width + SkipWidth) div Width2 - 1 do
11946
        with TPictureCollectionItemPattern.Create(FPatterns) do
11947
        begin
11948
          FRect := Bounds(x * Width2, y * Height2, Width, Height);
11949
          FSurface := TDirectDrawSurface(FSurfaceList[0]);
11950
        end;
11951
  end
11952
  else
11953
  begin
11954
    {  Load to a video memory with dividing the image.   }
11955
    BlockWidth := Min(((SurfaceDivWidth + Width2 - 1) div Width2) * Width2,
11956
      (FPicture.Width + SkipWidth) div Width2 * Width2);
11957
    BlockHeight := Min(((SurfaceDivHeight + Height2 - 1) div Height2) * Height2,
11958
      (FPicture.Height + SkipHeight) div Height2 * Height2);
11959
 
11960
    if (BlockWidth = 0) or (BlockHeight = 0) then Exit;
11961
 
11962
    BlockXCount := (FPicture.Width + BlockWidth - 1) div BlockWidth;
11963
    BlockYCount := (FPicture.Height + BlockHeight - 1) div BlockHeight;
11964
 
11965
    for y := 0 to BlockYCount - 1 do
11966
      for x := 0 to BlockXCount - 1 do
11967
      begin
11968
        x2 := Min(BlockWidth, Max(FPicture.Width - x * BlockWidth, 0));
11969
        if x2 = 0 then x2 := BlockWidth;
11970
 
11971
        y2 := Min(BlockHeight, Max(FPicture.Height - y * BlockHeight, 0));
11972
        if y2 = 0 then y2 := BlockHeight;
11973
 
11974
        AddSurface(Bounds(x * BlockWidth, y * BlockHeight, x2, y2));
11975
      end;
11976
 
11977
    for y := 0 to (FPicture.Height + SkipHeight) div Height2 - 1 do
11978
      for x := 0 to (FPicture.Width + SkipWidth) div Width2 - 1 do
11979
      begin
11980
        x2 := x * Width2;
11981
        y2 := y * Height2;
11982
        with TPictureCollectionItemPattern.Create(FPatterns) do
11983
        begin
11984
          FRect := Bounds(x2 - (x2 div BlockWidth * BlockWidth), y2 - (y2 div BlockHeight * BlockHeight), Width, Height);
11985
          FSurface := TDirectDrawSurface(FSurfaceList[(x2 div BlockWidth) + ((y2 div BlockHeight) * BlockXCount)]);
11986
        end;
11987
      end;
11988
  end;
11989
end;
11990
 
1 daniel-mar 11991
procedure TPictureCollectionItem.Initialize;
11992
begin
11993
  Finalize;
11994
  FInitialized := PictureCollection.Initialized;
4 daniel-mar 11995
  UpdateTag;
1 daniel-mar 11996
end;
11997
 
11998
procedure TPictureCollectionItem.Restore;
11999
 
12000
  function AddSurface(const SrcRect: TRect): TDirectDrawSurface;
12001
  begin
12002
    Result := TDirectDrawSurface.Create(PictureCollection.DXDraw.DDraw);
12003
    FSurfaceList.Add(Result);
12004
 
12005
    Result.SystemMemory := FSystemMemory;
12006
    Result.LoadFromGraphicRect(FPicture.Graphic, 0, 0, SrcRect);
12007
    Result.TransparentColor := Result.ColorMatch(FTransparentColor);
12008
  end;
12009
 
12010
var
12011
  x, y, x2, y2: Integer;
12012
  BlockWidth, BlockHeight, BlockXCount, BlockYCount: Integer;
12013
  Width2, Height2: Integer;
12014
begin
4 daniel-mar 12015
  if FPicture.Graphic = nil then Exit;
1 daniel-mar 12016
 
12017
  if not FInitialized then
12018
  begin
12019
    if PictureCollection.Initialized then
12020
      Initialize;
12021
    if not FInitialized then Exit;
12022
  end;
12023
 
12024
  ClearSurface;
12025
 
4 daniel-mar 12026
  Width2 := Width + SkipWidth;
12027
  Height2 := Height + SkipHeight;
1 daniel-mar 12028
 
4 daniel-mar 12029
  if (Width = FPicture.Width) and (Height = FPicture.Height) then
1 daniel-mar 12030
  begin
12031
    {  There is no necessity of division because the number of patterns is one.   }
12032
    with TPictureCollectionItemPattern.Create(FPatterns) do
12033
    begin
12034
      FRect := Bounds(0, 0, FPicture.Width, FPicture.Height);
12035
      FSurface := AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
12036
    end;
4 daniel-mar 12037
  end
12038
  else
12039
  if FSystemMemory then
1 daniel-mar 12040
  begin
12041
    {  Load to a system memory.  }
12042
    AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
12043
 
4 daniel-mar 12044
    for y := 0 to (FPicture.Height + SkipHeight) div Height2 - 1 do
12045
      for x := 0 to (FPicture.Width + SkipWidth) div Width2 - 1 do
1 daniel-mar 12046
        with TPictureCollectionItemPattern.Create(FPatterns) do
12047
        begin
12048
          FRect := Bounds(x * Width2, y * Height2, Width, Height);
12049
          FSurface := TDirectDrawSurface(FSurfaceList[0]);
12050
        end;
4 daniel-mar 12051
  end
12052
  else
1 daniel-mar 12053
  begin
12054
    {  Load to a video memory with dividing the image.   }
4 daniel-mar 12055
    BlockWidth := Min(((SurfaceDivWidth + Width2 - 1) div Width2) * Width2,
12056
      (FPicture.Width + SkipWidth) div Width2 * Width2);
12057
    BlockHeight := Min(((SurfaceDivHeight + Height2 - 1) div Height2) * Height2,
12058
      (FPicture.Height + SkipHeight) div Height2 * Height2);
1 daniel-mar 12059
 
4 daniel-mar 12060
    if (BlockWidth = 0) or (BlockHeight = 0) then Exit;
1 daniel-mar 12061
 
4 daniel-mar 12062
    BlockXCount := (FPicture.Width + BlockWidth - 1) div BlockWidth;
12063
    BlockYCount := (FPicture.Height + BlockHeight - 1) div BlockHeight;
1 daniel-mar 12064
 
4 daniel-mar 12065
    for y := 0 to BlockYCount - 1 do
12066
      for x := 0 to BlockXCount - 1 do
1 daniel-mar 12067
      begin
4 daniel-mar 12068
        x2 := Min(BlockWidth, Max(FPicture.Width - x * BlockWidth, 0));
12069
        if x2 = 0 then x2 := BlockWidth;
12070
 
12071
        y2 := Min(BlockHeight, Max(FPicture.Height - y * BlockHeight, 0));
12072
        if y2 = 0 then y2 := BlockHeight;
12073
 
12074
        AddSurface(Bounds(x * BlockWidth, y * BlockHeight, x2, y2));
1 daniel-mar 12075
      end;
12076
 
4 daniel-mar 12077
    for y := 0 to (FPicture.Height + SkipHeight) div Height2 - 1 do
12078
      for x := 0 to (FPicture.Width + SkipWidth) div Width2 - 1 do
1 daniel-mar 12079
      begin
12080
        x2 := x * Width2;
12081
        y2 := y * Height2;
12082
        with TPictureCollectionItemPattern.Create(FPatterns) do
12083
        begin
4 daniel-mar 12084
          FRect := Bounds(x2 - (x2 div BlockWidth * BlockWidth), y2 - (y2 div BlockHeight * BlockHeight), Width, Height);
12085
          FSurface := TDirectDrawSurface(FSurfaceList[(x2 div BlockWidth) + ((y2 div BlockHeight) * BlockXCount)]);
1 daniel-mar 12086
        end;
12087
      end;
12088
  end;
4 daniel-mar 12089
  {Code added for better compatibility}
12090
  {When is any picture changed, then all textures cleared and list have to reloaded}
12091
  with PictureCollection do
12092
    {$IFDEF D3D_deprecated}if (do3D in FDXDraw.Options) then{$ENDIF}
12093
      if AsSigned(FDXDraw.FD2D) then
12094
        if Assigned(FDXDraw.FD2D.D2DTextures) then
12095
          FDXDraw.FD2D.D2DTextures.D2DPruneAllTextures;
1 daniel-mar 12096
end;
12097
 
12098
procedure TPictureCollectionItem.SetPicture(Value: TPicture);
12099
begin
12100
  FPicture.Assign(Value);
12101
end;
12102
 
12103
procedure TPictureCollectionItem.SetTransparentColor(Value: TColor);
12104
var
12105
  i: Integer;
12106
  Surface: TDirectDrawSurface;
12107
begin
4 daniel-mar 12108
  if Value <> FTransparentColor then
1 daniel-mar 12109
  begin
12110
    FTransparentColor := Value;
4 daniel-mar 12111
    for i := 0 to FSurfaceList.Count - 1 do
1 daniel-mar 12112
    begin
12113
      try
12114
        Surface := TDirectDrawSurface(FSurfaceList[i]);
12115
        Surface.TransparentColor := Surface.ColorMatch(FTransparentColor);
12116
      except
12117
      end;
12118
    end;
12119
  end;
12120
end;
12121
 
4 daniel-mar 12122
procedure TPictureCollectionItem.DrawAlphaCol(Dest: TDirectDrawSurface;
12123
  const DestRect: TRect; PatternIndex, Color, Alpha: Integer);
12124
begin
12125
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
12126
  begin
12127
    with TPictureCollection(Self.GetPictureCollection) do
12128
      if FDXDraw.CheckD3D(Dest) then
12129
      begin
12130
        FDXDraw.FD2D.D2DRenderCol(Self, DestRect, PatternIndex, color, rtBlend, Alpha)
12131
      end else
12132
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
12133
          Dest.DrawAlpha(DestRect, FRect, FSurface, Transparent, Alpha);
12134
  end;
12135
end;
12136
 
12137
procedure TPictureCollectionItem.DrawRotateAddCol(Dest: TDirectDrawSurface;
12138
  X, Y, Width, Height, PatternIndex: Integer; CenterX, CenterY: Double;
12139
  Angle: single; Color, Alpha: Integer);
12140
begin
12141
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
12142
  begin
12143
    with TPictureCollection(Self.GetPictureCollection) do
12144
      if FDXDraw.CheckD3D(Dest) then
12145
      begin
12146
        FDXDraw.FD2D.D2DRenderRotateModeCol(Self, rtAdd, X, Y, Width,
12147
          Height, PatternIndex, CenterX, CenterY, Angle, Color, Alpha);
12148
      end
12149
      else
12150
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
12151
          Dest.DrawRotateAdd(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
12152
  end;
12153
end;
12154
 
12155
procedure TPictureCollectionItem.DrawRotateAlphaCol(Dest: TDirectDrawSurface;
12156
  X, Y, Width, Height, PatternIndex: Integer; CenterX, CenterY: Double;
12157
  Angle: single; Color, Alpha: Integer);
12158
begin
12159
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
12160
  begin
12161
    with TPictureCollection(Self.GetPictureCollection) do
12162
      if FDXDraw.CheckD3D(Dest) then
12163
      begin
12164
        FDXDraw.FD2D.D2DRenderRotateModeCol(Self, rtBlend, X, Y, Width,
12165
          Height, PatternIndex, CenterX, CenterY, Angle, Color, Alpha);
12166
      end
12167
      else
12168
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
12169
          Dest.DrawRotateAlpha(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
12170
  end;
12171
end;
12172
 
12173
procedure TPictureCollectionItem.DrawRotateSubCol(Dest: TDirectDrawSurface;
12174
  X, Y, Width, Height, PatternIndex: Integer; CenterX, CenterY: Double;
12175
  Angle: single; Color, Alpha: Integer);
12176
begin
12177
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
12178
  begin
12179
    with TPictureCollection(Self.GetPictureCollection) do
12180
      if FDXDraw.CheckD3D(Dest) then
12181
      begin
12182
        FDXDraw.FD2D.D2DRenderRotateModeCol(Self, rtSub, X, Y, Width,
12183
          Height, PatternIndex, CenterX, CenterY, Angle, Color, Alpha);
12184
      end
12185
      else
12186
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
12187
          Dest.DrawRotateSub(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
12188
  end;
12189
end;
12190
 
12191
procedure TPictureCollectionItem.DrawCol(Dest: TDirectDrawSurface;
12192
  const DestRect, SourceRect: TRect; PatternIndex: Integer; Faded: Boolean;
12193
  RenderType: TRenderType; Color, Specular: Integer; Alpha: Integer);
12194
begin
12195
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
12196
  begin
12197
    with TPictureCollection(Self.GetPictureCollection) do
12198
      if FDXDraw.CheckD3D(Dest) then
12199
      begin
12200
        FDXDraw.FD2D.D2DRenderColoredPartition(Self, DestRect, PatternIndex,
12201
          Color, Specular, Faded, SourceRect, RenderType,
12202
          Alpha)
12203
      end
12204
      else
12205
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
12206
          Dest.DrawAlpha(DestRect, FRect, FSurface, Transparent, Alpha);
12207
  end;
12208
end;
12209
 
12210
procedure TPictureCollectionItem.DrawRect(Dest: TDirectDrawSurface;
12211
  const DestRect, SourceRect: TRect; PatternIndex: Integer;
12212
  RenderType: TRenderType; Transparent: Boolean; Alpha: Integer);
12213
begin
12214
  if FInitialized and (PatternIndex >= 0) and (PatternIndex < FPatterns.Count) then
12215
  begin
12216
    {$IFDEF DrawHWAcc}
12217
    with TPictureCollection(Self.GetPictureCollection) do
12218
      if FDXDraw.CheckD3D(Dest) then
12219
      begin
12220
        FDXDraw.FD2D.D2DRender(Self, DestRect, PatternIndex, SourceRect, RenderType, Alpha);
12221
      end
12222
      else
12223
    {$ENDIF DrawHWAcc}
12224
        with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
12225
        begin
12226
          case RenderType of
12227
            rtDraw: Dest.StretchDraw(DestRect, SourceRect, FSurface, Transparent);
12228
              //Dest.Draw(DestRect.Left, DestRect.Top, SourceRect, FSurface, Transparent);
12229
            rtBlend: Dest.DrawAlpha(DestRect, SourceRect, FSurface, Transparent, Alpha);
12230
            rtAdd: Dest.DrawAdd(DestRect, SourceRect, FSurface, Transparent, Alpha);
12231
            rtSub: Dest.DrawSub(DestRect, SourceRect, FSurface, Transparent, Alpha);
12232
          end;
12233
        end;
12234
  end;
12235
end;
12236
 
1 daniel-mar 12237
{  TPictureCollection  }
12238
 
12239
constructor TPictureCollection.Create(AOwner: TPersistent);
12240
begin
12241
  inherited Create(TPictureCollectionItem);
12242
  FOwner := AOwner;
12243
end;
12244
 
12245
destructor TPictureCollection.Destroy;
12246
begin
12247
  Finalize;
12248
  inherited Destroy;
12249
end;
12250
 
12251
function TPictureCollection.GetItem(Index: Integer): TPictureCollectionItem;
12252
begin
12253
  Result := TPictureCollectionItem(inherited Items[Index]);
12254
end;
12255
 
12256
function TPictureCollection.GetOwner: TPersistent;
12257
begin
12258
  Result := FOwner;
12259
end;
12260
 
12261
function TPictureCollection.Find(const Name: string): TPictureCollectionItem;
12262
var
12263
  i: Integer;
12264
begin
12265
  i := IndexOf(Name);
4 daniel-mar 12266
  if i = -1 then
1 daniel-mar 12267
    raise EPictureCollectionError.CreateFmt(SImageNotFound, [Name]);
12268
  Result := Items[i];
12269
end;
12270
 
12271
procedure TPictureCollection.Finalize;
12272
var
12273
  i: Integer;
12274
begin
12275
  try
4 daniel-mar 12276
    for i := 0 to Count - 1 do
1 daniel-mar 12277
      Items[i].Finalize;
12278
  finally
12279
    FDXDraw := nil;
12280
  end;
12281
end;
12282
 
4 daniel-mar 12283
procedure TPictureCollection.InitializeImages(DXDraw: TCustomDXDraw; Id : Integer);
12284
var
12285
  i: Integer;
12286
begin
12287
  If id = -1 Then
12288
   Finalize;
12289
  FDXDraw := DXDraw;
12290
 
12291
  if not Initialized then
12292
    raise EPictureCollectionError.CreateFmt(SCannotInitialized, [ClassName]);
12293
 
12294
  for i := 0 to Count - 1 do
12295
   If (id = -1) or (id = i) Then
12296
    Items[i].Initialize;
12297
end;
12298
 
1 daniel-mar 12299
procedure TPictureCollection.Initialize(DXDraw: TCustomDXDraw);
12300
var
12301
  i: Integer;
12302
begin
12303
  Finalize;
12304
  FDXDraw := DXDraw;
12305
 
12306
  if not Initialized then
12307
    raise EPictureCollectionError.CreateFmt(SCannotInitialized, [ClassName]);
12308
 
4 daniel-mar 12309
  for i := 0 to Count - 1 do
1 daniel-mar 12310
    Items[i].Initialize;
12311
end;
12312
 
12313
function TPictureCollection.Initialized: Boolean;
12314
begin
4 daniel-mar 12315
  Result := (FDXDraw <> nil) and (FDXDraw.Initialized);
1 daniel-mar 12316
end;
12317
 
12318
procedure TPictureCollection.Restore;
12319
var
12320
  i: Integer;
12321
begin
4 daniel-mar 12322
  for i := 0 to Count - 1 do
1 daniel-mar 12323
    Items[i].Restore;
12324
end;
12325
 
12326
procedure TPictureCollection.MakeColorTable;
12327
var
12328
  UseColorTable: array[0..255] of Boolean;
12329
  PaletteCount: Integer;
12330
 
12331
  procedure SetColor(Index: Integer; Col: TRGBQuad);
12332
  begin
12333
    UseColorTable[Index] := True;
12334
    ColorTable[Index] := Col;
12335
    Inc(PaletteCount);
12336
  end;
12337
 
12338
  procedure AddColor(Col: TRGBQuad);
12339
  var
12340
    i: Integer;
12341
  begin
4 daniel-mar 12342
    for i := 0 to 255 do
1 daniel-mar 12343
      if UseColorTable[i] then
4 daniel-mar 12344
        if DWORD(ColorTable[i]) = DWORD(Col) then
1 daniel-mar 12345
          Exit;
4 daniel-mar 12346
    for i := 0 to 255 do
1 daniel-mar 12347
      if not UseColorTable[i] then
12348
      begin
12349
        SetColor(i, Col);
12350
        Exit;
12351
      end;
12352
  end;
12353
 
12354
  procedure AddDIB(DIB: TDIB);
12355
  var
12356
    i: Integer;
12357
  begin
4 daniel-mar 12358
    if DIB.BitCount > 8 then Exit;
1 daniel-mar 12359
 
4 daniel-mar 12360
    for i := 0 to 255 do
1 daniel-mar 12361
      AddColor(DIB.ColorTable[i]);
12362
  end;
12363
 
12364
  procedure AddGraphic(Graphic: TGraphic);
12365
  var
12366
    i, n: Integer;
12367
    PaletteEntries: TPaletteEntries;
12368
  begin
4 daniel-mar 12369
    if Graphic.Palette <> 0 then
1 daniel-mar 12370
    begin
12371
      n := GetPaletteEntries(Graphic.Palette, 0, 256, PaletteEntries);
4 daniel-mar 12372
      for i := 0 to n - 1 do
1 daniel-mar 12373
        AddColor(PaletteEntryToRGBQuad(PaletteEntries[i]));
12374
    end;
12375
  end;
12376
 
12377
var
12378
  i: Integer;
12379
begin
12380
  FillChar(UseColorTable, SizeOf(UseColorTable), 0);
12381
  FillChar(ColorTable, SizeOf(ColorTable), 0);
12382
 
12383
  PaletteCount := 0;
12384
 
12385
  {  The system color is included.  }
12386
  SetColor(0, RGBQuad(0, 0, 0));
12387
  SetColor(1, RGBQuad(128, 0, 0));
12388
  SetColor(2, RGBQuad(0, 128, 0));
12389
  SetColor(3, RGBQuad(128, 128, 0));
12390
  SetColor(4, RGBQuad(0, 0, 128));
12391
  SetColor(5, RGBQuad(128, 0, 128));
12392
  SetColor(6, RGBQuad(0, 128, 128));
12393
  SetColor(7, RGBQuad(192, 192, 192));
12394
 
12395
  SetColor(248, RGBQuad(128, 128, 128));
12396
  SetColor(249, RGBQuad(255, 0, 0));
12397
  SetColor(250, RGBQuad(0, 255, 0));
12398
  SetColor(251, RGBQuad(255, 255, 0));
12399
  SetColor(252, RGBQuad(0, 0, 255));
12400
  SetColor(253, RGBQuad(255, 0, 255));
12401
  SetColor(254, RGBQuad(0, 255, 255));
12402
  SetColor(255, RGBQuad(255, 255, 255));
12403
 
4 daniel-mar 12404
  for i := 0 to Count - 1 do
12405
    if Items[i].Picture.Graphic <> nil then
1 daniel-mar 12406
    begin
12407
      if Items[i].Picture.Graphic is TDIB then
12408
        AddDIB(TDIB(Items[i].Picture.Graphic))
12409
      else
12410
        AddGraphic(Items[i].Picture.Graphic);
4 daniel-mar 12411
      if PaletteCount = 256 then Break;
1 daniel-mar 12412
    end;
12413
end;
12414
 
12415
procedure TPictureCollection.DefineProperties(Filer: TFiler);
12416
begin
12417
  inherited DefineProperties(Filer);
12418
  Filer.DefineBinaryProperty('ColorTable', ReadColorTable, WriteColorTable, True);
12419
end;
12420
 
12421
type
12422
  TPictureCollectionComponent = class(TComponent)
12423
  private
12424
    FList: TPictureCollection;
12425
  published
12426
    property List: TPictureCollection read FList write FList;
12427
  end;
12428
 
12429
procedure TPictureCollection.LoadFromFile(const FileName: string);
12430
var
12431
  Stream: TFileStream;
12432
begin
12433
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
12434
  try
12435
    LoadFromStream(Stream);
12436
  finally
12437
    Stream.Free;
12438
  end;
12439
end;
12440
 
12441
procedure TPictureCollection.LoadFromStream(Stream: TStream);
12442
var
12443
  Component: TPictureCollectionComponent;
12444
begin
12445
  Clear;
12446
  Component := TPictureCollectionComponent.Create(nil);
12447
  try
12448
    Component.FList := Self;
12449
    Stream.ReadComponentRes(Component);
12450
 
12451
    if Initialized then
12452
    begin
12453
      Initialize(FDXDraw);
12454
      Restore;
12455
    end;
12456
  finally
12457
    Component.Free;
12458
  end;
12459
end;
12460
 
12461
procedure TPictureCollection.SaveToFile(const FileName: string);
12462
var
12463
  Stream: TFileStream;
12464
begin
12465
  Stream := TFileStream.Create(FileName, fmCreate);
12466
  try
12467
    SaveToStream(Stream);
12468
  finally
12469
    Stream.Free;
12470
  end;
12471
end;
12472
 
12473
procedure TPictureCollection.SaveToStream(Stream: TStream);
12474
var
12475
  Component: TPictureCollectionComponent;
12476
begin
12477
  Component := TPictureCollectionComponent.Create(nil);
12478
  try
12479
    Component.FList := Self;
12480
    Stream.WriteComponentRes('DelphiXPictureCollection', Component);
12481
  finally
12482
    Component.Free;
12483
  end;
12484
end;
12485
 
12486
procedure TPictureCollection.ReadColorTable(Stream: TStream);
12487
begin
12488
  Stream.ReadBuffer(ColorTable, SizeOf(ColorTable));
12489
end;
12490
 
12491
procedure TPictureCollection.WriteColorTable(Stream: TStream);
12492
begin
12493
  Stream.WriteBuffer(ColorTable, SizeOf(ColorTable));
12494
end;
12495
 
12496
{  TCustomDXImageList  }
12497
 
12498
constructor TCustomDXImageList.Create(AOnwer: TComponent);
12499
begin
12500
  inherited Create(AOnwer);
12501
  FItems := TPictureCollection.Create(Self);
12502
end;
12503
 
12504
destructor TCustomDXImageList.Destroy;
12505
begin
12506
  DXDraw := nil;
12507
  FItems.Free;
12508
  inherited Destroy;
12509
end;
12510
 
12511
procedure TCustomDXImageList.Notification(AComponent: TComponent;
12512
  Operation: TOperation);
12513
begin
12514
  inherited Notification(AComponent, Operation);
4 daniel-mar 12515
  if (Operation = opRemove) and (DXDraw = AComponent) then
1 daniel-mar 12516
    DXDraw := nil;
12517
end;
12518
 
12519
procedure TCustomDXImageList.DXDrawNotifyEvent(Sender: TCustomDXDraw;
12520
  NotifyType: TDXDrawNotifyType);
12521
begin
12522
  case NotifyType of
12523
    dxntDestroying: DXDraw := nil;
12524
    dxntInitialize: FItems.Initialize(Sender);
4 daniel-mar 12525
    dxntFinalize: FItems.Finalize;
12526
    dxntRestore: FItems.Restore;
1 daniel-mar 12527
  end;
12528
end;
12529
 
12530
procedure TCustomDXImageList.SetDXDraw(Value: TCustomDXDraw);
12531
begin
4 daniel-mar 12532
  if FDXDraw <> nil then
1 daniel-mar 12533
    FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
12534
 
12535
  FDXDraw := Value;
12536
 
4 daniel-mar 12537
  if FDXDraw <> nil then
1 daniel-mar 12538
    FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
12539
end;
12540
 
12541
procedure TCustomDXImageList.SetItems(Value: TPictureCollection);
12542
begin
12543
  FItems.Assign(Value);
12544
end;
12545
 
12546
{  TDirectDrawOverlay  }
12547
 
12548
constructor TDirectDrawOverlay.Create(DDraw: TDirectDraw; TargetSurface: TDirectDrawSurface);
12549
begin
12550
  inherited Create;
12551
  FDDraw := DDraw;
12552
  FTargetSurface := TargetSurface;
12553
  FVisible := True;
12554
end;
12555
 
12556
constructor TDirectDrawOverlay.CreateWindowed(WindowHandle: HWND);
4 daniel-mar 12557
{$IFDEF D3D_deprecated}
1 daniel-mar 12558
const
12559
  PrimaryDesc: TDDSurfaceDesc = (
4 daniel-mar 12560
    dwSize: SizeOf(PrimaryDesc);
12561
    dwFlags: DDSD_CAPS;
12562
    ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE)
12563
    );
12564
{$ELSE}
12565
var
12566
  PrimaryDesc: TDDSurfaceDesc2;
12567
{$ENDIF}
1 daniel-mar 12568
begin
12569
  FDDraw2 := TDirectDraw.CreateEx(nil, False);
4 daniel-mar 12570
  if FDDraw2.{$IFDEF D3D_deprecated}IDraw{$ELSE}IDraw7{$ENDIF}.SetCooperativeLevel(WindowHandle, DDSCL_NORMAL) <> DD_OK then
1 daniel-mar 12571
    raise EDirectDrawOverlayError.CreateFmt(SCannotInitialized, [SOverlay]);
12572
 
12573
  FTargetSurface2 := TDirectDrawSurface.Create(FDDraw2);
4 daniel-mar 12574
  {$IFNDEF D3D_deprecated}
12575
  FillChar(PrimaryDesc, SizeOf(PrimaryDesc), 0);
12576
  PrimaryDesc.dwSize := SizeOf(PrimaryDesc);
12577
  PrimaryDesc.dwFlags := DDSD_CAPS;
12578
  PrimaryDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
12579
  {$ENDIF}
1 daniel-mar 12580
  if not FTargetSurface2.CreateSurface(PrimaryDesc) then
12581
    raise EDirectDrawOverlayError.CreateFmt(SCannotInitialized, [SOverlay]);
12582
 
12583
  Create(FDDraw2, FTargetSurface2);
12584
end;
12585
 
12586
destructor TDirectDrawOverlay.Destroy;
12587
begin
12588
  Finalize;
12589
  FTargetSurface2.Free;
12590
  FDDraw2.Free;
12591
  inherited Destroy;
12592
end;
12593
 
12594
procedure TDirectDrawOverlay.Finalize;
12595
begin
12596
  FBackSurface.Free; FBackSurface := nil;
12597
  FSurface.Free; FSurface := nil;
12598
end;
12599
 
4 daniel-mar 12600
procedure TDirectDrawOverlay.Initialize(const SurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF});
12601
{$IFDEF D3D_deprecated}
1 daniel-mar 12602
const
12603
  BackBufferCaps: TDDSCaps = (dwCaps: DDSCAPS_BACKBUFFER);
12604
var
12605
  DDSurface: IDirectDrawSurface;
4 daniel-mar 12606
{$ELSE}
12607
var
12608
  DDSurface: IDirectDrawSurface7;
12609
  BackBufferCaps: TDDSCaps2;
12610
{$ENDIF}
1 daniel-mar 12611
begin
12612
  Finalize;
12613
  try
12614
    FSurface := TDirectDrawSurface.Create(FDDraw);
12615
    if not FSurface.CreateSurface(SurfaceDesc) then
12616
      raise EDirectDrawOverlayError.CreateFmt(SCannotInitialized, [SOverlay]);
12617
 
12618
    FBackSurface := TDirectDrawSurface.Create(FDDraw);
4 daniel-mar 12619
    {$IFNDEF D3D_deprecated}
12620
    BackBufferCaps.dwCaps := DDSCAPS_BACKBUFFER;
12621
    {$ENDIF}
12622
    if SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_FLIP <> 0 then
1 daniel-mar 12623
    begin
4 daniel-mar 12624
      if FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetAttachedSurface(BackBufferCaps, DDSurface) = DD_OK then
12625
        FBackSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := DDSurface;
12626
    end
12627
    else
12628
      FBackSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} := FSurface.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF};
1 daniel-mar 12629
 
12630
    if FVisible then
12631
      SetOverlayRect(FOverlayRect)
12632
    else
4 daniel-mar 12633
      FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.UpdateOverlay(PRect(nil), FTargetSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, PRect(nil), DDOVER_HIDE, PDDOverlayFX(nil));
1 daniel-mar 12634
  except
12635
    Finalize;
12636
    raise;
12637
  end;
12638
end;
12639
 
12640
procedure TDirectDrawOverlay.Flip;
12641
begin
4 daniel-mar 12642
  if FSurface = nil then Exit;
1 daniel-mar 12643
 
4 daniel-mar 12644
  if FSurface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_FLIP <> 0 then
12645
    FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.Flip(nil, DDFLIP_WAIT);
1 daniel-mar 12646
end;
12647
 
12648
procedure TDirectDrawOverlay.SetOverlayColorKey(Value: TColor);
12649
begin
12650
  FOverlayColorKey := Value;
4 daniel-mar 12651
  if FSurface <> nil then
1 daniel-mar 12652
    SetOverlayRect(FOverlayRect);
12653
end;
12654
 
12655
procedure TDirectDrawOverlay.SetOverlayRect(const Value: TRect);
12656
var
12657
  DestRect, SrcRect: TRect;
12658
  XScaleRatio, YScaleRatio: Integer;
12659
  OverlayFX: TDDOverlayFX;
12660
  OverlayFlags: DWORD;
12661
begin
12662
  FOverlayRect := Value;
4 daniel-mar 12663
  if (FSurface <> nil) and FVisible then
1 daniel-mar 12664
  begin
12665
    DestRect := FOverlayRect;
12666
    SrcRect.Left := 0;
12667
    SrcRect.Top := 0;
12668
    SrcRect.Right := FSurface.SurfaceDesc.dwWidth;
12669
    SrcRect.Bottom := FSurface.SurfaceDesc.dwHeight;
12670
 
12671
    OverlayFlags := DDOVER_SHOW;
12672
 
12673
    FillChar(OverlayFX, SizeOf(OverlayFX), 0);
12674
    OverlayFX.dwSize := SizeOf(OverlayFX);
12675
 
12676
    {  Scale rate limitation  }
12677
    XScaleRatio := (DestRect.right - DestRect.left) * 1000 div (SrcRect.right - SrcRect.left);
12678
    YScaleRatio := (DestRect.bottom - DestRect.top) * 1000 div (SrcRect.bottom - SrcRect.top);
12679
 
4 daniel-mar 12680
    if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH <> 0)
12681
      and (FDDraw.DriverCaps.dwMinOverlayStretch <> 0)
12682
      and (XScaleRatio < Integer(FDDraw.DriverCaps.dwMinOverlayStretch))
12683
    then
1 daniel-mar 12684
    begin
12685
      DestRect.Right := DestRect.Left + (Integer(FSurface.SurfaceDesc.dwWidth) * (Integer(FDDraw.DriverCaps.dwMinOverlayStretch) + 1)) div 1000;
12686
    end;
12687
 
4 daniel-mar 12688
    if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH <> 0)
12689
      and (FDDraw.DriverCaps.dwMaxOverlayStretch <> 0)
12690
      and (XScaleRatio > Integer(FDDraw.DriverCaps.dwMaxOverlayStretch))
12691
    then
1 daniel-mar 12692
    begin
12693
      DestRect.Right := DestRect.Left + (Integer(FSurface.SurfaceDesc.dwWidth) * (Integer(FDDraw.DriverCaps.dwMaxOverlayStretch) + 999)) div 1000;
12694
    end;
12695
 
4 daniel-mar 12696
    if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH <> 0)
12697
      and (FDDraw.DriverCaps.dwMinOverlayStretch <> 0)
12698
      and (YScaleRatio < Integer(FDDraw.DriverCaps.dwMinOverlayStretch))
12699
    then
1 daniel-mar 12700
    begin
12701
      DestRect.Bottom := DestRect.Top + (Integer(FSurface.SurfaceDesc.dwHeight) * (Integer(FDDraw.DriverCaps.dwMinOverlayStretch) + 1)) div 1000;
12702
    end;
12703
 
4 daniel-mar 12704
    if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH <> 0)
12705
      and (FDDraw.DriverCaps.dwMaxOverlayStretch <> 0)
12706
      and (YScaleRatio > Integer(FDDraw.DriverCaps.dwMaxOverlayStretch))
12707
    then
1 daniel-mar 12708
    begin
12709
      DestRect.Bottom := DestRect.Top + (Integer(FSurface.SurfaceDesc.dwHeight) * (Integer(FDDraw.DriverCaps.dwMaxOverlayStretch) + 999)) div 1000;
12710
    end;
12711
 
12712
    {  Clipping at forwarding destination  }
12713
    XScaleRatio := (DestRect.Right - DestRect.Left) * 1000 div (SrcRect.Right - SrcRect.Left);
12714
    YScaleRatio := (DestRect.Bottom - DestRect.Top) * 1000 div (SrcRect.Bottom - SrcRect.Top);
12715
 
12716
    if DestRect.Top < 0 then
12717
    begin
12718
      SrcRect.Top := -DestRect.Top * 1000 div YScaleRatio;
12719
      DestRect.Top := 0;
12720
    end;
12721
 
12722
    if DestRect.Left < 0 then
12723
    begin
12724
      SrcRect.Left := -DestRect.Left * 1000 div XScaleRatio;
12725
      DestRect.Left := 0;
12726
    end;
12727
 
12728
    if DestRect.Right > Integer(FTargetSurface.SurfaceDesc.dwWidth) then
12729
    begin
12730
      SrcRect.Right := Integer(FSurface.SurfaceDesc.dwWidth) - ((DestRect.Right - Integer(FTargetSurface.SurfaceDesc.dwWidth)) * 1000 div XScaleRatio);
12731
      DestRect.Right := FTargetSurface.SurfaceDesc.dwWidth;
12732
    end;
12733
 
12734
    if DestRect.Bottom > Integer(FTargetSurface.SurfaceDesc.dwHeight) then
12735
    begin
12736
      SrcRect.Bottom := Integer(FSurface.SurfaceDesc.dwHeight) - ((DestRect.Bottom - Integer(FTargetSurface.SurfaceDesc.dwHeight)) * 1000 div YScaleRatio);
12737
      DestRect.Bottom := FTargetSurface.SurfaceDesc.dwHeight;
12738
    end;
12739
 
12740
    {  Forwarding former arrangement  }
4 daniel-mar 12741
    if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNBOUNDARYSRC <> 0) and (FDDraw.DriverCaps.dwAlignBoundarySrc <> 0) then
1 daniel-mar 12742
    begin
12743
      SrcRect.Left := (SrcRect.Left + Integer(FDDraw.DriverCaps.dwAlignBoundarySrc) div 2) div
4 daniel-mar 12744
        Integer(FDDraw.DriverCaps.dwAlignBoundarySrc) * Integer(FDDraw.DriverCaps.dwAlignBoundarySrc);
1 daniel-mar 12745
    end;
12746
 
4 daniel-mar 12747
    if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNSIZESRC <> 0) and (FDDraw.DriverCaps.dwAlignSizeSrc <> 0) then
1 daniel-mar 12748
    begin
12749
      SrcRect.Right := SrcRect.Left + (SrcRect.Right - SrcRect.Left + Integer(FDDraw.DriverCaps.dwAlignSizeSrc) div 2) div
4 daniel-mar 12750
        Integer(FDDraw.DriverCaps.dwAlignSizeSrc) * Integer(FDDraw.DriverCaps.dwAlignSizeSrc);
1 daniel-mar 12751
    end;
12752
 
12753
    {  Forwarding destination arrangement  }
4 daniel-mar 12754
    if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNBOUNDARYDEST <> 0) and (FDDraw.DriverCaps.dwAlignBoundaryDest <> 0) then
1 daniel-mar 12755
    begin
12756
      DestRect.Left := (DestRect.Left + Integer(FDDraw.DriverCaps.dwAlignBoundaryDest) div 2) div
4 daniel-mar 12757
        Integer(FDDraw.DriverCaps.dwAlignBoundaryDest) * Integer(FDDraw.DriverCaps.dwAlignBoundaryDest);
1 daniel-mar 12758
    end;
12759
 
4 daniel-mar 12760
    if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNSIZEDEST <> 0) and (FDDraw.DriverCaps.dwAlignSizeDest <> 0) then
1 daniel-mar 12761
    begin
12762
      DestRect.Right := DestRect.Left + (DestRect.Right - DestRect.Left) div
4 daniel-mar 12763
        Integer(FDDraw.DriverCaps.dwAlignSizeDest) * Integer(FDDraw.DriverCaps.dwAlignSizeDest);
1 daniel-mar 12764
    end;
12765
 
12766
    {  Color key setting  }
4 daniel-mar 12767
    if FDDraw.DriverCaps.dwCKeyCaps and DDCKEYCAPS_DESTOVERLAY <> 0 then
1 daniel-mar 12768
    begin
12769
      OverlayFX.dckDestColorkey.dwColorSpaceLowValue := FTargetSurface.ColorMatch(FOverlayColorKey);
12770
      OverlayFX.dckDestColorkey.dwColorSpaceHighValue := OverlayFX.dckDestColorkey.dwColorSpaceLowValue;
12771
 
12772
      OverlayFlags := OverlayFlags or (DDOVER_KEYDESTOVERRIDE or DDOVER_DDFX);
12773
    end;
12774
 
4 daniel-mar 12775
    FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.UpdateOverlay(@SrcRect, FTargetSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, @DestRect, OverlayFlags, @OverlayFX);
1 daniel-mar 12776
  end;
12777
end;
12778
 
12779
procedure TDirectDrawOverlay.SetVisible(Value: Boolean);
12780
begin
12781
  FVisible := False;
4 daniel-mar 12782
  if FSurface <> nil then
1 daniel-mar 12783
  begin
12784
    if FVisible then
12785
      SetOverlayRect(FOverlayRect)
12786
    else
4 daniel-mar 12787
      FSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.UpdateOverlay(PRect(nil), FTargetSurface.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}, PRect(nil), DDOVER_HIDE, PDDOverlayFX(nil));
1 daniel-mar 12788
  end;
12789
end;
12790
 
4 daniel-mar 12791
{ TDXFont }
12792
 
12793
constructor TDXFont.Create(AOwner: TComponent);
12794
begin
12795
  inherited Create(AOwner);
12796
end;
12797
 
12798
destructor TDXFont.Destroy;
12799
begin
12800
  inherited Destroy;
12801
end;
12802
 
12803
procedure TDXFont.Notification(AComponent: TComponent; Operation: TOperation);
12804
begin
12805
  inherited Notification(AComponent, Operation);
12806
  if (Operation = opRemove) and (AComponent = FDXImageList) then
12807
  begin
12808
    FDXImageList := nil;
12809
  end;
12810
end; {Notification}
12811
 
12812
procedure TDXFont.SetFont(const Value: string);
12813
begin
12814
  FFont := Value;
12815
  if assigned(FDXImageList) then
12816
  begin
12817
    FFontIndex := FDXImageList.items.IndexOf(FFont); { find font once }
12818
    fOffset := FDXImageList.Items[FFontIndex].PatternWidth;
12819
  end;
12820
end;
12821
 
12822
procedure TDXFont.SetFontIndex(const Value: Integer);
12823
begin
12824
  FFontIndex := Value;
12825
  if assigned(FDXImageList) then
12826
  begin
12827
    FFont := FDXImageList.Items[FFontIndex].Name;
12828
    fOffset := FDXImageList.Items[FFontIndex].PatternWidth;
12829
  end;
12830
end;
12831
 
12832
procedure TDXFont.TextOut(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string);
12833
var
12834
  loop, letter: Integer;
12835
  UpperText: string;
12836
begin
12837
  if not assigned(FDXImageList) then
12838
    exit;
12839
  Offset := FDXImageList.Items[FFontIndex].PatternWidth;
12840
  UpperText := AnsiUppercase(text);
12841
  for loop := 1 to Length(UpperText) do
12842
  begin
12843
    letter := AnsiPos(UpperText[loop], Alphabet) - 1;
12844
    if letter < 0 then letter := 30;
12845
    FDXImageList.items[FFontIndex].Draw(DirectDrawSurface, x + Offset * loop, y, letter);
12846
  end; { loop }
12847
end;
12848
 
12849
{ TDXPowerFontEffectsParameters }
12850
 
12851
procedure TDXPowerFontEffectsParameters.SetAlphaValue(
12852
  const Value: Integer);
12853
begin
12854
  FAlphaValue := Value;
12855
end;
12856
 
12857
procedure TDXPowerFontEffectsParameters.SetAngle(const Value: Integer);
12858
begin
12859
  FAngle := Value;
12860
end;
12861
 
12862
procedure TDXPowerFontEffectsParameters.SetCenterX(const Value: Integer);
12863
begin
12864
  FCenterX := Value;
12865
end;
12866
 
12867
procedure TDXPowerFontEffectsParameters.SetCenterY(const Value: Integer);
12868
begin
12869
  FCenterY := Value;
12870
end;
12871
 
12872
procedure TDXPowerFontEffectsParameters.SetHeight(const Value: Integer);
12873
begin
12874
  FHeight := Value;
12875
end;
12876
 
12877
procedure TDXPowerFontEffectsParameters.SetWAmplitude(
12878
  const Value: Integer);
12879
begin
12880
  FWAmplitude := Value;
12881
end;
12882
 
12883
procedure TDXPowerFontEffectsParameters.SetWidth(const Value: Integer);
12884
begin
12885
  FWidth := Value;
12886
end;
12887
 
12888
procedure TDXPowerFontEffectsParameters.SetWLenght(const Value: Integer);
12889
begin
12890
  FWLenght := Value;
12891
end;
12892
 
12893
procedure TDXPowerFontEffectsParameters.SetWPhase(const Value: Integer);
12894
begin
12895
  FWPhase := Value;
12896
end;
12897
 
12898
{ TDXPowerFont }
12899
 
12900
constructor TDXPowerFont.Create(AOwner: TComponent);
12901
begin
12902
  inherited Create(AOwner);
12903
  FUseEnterChar := True;
12904
  FEnterCharacter := '|<';
12905
  FAlphabets := PowerAlphaBet;
12906
  FTextOutType := ttNormal;
12907
  FTextOutEffect := teNormal;
12908
  FEffectsParameters := TDXPowerFontEffectsParameters.Create;
12909
end;
12910
 
12911
destructor TDXPowerFont.Destroy;
12912
begin
12913
  inherited Destroy;
12914
end;
12915
 
12916
procedure TDXPowerFont.SetAlphabets(const Value: string);
12917
begin
12918
  if FDXImageList <> nil then
12919
    if Length(Value) > FDXImageList.Items[FFontIndex].PatternCount - 1 then Exit;
12920
  FAlphabets := Value;
12921
end;
12922
 
12923
procedure TDXPowerFont.SetEnterCharacter(const Value: string);
12924
begin
12925
  if Length(Value) >= 2 then Exit;
12926
  FEnterCharacter := Value;
12927
end;
12928
 
12929
procedure TDXPowerFont.SetFont(const Value: string);
12930
begin
12931
  FFont := Value;
12932
  if FDXImageList <> nil then
12933
  begin
12934
    FFontIndex := FDXImageList.Items.IndexOf(FFont); // Find font once...
12935
    Offset := FDXImageList.Items[FFontIndex].PatternWidth;
12936
 
12937
    FEffectsParameters.Width := FDXImageList.Items[FFontIndex].PatternWidth;
12938
    FEffectsParameters.Height := FDXImageList.Items[FFontIndex].PatternHeight;
12939
  end;
12940
end;
12941
 
12942
procedure TDXPowerFont.SetFontIndex(const Value: Integer);
12943
begin
12944
  FFontIndex := Value;
12945
  if FDXImageList <> nil then
12946
  begin
12947
    FFont := FDXImageList.Items[FFontIndex].Name;
12948
    Offset := FDXImageList.Items[FFontIndex].PatternWidth;
12949
 
12950
    FEffectsParameters.Width := FDXImageList.Items[FFontIndex].PatternWidth;
12951
    FEffectsParameters.Height := FDXImageList.Items[FFontIndex].PatternHeight;
12952
  end;
12953
end;
12954
 
12955
procedure TDXPowerFont.SetEffectsParameters(const Value: TDXPowerFontEffectsParameters);
12956
begin
12957
  FEffectsParameters := Value;
12958
end;
12959
 
12960
procedure TDXPowerFont.SetTextOutEffect(const Value: TDXPowerFontTextOutEffect);
12961
begin
12962
  FTextOutEffect := Value;
12963
end;
12964
 
12965
procedure TDXPowerFont.SetTextOutType(const Value: TDXPowerFontTextOutType);
12966
begin
12967
  FTextOutType := Value;
12968
end;
12969
 
12970
procedure TDXPowerFont.SetUseEnterChar(const Value: Boolean);
12971
begin
12972
  FUseEnterChar := Value;
12973
end;
12974
 
12975
function TDXPowerFont.TextOutFast(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string): Boolean;
12976
var
12977
  Loop, Letter: Integer;
12978
  txt: string;
12979
begin
12980
  Result := False;
12981
  if FDXImageList = nil then Exit;
12982
        // modified
12983
  case FTextOutType of
12984
    ttNormal: Txt := Text;
12985
    ttUpperCase: Txt := AnsiUpperCase(Text);
12986
    ttLowerCase: Txt := AnsiLowerCase(Text);
12987
  end;
12988
  Offset := FDXImageList.Items[FFontIndex].PatternWidth;
12989
  Loop := 1;
12990
  while (Loop <= Length(Text)) do
12991
  begin
12992
    Letter := AnsiPos(txt[Loop], FAlphabets); // modified
12993
    if (Letter > 0) and (Letter < FDXImageList.Items[FFontIndex].PatternCount - 1) then
12994
      FDXImageList.Items[FFontIndex].Draw(DirectDrawSurface, X + (Offset * Loop), Y, Letter - 1);
12995
    Inc(Loop);
12996
  end;
12997
  Result := True;
12998
end;
12999
 
13000
function TDXPowerFont.TextOut(DirectDrawSurface: TDirectDrawSurface; X, Y: Integer; const Text: string): Boolean;
13001
var
13002
  Loop, Letter: Integer;
13003
  FCalculatedEnters, EnterHeghit, XLoop: Integer;
13004
  DoTextOut: Boolean;
13005
  Txt: string;
13006
  Rect: TRect;
13007
begin
13008
  Result := False;
13009
  if FDXImageList = nil then Exit;
13010
  Txt := Text;
13011
  DoTextOut := True;
13012
  if Assigned(FBeforeTextOut) then FBeforeTextOut(Self, Txt, DoTextOut);
13013
  if not DoTextOut then Exit;
13014
  // modified
13015
  case FTextOutType of
13016
    ttNormal: Txt := Text;
13017
    ttUpperCase: Txt := AnsiUpperCase(Text);
13018
    ttLowerCase: Txt := AnsiLowerCase(Text);
13019
  end;
13020
  Offset := FDXImageList.Items[FFontIndex].PatternWidth;
13021
  FCalculatedEnters := 0;
13022
  EnterHeghit := FDXImageList.Items[FFontIndex].PatternHeight;
13023
  XLoop := 0;
13024
  Loop := 1;
13025
  while (Loop <= Length(Txt)) do
13026
  begin
13027
    if FUseEnterChar then
13028
    begin
13029
      if Txt[Loop] = FEnterCharacter[1] then begin Inc(FCalculatedEnters); Inc(Loop); end;
13030
      if Txt[Loop] = FEnterCharacter[2] then begin Inc(FCalculatedEnters); XLoop := 0; {-FCalculatedEnters;} Inc(Loop); end;
13031
    end;
13032
    Letter := AnsiPos(Txt[Loop], FAlphabets); // modified
13033
 
13034
    if (Letter > 0) and (Letter < FDXImageList.Items[FFontIndex].PatternCount - 1) then
13035
      case FTextOutEffect of
13036
        teNormal: FDXImageList.Items[FFontIndex].Draw(DirectDrawSurface, X + (Offset * XLoop), Y + (FCalculatedEnters * EnterHeghit), Letter - 1);
13037
        teRotat: FDXImageList.Items[FFontIndex].DrawRotate(DirectDrawSurface, X + (Offset * XLoop), Y + (FCalculatedEnters * EnterHeghit), FEffectsParameters.Width, FEffectsParameters.Height, Letter - 1, FEffectsParameters.CenterX, FEffectsParameters.CenterY, FEffectsParameters.Angle);
13038
        teAlphaBlend:
13039
          begin
13040
            Rect.Left := X + (Offset * XLoop);
13041
            Rect.Top := Y + (FCalculatedEnters * EnterHeghit);
13042
            Rect.Right := Rect.Left + FEffectsParameters.Width;
13043
            Rect.Bottom := Rect.Top + FEffectsParameters.Height;
13044
 
13045
            FDXImageList.Items[FFontIndex].DrawAlpha(DirectDrawSurface, Rect, Letter - 1, FEffectsParameters.AlphaValue);
13046
          end;
13047
        teWaveX: FDXImageList.Items[FFontIndex].DrawWaveX(DirectDrawSurface, X + (Offset * XLoop), Y + (FCalculatedEnters * EnterHeghit), FEffectsParameters.Width, FEffectsParameters.Height, Letter - 1, FEffectsParameters.WAmplitude, FEffectsParameters.WLenght, FEffectsParameters.WPhase);
13048
      end;
13049
    Inc(Loop);
13050
    Inc(XLoop);
13051
  end;
13052
  if Assigned(FAfterTextOut) then FAfterTextOut(Self, Txt);
13053
  Result := True;
13054
end;
13055
 
13056
//---------------------------------------------------------------------------
13057
{
13058
Main code supported hardware acceleration by videoadapteur
13059
 *  Copyright (c) 2004-2010 Jaro Benes
13060
 *  All Rights Reserved
13061
 *  Version 1.09
13062
 *  D2D Hardware module - main implementation part
13063
 *  web site: www.micrel.cz/Dx
13064
 *  e-mail: delphix_d2d@micrel.cz
13065
}
13066
 
13067
constructor TD2DTextures.Create(DDraw: TCustomDXDraw);
13068
begin
13069
  //inherited;
13070
  FDDraw := DDraw; //reload DDraw
13071
{$IFNDEF VER4UP}
13072
  TexLen := 0;
13073
  Texture := nil;
13074
{$ELSE}
13075
  SetLength(Texture, 0);
13076
{$ENDIF}
13077
end;
13078
 
13079
destructor TD2DTextures.Destroy;
13080
var
13081
  I: Integer;
13082
begin
13083
  if Assigned(Texture) then
13084
    {$IFDEF VER4UP}
13085
    for I := Low(Texture) to High(Texture) do
13086
    begin
13087
      Texture[I].D2DTexture.Free;
13088
      {$IFDEF VIDEOTEX}
13089
      if Assigned(Texture[I].VDIB) then
13090
        Texture[I].VDIB.Free;
13091
      {$ENDIF}
13092
    end;
13093
    {$ELSE}
13094
    for I := 0 to TexLen - 1 do
13095
    begin
13096
      Texture[I].D2DTexture.Free;
13097
      {$IFDEF VIDEOTEX}
13098
      if Assigned(Texture[I].VDIB) then
13099
        Texture[I].VDIB.Free;
13100
      {$ENDIF}
13101
    end;
13102
    {$ENDIF}
13103
  inherited;
13104
end;
13105
 
13106
function TD2DTextures.GetD2DMaxTextures: Integer;
13107
begin
13108
  Result := {$IFDEF VER4UP}Length(Texture){$ELSE}TexLen{$ENDIF};
13109
end;
13110
 
13111
procedure TD2DTextures.SaveTextures(path: string);
13112
var I: Integer;
13113
begin
13114
  if Texture <> nil then
13115
    {$IFDEF VER4UP}
13116
    if Length(Texture) > 0 then
13117
      for I := Low(Texture) to High(Texture) do
13118
    {$ELSE}
13119
    if TexLen > 0 then
13120
      for I := 0 to TexLen - 1 do
13121
    {$ENDIF}
13122
        Texture[I].D2DTexture.FImage.SaveToFile(path + Texture[I].Name + '.dxt');
13123
end;
13124
 
13125
procedure TD2DTextures.SetD2DMaxTextures(const Value: Integer);
13126
begin
13127
  if Value > 0 then
13128
  {$IFDEF VER4UP}
13129
    SetLength(Texture, Value)
13130
  {$ELSE}
13131
    Inc(TexLen);
13132
  if Texture = nil then
13133
    Texture := AllocMem(SizeOf(TTextureRec))
13134
  else begin
13135
      {alokuj pamet}
13136
    ReallocMem(Texture, TexLen * SizeOf(TTextureRec));
13137
  end;
13138
  {$ENDIF}
13139
end;
13140
 
13141
function TD2DTextures.Find(byName: string): Integer;
13142
var I: Integer;
13143
begin
13144
  Result := -1;
13145
  if Texture <> nil then
13146
    {$IFDEF VER4UP}
13147
    if Length(Texture) > 0 then
13148
      for I := Low(Texture) to High(Texture) do
13149
        if AnsiUpperCase(Texture[I].Name) = AnsiUpperCase(byName) then
13150
        begin
13151
          Result := I;
13152
          Exit;
13153
        end;
13154
    {$ELSE}
13155
    if TexLen > 0 then
13156
      for I := 0 to TexLen - 1 do
13157
        if AnsiUpperCase(Texture[I].Name) = AnsiUpperCase(byName) then
13158
        begin
13159
          Result := I;
13160
          Exit;
13161
        end;
13162
    {$ENDIF}
13163
end;
13164
 
13165
function TD2DTextures.GetTextureByName(const byName: string): TDirect3DTexture2;
13166
begin
13167
  Result := nil;
13168
  if Assigned(Texture) then
13169
    Result := Texture[Find(byName)].D2DTexture;
13170
end;
13171
 
13172
function TD2DTextures.GetTextureByIndex(const byIndex: Integer): TDirect3DTexture2;
13173
begin
13174
  Result := nil;
13175
  {$IFNDEF VER4UP}
13176
  if Assigned(Texture) and (byIndex >= 0) and (byIndex <= (TexLen - 1)) then
13177
    Result := Texture[byIndex].D2DTexture;
13178
  {$ELSE}
13179
  if Assigned(Texture) and (byIndex in [0..High(Texture)]) then
13180
    Result := Texture[byIndex].D2DTexture;
13181
  {$ENDIF}
13182
end;
13183
 
13184
function TD2DTextures.GetTextureNameByIndex(const byIndex: Integer): string;
13185
begin
13186
  Result := '';
13187
  {$IFNDEF VER4UP}
13188
  if Assigned(Texture) and (byIndex >= 0) and (byIndex <= (TexLen - 1)) then
13189
    Result := Texture[byIndex].Name;
13190
  {$ELSE}
13191
  if Assigned(Texture) and (byIndex in [0..High(Texture)]) then
13192
    Result := Texture[byIndex].Name;
13193
  {$ENDIF}
13194
end;
13195
 
13196
function TD2DTextures.Count: Integer;
13197
begin
13198
  Result := 0;
13199
  if Assigned(Texture) then
13200
  {$IFNDEF VER4UP}
13201
    Result := TexLen;
13202
  {$ELSE}
13203
    Result := High(Texture) + 1;
13204
  {$ENDIF}
13205
end;
13206
 
13207
procedure TD2DTextures.D2DPruneAllTextures;
13208
var I: Integer;
13209
begin
13210
  if not Assigned(Texture) then Exit;
13211
  {$IFDEF VER4UP}
13212
  for I := Low(Texture) to High(Texture) do
13213
  {$ELSE}
13214
  for I := 0 to TexLen - 1 do
13215
  {$ENDIF}
13216
  begin
13217
    Texture[I].D2DTexture.Free;
13218
    {$IFDEF VIDEOTEX}
13219
    if Assigned(Texture[I].VDIB) then
13220
      Texture[I].VDIB.Free;
13221
    {$ENDIF}
13222
  end;
13223
  {$IFDEF VER4UP}
13224
  SetLength(Texture, 0);
13225
  {$ELSE}
13226
  TexLen := 0;
13227
  {$ENDIF}
13228
end;
13229
 
13230
procedure TD2DTextures.D2DFreeTextures;
13231
var I: Integer;
13232
begin
13233
  if not Assigned(Texture) then Exit;
13234
  {$IFDEF VER4UP}
13235
  for I := Low(Texture) to High(Texture) do
13236
  {$ELSE}
13237
  for I := 0 to TexLen - 1 do
13238
  {$ENDIF}
13239
  begin
13240
    Texture[I].D2DTexture.Free;
13241
    {$IFDEF VIDEOTEX}
13242
    if Assigned(Texture[I].VDIB) then
13243
      Texture[I].VDIB.Free;
13244
    {$ENDIF}  
13245
  end;
13246
  {$IFNDEF VER4UP}
13247
  FreeMem(Texture, TexLen * SizeOf(TTextureRec));
13248
  Texture := nil;
13249
  {$ENDIF}
13250
end;
13251
 
13252
procedure TD2DTextures.D2DPruneTextures;
13253
begin
13254
  if {$IFDEF VER4UP}Length(Texture){$ELSE}TexLen{$ENDIF} > maxTexBlock then
13255
  begin
13256
    D2DPruneAllTextures
13257
  end;
13258
end;
13259
 
13260
procedure TD2DTextures.SizeAdjust(var DIB: TDIB; var FloatX1, FloatY1, FloatX2, FloatY2: Double);
13261
var
13262
  X, Y: Integer;
13263
  tempDIB: TDIB;
13264
begin {auto-adjust size n^2 for accelerator compatibility}
13265
  X := 1;
13266
  repeat
13267
    X := X * 2;
13268
  until DIB.Width <= X;
13269
  Y := 1;
13270
  repeat
13271
    Y := Y * 2
13272
  until DIB.Height <= Y;
13273
  {$IFDEF FORCE_SQUARE}
13274
  X := Max(X, Y);
13275
  Y := X;
13276
  {$ENDIF}
13277
  if (X = DIB.Width) and (Y = DIB.Height) then
13278
  begin
13279
    if DIB.BitCount = 32 then Exit; {do not touch}
13280
    {code for correction a DIB.BitCount to 24 bit only}
13281
    tempDIB := TDIB.Create;
13282
    try
13283
      tempDIB.SetSize(X, Y, 24);
13284
      FillChar(tempDIB.PBits^, tempDIB.Size, 0);
13285
      tempDIB.Canvas.Draw(0, 0, DIB);
13286
      DIB.Assign(tempDIB);
13287
    finally
13288
      tempDIB.Free;
13289
    end;
13290
    Exit;
13291
  end;
13292
  tempDIB := TDIB.Create;
13293
  try
13294
    if DIB.BitCount = 32 then
13295
    begin
13296
      tempDIB.SetSize(X, Y, 32);
13297
      FillChar(tempDIB.PBits^, tempDIB.Size, 0);
13298
      //tempDIB.Canvas.Brush.Color := clBlack;
13299
      //tempDIB.Canvas.FillRect(Bounds(0, 0, X, Y));
13300
      tempDIB.Canvas.Draw(0, 0, DIB);
13301
//      if DIB.HasAlphaChannel then
13302
//        tempDIB.AssignAlphaChannel(DIB);
13303
    end
13304
    else
13305
    begin
13306
      tempDIB.SetSize(X, Y, 24 {DIB.BitCount}); {bad value for some 16}
13307
      FillChar(tempDIB.PBits^, tempDIB.Size, 0);
13308
      //tempDIB.Canvas.Brush.Color := clBlack;
13309
      //tempDIB.Canvas.FillRect(Bounds(0, 0, X, Y));
13310
      tempDIB.Canvas.Draw(0, 0, DIB);
13311
    end;
13312
    FloatX2 := (1 / tempDIB.Width) * DIB.Width;
13313
    FloatY2 := (1 / tempDIB.Height) * DIB.Height;
13314
    DIB.Assign(tempDIB);
13315
  finally
13316
    tempDIB.Free;
13317
  end
13318
end;
13319
 
13320
function TD2DTextures.CanFindTexture(aImage: TPictureCollectionItem): Boolean;
13321
var I: Integer;
13322
begin
13323
  Result := True;
13324
  {$IFDEF VER4UP}
13325
  if Length(Texture) > 0 then
13326
  {$ELSE}
13327
  if TexLen > 0 then
13328
  {$ENDIF}
13329
    for I := 0 to D2DMaxTextures - 1 do
13330
      if Texture[I].Name = aImage.Name then Exit;
13331
  Result := False;
13332
end;
13333
 
13334
function TD2DTextures.LoadTextures(aImage: TPictureCollectionItem): Boolean;
13335
var
13336
  {$IFNDEF VIDEOTEX}
13337
  VDIB: TDIB;
13338
  {$ENDIF}
13339
  T: TDXTextureImage;
13340
begin
13341
  Result := True;
13342
  try
13343
    D2DPruneTextures; {up to maxTexBlock textures only}
13344
    D2DMaxTextures := D2DMaxTextures + 1;
13345
    if aImage.Name = '' then // FIX: OPTIMIZED
13346
      aImage.Name := aImage.GetNamePath; {this name is supplement name, when wasn't aImage.Name fill}
13347
    {$IFDEF VIDEOTEX}Texture[D2DMaxTextures - 1].{$ENDIF}VDIB := TDIB.Create;
13348
    try
13349
    with Texture[D2DMaxTextures - 1] do
13350
    begin
13351
      VDIB.Assign(aImage.Picture.Graphic);
13352
      VDIB.Transparent := aImage.Transparent;
13353
      FloatX1 := 0; FloatY1 := 0; FloatX2 := 1; FloatY2 := 1;
13354
      SizeAdjust(VDIB, FloatX1, FloatY1, FloatX2, FloatY2);
13355
      Name := aImage.Name;
13356
      Width := VDIB.Width;
13357
      Height := VDIB.Height;
13358
      if VDIB.HasAlphaChannel then
13359
      begin
13360
        DIB2DXT(VDIB, T);
13361
        T.ImageName := aImage.Name;
13362
        T.Transparent := aImage.Transparent;
13363
        D2DTexture := TDirect3DTexture2.Create(FDDraw, T, False);
13364
        D2DTexture.Transparent := aImage.Transparent;
13365
        AlphaChannel := True;
13366
        //**T.Free; DO NOT FREE - surface is lost ** FIX by JB.
13367
      end
13368
      else
13369
      begin
13370
        D2DTexture := TDirect3DTexture2.Create(FDDraw, VDIB, False);
13371
        D2DTexture.TransparentColor := DWORD(aImage.TransparentColor);
13372
        D2DTexture.Surface.TransparentColor := DWORD(aImage.TransparentColor);
13373
        D2DTexture.Transparent := aImage.Transparent;
13374
        AlphaChannel := False;
13375
      end;
13376
    end;
13377
    finally
13378
      {$IFNDEF VIDEOTEX}
13379
      VDIB.Free;
13380
      {$ENDIF}
13381
    end;
13382
  except
13383
    D2DMaxTextures := D2DMaxTextures - 1;
13384
    Result := False;
13385
  end;
13386
end;
13387
 
13388
{$IFDEF VER4UP}
13389
function TD2DTextures.CanFindTexture(const TexName: string): Boolean;
13390
{$ELSE}
13391
function TD2DTextures.CanFindTexture2(const TexName: string): Boolean;
13392
{$ENDIF}
13393
var I: Integer;
13394
begin
13395
  Result := True;
13396
{$IFDEF VER4UP}
13397
  if Length(Texture) > 0 then
13398
{$ELSE}
13399
  if TexLen > 0 then
13400
{$ENDIF}
13401
    for I := 0 to D2DMaxTextures - 1 do
13402
      if Texture[I].Name = TexName then Exit;
13403
  Result := False;
13404
end;
13405
 
13406
function TD2DTextures.SetTransparentColor(dds: TDirectDrawSurface; PixelColor: Integer; Transparent: Boolean): Integer;
13407
{Give a speculative transparent color value from DDS}
13408
var
13409
  ddck: TDDColorKey;
13410
  CLL: Integer;
13411
begin
13412
  Result := 0;
13413
  if dds.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
13414
    if dds.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetColorKey(DDCKEY_SRCBLT, ddck) = DD_OK then
13415
      Result := ddck.dwColorSpaceLowValue;
13416
  CLL := PixelColor; {have to pick up color from 0,0 pix of DIB}
13417
  if Transparent then {and must be transparent}
13418
    if (CLL <> Result) then {when different}
13419
      Result := CLL; {use our TransparentColor}
13420
end;
13421
 
13422
{$IFDEF VER4UP}
13423
function TD2DTextures.LoadTextures(dds: TDirectDrawSurface; Transparent: Boolean; asTexName: string): Boolean;
13424
{$ELSE}
13425
function TD2DTextures.LoadTextures2(dds: TDirectDrawSurface; Transparent: Boolean; asTexName: string): Boolean;
13426
{$ENDIF}
13427
var
13428
  {$IFNDEF VIDEOTEX}
13429
  VDIB: TDIB;
13430
  {$ENDIF}
13431
  Col: Integer;
13432
  T: PTextureRec;
13433
begin
13434
  Result := True;
13435
  T := nil;
13436
  try
13437
    if dds.Modified then
13438
    begin
13439
      {search existing texture and return the pointer}
13440
      T := Addr(Texture[Find(asTexName)]);
13441
      {$IFNDEF VIDEOTEX}VDIB := TDIB.Create;{$ENDIF}
13442
    end
13443
    else
13444
    begin
13445
      D2DPruneTextures; {up to maxTexBlock textures only}
13446
      D2DMaxTextures := D2DMaxTextures + 1; {next to new space}
13447
      T := Addr(Texture[D2DMaxTextures - 1]); {is new place}
13448
      {set name}
13449
      T.Name := asTexName;
13450
      {and create video-dib object for store the picture periodically changed}
13451
      {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB := TDIB.Create;
13452
      //T.VDIB.PixelFormat := MakeDIBPixelFormat(8, 8, 8);
13453
    end;
13454
    try
13455
      {the dds assigned here}
13456
      {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Assign(dds);
13457
      {with full adjustation}
13458
      T.FloatX1 := 0; T.FloatY1 := 0; T.FloatX2 := 1; T.FloatY2 := 1;
13459
      SizeAdjust({$IFDEF VIDEOTEX}T.{$ENDIF}VDIB, T.FloatX1, T.FloatY1, T.FloatX2, T.FloatY2);
13460
      {and store 'changed' values of size here}
13461
      T.Width := {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Width;
13462
      T.Height := {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Height;
13463
      {and it have to set by dds as transparent, when it set up}
13464
      {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Transparent := Transparent;
13465
      {get up transparent color}
13466
      Col := SetTransparentColor(dds, {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Pixels[0, 0], Transparent);
13467
      if dds.Modified then
13468
        T.D2DTexture.Load {for minimize time only load as videotexture}
13469
      else
13470
        T.D2DTexture := TDirect3DTexture2.Create(FDDraw, {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB, False); {create it}
13471
      {don't forget set transparent values on texture!}
13472
      T.D2DTexture.TransparentColor := DWORD(COL);
13473
      T.D2DTexture.Surface.TransparentColor := DWORD(COL);
13474
      T.D2DTexture.Transparent := Transparent;
13475
    finally
13476
     {$IFNDEF VIDEOTEX}
13477
      if Assigned(VDIB) then VDIB.Free;
13478
     {$ENDIF}
13479
    end;
13480
  except
13481
    {eh, sorry, when is not the dds modified, roll back and release last the VDIB}
13482
    if not dds.Modified then
13483
      if T <> nil then
13484
      begin
13485
        if Assigned({$IFDEF VIDEOTEX}T.{$ENDIF}VDIB) then
13486
        {$IFNDEF D5UP}
13487
        begin {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB.Free; {$IFDEF VIDEOTEX}T.{$ENDIF}VDIB := nil; end;
13488
        {$ELSE}
13489
          FreeAndNil({$IFDEF VIDEOTEX}T.{$ENDIF}VDIB);
13490
        {$ENDIF}
13491
        if Assigned(T.D2DTexture) then
13492
        {$IFNDEF D5UP}
13493
        begin T.D2DTexture.Free; T.D2DTexture := nil; end;
13494
        {$ELSE}
13495
          FreeAndNil(T.D2DTexture);
13496
        {$ENDIF}
13497
 
13498
        D2DMaxTextures := D2DMaxTextures - 1; //go back
13499
      end;
13500
    Result := False;
13501
  end;
13502
  dds.Modified := False; {this flag turn off always}
13503
end;
13504
 
13505
{$IFDEF VER4UP}
13506
function TD2DTextures.LoadTextures(dds: TDirectDrawSurface; Transparent: Boolean;
13507
  TransparentColor: Integer; asTexName: string): Boolean;
13508
{$ELSE}
13509
function TD2DTextures.LoadTextures3(dds: TDirectDrawSurface; Transparent: Boolean;
13510
  TransparentColor: Integer; asTexName: string): Boolean;
13511
{$ENDIF}
13512
  function getDDSTransparentColor(DIB: TDIB; dds: TDirectDrawSurface): Integer;
13513
  var CLL: Integer; ddck: TDDColorKey;
13514
  begin
13515
    Result := 0;
13516
    if dds.{$IFDEF D3D_deprecated}IDDSurface{$ELSE}IDDSurface7{$ENDIF} <> nil then
13517
      if dds.{$IFDEF D3D_deprecated}ISurface{$ELSE}ISurface7{$ENDIF}.GetColorKey(DDCKEY_SRCBLT, ddck) = DD_OK then
13518
        Result := ddck.dwColorSpaceLowValue;
13519
    CLL := TransparentColor;
13520
    if (CLL = -1) or (cardinal(CLL) <> DIB.Pixels[0, 0]) then //when is DDS
13521
      CLL := DIB.Pixels[0, 0]; //have to pick up color from 0,0 pix of DIB
13522
    if Transparent then //and must be transparent
13523
      if CLL <> Result then //when different
13524
        Result := CLL; //use TransparentColor
13525
  end;
13526
var
13527
  {$IFNDEF VIDEOTEX}
13528
  VDIB: TDIB;
13529
  {$ENDIF}
13530
  COL: Integer;
13531
  T: TDXTextureImage;
13532
begin
13533
  Result := True;
13534
  try
13535
    D2DPruneTextures; {up to maxTexBlock textures only}
13536
    D2DMaxTextures := D2DMaxTextures + 1;
13537
    Texture[D2DMaxTextures - 1].Name := asTexName;
13538
    {$IFDEF VIDEOTEX}Texture[D2DMaxTextures - 1].{$ENDIF}VDIB := TDIB.Create;
13539
    try
13540
    with Texture[D2DMaxTextures - 1] do
13541
    begin
13542
      VDIB.AsSign(dds);
13543
      VDIB.Transparent := Transparent;
13544
      FloatX1 := 0; FloatY1 := 0; FloatX2 := 1; FloatY2 := 1;
13545
      SizeAdjust(VDIB, FloatX1, FloatY1, FloatX2, FloatY2);
13546
      Width := VDIB.Width;
13547
      Height := VDIB.Height;
13548
      if VDIB.HasAlphaChannel then
13549
      begin
13550
        DIB2DXT(VDIB, T);
13551
        T.ImageName := asTexName;
13552
        T.Transparent := Transparent;
13553
        D2DTexture := TDirect3DTexture2.Create(FDDraw, T, False);
13554
        D2DTexture.Transparent := Transparent;
13555
        AlphaChannel := True;
13556
        //**T.Free; DO NOT FREE - surface is lost ** FIX by JB.
13557
      end
13558
      else
13559
      begin
13560
        D2DTexture := TDirect3DTexture2.Create(FDDraw, VDIB, False);
13561
        if transparentcolor = -1 then
13562
          COL := getDDSTransparentColor(VDIB, DDS)
13563
        else
13564
          COL := D2DTexture.Surface.ColorMatch(transparentcolor);
13565
          D2DTexture.TransparentColor := DWORD(COL); //**
13566
          D2DTexture.Surface.TransparentColor := DWORD(COL); //**
13567
          D2DTexture.Transparent := Transparent;
13568
          AlphaChannel := False;
13569
      end;
13570
    end
13571
    finally
13572
      {$IFNDEF VIDEOTEX}
13573
      VDIB.Free;
13574
      {$ENDIF}
13575
    end;
13576
  except
13577
    D2DMaxTextures := D2DMaxTextures - 1;
13578
    Result := False;
13579
  end;
13580
end;
13581
 
13582
{$IFDEF VER4UP}
13583
function TD2DTextures.CanFindTexture(const Color: LongInt): Boolean;
13584
{$ELSE}
13585
function TD2DTextures.CanFindTexture3(const Color: LongInt): Boolean;
13586
{$ENDIF}
13587
var I: Integer;
13588
begin
13589
  Result := True;
13590
  {$IFDEF VER4UP}
13591
  if Length(Texture) > 0 then
13592
  {$ELSE}
13593
  if TexLen > 0 then
13594
  {$ENDIF}
13595
    for I := 0 to D2DMaxTextures - 1 do
13596
      if Texture[I].Name = '$' + IntToStr(Color) then Exit;
13597
  Result := False;
13598
end;
13599
 
13600
{$IFDEF VER4UP}
13601
function TD2DTextures.LoadTextures(Color: LongInt): Boolean;
13602
{$ELSE}
13603
function TD2DTextures.LoadTextures4(Color: LongInt): Boolean;
13604
{$ENDIF}
13605
var
13606
  S: string;
13607
  {$IFNDEF VIDEOTEX}
13608
  VDIB: TDIB;
13609
  {$ENDIF}
13610
begin
13611
  Result := True;
13612
  try
13613
    D2DPruneTextures; {up to maxTexBlock textures only}
13614
    D2DMaxTextures := D2DMaxTextures + 1;
13615
    S := '$' + IntToStr(Color); {this name is supplement name}
13616
    {$IFDEF VIDEOTEX}Texture[D2DMaxTextures - 1].{$ENDIF}VDIB := TDIB.Create;
13617
    try
13618
    with Texture[D2DMaxTextures - 1] do
13619
    begin
13620
      VDIB.SetSize(16, 16, 24); {16x16 good size}
13621
      VDIB.Canvas.Brush.Color := Color;
13622
      VDIB.Canvas.FillRect(Bounds(0, 0, 16, 16));
13623
 
13624
      FloatX1 := 0;
13625
      FloatY1 := 0;
13626
      FloatX2 := 1;
13627
      FloatY2 := 1;
13628
      Name := S;
13629
      D2DTexture := TDirect3DTexture2.Create(FDDraw, VDIB, False);
13630
      D2DTexture.Transparent := False; //cannot be transparent
13631
    end;
13632
    finally
13633
      {$IFNDEF VIDEOTEX}
13634
      VDIB.Free;
13635
      {$ENDIF}
13636
    end;
13637
  except
13638
    D2DMaxTextures := D2DMaxTextures - 1;
13639
    Result := False;
13640
  end;
13641
end;
13642
 
13643
{$IFDEF VIDEOTEX}
13644
function TD2DTextures.GetTexLayoutByName(name: string): TDIB;
13645
var
13646
  I: Integer;
13647
begin
13648
  Result := nil;
13649
  I := Find(name);
13650
  {$IFDEF VER4UP}
13651
  if (I >= Low(Texture)) and (I <= High(Texture)) then
13652
  {$ELSE}
13653
  if I <> -1 then
13654
  {$ENDIF}
13655
    Result := Texture[I].VDIB
13656
end;
13657
{$ENDIF}
13658
 
13659
//---------------------------------------------------------------------------
13660
 
13661
constructor TD2D.Create(DDraw: TCustomDXDraw);
13662
begin
13663
  inherited Create;
13664
  //after inheritance
13665
  FDDraw := DDraw;
13666
  FD2DTextureFilter := D2D_POINT {D2D_LINEAR};
13667
  {$IFNDEF D3D_deprecated}
13668
  FD2DTexture := TD2DTextures.Create(FDDraw);
13669
  {$ENDIF}
13670
  InitVertex;
13671
  {internal allocation of texture}
13672
  CanUseD2D := {$IFDEF D3D_deprecated}(do3D in FDDraw.Options) and
13673
    (doDirectX7Mode in FDDraw.Options) and
13674
    (doHardware in FDDraw.Options){$ELSE}True{$ENDIF};
13675
  FDIB := TDIB.Create;
13676
  FInitialized := False;
13677
end;
13678
 
13679
destructor TD2D.Destroy;
13680
begin
13681
  {freeing texture and stop using it}
13682
  CanUseD2D := False;
13683
  if AsSigned(FD2DTexture) then
13684
  begin
13685
    FD2DTexture.Free; {add 29.5.2005 Takanori Kawasaki}
13686
    FD2DTexture := nil;
13687
  end;
13688
  FDIB.Free;
13689
  inherited Destroy;
13690
end;
13691
 
13692
procedure TD2D.InitVertex;
13693
var i: Integer;
13694
begin
13695
  Fillchar(FVertex, SizeOf(FVertex), 0);
13696
  for i := 0 to 3 do
13697
  begin
13698
    FVertex[i].Specular := D3DRGB(1.0, 1.0, 1.0);
13699
    FVertex[i].rhw := 1.0;
13700
  end;
13701
end;
13702
 
13703
//---------------------------------------------------------------------------
13704
 
13705
procedure TD2D.BeginScene();
13706
begin
13707
  asm
13708
    FINIT
13709
  end;
13710
  FDDraw.D3DDevice7.BeginScene();
13711
  asm
13712
    FINIT
13713
  end;
13714
  FDDraw.D3DDevice7.Clear(0, nil, D3DCLEAR_TARGET, 0, 0, 0);
13715
end;
13716
 
13717
//---------------------------------------------------------------------------
13718
 
13719
procedure TD2D.EndScene();
13720
begin
13721
  asm
13722
    FINIT
13723
  end;
13724
  FDDraw.D3DDevice7.EndScene();
13725
  asm
13726
    FINIT
13727
  end;
13728
end;
13729
 
13730
function TD2D.D2DTexturedOn(Image: TPictureCollectionItem; Pattern: Integer; SubPatternRect: TRect; RenderType: TRenderType; Alpha: Byte): Boolean;
13731
var I: Integer;
13732
  SrcX, SrcY, diffX: Double;
13733
  R: TRect;
13734
  Q: TTextureRec;
13735
begin
13736
  Result := False;
13737
  FDDraw.D3DDevice7.SetTexture(0, nil);
13738
  if not FD2DTexture.CanFindTexture(Image) then {when no texture in list try load it}
13739
    if not FD2DTexture.LoadTextures(Image) then {loading is here}
13740
      Exit; {on error occurr out}
13741
  I := FD2DTexture.Find(Image.Name);
13742
  if I = -1 then Exit;
13743
  {set pattern as texture}
13744
//  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
13745
//  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
13746
  try
13747
    RenderError := FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7) <> DD_OK;
13748
    case RenderType of
13749
      rtDraw: begin D2DEffectSolid; D2DWhite; end;
13750
      rtBlend: begin D2DEffectBlend; D2DAlphaVertex(Alpha); end;
13751
      rtAdd: begin D2DEffectAdd; D2DFade(Alpha); end;
13752
      rtSub: begin D2DEffectSub; D2DFade(Alpha); end;
13753
    end;
13754
  except
13755
    RenderError := True;
13756
    FD2DTexture.D2DPruneAllTextures;
13757
    Image.Restore;
13758
    SetD2DTextureFilter(D2D_LINEAR);
13759
    Exit;
13760
  end;
13761
  {set transparent area}
13762
  RenderError := FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Ord(FD2DTexture.Texture[I].D2DTexture.Transparent)) <> DD_OK;
13763
  {except for Draw when alphachannel exists}
13764
  {change for blend drawing but save transparent area still}
13765
  if FD2DTexture.Texture[I].AlphaChannel then
13766
    {when is Draw selected then}
13767
    if RenderType = rtDraw then
13768
    begin
13769
      D2DEffectBlend;
13770
      D2DAlphaVertex($FF);
13771
    end;
13772
  {pokud je obrazek rozdeleny, nastav oka site}
13773
  if (Image.PatternHeight <> 0) or (Image.PatternWidth <> 0) then
13774
  begin
13775
    {vezmi rect jenom dilku}
13776
    R := Image.PatternRects[Pattern];
13777
    SrcX := 1 / FD2DTexture.Texture[I].Width;
13778
    SrcY := 1 / FD2DTexture.Texture[I].Height;
13779
    //namapovani vertexu na texturu
13780
    FD2DTexture.Texture[I].FloatX1 := SrcX * R.Left;
13781
    FD2DTexture.Texture[I].FloatY1 := SrcY * R.Top;
13782
    {for meshed subimage contain one image only can be problem there}
13783
    diffX := 0.5; if Image.PatternCount = 1 then diffX := 0;
13784
    FD2DTexture.Texture[I].FloatX2 := SrcX * (R.Right - diffX);
13785
    FD2DTexture.Texture[I].FloatY2 := SrcY * (R.Bottom - diffX);
13786
    if not (
13787
      (SubPatternRect.Left = Image.PatternRects[Pattern].Left) and
13788
      (SubPatternRect.Top = Image.PatternRects[Pattern].Top) and
13789
      (SubPatternRect.Right = Image.PatternRects[Pattern].Right) and
13790
      (SubPatternRect.Bottom = Image.PatternRects[Pattern].Bottom))
13791
    then
13792
    begin
13793
      {remaping subtexture via subpattern}
13794
      Q.FloatX1 := SrcX * SubPatternRect.Left;
13795
      Q.FloatY1 := SrcY * SubPatternRect.Top;
13796
      Q.FloatX2 := SrcX * (SubPatternRect.Right - diffX);
13797
      Q.FloatY2 := SrcY * (SubPatternRect.Bottom - diffX);
13798
      D2DTU(Q); {with mirroring/flipping}
13799
      Result := not RenderError;
13800
      Exit;
13801
    end;
13802
  end; {jinak celeho obrazku}
13803
 
13804
  {  X1,Y1             X2,Y1
13805
 
13806
     |                 |
13807
     |                 |
13808
     |                 |
13809
     |                 |
13810
  2  +-----------------+  3
13811
     X1,Y2             X2,Y2  }
13812
  D2DTU(FD2DTexture.Texture[I]);
13813
  Result := not RenderError;
13814
end;
13815
 
13816
function TD2D.D2DTexturedOnDDSTex(dds: TDirectDrawSurface; SubPatternRect: TRect; Transparent: Boolean): Integer;
13817
{special version of map for TDirectDrawSurface only}
13818
{set up transparent color from this surface}
13819
var
13820
  TexName: string;
13821
begin
13822
  Result := -1;
13823
  {pokud je seznam prazdny, nahrej texturu}
13824
  if dds.Caption <> '' then TexName := dds.Caption
13825
  else TexName := IntToStr(Integer(dds)); {simple but stupid}
13826
  if not FD2DTexture.{$IFDEF VER4UP}CanFindTexture{$ELSE}CanFindTexture2{$ENDIF}(TexName) then
13827
  begin
13828
    {when texture doesn't exists, has to the Modified flag turn off}
13829
    if dds.Modified then
13830
      dds.Modified := not dds.Modified;
13831
    if not FD2DTexture.{$IFDEF VER4UP}LoadTextures{$ELSE}LoadTextures2{$ENDIF}(dds, Transparent, TexName) then
13832
      Exit; {nepovede-li se to, pak ven}
13833
  end
13834
  else
13835
    if dds.Modified then
13836
    begin {when modifying, load texture allways}
13837
      if not FD2DTexture.{$IFDEF VER4UP}LoadTextures{$ELSE}LoadTextures2{$ENDIF}(dds, Transparent, TexName) then
13838
        Exit; {nepovede-li se to, pak ven}
13839
    end;
13840
  Result := FD2DTexture.Find(TexName);
13841
end;
13842
 
13843
function IsNotZero(Z: TRect): Boolean;
13844
begin
13845
  Result := ((Z.Right - Z.Left) > 0) and ((Z.Bottom - Z.Top) > 0)
13846
end;
13847
 
13848
function TD2D.D2DTexturedOnDDS(dds: TDirectDrawSurface; SubPatternRect: TRect; Transparent: Boolean; RenderType: TRenderType; Alpha: Byte): Boolean;
13849
var I: Integer;
13850
  SrcX, SrcY: Double;
13851
begin
13852
  Result := False;
13853
  FDDraw.D3DDevice7.SetTexture(0, nil);
13854
  {call a low level routine for load DDS texture}
13855
  I := D2DTexturedOnDDSTex(dds, SubPatternRect, Transparent);
13856
  if I = -1 then Exit;
13857
  {set pattern as texture}
13858
//  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
13859
//  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
13860
  try
13861
    RenderError := FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7) <> DD_OK;
13862
    case RenderType of
13863
      rtDraw: begin D2DEffectSolid; D2DWhite; end;
13864
      rtBlend: begin D2DEffectBlend; D2DAlphaVertex(Alpha); end;
13865
      rtAdd: begin D2DEffectAdd; D2DFade(Alpha); end;
13866
      rtSub: begin D2DEffectSub; D2DFade(Alpha); end;
13867
    end;
13868
  except
13869
    RenderError := True;
13870
    FD2DTexture.D2DPruneAllTextures;
13871
    SetD2DTextureFilter(D2D_LINEAR); //default
13872
    Exit;
13873
  end;
13874
  {set transparent area}
13875
  RenderError := FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Ord(FD2DTexture.Texture[I].D2DTexture.Transparent)) <> DD_OK;
13876
  if IsNotZero(SubPatternRect) then
13877
  begin
13878
    {Set Texture Coordinates}
13879
    SrcX := 1 / FD2DTexture.Texture[I].D2DTexture.FImage.Width;
13880
    SrcY := 1 / FD2DTexture.Texture[I].D2DTexture.FImage.Height;
13881
    //namapovani vertexu na texturu
13882
    FD2DTexture.Texture[I].FloatX1 := SrcX * SubPatternRect.Left;
13883
    FD2DTexture.Texture[I].FloatY1 := SrcY * SubPatternRect.Top;
13884
    FD2DTexture.Texture[I].FloatX2 := SrcX * (SubPatternRect.Right - 0.5 { - 1}); //by Speeeder
13885
    FD2DTexture.Texture[I].FloatY2 := SrcY * (SubPatternRect.Bottom - 0.5 { - 1}); //by Speeeder
13886
  end;
13887
  D2DTU(FD2DTexture.Texture[I]);
13888
  Result := not RenderError;
13889
end;
13890
 
13891
//---------------------------------------------------------------------------
13892
 
13893
procedure TD2D.SaveTextures(path: string);
13894
begin
13895
  FD2DTexture.SaveTextures(path);
13896
end;
13897
 
13898
procedure TD2D.SetCanUseD2D(const Value: Boolean);
13899
begin
13900
  case Value of
13901
    False: {prestava se uzivat}
13902
      if AsSigned(FD2DTexture) and (Value <> FCanUseD2D) then
13903
      begin
13904
        FInitialized := False;
13905
      end;
13906
    True:
13907
      if Value <> FCanUseD2D then
13908
      begin
13909
        {$IFDEF D3D_deprecated}
13910
        FD2DTexture := TD2DTextures.Create(FDDraw);
13911
        TextureFilter := D2D_LINEAR;
13912
        {$ENDIF}
13913
      end
13914
  end;
13915
  FCanUseD2D := Value;
13916
end;
13917
 
13918
function TD2D.GetCanUseD2D: Boolean;
13919
begin
13920
  {$IFDEF D3D_deprecated}
13921
  {Mode has to do3D, doDirectX7Mode and doHardware}
13922
  if (do3D in FDDraw.Options) and
13923
    (doDirectX7Mode in FDDraw.Options) and
13924
    (doHardware in FDDraw.Options)
13925
  then
13926
  begin
13927
    if not FCanUseD2D then CanUseD2D := True;
13928
  end
13929
  else
13930
    if not (do3D in FDDraw.Options) or
13931
      not (doDirectX7Mode in FDDraw.Options) or
13932
      not (doHardware in FDDraw.Options)
13933
      then
13934
      if FCanUseD2D then FCanUseD2D := False; // CanUseD2D -> FCanUseD2D
13935
  {$ELSE}
13936
  FCanUseD2D := (doHardware in FDDraw.Options);
13937
  {$ENDIF}
13938
  FBitCount := FDDraw.Surface.SurfaceDesc.ddpfPixelFormat.dwRGBBitCount;
13939
  {supported 16 or 32 bitcount deepth only}
13940
  {$IFDEF D3D_deprecated}
13941
  if not (FBitCount in [16, 32]) then FCanUseD2D := False;
13942
  {$ENDIF}
13943
  if not FInitialized then
13944
    if FCanUseD2D and Assigned(FDDraw.D3DDevice7) then
13945
    begin
13946
      FDDraw.D3DDevice7.GetCaps(FD3DDevDesc7);
13947
      FInitialized := True;
13948
    end;
13949
 
13950
  Result := FCanUseD2D;
13951
end;
13952
 
13953
procedure TD2D.SetD2DTextureFilter(const Value: TD2DTextureFilter);
13954
begin
13955
  FD2DTextureFilter := Value;
13956
  if {$IFDEF D3D_deprecated}(do3D in FDDraw.Options) and{$ENDIF} AsSigned(FDDraw.D3DDevice7) then
13957
  begin
13958
    FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter) + 1));
13959
    FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter) + 1));
13960
  end;
13961
end;
13962
 
13963
procedure TD2D.SetD2DAntialiasFilter(const Value: TD3DAntialiasMode);
13964
begin
13965
  FD2DAntialiasFilter := Value;
13966
  if {$IFDEF D3D_deprecated}(do3D in FDDraw.Options) and{$ENDIF} AsSigned(FDDraw.D3DDevice7) then
13967
  begin
13968
    FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_ANTIALIAS, Ord(Value));
13969
  end;
13970
end;
13971
 
13972
procedure TD2D.D2DRect(R: TRect);
13973
begin
13974
  FVertex[0].sx := R.Left - 0.5;
13975
  FVertex[0].sy := R.Top - 0.5;
13976
  FVertex[1].sx := R.Right - 0.5;
13977
  FVertex[1].sy := R.Top - 0.5;
13978
  FVertex[2].sx := R.Left - 0.5;
13979
  FVertex[2].sy := R.Bottom - 0.5;
13980
  FVertex[3].sx := R.Right - 0.5;
13981
  FVertex[3].sy := R.Bottom - 0.5;
13982
end;
13983
 
13984
procedure TD2D.D2DTU(T: TTextureRec);
13985
begin
13986
  if FMirrorFlipSet = [rmfMirror] then
13987
  begin
13988
    {  X1,Y1             X2,Y1
13989
 
13990
       |                 |
13991
       |                 |
13992
       |                 |
13993
       |                 |
13994
    2  +-----------------+  3
13995
       X1,Y2             X2,Y2  }
13996
    FVertex[1].tu := T.FloatX1;
13997
    FVertex[1].tv := T.FloatY1;
13998
    FVertex[0].tu := T.FloatX2;
13999
    FVertex[0].tv := T.FloatY1;
14000
    FVertex[3].tu := T.FloatX1;
14001
    FVertex[3].tv := T.FloatY2;
14002
    FVertex[2].tu := T.FloatX2;
14003
    FVertex[2].tv := T.FloatY2;
14004
  end
14005
  else
14006
  if FMirrorFlipSet = [rmfFlip] then
14007
  begin
14008
    {  X1,Y1             X2,Y1
14009
 
14010
       |                 |
14011
       |                 |
14012
       |                 |
14013
       |                 |
14014
    2  +-----------------+  3
14015
       X1,Y2             X2,Y2  }
14016
    FVertex[2].tu := T.FloatX1;
14017
    FVertex[2].tv := T.FloatY1;
14018
    FVertex[3].tu := T.FloatX2;
14019
    FVertex[3].tv := T.FloatY1;
14020
    FVertex[0].tu := T.FloatX1;
14021
    FVertex[0].tv := T.FloatY2;
14022
    FVertex[1].tu := T.FloatX2;
14023
    FVertex[1].tv := T.FloatY2;
14024
  end
14025
  else
14026
  if FMirrorFlipSet = [rmfMirror, rmfFlip] then
14027
  begin
14028
    {  X1,Y1             X2,Y1
14029
 
14030
       |                 |
14031
       |                 |
14032
       |                 |
14033
       |                 |
14034
    2  +-----------------+  3
14035
       X1,Y2             X2,Y2  }
14036
    FVertex[3].tu := T.FloatX1;
14037
    FVertex[3].tv := T.FloatY1;
14038
    FVertex[2].tu := T.FloatX2;
14039
    FVertex[2].tv := T.FloatY1;
14040
    FVertex[1].tu := T.FloatX1;
14041
    FVertex[1].tv := T.FloatY2;
14042
    FVertex[0].tu := T.FloatX2;
14043
    FVertex[0].tv := T.FloatY2;
14044
  end
14045
  else
14046
  begin
14047
    {  X1,Y1             X2,Y1
14048
 
14049
       |                 |
14050
       |                 |
14051
       |                 |
14052
       |                 |
14053
    2  +-----------------+  3
14054
       X1,Y2             X2,Y2  }
14055
    FVertex[0].tu := T.FloatX1;
14056
    FVertex[0].tv := T.FloatY1;
14057
    FVertex[1].tu := T.FloatX2;
14058
    FVertex[1].tv := T.FloatY1;
14059
    FVertex[2].tu := T.FloatX1;
14060
    FVertex[2].tv := T.FloatY2;
14061
    FVertex[3].tu := T.FloatX2;
14062
    FVertex[3].tv := T.FloatY2;
14063
  end;
14064
end;
14065
 
14066
{Final public routines}
14067
 
14068
function TD2D.D2DRender(Image: TPictureCollectionItem; DestRect: TRect;
14069
  Pattern: Integer; SourceRect: TRect; RenderType: TRenderType; Alpha: Byte): Boolean;
14070
begin
14071
  Result := False; if not CanUseD2D then Exit;
14072
  if D2DTexturedOnSubRect(Image, Pattern, Image.PatternRects[Pattern], SourceRect, RenderType, Alpha) then
14073
  begin
14074
    D2DRect(DestRect);
14075
    Result := RenderQuad;
14076
  end;
14077
end;
14078
 
14079
function TD2D.{$IFNDEF VER4UP}D2DRender2{$ELSE}D2DRender{$ENDIF}(Image: TPictureCollectionItem; R: TRect;
14080
  Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
14081
begin
14082
  Result := False; if not CanUseD2D then Exit;
14083
  if D2DTexturedOn(Image, Pattern, Image.PatternRects[Pattern], RenderType, Alpha) then
14084
  begin
14085
    D2DRect(R);
14086
    Result := RenderQuad;
14087
  end;
14088
end;
14089
 
14090
function TD2D.D2DRenderDDS(Source: TDirectDrawSurface; SourceRect, DestRect: TRect;
14091
  Transparent: Boolean; Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
14092
begin
14093
  Result := False; if not CanUseD2D then Exit;
14094
  if D2DTexturedOnDDS(Source, SourceRect, Transparent, RenderType, Alpha) then
14095
  begin
14096
    D2DRect(DestRect);
14097
    Result := RenderQuad;
14098
  end;
14099
end;
14100
 
14101
function TD2D.D2DRenderCol(Image: TPictureCollectionItem; R: TRect;
14102
  Pattern, Color: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
14103
begin
14104
  Result := False; if not CanUseD2D then Exit;
14105
  if D2DTexturedOn(Image, Pattern, Image.PatternRects[Pattern], RenderType, Alpha) then
14106
  begin
14107
    D2DRect(R);
14108
    Result := RenderQuad;
14109
  end;
14110
end;
14111
 
14112
function TD2D.D2DRenderColDDS(Source: TDirectDrawSurface; SourceRect, DestRect: TRect;
14113
  Transparent: Boolean; Pattern, Color: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
14114
begin
14115
  Result := False; if not CanUseD2D then Exit;
14116
  {Add}
14117
  if D2DTexturedOnDDS(Source, SourceRect, Transparent, RenderType, Alpha) then
14118
  begin
14119
    D2DRect(DestRect);
14120
    Result := RenderQuad;
14121
  end;
14122
end;
14123
 
14124
function TD2D.D2DRenderDrawXY(Image: TPictureCollectionItem; X, Y: Integer;
14125
  Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
14126
var PWidth, PHeight: Integer;
14127
begin
14128
  Result := False; if not CanUseD2D then Exit;
14129
  {Draw}
14130
  if D2DTexturedOn(Image, Pattern, Image.PatternRects[Pattern], RenderType, Alpha) then
14131
  begin
14132
    PWidth := Image.PatternWidth; if PWidth = 0 then PWidth := Image.Width;
14133
    PHeight := Image.PatternHeight; if PHeight = 0 then PHeight := Image.Height;
14134
    D2DRect(Bounds(X, Y, PWidth, PHeight));
14135
    Result := RenderQuad;
14136
  end;
14137
end;
14138
 
14139
function TD2D.D2DRenderDrawDDSXY(Source: TDirectDrawSurface; X, Y: Integer;
14140
  Transparent: Boolean; Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
14141
begin
14142
  Result := False; if not CanUseD2D then Exit;
14143
  {Draw}
14144
  if D2DTexturedOnDDS(Source, ZeroRect, Transparent, RenderType, Alpha) then
14145
  begin
14146
    D2DRect(Bounds(X, Y, Source.Width, Source.Height));
14147
    Result := RenderQuad;
14148
  end;
14149
end;
14150
 
14151
{$IFDEF VER4UP}
14152
function TD2D.D2DRenderDrawDDSXY(Source: TDirectDrawSurface; X, Y: Integer;
14153
  SrcRect: TRect; Transparent: Boolean; Pattern: Integer; RenderType: TRenderType; Alpha: Byte): Boolean;
14154
begin
14155
  Result := False; if not CanUseD2D then Exit;
14156
  {Draw}
14157
  if D2DTexturedOnDDS(Source, SrcRect, Transparent, RenderType, Alpha) then
14158
  begin
14159
    D2DRect(Bounds(X, Y, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top));
14160
    Result := RenderQuad;
14161
  end;
14162
end;
14163
{$ENDIF}
14164
 
14165
{Rotate functions}
14166
 
14167
procedure TD2D.D2DRotate(X, Y, W, H: Integer; Px, Py: Double; Angle: Single);
14168
  procedure SinCosS(const Theta: Single; var Sin, Cos: Single); register;
14169
  { EAX contains address of Sin}
14170
  { EDX contains address of Cos}
14171
  { Theta is passed over the stack}
14172
  asm
14173
    FLD  Theta
14174
    FSINCOS
14175
    FSTP DWORD PTR [EDX]    // cosine
14176
    FSTP DWORD PTR [EAX]    // sine
14177
  end;
14178
const PI256 = 2 * PI / 256;
14179
var x1, y1, up, s_angle, c_angle, s_up, c_up: Single;
14180
begin
14181
  angle := angle * PI256; up := angle + PI / 2;
14182
  x1 := w * px; y1 := h * py;
14183
  SinCosS(angle, s_angle, c_angle);
14184
  SinCosS(up, s_up, c_up);
14185
  FVertex[0].sx := X - x1 * c_angle - y1 * c_up;
14186
  FVertex[0].sy := Y - x1 * s_angle - y1 * s_up;
14187
  FVertex[1].sx := FVertex[0].sx + W * c_angle;
14188
  FVertex[1].sy := FVertex[0].sy + W * s_angle;
14189
  FVertex[2].sx := FVertex[0].sx + H * c_up;
14190
  FVertex[2].sy := FVertex[0].sy + H * s_up;
14191
  FVertex[3].sx := FVertex[2].sx + W * c_angle;
14192
  FVertex[3].sy := FVertex[2].sy + W * s_angle;
14193
end;
14194
 
14195
function TD2D.D2DRenderRotate(Image: TPictureCollectionItem; RotX, RotY,
14196
  PictWidth, PictHeight, PatternIndex: Integer; RenderType: TRenderType;
14197
  CenterX, CenterY: Double;
14198
  Angle: single; Alpha: Byte): Boolean;
14199
begin
14200
  Result := False; if not CanUseD2D then Exit;
14201
  {load textures and map it, set of effect}
14202
  if D2DTexturedOn(Image, PatternIndex, Image.PatternRects[PatternIndex], RenderType, Alpha) then
14203
  begin
14204
    {do rotate mesh}
14205
    D2DRotate(RotX, RotY, PictWidth, PictHeight, CenterX, CenterY, Angle);
14206
    {render it}
14207
    Result := RenderQuad;
14208
  end;
14209
end;
14210
 
14211
function TD2D.D2DRenderRotateDDS(Image: TDirectDrawSurface; SourceRect: TRect; RotX, RotY,
14212
  PictWidth, PictHeight: Integer; RenderType: TRenderType;
14213
  CenterX, CenterY: Double; Angle: single; Alpha: Byte;
14214
  Transparent: Boolean): Boolean;
14215
begin
14216
  Result := False; if not CanUseD2D then Exit;
14217
  {load textures and map it, set of effect}
14218
  if D2DTexturedOnDDS(Image, SourceRect, Transparent, RenderType, Alpha) then
14219
  begin
14220
    {do rotate mesh}
14221
    D2DRotate(RotX, RotY, PictWidth, PictHeight, CenterX, CenterY, Angle);
14222
    {render it}
14223
    Result := RenderQuad;
14224
  end;
14225
end;
14226
 
14227
{------------------------------------------------------------------------------}
14228
{created 31.1.2005 JB.}
14229
{replacement original Hori's functionality}
14230
{24.4.2006 create WaveY as supplement like WaveX functions}
14231
{14.5.2006 added functionality for tile drawing through PatternIndex}
14232
 
14233
function TD2D.D2DMeshMapToWave(dds: TDirectDrawSurface; Transparent: Boolean;
14234
  TransparentColor: Integer; X, Y, iWidth, iHeight, PatternIndex: Integer;
14235
  PatternRect: TRect;
14236
  Amp, Len, Ph, Alpha: Integer; effect: TRenderType; DoY: Boolean): Boolean;
14237
  function D2DTexturedOn(dds: TDirectDrawSurface; Transparent: Boolean; var TexNo: Integer): Boolean;
14238
  {special version of mapping for TDirectDrawSurface only}
14239
  {set up transparent color from this surface}
14240
  var I: Integer;
14241
    TexName: string;
14242
  begin
14243
    Result := False;
14244
    TexNo := -1;
14245
    RenderError := FDDraw.D3DDevice7.SetTexture(0, nil) <> DD_OK;
14246
    {pokud je seznam prazdny, nahrej texturu}
14247
    if dds.Caption <> '' then TexName := dds.Caption
14248
    else TexName := IntToStr(Integer(dds));
14249
    if not FD2DTexture.{$IFDEF VER4UP}CanFindTexture{$ELSE}CanFindTexture2{$ENDIF}(TexName) then
14250
      {nepovede-li se to, pak ven}
14251
      if not FD2DTexture.{$IFDEF VER4UP}LoadTextures{$ELSE}LoadTextures3{$ENDIF}(dds, Transparent, TransparentColor, TexName) then Exit;
14252
    I := FD2DTexture.Find(TexName);
14253
    if I = -1 then Exit;
14254
    TexNo := I;
14255
    {set pattern as texture}
14256
//    FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
14257
//    FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
14258
    try
14259
      RenderError := FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7) <> DD_OK;
14260
      //Result := True; {not RetderError}
14261
    except
14262
      RenderError := True;
14263
      Result := False;
14264
      FD2DTexture.D2DPruneAllTextures;
14265
      Exit;
14266
    end;
14267
    {set transparent area}
14268
    RenderError := FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Ord(FD2DTexture.Texture[I].D2DTexture.Transparent)) <> DD_OK;
14269
    Result := not RenderError;
14270
  end;
14271
type
14272
  TVertexArray = array{$IFNDEF VER4UP} [0..0]{$ENDIF} of TD3DTLVERTEX;
14273
  {$IFNDEF VER4UP}
14274
  PVertexArray = ^TVertexArray;
14275
  {$ENDIF}
14276
var
14277
  SVertex: {$IFDEF VER4UP}TVertexArray{$ELSE}PVertexArray{$ENDIF};
14278
  I, maxVertex, maxPix, VStepVx, TexNo, Width, Height: Integer;
14279
  VStep, VStepTo, D, Z, FX1, FX2, FY1, FY2, SX, SY, X1, Y1, X2, Y2: Extended;
14280
  R: TRect;
14281
  clr: DWORD;
14282
begin
14283
  Result := False;
14284
  {zde uschovano maximum [0..1] po adjustaci textury, ktera nemela nektery rozmer 2^n}
14285
  {FD2DTexture.Texture[I].FloatX2;}
14286
  {FD2DTexture.Texture[I].FloatY2;}
14287
  {napr. pokud byl rozmer 0.7 pak je nutno prepocitat tento interval [0..0.7] na height}
14288
  if not D2DTexturedOn(dds, Transparent, TexNo) then Exit;
14289
  {musi se prenastavit velikost pokud je PatternIndex <> -1}
14290
  Width := iWidth;
14291
  Height := iHeight;
14292
  {remove into local variabled for multi-picture adjustation}
14293
  FX1 := FD2DTexture.Texture[TexNo].FloatX1;
14294
  FX2 := FD2DTexture.Texture[TexNo].FloatX2;
14295
  FY1 := FD2DTexture.Texture[TexNo].FloatY1;
14296
  FY2 := FD2DTexture.Texture[TexNo].FloatY2;
14297
  {when pattertindex selected, get real value of subtexture}
14298
  if (PatternIndex <> -1) {and (PatternRect <> ZeroRect)} then
14299
  begin
14300
    R := PatternRect;
14301
    Width := R.Right - R.Left;
14302
    Height := R.Bottom - R.Top;
14303
    {scale unit of full new width and height}
14304
    SX := 1 / FD2DTexture.Texture[TexNo].Width;
14305
    SY := 1 / FD2DTexture.Texture[TexNo].Height;
14306
    {remap there}
14307
    FX1 := R.Left * SX;
14308
    FX2 := R.Right * SX;
14309
    FY1 := R.Top * SY;
14310
    FY2 := R.Bottom * SY;
14311
  end;
14312
  {nastavuje se tolik vertexu, kolik je potreba}
14313
  {speculative set up of rows for better look how needed}
14314
  if not DoY then
14315
  begin
14316
    maxVertex := 2 * Trunc(Height / Len * 8);
14317
    if (maxVertex mod 2) > 0 then {top to limits}
14318
      Inc(maxVertex, 2);
14319
    if (maxVertex div 2) > Height then {correct to Height}
14320
      maxVertex := 2 * Height;
14321
  end
14322
  else
14323
  begin
14324
    maxVertex := 2 * Trunc(Width / Len * 8);
14325
    if (maxVertex mod 2) > 0 then {top to limits}
14326
      Inc(maxVertex, 2);
14327
    if (maxVertex div 2) > Width then {correct to Width}
14328
      maxVertex := 2 * Width;
14329
  end;
14330
 
14331
  {pocet pixlu mezi ploskami}
14332
  if not DoY then
14333
  begin
14334
    repeat
14335
      if (Height mod (maxVertex div 2)) <> 0 then
14336
        Inc(maxVertex, 2);
14337
      maxPix := Height div (maxVertex div 2);
14338
    until (Height mod (maxVertex div 2)) = 0;
14339
    {krok k nastaveni vertexu}
14340
    VStep := (FY2 - FY1) / (maxVertex div 2);
14341
  end
14342
  else
14343
  begin
14344
    repeat
14345
      if (Width mod (maxVertex div 2)) <> 0 then
14346
        Inc(maxVertex, 2);
14347
      maxPix := Width div (maxVertex div 2);
14348
    until (Width mod (maxVertex div 2)) = 0;
14349
    {krok k nastaveni vertexu}
14350
    VStep := (FX2 - FX1) / (maxVertex div 2);
14351
  end;
14352
  //prostor
14353
  {$IFDEF VER4UP}
14354
  SetLength(SVertex, maxVertex);
14355
  {$ELSE}
14356
  SVertex := AllocMem(maxVertex * SizeOf(TD3DTLVERTEX));
14357
  try
14358
  {$ENDIF}
14359
    //inicializace
14360
    VStepVx := 0;
14361
    VStepTo := 0;
14362
    D := ph / (128 / PI); {shift wave}
14363
    Z := (Len / 2) / PI; {wave length to radians}
14364
    clr := D2DVertColor(Effect, Alpha); //effect cumulate to one param and one line of code
14365
    {vlastni nastaveni vertexu v pasu vertexu}
14366
    for I := 0 to maxVertex - 1 do
14367
    begin
14368
      SVertex[I].Specular := D3DRGB(1.0, 1.0, 1.0);
14369
      SVertex[I].rhw := 1.0;
14370
      SVertex[I].color := clr;
14371
      if not DoY then
14372
        case (I + 1) mod 2 of //triangle driver
14373
          1: begin
14374
              if I <> 0 then Inc(VStepVx, maxPix);
14375
              SVertex[I].sx := X + Trunc(amp * Sin((Y + VStepVx) / Z + D)) - 0.5; //levy
14376
              SVertex[I].sy := Y + VStepVx - 0.5;
14377
              if FMirrorFlipSet = [rmfMirror] then
14378
              begin
14379
                X1 := FX2; if I <> 0 then VStepTo := VStepTo + VStep;
14380
                Y1 := FY1 + VStepTo;
14381
              end
14382
              else
14383
                if FMirrorFlipSet = [rmfFlip] then
14384
                begin
14385
                  X1 := FX1;
14386
                  Y1 := FY2 - VStepTo;
14387
                end
14388
                else
14389
                  if FMirrorFlipSet = [rmfMirror, rmfFlip] then
14390
                  begin
14391
                    X1 := FX2;
14392
                    Y1 := FY2 - VStepTo;
14393
                  end
14394
                  else
14395
                  begin
14396
                    X1 := FX1; if I <> 0 then VStepTo := VStepTo + VStep;
14397
                    Y1 := FY1 + VStepTo;
14398
                  end;
14399
              SVertex[I].tu := X1;
14400
              SVertex[I].tv := Y1;
14401
            end;
14402
          0: begin
14403
              SVertex[I].sx := X + Width + Trunc(amp * Sin((Y + VStepVx) / Z + D)) - 1; //pravy
14404
              SVertex[I].sy := Y + VStepVx;
14405
              if FMirrorFlipSet = [rmfMirror] then
14406
              begin
14407
                X2 := FX1;
14408
                Y2 := FY1 + VStepTo;
14409
              end
14410
              else
14411
                if FMirrorFlipSet = [rmfFlip] then
14412
                begin
14413
                  X2 := FX2;
14414
                  Y2 := FY2 - VStepTo; if I <> 0 then VStepTo := VStepTo + VStep;
14415
                end
14416
                else
14417
                  if FMirrorFlipSet = [rmfMirror, rmfFlip] then
14418
                  begin
14419
                    X2 := FX1;
14420
                    Y2 := FY2 - VStepTo; if I <> 0 then VStepTo := VStepTo + VStep;
14421
                  end
14422
                  else
14423
                  begin
14424
                    X2 := FX2;
14425
                    Y2 := FY1 + VStepTo;
14426
                  end;
14427
              SVertex[I].tu := X2;
14428
              SVertex[I].tv := Y2;
14429
            end;
14430
        end {case}
14431
      else
14432
        case (I + 1) mod 2 of //triangle driver
14433
          0: begin
14434
              if I <> 0 then Inc(VStepVx, maxPix);
14435
              SVertex[I].sy := Y + Trunc(amp * Sin((X + VStepVx) / Z + D)) - 0.5; //hore
14436
              SVertex[I].sx := X + VStepVx - 0.5;
14437
              if FMirrorFlipSet = [rmfMirror] then
14438
              begin
14439
                Y1 := FY1; if I <> 0 then VStepTo := VStepTo + VStep;
14440
                X1 := FX2 - VStepTo;
14441
              end
14442
              else
14443
                if FMirrorFlipSet = [rmfFlip] then
14444
                begin
14445
                  Y1 := FY2; if I <> 0 then VStepTo := VStepTo + VStep;
14446
                  X1 := FX1 + VStepTo;
14447
                end
14448
                else
14449
                  if FMirrorFlipSet = [rmfMirror, rmfFlip] then
14450
                  begin
14451
                    Y1 := FY2; if I <> 0 then VStepTo := VStepTo + VStep;
14452
                    X1 := FX2 - VStepTo;
14453
                  end
14454
                  else
14455
                  begin
14456
                    Y1 := FY1; if I <> 0 then VStepTo := VStepTo + VStep;
14457
                    X1 := FX1 + VStepTo;
14458
                  end;
14459
              SVertex[I].tu := X1;
14460
              SVertex[I].tv := Y1;
14461
            end;
14462
          1: begin
14463
              SVertex[I].sy := Y + Height + Trunc(amp * Sin((X + VStepVx) / Z + D)) - 1; //dole
14464
              SVertex[I].sx := X + VStepVx;
14465
              if FMirrorFlipSet = [rmfMirror] then
14466
              begin
14467
                Y2 := FY2;
14468
                X2 := FX2 - VStepTo;
14469
              end
14470
              else
14471
                if FMirrorFlipSet = [rmfFlip] then
14472
                begin
14473
                  Y2 := FY1;
14474
                  X2 := FX1 + VStepTo;
14475
                end
14476
                else
14477
                  if FMirrorFlipSet = [rmfMirror, rmfFlip] then
14478
                  begin
14479
                    Y2 := FY1;
14480
                    X2 := FX2 - VStepTo;
14481
                  end
14482
                  else
14483
                  begin
14484
                    Y2 := FY2;
14485
                    X2 := FX1 + VStepTo;
14486
                  end;
14487
              SVertex[I].tu := X2;
14488
              SVertex[I].tv := Y2;
14489
            end;
14490
        end;
14491
    end;
14492
    {set of effect}
14493
    case Effect of
14494
      rtDraw: D2DEffectSolid;
14495
      rtBlend: D2DEffectBlend;
14496
      rtAdd: D2DEffectAdd;
14497
      rtSub: D2DEffectSub;
14498
    end;
14499
    with FDDraw.D3DDevice7 do
14500
    begin
14501
      {kreslime hned zde}//render now and here
14502
      Result := DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, SVertex[0], maxVertex, D3DDP_WAIT) = DD_OK;
14503
      //zpet hodnoty
14504
      //FIX InitVertex;
14505
      FMirrorFlipSet := []; {only for one operation, back to normal position}
14506
      {restore device status}
14507
      RenderError := SetTextureStageState(1, D3DTSS_COLOROP, Ord(D3DTOP_DISABLE)) <> DD_OK;
14508
      RenderError := SetTextureStageState(1, D3DTSS_ALPHAOP, Ord(D3DTOP_DISABLE)) <> DD_OK;
14509
      RenderError := SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 0) <> DD_OK;
14510
    end;
14511
  {$IFNDEF VER4UP}
14512
  finally
14513
    FreeMem(SVertex, maxVertex * SizeOf(TD3DTLVERTEX));
14514
  end;
14515
  {$ENDIF}
14516
end;
14517
 
14518
function TD2D.D2DRenderWaveX(Image: TPictureCollectionItem; X, Y, Width,
14519
  Height, PatternIndex: Integer; RenderType: TRenderType; transparent: Boolean;
14520
  amp, Len, ph, Alpha: Integer): Boolean;
14521
begin
14522
  Result := False; if not CanUseD2D then Exit;
14523
  {load textures and map, do make wave mesh and render it}
14524
  Result := D2DMeshMapToWave(Image.PatternSurfaces[PatternIndex], transparent,
14525
    Image.FTransparentColor, X, Y, Width, Height, PatternIndex,
14526
    Image.PatternRects[PatternIndex],
14527
    amp, Len, ph, Alpha, RenderType{$IFNDEF VER4UP}, False{$ENDIF});
14528
end;
14529
 
14530
function TD2D.D2DRenderWaveXDDS(Source: TDirectDrawSurface; X, Y, Width,
14531
  Height: Integer; RenderType: TRenderType; Transparent: Boolean; Amp, Len, Ph, Alpha: Integer): Boolean;
14532
begin
14533
  Result := False; if not CanUseD2D then Exit;
14534
  {load textures and map, do make wave mesh and render it}
14535
  Result := D2DMeshMapToWave(Source, transparent, -1, X, Y, Width, Height, -1,
14536
    ZeroRect,
14537
    amp, Len, ph, Alpha, RenderType{$IFNDEF VER4UP}, False{$ENDIF});
14538
end;
14539
 
14540
function TD2D.D2DRenderWaveY(Image: TPictureCollectionItem; X, Y, Width,
14541
  Height, PatternIndex: Integer; RenderType: TRenderType; Transparent: Boolean;
14542
  Amp, Len, Ph, Alpha: Integer): Boolean;
14543
begin
14544
  Result := False; if not CanUseD2D then Exit;
14545
  {load textures and map, do make wave mesh and render it}
14546
  Result := D2DMeshMapToWave(Image.PatternSurfaces[PatternIndex], transparent,
14547
    Image.FTransparentColor, X, Y, Width, Height, PatternIndex,
14548
    Image.PatternRects[PatternIndex],
14549
    amp, Len, ph, Alpha, RenderType, True);
14550
end;
14551
 
14552
function TD2D.D2DRenderWaveYDDS(Source: TDirectDrawSurface; X, Y, Width,
14553
  Height: Integer; RenderType: TRenderType; Transparent: Boolean;
14554
  Amp, Len, Ph, Alpha: Integer): Boolean;
14555
begin
14556
  Result := False; if not CanUseD2D then Exit;
14557
  {load textures and map, do make wave mesh and render it}
14558
  Result := D2DMeshMapToWave(Source, transparent, -1, X, Y, Width, Height, -1,
14559
    ZeroRect,
14560
    amp, Len, ph, Alpha, RenderType, True);
14561
end;
14562
 
14563
function TD2D.D2DTexturedOnRect(Rect: TRect; Color: LongInt): Boolean;
14564
var I: Integer;
14565
begin
14566
  Result := False;
14567
  FDDraw.D3DDevice7.SetTexture(0, nil);
14568
  if not FD2DTexture.{$IFDEF VER4UP}CanFindTexture{$ELSE}CanFindTexture3{$ENDIF}(Color) then {when no texture in list try load it}
14569
    if not FD2DTexture.{$IFDEF VER4UP}LoadTextures{$ELSE}LoadTextures4{$ENDIF}(Color) then Exit; {on error occurr go out}
14570
  I := FD2DTexture.Find('$' + IntToStr(Color)); //simply .. but stupid
14571
  if I = -1 then Exit;
14572
  {set pattern as texture}
14573
//  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
14574
//  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
14575
  try
14576
    RenderError := FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7) <> DD_OK;
14577
  except
14578
    RenderError := True;
14579
    FD2DTexture.D2DPruneAllTextures;
14580
    exit;
14581
  end;
14582
  {set transparent part}
14583
  FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, 0); //no transparency
14584
 
14585
  D2DTU(FD2DTexture.Texture[I]);
14586
  Result := not RenderError;
14587
end;
14588
 
14589
function TD2D.D2DTexturedOnSubRect(Image: TPictureCollectionItem;
14590
  Pattern: Integer; SubPatternRect, SubRect: TRect; RenderType: TRenderType;
14591
  Alpha: Byte): Boolean;
14592
label
14593
  lblHop;  
14594
var
14595
  I, W, H: Integer;
14596
  SrcX, SrcY, diffX: Double;
14597
  R, tmpSubRect: TRect;
14598
  Q: TTextureRec;
14599
  qFloatX1, qFloatX2, qFloatY1, qFloatY2: Double;
14600
begin
14601
  Result := False;
14602
  FDDraw.D3DDevice7.SetTexture(0, nil);
14603
  if not FD2DTexture.CanFindTexture(Image) then {when no texture in list try load it}
14604
    if not FD2DTexture.LoadTextures(Image) then {loading is here}
14605
      Exit; {on error occurr out}
14606
  I := FD2DTexture.Find(Image.Name);
14607
  if I = -1 then Exit;
14608
  {set pattern as texture}
14609
//  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MAGFILTER, DWord(Ord(FD2DTextureFilter)+1));
14610
//  FDDraw.D3DDevice7.SetTextureStageState(0, D3DTSS_MINFILTER, DWord(Ord(FD2DTextureFilter)+1));
14611
  try
14612
    FDDraw.D3DDevice7.SetTexture(0, FD2DTexture.Texture[I].D2DTexture.Surface.IDDSurface7);
14613
    case RenderType of
14614
      rtDraw: begin D2DEffectSolid; D2DWhite; end;
14615
      rtBlend: begin D2DEffectBlend; D2DAlphaVertex(Alpha); end;
14616
      rtAdd: begin D2DEffectAdd; D2DFade(Alpha); end;
14617
      rtSub: begin D2DEffectSub; D2DFade(Alpha); end;
14618
    end;
14619
  except
14620
    RenderError := true;
14621
    FD2DTexture.D2DPruneAllTextures;
14622
    Image.Restore;
14623
    SetD2DTextureFilter(D2D_LINEAR);
14624
    Exit;
14625
  end;
14626
  {set transparent part}
14627
  FDDraw.D3DDevice7.SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Ord(FD2DTexture.Texture[I].D2DTexture.Transparent));
14628
  {except for Draw when alphachannel exists}
14629
  {change for blend drawing but save transparent area still}
14630
  if FD2DTexture.Texture[I].AlphaChannel then
14631
    {when is Draw selected then}
14632
    if RenderType = rtDraw then
14633
    begin
14634
      D2DEffectBlend; D2DAlphaVertex($FF);
14635
    end;
14636
  {pokud je obrazek rozdeleny, nastav oka site}
14637
  if (Image.PatternHeight <> 0) or (Image.PatternWidth <> 0) then
14638
  begin
14639
    {vezmi rect jenom dilku}
14640
    R := Image.PatternRects[Pattern];
14641
 
14642
    if not CompareMem(@SubRect, @ZeroRect, SizeOf(SubRect)) then
14643
    begin
14644
      {ktere oko site to je?}
14645
      W := SubRect.Right - SubRect.Left; {takhle je siroky}
14646
      H := SubRect.Bottom - SubRect.Top; {takhle je vysoky}
14647
      tmpSubRect := Bounds(R.Left + SubRect.Left, R.Top + SubRect.Top, W, H);
14648
      if RectInRect(tmpSubRect, R) then
14649
      begin
14650
        {pokud je subrect jeste v ramci patternu, musi se posouvat podle patternindex}
14651
        Inc(R.Left, SubRect.Left);
14652
        Inc(R.Top, SubRect.Top);
14653
        if (R.Left + W) < R.Right then R.Right := R.Left + W;
14654
        if (R.Top + H) < R.Bottom then R.Bottom := R.Top + H;
14655
        goto lblHop;
14656
      end;
14657
    end;
14658
    SrcX := 1 / FD2DTexture.Texture[I].Width;
14659
    SrcY := 1 / FD2DTexture.Texture[I].Height;
14660
    //namapovani vertexu na texturu
14661
    FD2DTexture.Texture[I].FloatX1 := SrcX * R.Left;
14662
    FD2DTexture.Texture[I].FloatY1 := SrcY * R.Top;
14663
    {for meshed subimage contain one image only can be problem there}
14664
    diffX := 0.5; if Image.PatternCount = 1 then diffX := 0;
14665
    FD2DTexture.Texture[I].FloatX2 := SrcX * (R.Right - diffX);
14666
    FD2DTexture.Texture[I].FloatY2 := SrcY * (R.Bottom - diffX);
14667
    if not (
14668
      (SubPatternRect.Left = Image.PatternRects[Pattern].Left) and
14669
      (SubPatternRect.Top = Image.PatternRects[Pattern].Top) and
14670
      (SubPatternRect.Right = Image.PatternRects[Pattern].Right) and
14671
      (SubPatternRect.Bottom = Image.PatternRects[Pattern].Bottom))
14672
    then
14673
    begin
14674
      {remaping subtexture via subpattern}
14675
      Q.FloatX1 := SrcX * SubPatternRect.Left;
14676
      Q.FloatY1 := SrcY * SubPatternRect.Top;
14677
      Q.FloatX2 := SrcX * (SubPatternRect.Right - diffX);
14678
      Q.FloatY2 := SrcY * (SubPatternRect.Bottom - diffX);
14679
      D2DTU(Q); {with mirroring/flipping}
14680
      Result := True;
14681
      Exit;
14682
    end;
14683
  end; {jinak celeho obrazku}
14684
 
14685
  if not CompareMem(@SubRect, @ZeroRect, SizeOf(SubRect)) then
14686
    if RectInRect(SubRect, Bounds(0,0, FD2DTexture.Texture[I].Width, FD2DTexture.Texture[I].Height)) then
14687
    begin
14688
      R := SubRect;
14689
     lblHop:
14690
      SrcX := 1 / FD2DTexture.Texture[I].Width;
14691
      SrcY := 1 / FD2DTexture.Texture[I].Height;
14692
      //namapovani vertexu na texturu
14693
      qFloatX1 := FD2DTexture.Texture[I].FloatX1;
14694
      qFloatY1 := FD2DTexture.Texture[I].FloatY1;
14695
      qFloatX2 := FD2DTexture.Texture[I].FloatX2;
14696
      qFloatY2 := FD2DTexture.Texture[I].FloatY2;
14697
      try
14698
        FD2DTexture.Texture[I].FloatX1 := SrcX * R.Left;
14699
        FD2DTexture.Texture[I].FloatY1 := SrcY * R.Top;
14700
        {for meshed subimage contain one image only can be problem there}
14701
        diffX := 0.5; if Image.PatternCount = 1 then diffX := 0;
14702
        FD2DTexture.Texture[I].FloatX2 := SrcX * (R.Right - diffX);
14703
        FD2DTexture.Texture[I].FloatY2 := SrcY * (R.Bottom - diffX);
14704
        {remaping subtexture via subpattern}
14705
        D2DTU(FD2DTexture.Texture[I]); {with mirroring/flipping}
14706
        Result := True;
14707
        Exit;
14708
      finally
14709
        FD2DTexture.Texture[I].FloatX1 := qFloatX1;
14710
        FD2DTexture.Texture[I].FloatY1 := qFloatY1;
14711
        FD2DTexture.Texture[I].FloatX2 := qFloatX2;
14712
        FD2DTexture.Texture[I].FloatY2 := qFloatY2;
14713
      end;
14714
    end;
14715
 
14716
  {  X1,Y1             X2,Y1
14717
 
14718
     |                 |
14719
     |                 |
14720
     |                 |
14721
     |                 |
14722
  2  +-----------------+  3
14723
     X1,Y2             X2,Y2  }
14724
  D2DTU(FD2DTexture.Texture[I]);
14725
  Result := True;
14726
end;
14727
 
14728
function TD2D.D2DRenderColoredPartition(Image: TPictureCollectionItem;
14729
  DestRect: TRect;
14730
  PatternIndex, Color, Specular: Integer;
14731
  Faded: Boolean;
14732
  SourceRect: TRect;
14733
  RenderType: TRenderType;
14734
  Alpha: Byte): Boolean;
14735
begin
14736
  Result := False; if not CanUseD2D then Exit;
14737
  {set of effect before fade}
14738
  case RenderType of
14739
    rtDraw: D2DEffectSolid;
14740
    rtBlend: D2DEffectBlend;
14741
    rtAdd: D2DEffectAdd;
14742
    rtSub: D2DEffectSub;
14743
  end;
14744
  if Faded then D2DFade(Alpha);
14745
 
14746
  D2DColoredVertex(Color);
14747
  if Specular <> Round(D3DRGB(1.0, 1.0, 1.0)) then
14748
    D2DSpecularVertex(Specular);
14749
  {load textures and map it}
14750
  if D2DTexturedOn(Image, PatternIndex, SourceRect, RenderType, Alpha) then
14751
  begin
14752
    D2DRect(DestRect);
14753
    {render it}
14754
    Result := RenderQuad;
14755
  end;
14756
end;
14757
 
14758
function TD2D.D2DRenderFillRect(Rect: TRect; RGBColor: LongInt;
14759
  RenderType: TRenderType; Alpha: Byte): Boolean;
14760
begin
14761
  Result := False; if not CanUseD2D then Exit;
14762
  case RenderType of
14763
    rtDraw: begin D2DEffectSolid; D2DColoredVertex(RGBColor); end;
14764
    rtBlend: begin D2DEffectBlend; D2DAlphaVertex(Alpha); end;
14765
    rtAdd: begin D2DEffectAdd; D2DFade(Alpha); end;
14766
    rtSub: begin D2DEffectSub; D2DFade(Alpha); end;
14767
  end;
14768
  if D2DTexturedOnRect(Rect, RGBColor) then
14769
  begin
14770
    D2DRect(Rect);
14771
    Result := RenderQuad;
14772
  end;
14773
end;
14774
 
14775
function TD2D.D2DRenderRotateModeCol(Image: TPictureCollectionItem;
14776
  RenderType: TRenderType;
14777
  RotX, RotY, PictWidth, PictHeight, PatternIndex: Integer; CenterX,
14778
  CenterY: Double; Angle: single; Color: Integer; Alpha: Byte): Boolean;
14779
begin
14780
  Result := False; if not CanUseD2D then Exit;
14781
  {set of effect before colored}
14782
  case RenderType of
14783
    rtDraw: D2DEffectSolid;
14784
    rtAdd: D2DEffectAdd;
14785
    rtSub: D2DEffectSub;
14786
    rtBlend: D2DEffectBlend;
14787
  end;
14788
  D2DFadeColored(Color, Alpha);
14789
  {load textures and map it}
14790
  if D2DTexturedOn(Image, PatternIndex, Image.PatternRects[PatternIndex], RenderType, Alpha) then
14791
  begin
14792
    {do rotate mesh}
14793
    D2DRotate(RotX, RotY, PictWidth, PictHeight, CenterX, CenterY, Angle);
14794
    {render it}
14795
    Result := RenderQuad;
14796
  end;
14797
end;
14798
 
14799
function TD2D.D2DRenderRotateModeColDDS(Image: TDirectDrawSurface;
14800
  RotX, RotY, PictWidth, PictHeight: Integer; RenderType: TRenderType;
14801
  CenterX, CenterY: Double; Angle: Single; Color: Integer; Alpha: Byte;
14802
  Transparent: Boolean): Boolean;
14803
begin
14804
  Result := False; if not CanUseD2D then Exit;
14805
  {set of effect}
14806
  D2DFadeColored(Color, Alpha);
14807
  {load textures and map it}
14808
  if D2DTexturedOnDDS(Image, ZeroRect, Transparent, RenderType, Alpha) then
14809
  begin
14810
    {do rotate mesh}
14811
    D2DRotate(RotX, RotY, PictWidth, PictHeight, CenterX, CenterY, Angle);
14812
    {render it}
14813
    Result := RenderQuad;
14814
  end;
14815
end;
14816
 
14817
procedure TD2D.D2DEffectSolid;
14818
begin
14819
  with FDDraw.D3DDevice7 do
14820
  begin
14821
    SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 0);
14822
    //SetRenderState(D3DRENDERSTATE_FILLMODE, Integer(D3DFILL_SOLID));
14823
    SetRenderState(D3DRENDERSTATE_COLORKEYENABLE, Integer(True));
14824
    SetRenderState(D3DRENDERSTATE_SRCBLEND, Integer(D3DBLEND_ONE));
14825
  end;
14826
end;
14827
 
14828
procedure TD2D.D2DEffectBlend;
14829
begin
14830
  with FDDraw.D3DDevice7 do
14831
  begin
14832
    SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 1);
14833
    SetRenderState(D3DRENDERSTATE_SRCBLEND, Integer(D3DBLEND_SRCALPHA));
14834
    SetRenderState(D3DRENDERSTATE_DESTBLEND, Integer(D3DBLEND_INVSRCALPHA));
14835
 
14836
    SetTextureStageState(0, D3DTSS_COLOROP, Integer(D3DTOP_MODULATE));
14837
    SetTextureStageState(0, D3DTSS_COLORARG1, Integer(D3DTA_TEXTURE));
14838
    SetTextureStageState(0, D3DTSS_COLORARG2, Integer(D3DTA_CURRENT));
14839
 
14840
    SetTextureStageState(0, D3DTSS_ALPHAOP, Integer(D3DTOP_BLENDDIFFUSEALPHA));
14841
    SetTextureStageState(0, D3DTSS_ALPHAARG1, Integer(D3DTA_TEXTURE));
14842
    SetTextureStageState(0, D3DTSS_ALPHAARG2, Integer(D3DTA_CURRENT));
14843
 
14844
    SetTextureStageState(0, D3DTSS_ALPHAOP, Integer(D3DTOP_MODULATE));
14845
  end;
14846
end;
14847
 
14848
procedure TD2D.D2DEffectAdd;
14849
begin
14850
  with FDDraw.D3DDevice7 do
14851
  begin
14852
    SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 1);
14853
    SetRenderState(D3DRENDERSTATE_SRCBLEND, Integer(D3DBLEND_ONE));
14854
    SetRenderState(D3DRENDERSTATE_DESTBLEND, Integer(D3DBLEND_ONE));
14855
    SetTextureStageState(0, D3DTSS_ALPHAOP, Ord(D3DTOP_SELECTARG1));
14856
    SetTextureStageState(0, D3DTSS_ALPHAARG1,  D3DTA_CURRENT);
14857
    SetTextureStageState(0, D3DTSS_ALPHAOP, Integer(D3DTOP_MODULATE));
14858
  end;
14859
end;
14860
 
14861
procedure TD2D.D2DEffectSub;
14862
begin
14863
  with FDDraw.D3DDevice7 do
14864
  begin
14865
    SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 1);
14866
    SetRenderState(D3DRENDERSTATE_SRCBLEND, Integer(D3DBLEND_ZERO));
14867
    SetRenderState(D3DRENDERSTATE_DESTBLEND, Integer(D3DBLEND_INVSRCCOLOR));
14868
    SetTextureStageState(0, D3DTSS_ALPHAOP, Ord(D3DTOP_SELECTARG1));
14869
    SetTextureStageState(0, D3DTSS_ALPHAARG1,  D3DTA_CURRENT);
14870
    SetTextureStageState(0, D3DTSS_ALPHAOP, Integer(D3DTOP_MODULATE));
14871
  end;
14872
end;
14873
 
14874
function TD2D.D2DAlphaVertex(Alpha: Integer): Integer;
14875
begin
14876
  Result := RGBA_MAKE($FF, $FF, $FF, Alpha);
14877
  FVertex[0].Color := Result;
14878
  FVertex[1].Color := Result;
14879
  FVertex[2].Color := Result;
14880
  FVertex[3].Color := Result;
14881
end;
14882
 
14883
procedure TD2D.D2DColoredVertex(C: Integer);
14884
begin
14885
  C := D3DRGB(C and $FF / 255, (C shr 8) and $FF / 255, (C shr 16) and $FF / 255);
14886
  FVertex[0].Color := C;
14887
  FVertex[1].Color := C;
14888
  FVertex[2].Color := C;
14889
  FVertex[3].Color := C;
14890
end;
14891
 
14892
procedure TD2D.D2DColAlpha(C, Alpha: Integer);
14893
begin
14894
  C := D3DRGBA(C and $FF / 255, (C shr 8) and $FF / 255, (C shr 16) and $FF / 255, Alpha / 255);
14895
  FVertex[0].Color := C;
14896
  FVertex[1].Color := C;
14897
  FVertex[2].Color := C;
14898
  FVertex[3].Color := C;
14899
end;
14900
 
14901
procedure TD2D.D2DSpecularVertex(C: Integer);
14902
begin
14903
  C := D3DRGB(C and $FF / 255, (C shr 8) and $FF / 255, (C shr 16) and $FF / 255);
14904
  FVertex[0].Specular := C;
14905
  FVertex[1].Specular := C;
14906
  FVertex[2].Specular := C;
14907
  FVertex[3].Specular := C;
14908
end;
14909
 
14910
procedure TD2D.D2DCol4Alpha(C1, C2, C3, C4, Alpha: Integer);
14911
begin
14912
  FVertex[0].Color := D3DRGBA(C1 and $FF / 255, (C1 shr 8) and $FF / 255,
14913
    (C1 shr 16) and $FF / 255, Alpha / 255);
14914
  FVertex[1].Color := D3DRGBA(C2 and $FF / 255, (C2 shr 8) and $FF / 255,
14915
    (C2 shr 16) and $FF / 255, Alpha / 255);
14916
  FVertex[2].Color := D3DRGBA(C3 and $FF / 255, (C3 shr 8) and $FF / 255,
14917
    (C3 shr 16) and $FF / 255, Alpha / 255);
14918
  FVertex[3].Color := D3DRGBA(C4 and $FF / 255, (C4 shr 8) and $FF / 255,
14919
    (C4 shr 16) and $FF / 255, Alpha / 255);
14920
end;
14921
 
14922
function TD2D.D2DVertColor(RenderType: TRenderType; Alpha: Byte): DWORD;
14923
begin
14924
  case RenderType of //effect cumulate to one param and four line of code
14925
    rtDraw: Result := RGB_MAKE($FF, $FF, $FF);
14926
    rtBlend: Result := RGBA_MAKE($FF, $FF, $FF, Alpha);
14927
    rtAdd: Result := RGB_MAKE(Alpha, Alpha, Alpha);
14928
    rtSub: Result := RGB_MAKE(Alpha, Alpha, Alpha);
14929
  else
14930
    Result := RGB_MAKE($FF, $FF, $FF);
14931
  end;
14932
end;
14933
 
14934
function TD2D.D2DWhite: Integer;
14935
begin
14936
  Result := RGB_MAKE($FF, $FF, $FF);
14937
  FVertex[0].Color := Result;
14938
  FVertex[1].Color := Result;
14939
  FVertex[2].Color := Result;
14940
  FVertex[3].Color := Result;
14941
end;
14942
 
14943
function TD2D.D2DFade(Alpha: Integer): Integer;
14944
begin
14945
  Result := RGB_MAKE(Alpha, Alpha, Alpha);
14946
  FVertex[0].Color := Result;
14947
  FVertex[1].Color := Result;
14948
  FVertex[2].Color := Result;
14949
  FVertex[3].Color := Result;
14950
end;
14951
 
14952
procedure TD2D.D2DFadeColored(C, Alpha: Integer);
14953
var mult: single;
14954
begin
14955
  mult := Alpha / 65025; //Alpha/255/255;
14956
  C := D3DRGB((C and $FF) * mult, ((C shr 8) and $FF) * mult, ((C shr 16) and $FF) * mult);
14957
  FVertex[0].Color := C;
14958
  FVertex[1].Color := C;
14959
  FVertex[2].Color := C;
14960
  FVertex[3].Color := C;
14961
end;
14962
 
14963
procedure TD2D.D2DFade4Colored(C1, C2, C3, C4, Alpha: Integer);
14964
var mult: single;
14965
begin
14966
  mult := Alpha / 65025; //Alpha/255/255;
14967
  FVertex[0].Color := D3DRGB((C1 and $FF) * mult, ((C1 shr 8) and $FF) * mult,
14968
    ((C1 shr 16) and $FF) * mult);
14969
  FVertex[1].Color := D3DRGB((C2 and $FF) * mult, ((C2 shr 8) and $FF) * mult,
14970
    ((C2 shr 16) and $FF) * mult);
14971
  FVertex[2].Color := D3DRGB((C3 and $FF) * mult, ((C3 shr 8) and $FF) * mult,
14972
    ((C3 shr 16) and $FF) * mult);
14973
  FVertex[3].Color := D3DRGB((C4 and $FF) * mult, ((C4 shr 8) and $FF) * mult,
14974
    ((C4 shr 16) and $FF) * mult);
14975
end;
14976
 
14977
function TD2D.RenderQuad: Boolean;
14978
begin
14979
  Result := FDDraw.D3DDevice7.DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, FVertex, 4, D3DDP_WAIT) <> DD_OK;
14980
  InitVertex;
14981
  FMirrorFlipSet := []; {only for one operation, back to normal position}
14982
  {restore device status}
14983
  with FDDraw.D3DDevice7 do
14984
  begin
14985
    SetTextureStageState(1, D3DTSS_COLOROP, Ord(D3DTOP_DISABLE));
14986
    SetTextureStageState(1, D3DTSS_ALPHAOP, Ord(D3DTOP_DISABLE));
14987
    SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 0);
14988
  end;
14989
end;
14990
 
14991
function TD2D.RenderTri: Boolean;
14992
begin
14993
  Result := FDDraw.D3DDevice7.DrawPrimitive(D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, FVertex, 3, D3DDP_WAIT) <> DD_OK;
14994
  InitVertex;
14995
  FMirrorFlipSet := []; {only for one operation, back to normal position}
14996
  {restore device status}
14997
  with FDDraw.D3DDevice7 do
14998
  begin
14999
    SetTextureStageState(1, D3DTSS_COLOROP, Ord(D3DTOP_DISABLE));
15000
    SetTextureStageState(1, D3DTSS_ALPHAOP, Ord(D3DTOP_DISABLE));
15001
    SetRenderState(D3DRENDERSTATE_ALPHABLENDENABLE, 0);
15002
  end;
15003
end;
15004
 
15005
procedure TD2D.D2DMeshMapToRect(R: TRect);
15006
begin
15007
  FVertex[0].sx := R.Left - 0.5;
15008
  FVertex[0].sy := R.Top - 0.5;
15009
  FVertex[1].sx := R.Right - 0.5;
15010
  FVertex[1].sy := R.Top - 0.5;
15011
  FVertex[2].sx := R.Left - 0.5;
15012
  FVertex[2].sy := R.Bottom - 0.5;
15013
  FVertex[3].sx := R.Right - 0.5;
15014
  FVertex[3].sy := R.Bottom - 0.5;
15015
end;
15016
 
15017
function TD2D.D2DInitializeSurface: Boolean;
15018
begin
15019
  Result := False;
15020
  if Assigned(FDDraw.D3DDevice7) then
15021
    Result := FDDraw.D3DDevice7.SetRenderTarget(FDDraw.Surface.IDDSurface7, 0) = DD_OK;
15022
end;
15023
 
15024
procedure TD2D.D2DUpdateTextures;
15025
var I: Integer;
15026
begin
15027
  {$IFDEF VER4UP}
15028
  for I := Low(FD2DTexture.Texture) to High(FD2DTexture.Texture) do
15029
  {$ELSE}
15030
  for I := 0 to FD2DTexture.TexLen - 1 do
15031
  {$ENDIF}
15032
  begin
15033
    FD2DTexture.Texture[I].Width := FD2DTexture.Texture[I].D2DTexture.Surface.Width;
15034
    FD2DTexture.Texture[I].Height := FD2DTexture.Texture[I].D2DTexture.Surface.Height;
15035
//    FD2DTexture.Texture[I].AlphaChannel := ?
15036
  end;
15037
end;
15038
 
15039
{  TTrace  }
15040
 
15041
constructor TTrace.Create(Collection: TCollection);
15042
begin
15043
  inherited Create(Collection);
15044
  FBlit := TBlit.Create(Self);
15045
  FBlit.FEngine := TCustomDXDraw(Traces.FOwner);
15046
end;
15047
 
15048
destructor TTrace.Destroy;
15049
begin
15050
  FBlit.Free;
15051
  inherited Destroy;
15052
end;
15053
 
15054
function TTrace.GetDisplayName: string;
15055
begin
15056
  Result := inherited GetDisplayName
15057
end;
15058
 
15059
procedure TTrace.SetDisplayName(const Value: string);
15060
begin
15061
  if (Value <> '') and (AnsiCompareText(Value, GetDisplayName) <> 0) and
15062
    (Collection is TTraces) and (TTraces(Collection).IndexOf(Value) >= 0) then
15063
    raise Exception.Create(Format('Item duplicate name "%s" error', [Value]));
15064
  inherited SetDisplayName(Value);
15065
end;
15066
 
15067
function TTrace.GetTraces: TTraces;
15068
begin
15069
  if Collection is TTraces then
15070
    Result := TTraces(Collection)
15071
  else
15072
    Result := nil;
15073
end;
15074
 
15075
procedure TTrace.Render(const LagCount: Integer);
15076
begin
15077
  FBlit.DoMove(LagCount);
15078
  FBlit.DoCollision;
15079
  FBlit.DoDraw;
15080
  if Assigned(FBlit.FOnRender) then
15081
    FBlit.FOnRender(FBlit);
15082
end;
15083
 
15084
function TTrace.IsActualized: Boolean;
15085
begin
15086
  Result := FActualized;
15087
end;
15088
 
15089
procedure TTrace.Assign(Source: TPersistent);
15090
begin
15091
  if Source is TTrace then begin
15092
    //FTracePoints.Assign(TTrace(Source).FTracePoints);
15093
    FBlit.Assign(TTrace(Source).FBlit);
15094
    FTag := TTrace(Source).FTag;
15095
  end
15096
  else
15097
    inherited Assign(Source);
15098
end;
15099
 
15100
function TTrace.GetActive: Boolean;
15101
begin
15102
  Result := FBlit.FActive;
15103
end;
15104
 
15105
procedure TTrace.SetActive(const Value: Boolean);
15106
begin
15107
  FBlit.FActive := Value;
15108
end;
15109
 
15110
function TTrace.GetOnCollision: TNotifyEvent;
15111
begin
15112
  Result := FBlit.FOnCollision;
15113
end;
15114
 
15115
procedure TTrace.SetOnCollision(const Value: TNotifyEvent);
15116
begin
15117
  FBlit.FOnCollision := Value;
15118
end;
15119
 
15120
function TTrace.GetOnGetImage: TNotifyEvent;
15121
begin
15122
  Result := FBlit.FOnGetImage;
15123
end;
15124
 
15125
procedure TTrace.SetOnGetImage(const Value: TNotifyEvent);
15126
begin
15127
  FBlit.FOnGetImage := Value;
15128
end;
15129
 
15130
function TTrace.GetOnDraw: TNotifyEvent;
15131
begin
15132
  Result := FBlit.FOnDraw;
15133
end;
15134
 
15135
procedure TTrace.SetOnDraw(const Value: TNotifyEvent);
15136
begin
15137
  FBlit.FOnDraw := Value;
15138
end;
15139
 
15140
function TTrace.GetOnMove: TBlitMoveEvent;
15141
begin
15142
  Result := FBlit.FOnMove;
15143
end;
15144
 
15145
procedure TTrace.SetOnMove(const Value: TBlitMoveEvent);
15146
begin
15147
  FBlit.FOnMove := Value;
15148
end;
15149
 
15150
function TTrace.Clone(NewName: string; OffsetX, OffsetY: Integer;
15151
  Angle: Single): TTrace;
15152
var
15153
  NewItem: TTrace;
15154
  I: Integer;
15155
begin
15156
  NewItem := GetTraces.Add;
15157
  NewItem.Assign(Self);
15158
  NewItem.Name := NewName;
15159
  for I := 0 to NewItem.Blit.GetPathCount - 1 do begin
15160
    NewItem.Blit.FPathArr[I].X := NewItem.Blit.FPathArr[I].X + OffsetX;
15161
    NewItem.Blit.FPathArr[I].Y := NewItem.Blit.FPathArr[I].Y + OffsetY;
15162
  end;
15163
  Result := NewItem
15164
end;
15165
 
15166
function TTrace.GetOnRender: TOnRender;
15167
begin
15168
  Result := FBlit.FOnRender;
15169
end;
15170
 
15171
procedure TTrace.SetOnRender(const Value: TOnRender);
15172
begin
15173
  FBlit.FOnRender := Value;
15174
end;
15175
 
15176
{  TTraces  }
15177
 
15178
constructor TTraces.Create(AOwner: TComponent);
15179
begin
15180
  inherited Create(TTrace);
15181
  FOwner := AOwner;
15182
end;
15183
 
15184
destructor TTraces.Destroy;
15185
begin
15186
  inherited Destroy;
15187
end;
15188
 
15189
function TTraces.Add: TTrace;
15190
begin
15191
  Result := TTrace(inherited Add);
15192
end;
15193
 
15194
function TTraces.Find(const Name: string): TTrace;
15195
var
15196
  i: Integer;
15197
begin
15198
  i := IndexOf(Name);
15199
  if i = -1 then
15200
    raise EDXTracerError.CreateFmt('Tracer item named %s not found', [Name]);
15201
  Result := Items[i];
15202
end;
15203
 
15204
function TTraces.GetItem(Index: Integer): TTrace;
15205
begin
15206
  Result := TTrace(inherited GetItem(Index));
15207
end;
15208
 
15209
procedure TTraces.SetItem(Index: Integer;
15210
  Value: TTrace);
15211
begin
15212
  inherited SetItem(Index, Value);
15213
end;
15214
 
15215
procedure TTraces.Update(Item: TCollectionItem);
15216
begin
15217
  inherited Update(Item);
15218
end;
15219
 
15220
{$IFDEF VER4UP}
15221
function TTraces.Insert(Index: Integer): TTrace;
15222
begin
15223
  Result := TTrace(inherited Insert(Index));
15224
end;
15225
{$ENDIF}
15226
 
15227
function TTraces.GetOwner: TPersistent;
15228
begin
15229
  Result := FOwner;
15230
end;
15231
 
15232
{  TBlit  }
15233
 
15234
function TBlit.GetWorldX: Double;
15235
begin
15236
  if Parent <> nil then
15237
    Result := Parent.WorldX + FBlitRec.FX
15238
  else
15239
    Result := FBlitRec.FX;
15240
end;
15241
 
15242
function TBlit.GetWorldY: Double;
15243
begin
15244
  if Parent <> nil then
15245
    Result := Parent.WorldY + FBlitRec.FY
15246
  else
15247
    Result := FBlitRec.FY;
15248
end;
15249
 
15250
procedure TBlit.DoMove(LagCount: Integer);
15251
var
15252
  MoveIt: Boolean;
15253
begin
15254
  if not FBlitRec.FMoved then Exit;
15255
  if AsSigned(FOnMove) then begin
15256
    MoveIt := True; {if nothing then reanimate will force}
15257
    FOnMove(Self, LagCount, MoveIt); {when returned MoveIt = true still that do not move}
15258
    if MoveIt then
15259
      ReAnimate(LagCount); //for reanimation
15260
  end
15261
  else begin
15262
    ReAnimate(LagCount);
15263
  end;
15264
  {there is moving to next foot of the path}
15265
  if Active then
15266
    if GetPathCount > 0 then begin
15267
      Dec(FCurrentTime, LagCount);
15268
      if FCurrentTime < 0 then begin
15269
        if FBustrofedon then begin
15270
          case FCurrentDirection of
15271
            True: begin
15272
                Inc(FCurrentPosition); //go forward
15273
                if FCurrentPosition = (GetPathCount - 1) then
15274
                  FCurrentDirection := not FCurrentDirection //change direction
15275
              end;
15276
            False: begin
15277
                Dec(FCurrentPosition); //go backward
15278
                if FCurrentPosition = 0 then
15279
                  FCurrentDirection := not FCurrentDirection //change direction
15280
              end;
15281
          end;
15282
        end
15283
        else
15284
          if FCurrentPosition < (GetPathCount - 1) then begin
15285
            Inc(FCurrentPosition) //go forward only
15286
          end
15287
          else
15288
            if FMovingRepeatly then
15289
              FCurrentPosition := 0; {return to start}
15290
        {get actual new value for showing time}
15291
        {must be pick-up there, after change of the current position}
15292
        FCurrentTime := Path[FCurrentPosition].StayOn; {cas mezi pohyby}
15293
      end;
15294
      X := Path[FCurrentPosition].X;
15295
      Y := Path[FCurrentPosition].Y;
15296
    end;
15297
  {}
15298
end;
15299
 
15300
function TBlit.GetDrawImageIndex: Integer;
15301
begin
15302
  Result := FBlitRec.FAnimStart + Trunc(FBlitRec.FAnimPos);
15303
end;
15304
 
15305
procedure TBlit.DoDraw;
15306
var
15307
  f: TRenderMirrorFlipSet;
15308
  r: TRect;
15309
begin
15310
  with FBlitRec do begin
15311
    if not FVisible then Exit;
15312
    if FImage = nil then DoGetImage;
15313
    if FImage = nil then Exit;
15314
    {owner draw called here}
15315
    if AsSigned(FOnDraw) then
15316
      FOnDraw(Self)
15317
    else
15318
    {when is not owner draw then go here}
15319
    begin
15320
      f := [];
15321
      if FMirror then f := f + [rmfMirror];
15322
      if FFlip then f := f + [rmfFlip];
15323
      r := Bounds(Round(FX), Round(FY), FImage.Width, FImage.Height);
15324
      DXDraw_Render(FEngine, FImage, r,
15325
        GetDrawImageIndex, FBlurImageArr, FBlurImage, FTextureFilter, f, FBlendMode, FAngle,
15326
        FAlpha, FCenterX, FCenterY, FScale, FWaveType, FAmplitude, FAmpLength, FPhase);
15327
    end;
15328
  end
15329
end;
15330
 
15331
function Mod2f(i: Double; i2: Integer): Double;
15332
begin
15333
  if i2 = 0 then
15334
    Result := i
15335
  else
15336
  begin
15337
    Result := i - Round(i / i2) * i2;
15338
    if Result < 0 then
15339
      Result := i2 + Result;
15340
  end;
15341
end;
15342
 
15343
procedure TBlit.ReAnimate(MoveCount: Integer);
15344
var I: Integer;
15345
begin
15346
  with FBlitRec do begin
15347
    FAnimPos := FAnimPos + FAnimSpeed * MoveCount;
15348
 
15349
    if FAnimLooped then
15350
    begin
15351
      if FAnimCount > 0 then
15352
        FAnimPos := Mod2f(FAnimPos, FAnimCount)
15353
      else
15354
        FAnimPos := 0;
15355
    end
15356
    else
15357
    begin
15358
      if Round(FAnimPos) >= FAnimCount then
15359
      begin
15360
        FAnimPos := FAnimCount - 1;
15361
        FAnimSpeed := 0;
15362
      end;
15363
      if FAnimPos < 0 then
15364
      begin
15365
        FAnimPos := 0;
15366
        FAnimSpeed := 0;
15367
      end;
15368
    end;
15369
    {incerease or decrease speed}
15370
    if (FEnergy <> 0) then begin
15371
      FSpeedX := FSpeedX + FSpeedX * FEnergy;
15372
      FSpeedY := FSpeedY + FSpeedY * FEnergy;
15373
    end;
15374
    {adjust with speed}
15375
    if (FSpeedX > 0) or (FSpeedY > 0) then begin
15376
      FX := FX + FSpeedX * MoveCount;
15377
      FY := FY + FSpeedY * MoveCount;
15378
    end;
15379
    {and gravity aplicable}
15380
    if (FGravityX > 0) or (FGravityY > 0) then begin
15381
      FX := FX + FGravityX * MoveCount;
15382
      FY := FY + FGravityY * MoveCount;
15383
    end;
15384
    if FBlurImage then begin
15385
      {ale jen jsou-li jine souradnice}
15386
      if (FBlurImageArr[High(FBlurImageArr)].eX <> Round(WorldX)) or
15387
      (FBlurImageArr[High(FBlurImageArr)].eY <> Round(WorldY)) then begin
15388
        for i := Low(FBlurImageArr) + 1 to High(FBlurImageArr) do begin
15389
          FBlurImageArr[i - 1] := FBlurImageArr[i];
15390
          {adjust the blur intensity}
15391
          FBlurImageArr[i - 1].eIntensity := Round(FAlpha / (High(FBlurImageArr) + 1)) * (i - 1);
15392
        end;
15393
        with FBlurImageArr[High(FBlurImageArr)] do begin
15394
          eX := Round(WorldX);
15395
          eY := Round(WorldY);
15396
          ePatternIndex := GetDrawImageIndex;
15397
          eIntensity := Round(FAlpha / (High(FBlurImageArr) + 1)) * High(FBlurImageArr);
15398
          eBlendMode := FBlendMode;
15399
          eActive := True;
15400
        end;
15401
      end;
15402
    end;
15403
  end;
15404
end;
15405
 
15406
function TBlit.DoCollision: TBlit;
15407
var
15408
  i, maxzaxis: Integer;
15409
begin
15410
  Result := nil;
15411
  if not FBlitRec.FCollisioned then Exit;
15412
  if AsSigned(FOnCollision) then
15413
    FOnCollision(Self)
15414
  else begin
15415
    {over z axis}
15416
    maxzaxis := 0;
15417
    for i := 0 to FEngine.Traces.Count - 1 do
15418
      maxzaxis := Max(maxzaxis, FEngine.Traces.Items[i].FBlit.Z);
15419
    {for all items}
15420
    for i := 0 to FEngine.Traces.Count - 1 do
15421
      {no self item}
15422
      if FEngine.Traces.Items[i].FBlit <> Self then
15423
        {through engine}
15424
        with FEngine.Traces.Items[i] do
15425
          {test overlap}
15426
          if OverlapRect(Bounds(Round(FBlit.WorldX), Round(FBlit.WorldY),
15427
            FBlit.Width, FBlit.Height), Bounds(Round(WorldX), Round(WorldY), Width, Height)) then
15428
          begin
15429
            {if any, then return first blit}
15430
            Result := FBlit;
15431
            {and go out}
15432
            Break;
15433
          end;
15434
  end;
15435
end;
15436
 
15437
procedure TBlit.DoGetImage;
15438
begin
15439
  {init image when object come from form}
15440
  if FImage = nil then
15441
    if AsSigned(FOnGetImage) then begin
15442
      FOnGetImage(Self);
15443
      if FImage = nil then
15444
        raise EDXBlitError.Create('Undefined image file!');
15445
      FBlitRec.FWidth := FImage.Width;
15446
      FBlitRec.FHeight := FImage.Height;
15447
    end;
15448
end;
15449
 
15450
constructor TBlit.Create(AParent: TObject);
15451
begin
15452
  inherited Create;
15453
  FParent := nil;
15454
  if AParent is TBlit then
15455
    FParent := TBlit(AParent);
15456
  FillChar(FBlitRec, SizeOf(FBlitRec), 0);
15457
  with FBlitRec do begin
15458
    FCollisioned := True; {can be collisioned}
15459
    FMoved := True; {can be moved}
15460
    FVisible := True; {can be rendered}
15461
    FAnimCount := 0;
15462
    FAnimLooped := False;
15463
    FAnimPos := 0;
15464
    FAnimSpeed := 0;
15465
    FAnimStart := 0;
15466
    FAngle := 0;
15467
    FAlpha := $FF;
15468
    FCenterX := 0.5;
15469
    FCenterY := 0.5;
15470
    FScale := 1;
15471
    FBlendMode := rtDraw;
15472
    FAmplitude := 0;
15473
    FAmpLength := 0;
15474
    FPhase := 0;
15475
    FWaveType := wtWaveNone;
15476
    FSpeedX := 0;
15477
    FSpeedY := 0;
15478
    FGravityX := 0;
15479
    FGravityY := 0;
15480
    FEnergy := 0;
15481
    FBlurImage := False;
15482
    FMirror := False;
15483
    FFlip := False;
15484
  end;
15485
  FillChar(FBlurImageArr, SizeOf(FBlitRec), 0);
15486
  FActive := True; {active on}
15487
  FMovingRepeatly := True;
15488
  {super private}
15489
  FCurrentTime := 0;
15490
  FCurrentPosition := 0;
15491
  FCurrentDirection := True;
15492
end;
15493
 
15494
destructor TBlit.Destroy;
15495
begin
15496
  {$IFDEF VER4UP}
15497
  SetLength(FPathArr, 0);
15498
  {$ELSE}
15499
  SetPathLen(0);
15500
  {$ENDIF}
15501
  inherited;
15502
end;
15503
 
15504
function TBlit.GetMoved: Boolean;
15505
begin
15506
  Result := FBlitRec.FMoved;
15507
end;
15508
 
15509
procedure TBlit.SetMoved(const Value: Boolean);
15510
begin
15511
  FBlitRec.FMoved := Value;
15512
end;
15513
 
15514
function TBlit.GetWaveType: TWaveType;
15515
begin
15516
  Result := FBlitRec.FWaveType;
15517
end;
15518
 
15519
procedure TBlit.SetWaveType(const Value: TWaveType);
15520
begin
15521
  FBlitRec.FWaveType := Value;
15522
end;
15523
 
15524
function TBlit.GetAmplitude: Integer;
15525
begin
15526
  Result := FBlitRec.FAmplitude;
15527
end;
15528
 
15529
procedure TBlit.SetAmplitude(const Value: Integer);
15530
begin
15531
  FBlitRec.FAmplitude := Value;
15532
end;
15533
 
15534
function TBlit.GetAnimStart: Integer;
15535
begin
15536
  Result := FBlitRec.FAnimStart;
15537
end;
15538
 
15539
procedure TBlit.SetAnimStart(const Value: Integer);
15540
begin
15541
  FBlitRec.FAnimStart := Value;
15542
end;
15543
 
15544
function TBlit.GetAmpLength: Integer;
15545
begin
15546
  Result := FBlitRec.FAmpLength;
15547
end;
15548
 
15549
procedure TBlit.SetAmpLength(const Value: Integer);
15550
begin
15551
  FBlitRec.FAmpLength := Value;
15552
end;
15553
 
15554
function TBlit.GetWidth: Integer;
15555
begin
15556
  Result := FBlitRec.FWidth;
15557
end;
15558
 
15559
procedure TBlit.SetWidth(const Value: Integer);
15560
begin
15561
  FBlitRec.FWidth := Value;
15562
end;
15563
 
15564
function TBlit.GetGravityX: Single;
15565
begin
15566
  Result := FBlitRec.FGravityX;
15567
end;
15568
 
15569
procedure TBlit.SetGravityX(const Value: Single);
15570
begin
15571
  FBlitRec.FGravityX := Value;
15572
end;
15573
 
15574
function TBlit.StoreGravityX: Boolean;
15575
begin
15576
  Result := FBlitRec.FGravityX <> 1.0;
15577
end;
15578
 
15579
function TBlit.GetPhase: Integer;
15580
begin
15581
  Result := FBlitRec.FPhase;
15582
end;
15583
 
15584
procedure TBlit.SetPhase(const Value: Integer);
15585
begin
15586
  FBlitRec.FPhase := Value;
15587
end;
15588
 
15589
function TBlit.GetAnimPos: Double;
15590
begin
15591
  Result := FBlitRec.FAnimPos;
15592
end;
15593
 
15594
procedure TBlit.SetAnimPos(const Value: Double);
15595
begin
15596
  FBlitRec.FAnimPos := Value;
15597
end;
15598
 
15599
function TBlit.StoreAnimPos: Boolean;
15600
begin
15601
  Result := FBlitRec.FAnimPos <> 0;
15602
end;
15603
 
15604
function TBlit.GetFlip: Boolean;
15605
begin
15606
  Result := FBlitRec.FFlip;
15607
end;
15608
 
15609
procedure TBlit.SetFlip(const Value: Boolean);
15610
begin
15611
  FBlitRec.FFlip := Value;
15612
end;
15613
 
15614
function TBlit.GetGravityY: Single;
15615
begin
15616
  Result := FBlitRec.FGravityY;
15617
end;
15618
 
15619
procedure TBlit.SetGravityY(const Value: Single);
15620
begin
15621
  FBlitRec.FGravityY := Value;
15622
end;
15623
 
15624
function TBlit.StoreGravityY: Boolean;
15625
begin
15626
  Result := FBlitRec.FGravityY <> 1.0;
15627
end;
15628
 
15629
function TBlit.GetSpeedX: Single;
15630
begin
15631
  Result := FBlitRec.FSpeedX;
15632
end;
15633
 
15634
procedure TBlit.SetSpeedX(const Value: Single);
15635
begin
15636
  FBlitRec.FSpeedX := Value;
15637
end;
15638
 
15639
function TBlit.StoreSpeedX: Boolean;
15640
begin
15641
  Result := FBlitRec.FSpeedX <> 0;
15642
end;
15643
 
15644
function TBlit.GetSpeedY: Single;
15645
begin
15646
  Result := FBlitRec.FSpeedY;
15647
end;
15648
 
15649
procedure TBlit.SetSpeedY(const Value: Single);
15650
begin
15651
  FBlitRec.FSpeedY := Value;
15652
end;
15653
 
15654
function TBlit.StoreSpeedY: Boolean;
15655
begin
15656
  Result := FBlitRec.FSpeedY <> 0;
15657
end;
15658
 
15659
function TBlit.GetCenterX: Double;
15660
begin
15661
  Result := FBlitRec.FCenterX;
15662
end;
15663
 
15664
procedure TBlit.SetCenterX(const Value: Double);
15665
begin
15666
  FBlitRec.FCenterX := Value;
15667
end;
15668
 
15669
function TBlit.StoreCenterX: Boolean;
15670
begin
15671
  Result := FBlitRec.FCenterX <> 0.5;
15672
end;
15673
 
15674
function TBlit.GetAngle: Single;
15675
begin
15676
  Result := FBlitRec.FAngle;
15677
end;
15678
 
15679
procedure TBlit.SetAngle(const Value: Single);
15680
begin
15681
  FBlitRec.FAngle := Value;
15682
end;
15683
 
15684
function TBlit.StoreAngle: Boolean;
15685
begin
15686
  Result := FBlitRec.FAngle <> 0;
15687
end;
15688
 
15689
function TBlit.GetBlurImage: Boolean;
15690
begin
15691
  Result := FBlitRec.FBlurImage;
15692
end;
15693
 
15694
procedure TBlit.SetBlurImage(const Value: Boolean);
15695
begin
15696
  FBlitRec.FBlurImage := Value;
15697
end;
15698
 
15699
function TBlit.GetCenterY: Double;
15700
begin
15701
  Result := FBlitRec.FCenterY;
15702
end;
15703
 
15704
procedure TBlit.SetCenterY(const Value: Double);
15705
begin
15706
  FBlitRec.FCenterY := Value;
15707
end;
15708
 
15709
function TBlit.StoreCenterY: Boolean;
15710
begin
15711
  Result := FBlitRec.FCenterY <> 0.5;
15712
end;
15713
 
15714
function TBlit.GetBlendMode: TRenderType;
15715
begin
15716
  Result := FBlitRec.FBlendMode;
15717
end;
15718
 
15719
procedure TBlit.SetBlendMode(const Value: TRenderType);
15720
begin
15721
  FBlitRec.FBlendMode := Value;
15722
end;
15723
 
15724
function TBlit.GetAnimSpeed: Double;
15725
begin
15726
  Result := FBlitRec.FAnimSpeed;
15727
end;
15728
 
15729
procedure TBlit.SetAnimSpeed(const Value: Double);
15730
begin
15731
  FBlitRec.FAnimSpeed := Value;
15732
end;
15733
 
15734
function TBlit.StoreAnimSpeed: Boolean;
15735
begin
15736
  Result := FBlitRec.FAnimSpeed <> 0;
15737
end;
15738
 
15739
function TBlit.GetZ: Integer;
15740
begin
15741
  Result := FBlitRec.FZ;
15742
end;
15743
 
15744
procedure TBlit.SetZ(const Value: Integer);
15745
begin
15746
  FBlitRec.FZ := Value;
15747
end;
15748
 
15749
function TBlit.GetMirror: Boolean;
15750
begin
15751
  Result := FBlitRec.FMirror;
15752
end;
15753
 
15754
procedure TBlit.SetMirror(const Value: Boolean);
15755
begin
15756
  FBlitRec.FMirror := Value;
15757
end;
15758
 
15759
function TBlit.GetX: Double;
15760
begin
15761
  Result := FBlitRec.FX;
15762
end;
15763
 
15764
procedure TBlit.SetX(const Value: Double);
15765
begin
15766
  FBlitRec.FX := Value;
15767
end;
15768
 
15769
function TBlit.GetVisible: Boolean;
15770
begin
15771
  Result := FBlitRec.FVisible;
15772
end;
15773
 
15774
procedure TBlit.SetVisible(const Value: Boolean);
15775
begin
15776
  FBlitRec.FVisible := Value;
15777
end;
15778
 
15779
function TBlit.GetY: Double;
15780
begin
15781
  Result := FBlitRec.FY;
15782
end;
15783
 
15784
procedure TBlit.SetY(const Value: Double);
15785
begin
15786
  FBlitRec.FY := Value;
15787
end;
15788
 
15789
function TBlit.GetAlpha: Byte;
15790
begin
15791
  Result := FBlitRec.FAlpha;
15792
end;
15793
 
15794
procedure TBlit.SetAlpha(const Value: Byte);
15795
begin
15796
  FBlitRec.FAlpha := Value;
15797
end;
15798
 
15799
function TBlit.GetEnergy: Single;
15800
begin
15801
  Result := FBlitRec.FEnergy;
15802
end;
15803
 
15804
procedure TBlit.SetEnergy(const Value: Single);
15805
begin
15806
  FBlitRec.FEnergy := Value;
15807
end;
15808
 
15809
function TBlit.StoreEnergy: Boolean;
15810
begin
15811
  Result := FBlitRec.FEnergy <> 0;
15812
end;
15813
 
15814
function TBlit.GetCollisioned: Boolean;
15815
begin
15816
  Result := FBlitRec.FCollisioned;
15817
end;
15818
 
15819
procedure TBlit.SetCollisioned(const Value: Boolean);
15820
begin
15821
  FBlitRec.FCollisioned := Value;
15822
end;
15823
 
15824
function TBlit.GetAnimLooped: Boolean;
15825
begin
15826
  Result := FBlitRec.FAnimLooped;
15827
end;
15828
 
15829
procedure TBlit.SetAnimLooped(const Value: Boolean);
15830
begin
15831
  FBlitRec.FAnimLooped := Value;
15832
end;
15833
 
15834
function TBlit.GetHeight: Integer;
15835
begin
15836
  Result := FBlitRec.FHeight;
15837
end;
15838
 
15839
procedure TBlit.SetHeight(const Value: Integer);
15840
begin
15841
  FBlitRec.FHeight := Value;
15842
end;
15843
 
15844
function TBlit.GetScale: Double;
15845
begin
15846
  Result := FBlitRec.FScale;
15847
end;
15848
 
15849
procedure TBlit.SetScale(const Value: Double);
15850
begin
15851
  FBlitRec.FScale := Value;
15852
end;
15853
 
15854
function TBlit.StoreScale: Boolean;
15855
begin
15856
  Result := FBlitRec.FScale <> 1.0;
15857
end;
15858
 
15859
function TBlit.GetAnimCount: Integer;
15860
begin
15861
  Result := FBlitRec.FAnimCount;
15862
end;
15863
 
15864
procedure TBlit.SetAnimCount(const Value: Integer);
15865
begin
15866
  FBlitRec.FAnimCount := Value;
15867
end;
15868
 
15869
function TBlit.GetTextureFilter: TD2DTextureFilter;
15870
begin
15871
  Result := FBlitRec.FTextureFilter;
15872
end;
15873
 
15874
procedure TBlit.SetTextureFilter(const Value: TD2DTextureFilter);
15875
begin
15876
  FBlitRec.FTextureFilter := Value;
15877
end;
15878
 
15879
function TBlit.GetBoundsRect: TRect;
15880
begin
15881
  Result := Bounds(Round(WorldX), Round(WorldY), Width, Height);
15882
end;
15883
 
15884
function TBlit.GetClientRect: TRect;
15885
begin
15886
  Result := Bounds(0, 0, Width, Height);
15887
end;
15888
 
15889
function TBlit.GetBlitAt(X, Y: Integer): TBlit;
15890
 
15891
  procedure BlitAt(X, Y: Double; Blit: TBlit);
15892
  var
15893
    i: Integer;
15894
    X2, Y2: Double;
15895
  begin
15896
    if Blit.Visible and PointInRect(Point(Round(X), Round(Y)),
15897
      Bounds(Round(Blit.X), Round(Blit.Y), Blit.Width, Blit.Width)) then
15898
    begin
15899
      if (Result = nil) or (Blit.Z > Result.Z) then
15900
        Result := Blit; {uniquelly - where will be store last blit}
15901
    end;
15902
 
15903
    X2 := X - Blit.X;
15904
    Y2 := Y - Blit.Y;
15905
    for i := 0 to Blit.Engine.FTraces.Count - 1 do
15906
      BlitAt(X2, Y2, Blit.Engine.FTraces.Items[i].FBlit);
15907
  end;
15908
 
15909
var
15910
  i: Integer;
15911
  X2, Y2: Double;
15912
begin
15913
  Result := nil;
15914
 
15915
  X2 := X - Self.X;
15916
  Y2 := Y - Self.Y;
15917
  for i := 0 to Engine.FTraces.Count - 1 do
15918
    BlitAt(X2, Y2, Engine.FTraces.Items[i].FBlit);
15919
end;
15920
 
15921
procedure TBlit.SetPathLen(Len: Integer);
15922
var I, L: Integer;
15923
begin
15924
  {$IFDEF VER4UP}
15925
  if Length(FPathArr) <> Len then
15926
  {$ELSE}
15927
  if FPathLen <> Len then
15928
  {$ENDIF}
15929
  begin
15930
    L := Len;
15931
    if Len <= 0 then L := 0;
15932
    {$IFDEF VER4UP}
15933
    SetLength(FPathArr, L);
15934
    for I := Low(FPathArr) to High(FPathArr) do begin
15935
      FillChar(FPathArr[i], SizeOf(FPathArr), 0);
15936
      FPathArr[i].StayOn := 25;
15937
    end;
15938
    {$ELSE}
15939
    FPathLen := L;
15940
    if FPathArr = nil then
15941
      FPAthArr := AllocMem(FPathLen * SizeOf(TPath))
15942
    else
15943
      {alokuj pamet}
15944
      ReallocMem(FPathArr, FPathLen * SizeOf(TPath));
15945
    if Assigned(FPathArr) then begin
15946
      FillChar(FPathArr^, FPathLen * SizeOf(TPath), 0);
15947
      for I := 0 to FPathLen do
15948
        FPathArr[i].StayOn := 25;
15949
    end
15950
    {$ENDIF}
15951
  end;
15952
end;
15953
 
15954
function TBlit.IsPathEmpty: Boolean;
15955
begin
15956
  {$IFNDEF VER4UP}
15957
  Result := FPathLen = 0;
15958
  {$ELSE}
15959
  Result := Length(FPathArr) = 0;
15960
  {$ENDIF}
15961
end;
15962
 
15963
function TBlit.GetPathCount: Integer;
15964
begin
15965
  {$IFNDEF VER4UP}
15966
  Result := FPathLen;
15967
  {$ELSE}
15968
  Result := Length(FPathArr);
15969
  {$ENDIF}
15970
end;
15971
 
15972
function TBlit.GetPath(index: Integer): TPath;
15973
begin
15974
  {$IFDEF VER4UP}
15975
  if (index >= Low(FPathArr)) and (index <= High(FPathArr)) then
15976
  {$ELSE}
15977
  if (index >= 0) and (index < FPathLen) then
15978
  {$ENDIF}
15979
    Result := FPathArr[index]
15980
  else
15981
    raise Exception.Create('Bad path index!');
15982
end;
15983
 
15984
procedure TBlit.SetPath(index: Integer; const Value: TPath);
15985
begin
15986
  {$IFDEF VER4UP}
15987
  if (index >= Low(FPathArr)) and (index <= High(FPathArr)) then
15988
  {$ELSE}
15989
  if (index >= 0) and (index < FPathLen) then
15990
  {$ENDIF}
15991
    FPathArr[index] := Value
15992
  else
15993
    raise Exception.Create('Bad path index!');
15994
end;
15995
 
15996
procedure TBlit.ReadPaths(Stream: TStream);
15997
var
15998
  PathLen: Integer;
15999
begin
16000
  {nacti delku}
16001
  Stream.ReadBuffer(PathLen, SizeOf(PathLen));
16002
  SetPathLen(PathLen);
16003
  Stream.ReadBuffer(FPathArr[0], PathLen * SizeOf(TPath));
16004
end;
16005
 
16006
procedure TBlit.WritePaths(Stream: TStream);
16007
var
16008
  PathLen: Integer;
16009
begin
16010
  PathLen := GetPathCount;
16011
  Stream.WriteBuffer(PathLen, SizeOf(PathLen));
16012
  Stream.WriteBuffer(FPathArr[0], PathLen * SizeOf(TPath));
16013
end;
16014
 
16015
procedure TBlit.DefineProperties(Filer: TFiler);
16016
begin
16017
  inherited DefineProperties(Filer);
16018
  Filer.DefineBinaryProperty('Paths', ReadPaths, WritePaths, not IsPathEmpty);
16019
end;
16020
 
16021
procedure TBlit.Assign(Source: TPersistent);
16022
var I: Integer;
16023
begin
16024
  if Source is TBlit then
16025
  begin
16026
    {$IFDEF VER4UP}
16027
    I := Length(TBlit(Source).FPathArr);
16028
    {$ELSE}
16029
    I := FPathLen;
16030
    {$ENDIF}
16031
    SetPathLen(I);
16032
    if I > 0 then
16033
      Move(TBlit(Source).FPathArr[0], FPathArr[0], I * SizeOf(TPath));
16034
    FBlitRec := TBlit(Source).FBlitRec;
16035
    FillChar(FBlurImageArr, SizeOf(FBlurImageArr), 0);
16036
    FActive := TBlit(Source).FActive;
16037
    FMovingRepeatly := TBlit(Source).FMovingRepeatly;
16038
    FImage := nil;
16039
    FOnMove := TBlit(Source).FOnMove;
16040
    FOnDraw := TBlit(Source).FOnDraw;
16041
    FOnCollision := TBlit(Source).FOnCollision;
16042
    FOnGetImage := TBlit(Source).FOnGetImage;
16043
    FEngine := TBlit(Source).FEngine;
16044
  end
16045
  else
16046
    inherited Assign(Source);
16047
end;
16048
 
16049
function TBlit.GetMovingRepeatly: Boolean;
16050
begin
16051
  Result := FMovingRepeatly;
16052
end;
16053
 
16054
procedure TBlit.SetMovingRepeatly(const Value: Boolean);
16055
begin
16056
  FMovingRepeatly := Value;
16057
end;
16058
 
16059
function TBlit.GetBustrofedon: Boolean;
16060
begin
16061
  Result := FBustrofedon;
16062
end;
16063
 
16064
procedure TBlit.SetBustrofedon(const Value: Boolean);
16065
begin
16066
  FBustrofedon := Value;
16067
end;
16068
 
16069
{  utility draw  }
16070
 
16071
procedure DXDraw_Draw(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
16072
  Rect: TRect; Pattern: Integer; TextureFilter: TD2DTextureFilter;
16073
  MirrorFlip: TRenderMirrorFlipSet;
16074
  BlendMode: TRenderType; Angle: Single; Alpha: Byte;
16075
  CenterX: Double; CenterY: Double;
16076
  Scale: Single); {$IFDEF VER9UP}inline;{$ENDIF}
16077
var
16078
//  r: TRect;
16079
  width, height: Integer;
16080
begin
16081
  if not Assigned(DXDraw.Surface) then Exit;
16082
  if not Assigned(Image) then Exit;
16083
  if Scale <> 1.0 then begin
16084
    width := Round(Scale * Image.Width);
16085
    height := Round(Scale * Image.Height);
16086
  end
16087
  else begin
16088
    width := Image.Width;
16089
    height := Image.Height;
16090
  end;
16091
  //r := Bounds(X, Y, width, height);
16092
  DXDraw.TextureFilter(TextureFilter);
16093
  DXDraw.MirrorFlip(MirrorFlip);
16094
  case BlendMode of
16095
    rtDraw: begin
16096
        if Angle = 0 then
16097
          Image.StretchDraw(DXDraw.Surface, Rect, Pattern)
16098
        else
16099
          Image.DrawRotate(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
16100
            (Rect.Top + Rect.Bottom) div 2,
16101
            Width, Height, Pattern, CenterX, CenterY, Angle);
16102
      end;
16103
    rtBlend: begin
16104
        if Angle = 0 then
16105
          Image.DrawAlpha(DXDraw.Surface, Rect, Pattern, Alpha)
16106
        else
16107
          Image.DrawRotateAlpha(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
16108
            (Rect.Top + Rect.Bottom) div 2,
16109
            Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
16110
      end;
16111
    rtAdd: begin
16112
        if Angle = 0 then
16113
          Image.DrawAdd(DXDraw.Surface, Rect, Pattern, Alpha)
16114
        else
16115
          Image.DrawRotateAdd(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
16116
            (Rect.Top + Rect.Bottom) div 2,
16117
            Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
16118
      end;
16119
    rtSub: begin
16120
        if Angle = 0 then
16121
          Image.DrawSub(DXDraw.Surface, Rect, Pattern, Alpha)
16122
        else
16123
          Image.DrawRotateSub(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
16124
            (Rect.Top + Rect.Bottom) div 2,
16125
            Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
16126
      end;
16127
  end; {case}
16128
end;
16129
 
16130
procedure DXDraw_Paint(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
16131
  Rect: TRect; Pattern: Integer; var BlurImageArr: TBlurImageArr; BlurImage: Boolean;
16132
  TextureFilter: TD2DTextureFilter;
16133
  MirrorFlip: TRenderMirrorFlipSet;
16134
  BlendMode: TRenderType;
16135
  Angle: Single;
16136
  Alpha: Byte;
16137
  CenterX: Double; CenterY: Double); {$IFDEF VER9UP}inline;{$ENDIF}
16138
var
16139
  rr: TRect;
16140
  i, width, height: Integer;
16141
begin
16142
  if not Assigned(DXDraw.Surface) then Exit;
16143
  if not Assigned(Image) then Exit;
16144
  width := Image.Width;
16145
  height := Image.Height;
16146
  //rr := Bounds(X, Y, width, height);
16147
  //DXDraw.MirrorFlip(MirrorFlip);
16148
  DXDraw.TextureFilter(TextureFilter);
16149
  case BlendMode of
16150
    rtDraw: begin
16151
        if BlurImage then begin
16152
          for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
16153
              DXDraw.MirrorFlip(MirrorFlip);
16154
              rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Width, Height);
16155
              if Angle = 0 then
16156
                Image.DrawAlpha(DXDraw.Surface, rr, BlurImageArr[i].ePatternIndex, BlurImageArr[i].eIntensity)
16157
              else
16158
                Image.DrawRotateAlpha(DXDraw.Surface, (rr.Left + rr.Right) div 2,
16159
                  (rr.Top + rr.Bottom) div 2,
16160
                  Width, Height, BlurImageArr[i].ePatternIndex, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
16161
              if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
16162
            end;
16163
        end;
16164
        DXDraw.MirrorFlip(MirrorFlip);
16165
        if Angle = 0 then
16166
          Image.StretchDraw(DXDraw.Surface, Rect, Pattern)
16167
        else
16168
          Image.DrawRotate(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
16169
            (Rect.Top + Rect.Bottom) div 2,
16170
            Width, Height, Pattern, CenterX, CenterY, Angle);
16171
      end;
16172
    rtBlend: begin
16173
        if BlurImage then begin
16174
          for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
16175
              DXDraw.MirrorFlip(MirrorFlip);
16176
              rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Width, Height);
16177
              if Angle = 0 then
16178
                Image.DrawAlpha(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
16179
              else
16180
                Image.DrawRotateAlpha(DXDraw.Surface, (rr.Left + rr.Right) div 2,
16181
                  (rr.Top + rr.Bottom) div 2,
16182
                  Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
16183
              if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
16184
            end;
16185
        end;
16186
        DXDraw.MirrorFlip(MirrorFlip);
16187
        if Angle = 0 then
16188
          Image.DrawAlpha(DXDraw.Surface, Rect, Pattern, Alpha)
16189
        else
16190
          Image.DrawRotateAlpha(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
16191
            (Rect.Top + Rect.Bottom) div 2,
16192
            Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
16193
      end;
16194
    rtAdd: begin
16195
        if BlurImage then begin
16196
          for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
16197
              DXDraw.MirrorFlip(MirrorFlip);
16198
              rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Width, Height);
16199
              if Angle = 0 then
16200
                Image.DrawAdd(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
16201
              else
16202
                Image.DrawRotateAdd(DXDraw.Surface, (rr.Left + rr.Right) div 2,
16203
                  (rr.Top + rr.Bottom) div 2,
16204
                  Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
16205
              if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
16206
            end;
16207
        end;
16208
        DXDraw.MirrorFlip(MirrorFlip);
16209
        if Angle = 0 then
16210
          Image.DrawAdd(DXDraw.Surface, Rect, Pattern, Alpha)
16211
        else
16212
          Image.DrawRotateAdd(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
16213
            (Rect.Top + Rect.Bottom) div 2,
16214
            Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
16215
      end;
16216
    rtSub: begin
16217
        if BlurImage then begin
16218
          for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
16219
              DXDraw.MirrorFlip(MirrorFlip);
16220
              rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Width, Height);
16221
              if Angle = 0 then
16222
                Image.DrawSub(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
16223
              else
16224
                Image.DrawRotateSub(DXDraw.Surface, (rr.Left + rr.Right) div 2,
16225
                  (rr.Top + rr.Bottom) div 2,
16226
                  Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
16227
              if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
16228
            end;
16229
        end;
16230
        DXDraw.MirrorFlip(MirrorFlip);
16231
        if Angle = 0 then
16232
          Image.DrawSub(DXDraw.Surface, Rect, Pattern, Alpha)
16233
        else
16234
          Image.DrawRotateSub(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
16235
            (Rect.Top + Rect.Bottom) div 2,
16236
            Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
16237
      end;
16238
  end; {case}
16239
end;
16240
 
16241
procedure DXDraw_Render(DXDraw: TCustomDXDraw; Image: TPictureCollectionItem;
16242
  Rect: TRect; Pattern: Integer; var BlurImageArr: TBlurImageArr; BlurImage: Boolean;
16243
  TextureFilter: TD2DTextureFilter; MirrorFlip: TRenderMirrorFlipSet;
16244
  BlendMode: TRenderType;
16245
  Angle: Single;
16246
  Alpha: Byte;
16247
  CenterX: Double; CenterY: Double;
16248
  Scale: Single;
16249
  WaveType: TWaveType;
16250
  Amplitude: Integer; AmpLength: Integer; Phase: Integer); {$IFDEF VER9UP}inline;{$ENDIF}
16251
var
16252
  rr: TRect;
16253
  i, width, height: Integer;
16254
begin
16255
  if not Assigned(DXDraw.Surface) then Exit;
16256
  if not Assigned(Image) then Exit;
16257
  if Scale <> 1.0 then begin
16258
    width := Round(Scale * Image.Width);
16259
    height := Round(Scale * Image.Height);
16260
  end
16261
  else begin
16262
    width := Image.Width;
16263
    height := Image.Height;
16264
  end;
16265
  //r := Bounds(X, Y, width, height);
16266
  DXDraw.TextureFilter(TextureFilter);
16267
  DXDraw.MirrorFlip(MirrorFlip);
16268
  case BlendMode of
16269
    rtDraw:
16270
      begin
16271
        case WaveType of
16272
          wtWaveNone:
16273
            begin
16274
              if BlurImage then begin
16275
                for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
16276
                    DXDraw.MirrorFlip(MirrorFlip);
16277
                    rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Round(Scale * Width), Round(Scale * Height));
16278
                    if Angle = 0 then
16279
                      Image.DrawAlpha(DXDraw.Surface, rr, BlurImageArr[i].ePatternIndex, BlurImageArr[i].eIntensity)
16280
                    else
16281
                      Image.DrawRotateAlpha(DXDraw.Surface, (rr.Left + rr.Right) div 2,
16282
                        (rr.Top + rr.Bottom) div 2,
16283
                        Width, Height, BlurImageArr[i].ePatternIndex, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
16284
                    if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
16285
                  end;
16286
              end;
16287
              DXDraw.MirrorFlip(MirrorFlip);
16288
              if Angle = 0 then
16289
                Image.StretchDraw(DXDraw.Surface, Rect, Pattern)
16290
              else
16291
                Image.DrawRotate(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
16292
                  (Rect.Top + Rect.Bottom) div 2,
16293
                  Width, Height, Pattern, CenterX, CenterY, Angle);
16294
            end;
16295
          wtWaveX: Image.DrawWaveX(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase);
16296
          wtWaveY: Image.DrawWaveY(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase);
16297
        end;
16298
      end;
16299
    rtBlend: begin
16300
        case WaveType of
16301
          wtWaveNone: begin
16302
              if BlurImage then begin
16303
                for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
16304
                    DXDraw.MirrorFlip(MirrorFlip);
16305
                    rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Round(Scale * Width), Round(Scale * Height));
16306
                    if Angle = 0 then
16307
                      Image.DrawAlpha(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
16308
                    else
16309
                      Image.DrawRotateAlpha(DXDraw.Surface, (rr.Left + rr.Right) div 2,
16310
                        (rr.Top + rr.Bottom) div 2,
16311
                        Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
16312
                    if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
16313
                  end;
16314
              end;
16315
              DXDraw.MirrorFlip(MirrorFlip);
16316
              if Angle = 0 then
16317
                Image.DrawAlpha(DXDraw.Surface, Rect, Pattern, Alpha)
16318
              else
16319
                Image.DrawRotateAlpha(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
16320
                  (Rect.Top + Rect.Bottom) div 2,
16321
                  Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
16322
            end;
16323
          wtWaveX: Image.DrawWaveXAlpha(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
16324
          wtWaveY: Image.DrawWaveYAlpha(DXDraw.Surface, Round(Rect.Top), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
16325
        end;
16326
      end;
16327
    rtAdd: begin
16328
        case WaveType of
16329
          wtWaveNone: begin
16330
              if BlurImage then begin
16331
                for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
16332
                    DXDraw.MirrorFlip(MirrorFlip);
16333
                    rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Round(Scale * Width), Round(Scale * Height));
16334
                    if Angle = 0 then
16335
                      Image.DrawAdd(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
16336
                    else
16337
                      Image.DrawRotateAdd(DXDraw.Surface, (rr.Left + rr.Right) div 2,
16338
                        (rr.Top + rr.Bottom) div 2,
16339
                        Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
16340
                    if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
16341
                  end;
16342
              end;
16343
              DXDraw.MirrorFlip(MirrorFlip);
16344
              if Angle = 0 then
16345
                Image.DrawAdd(DXDraw.Surface, Rect, Pattern, Alpha)
16346
              else
16347
                Image.DrawRotateAdd(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
16348
                  (Rect.Top + Rect.Bottom) div 2,
16349
                  Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
16350
            end;
16351
          wtWaveX: Image.DrawWaveXAdd(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
16352
          wtWaveY: Image.DrawWaveYAdd(DXDraw.Surface, Round(Rect.Top), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
16353
        end;
16354
      end;
16355
    rtSub: begin
16356
        case WaveType of
16357
          wtWaveNone: begin
16358
              if BlurImage then begin
16359
                for i := Low(BlurImageArr) to High(BlurImageArr) do if BlurImageArr[i].eActive then begin
16360
                    DXDraw.MirrorFlip(MirrorFlip);
16361
                    rr := Bounds(BlurImageArr[i].eX, BlurImageArr[i].eY, Round(Scale * Width), Round(Scale * Height));
16362
                    if Angle = 0 then
16363
                      Image.DrawSub(DXDraw.Surface, rr, Pattern, BlurImageArr[i].eIntensity)
16364
                    else
16365
                      Image.DrawRotateSub(DXDraw.Surface, (rr.Left + rr.Right) div 2,
16366
                        (rr.Top + rr.Bottom) div 2,
16367
                        Width, Height, Pattern, CenterX, CenterY, BlurImageArr[i].eAngle, BlurImageArr[i].eIntensity);
16368
                    if BlurImageArr[i].eIntensity > 0 then Dec(BlurImageArr[i].eIntensity) else FillChar(BlurImageArr[i], SizeOf(BlurImageArr[i]), 0);
16369
                  end;
16370
              end;
16371
              DXDraw.MirrorFlip(MirrorFlip);
16372
              if Angle = 0 then
16373
                Image.DrawSub(DXDraw.Surface, Rect, Pattern, Alpha)
16374
              else
16375
                Image.DrawRotateSub(DXDraw.Surface, (Rect.Left + Rect.Right) div 2,
16376
                  (Rect.Top + Rect.Bottom) div 2,
16377
                  Width, Height, Pattern, CenterX, CenterY, Angle, Alpha);
16378
            end;
16379
          wtWaveX: Image.DrawWaveXSub(DXDraw.Surface, Round(Rect.Left), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
16380
          wtWaveY: Image.DrawWaveYSub(DXDraw.Surface, Round(Rect.Top), Round(Rect.Top), Width, Height, Pattern, Amplitude, AmpLength, Phase, Alpha);
16381
        end;
16382
      end;
16383
  end; {case}
16384
end;
16385
 
1 daniel-mar 16386
initialization
4 daniel-mar 16387
  _DXTextureImageLoadFuncList := TList.Create;
16388
  TDXTextureImage.RegisterLoadFunc(DXTextureImage_LoadDXTextureImageFunc); //delete Mr.Kawasaki
16389
  TDXTextureImage.RegisterLoadFunc(DXTextureImage_LoadBitmapFunc);
1 daniel-mar 16390
finalization
4 daniel-mar 16391
  TDXTextureImage.UnRegisterLoadFunc(DXTextureImage_LoadDXTextureImageFunc); //delete Mr.Kawasaki
16392
  TDXTextureImage.UnRegisterLoadFunc(DXTextureImage_LoadBitmapFunc);
16393
  _DXTextureImageLoadFuncList.Free;
16394
  { driver free }
1 daniel-mar 16395
  DirectDrawDrivers.Free;
4 daniel-mar 16396
  {$IFDEF _DMO_}DirectDrawDriversEx.Free;{$ENDIF}
16397
end.