1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRATransform;
3
4 {$mode objfpc}
5
6 interface
7
8 { This unit contains bitmap transformations as classes and the TAffineMatrix record and functions. }
9
10 uses
11 BGRAClasses, SysUtils, BGRABitmapTypes;
12
13 type
14 { Contains an affine matrix, i.e. a matrix to transform linearly and translate TPointF coordinates }
15 TAffineMatrix = BGRABitmapTypes.TAffineMatrix;
16 { Contains an affine base and information on the resulting box }
17 TAffineBox = BGRABitmapTypes.TAffineBox;
18
19 { TBGRAAffineScannerTransform allow to transform any scanner. To use it,
20 create this object with a scanner as parameter, call transformation
21 procedures, and finally, use the newly created object as a scanner.
22
23 You can transform a gradient or a bitmap. See TBGRAAffineBitmapTransform
24 for bitmap specific transformation. }
25
26 { TBGRAAffineScannerTransform }
27
28 TBGRAAffineScannerTransform = class(TBGRACustomScanner)
29 protected
30 FScanner: IBGRAScanner;
31 FScanAtFunc: TScanAtFunction;
FCurnull32 FCur: TPointF;
33 FEmptyMatrix: Boolean;
34 FMatrix: TAffineMatrix;
35 procedure SetMatrix(AMatrix: TAffineMatrix);
InternalScanCurrentPixelnull36 function InternalScanCurrentPixel: TBGRAPixel; virtual;
GetViewMatrixnull37 function GetViewMatrix: TAffineMatrix;
38 procedure SetViewMatrix(AValue: TAffineMatrix);
39 public
40 GlobalOpacity: Byte;
41 constructor Create(AScanner: IBGRAScanner);
42 procedure Reset;
43 procedure Invert;
44 procedure Translate(OfsX,OfsY: Single);
45 procedure RotateDeg(AngleCW: Single);
46 procedure RotateRad(AngleCCW: Single);
47 procedure MultiplyBy(AMatrix: TAffineMatrix);
48 procedure Fit(Origin,HAxis,VAxis: TPointF); virtual;
49 procedure Scale(sx,sy: single); overload;
50 procedure Scale(factor: single); overload;
GetScanCustomColorspacenull51 function GetScanCustomColorspace: TColorspaceAny; override;
52 procedure ScanMoveTo(X, Y: Integer); override;
53 procedure ScanMoveToF(X, Y: single); inline;
ScanNextPixelnull54 function ScanNextPixel: TBGRAPixel; override;
55 procedure ScanSkipPixels(ACount: integer); override;
ScanAtnull56 function ScanAt(X, Y: Single): TBGRAPixel; override;
57 property Matrix: TAffineMatrix read FMatrix write SetMatrix;
58 property ViewMatrix: TAffineMatrix read GetViewMatrix write SetViewMatrix;
59 end;
60
61 { If you don't want the bitmap to repeats itself, or want to specify the
62 resample filter, or want to fit easily the bitmap on axes,
63 use TBGRAAffineBitmapTransform instead of TBGRAAffineScannerTransform }
64
65 { TBGRAAffineBitmapTransform }
66
67 TBGRAAffineBitmapTransform = class(TBGRAAffineScannerTransform)
68 protected
69 FBitmap: TBGRACustomBitmap;
70 FRepeatImageX,FRepeatImageY: boolean;
71 FResampleFilter : TResampleFilter;
72 FBuffer: PBGRAPixel;
73 FBufferSize: Int32or64;
74 FIncludeEdges: boolean;
75 procedure Init(ABitmap: TBGRACustomBitmap; ARepeatImageX: Boolean= false; ARepeatImageY: Boolean= false; AResampleFilter: TResampleFilter = rfLinear; AIncludeEdges: boolean = false);
76 public
77 constructor Create(ABitmap: TBGRACustomBitmap; ARepeatImage: Boolean= false; AResampleFilter: TResampleFilter = rfLinear; AIncludeEdges: boolean = false); overload;
78 constructor Create(ABitmap: TBGRACustomBitmap; ARepeatImageX: Boolean; ARepeatImageY: Boolean; AResampleFilter: TResampleFilter = rfLinear; AIncludeEdges: boolean = false); overload;
79 destructor Destroy; override;
InternalScanCurrentPixelnull80 function InternalScanCurrentPixel: TBGRAPixel; override;
81 procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); override;
IsScanPutPixelsDefinednull82 function IsScanPutPixelsDefined: boolean; override;
83 procedure Fit(Origin, HAxis, VAxis: TPointF); override;
84 end;
85
86 { TBGRAQuadLinearScanner }
87
88 TBGRAQuadLinearScanner = class(TBGRACustomScanner)
89 private
90 FPadding: boolean;
91 FPoints,FVectors: array[0..3] of TPointF;
92 FInvLengths,FDets: array[0..3] of single;
93 FCoeffs: array[0..3] of TPointF;
94 aa,bb0,cc0,inv2aa: double;
95 FSource: IBGRAScanner;
96 FSourceMatrix: TAffineMatrix;
97 FUVVector: TPointF;
98
99 ScanParaBB, ScanParaCC, ScanParaBBInv: double;
100
101 ScanVertV0,ScanVertVStep0,ScanVertDenom0,ScanVertDenomStep0: double;
102
103 FHasC1, FHasC2: boolean;
104 FShowC1, FShowC2: boolean;
105 FScanFunc: TScanNextPixelFunction;
FCurXFnull106 FCurXF,FCurYF: single;
107 FBuffer: PBGRAPixel;
108 FBufferSize: Int32or64;
109 FTextureInterpolation: Boolean;
GetCullingnull110 function GetCulling: TFaceCulling;
ScanNonenull111 function ScanNone: TBGRAPixel;
ScanGeneralnull112 function ScanGeneral: TBGRAPixel;
113 procedure PrepareScanVert0;
ScanVert0null114 function ScanVert0: TBGRAPixel;
115 procedure PrepareScanPara;
ScanParanull116 function ScanPara: TBGRAPixel;
117 procedure GetTexColorAt(u,v: Single; out AColor: TBGRAPixel; out AIsPadding: boolean); inline;
GetTexColorAtnull118 function GetTexColorAt(u,v: Single; detNeg: boolean): TBGRAPixel; inline;
119 procedure ScanMoveToF(X,Y: single); inline;
120 procedure SetCulling(AValue: TFaceCulling);
121 procedure Init(ASource: IBGRAScanner; const APoints: array of TPointF;
122 ATextureInterpolation: boolean);
123 public
ScanAtnull124 function ScanAt(X, Y: Single): TBGRAPixel; override;
125 procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); override;
IsScanPutPixelsDefinednull126 function IsScanPutPixelsDefined: boolean; override;
127 procedure ScanMoveTo(X, Y: Integer); override;
ScanNextPixelnull128 function ScanNextPixel: TBGRAPixel; override;
129 procedure ScanSkipPixels(ACount: integer); override;
130 constructor Create(ASource: IBGRAScanner;
131 ASourceMatrix: TAffineMatrix; const APoints: array of TPointF;
132 ATextureInterpolation: boolean = true); overload;
133 constructor Create(ASource: IBGRAScanner;
134 const ATexCoords: array of TPointF; const APoints: array of TPointF;
135 ATextureInterpolation: boolean = true); overload;
136 destructor Destroy; override;
137 property Culling: TFaceCulling read GetCulling write SetCulling;
138 property Padding: boolean read FPadding write FPadding;
139 end;
140
141 { TBGRABitmapScanner }
142
143 TBGRABitmapScanner = class(TBGRACustomScanner)
144 protected
145 FSource: TBGRACustomBitmap;
146 FRepeatX,FRepeatY: boolean;
147 FScanline: PBGRAPixel;
148 FCurX: integer;
149 FOrigin: TPoint;
150 public
151 constructor Create(ASource: TBGRACustomBitmap; ARepeatX,ARepeatY: boolean; AOrigin: TPoint);
152 procedure ScanMoveTo(X, Y: Integer); override;
ScanNextPixelnull153 function ScanNextPixel: TBGRAPixel; override;
ScanAtnull154 function ScanAt(X, Y: Single): TBGRAPixel; override;
155 procedure ScanSkipPixels(ACount: integer); override;
156 end;
157
158 { TBGRAExtendedBorderScanner }
159
160 TBGRAExtendedBorderScanner = class(TBGRACustomScanner)
161 protected
162 FSource: IBGRAScanner;
163 FBounds: TRect;
164 public
165 constructor Create(ASource: IBGRAScanner; ABounds: TRect);
ScanAtnull166 function ScanAt(X,Y: Single): TBGRAPixel; override;
167 end;
168
169 { TBGRAScannerOffset }
170
171 TBGRAScannerOffset = class(TBGRACustomScanner)
172 protected
173 FSource: IBGRAScanner;
174 FOffset: TPoint;
175 public
176 constructor Create(ASource: IBGRAScanner; AOffset: TPoint);
177 destructor Destroy; override;
178 procedure ScanMoveTo(X, Y: Integer); override;
ScanNextPixelnull179 function ScanNextPixel: TBGRAPixel; override;
ScanAtnull180 function ScanAt(X, Y: Single): TBGRAPixel; override;
IsScanPutPixelsDefinednull181 function IsScanPutPixelsDefined: boolean; override;
182 procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); override;
183 procedure ScanSkipPixels(ACount: integer); override;
184 end;
185
186
187 {---------------------- Affine matrix functions -------------------}
188 //fill a matrix
AffineMatrixnull189 function AffineMatrix(m11,m12,m13,m21,m22,m23: single): TAffineMatrix; overload;
AffineMatrixnull190 function AffineMatrix(AU,AV: TPointF; ATranslation: TPointF): TAffineMatrix; overload;
191
192 //matrix multiplication
193 operator *(M,N: TAffineMatrix): TAffineMatrix;
194 operator =(M,N: TAffineMatrix): boolean;
195
196 //matrix multiplication by a vector (apply transformation to that vector)
197 operator *(M: TAffineMatrix; V: TPointF): TPointF;
198 operator *(M: TAffineMatrix; A: array of TPointF): ArrayOfTPointF;
199 operator *(M: TAffineMatrix; ab: TAffineBox): TAffineBox;
200
201 //check if matrix is inversible
IsAffineMatrixInversiblenull202 function IsAffineMatrixInversible(M: TAffineMatrix): boolean;
203
204 //check if the matrix is a translation (including the identity)
IsAffineMatrixTranslationnull205 function IsAffineMatrixTranslation(M: TAffineMatrix): boolean;
206
207 //check if the matrix is a scaling (including a projection i.e. with factor 0)
IsAffineMatrixScalenull208 function IsAffineMatrixScale(M: TAffineMatrix): boolean;
209
210 //check if the matrix is the identity
IsAffineMatrixIdentitynull211 function IsAffineMatrixIdentity(M: TAffineMatrix): boolean;
212
213 //compute inverse (check if inversible before)
AffineMatrixInversenull214 function AffineMatrixInverse(M: TAffineMatrix): TAffineMatrix;
215
216 //define a translation matrix
AffineMatrixTranslationnull217 function AffineMatrixTranslation(OfsX,OfsY: Single): TAffineMatrix;
218
219 //define a scaling matrix
AffineMatrixScalenull220 function AffineMatrixScale(sx,sy: single): TAffineMatrix;
AffineMatrixScaledRotationnull221 function AffineMatrixScaledRotation(ASourceVector, ATargetVector: TPointF): TAffineMatrix;
AffineMatrixScaledRotationnull222 function AffineMatrixScaledRotation(ASourcePoint, ATargetPoint, AOrigin: TPointF): TAffineMatrix;
223
AffineMatrixSkewXDegnull224 function AffineMatrixSkewXDeg(AngleCW: single): TAffineMatrix;
AffineMatrixSkewYDegnull225 function AffineMatrixSkewYDeg(AngleCW: single): TAffineMatrix;
AffineMatrixSkewXRadnull226 function AffineMatrixSkewXRad(AngleCCW: single): TAffineMatrix;
AffineMatrixSkewYRadnull227 function AffineMatrixSkewYRad(AngleCCW: single): TAffineMatrix;
228
229 //define a linear matrix
AffineMatrixLinearnull230 function AffineMatrixLinear(v1,v2: TPointF): TAffineMatrix; overload;
AffineMatrixLinearnull231 function AffineMatrixLinear(const AMatrix: TAffineMatrix): TAffineMatrix; overload;
232
233 //define a rotation matrix (positive radians are counter-clockwise)
234 //(assuming the y-axis is pointing down)
AffineMatrixRotationRadnull235 function AffineMatrixRotationRad(AngleCCW: Single): TAffineMatrix;
236
237 //Positive degrees are clockwise
238 //(assuming the y-axis is pointing down)
AffineMatrixRotationDegnull239 function AffineMatrixRotationDeg(AngleCW: Single): TAffineMatrix;
240
241 //define the identity matrix (that do nothing)
AffineMatrixIdentitynull242 function AffineMatrixIdentity: TAffineMatrix;
243
IsAffineMatrixOrthogonalnull244 function IsAffineMatrixOrthogonal(M: TAffineMatrix): boolean;
IsAffineMatrixScaledRotationnull245 function IsAffineMatrixScaledRotation(M: TAffineMatrix): boolean;
246
247 type
248 { TBGRATriangleLinearMapping is a scanner that provides
249 an optimized transformation for linear texture mapping
250 on triangles }
251
252 { TBGRATriangleLinearMapping }
253
254 TBGRATriangleLinearMapping = class(TBGRACustomScanner)
255 protected
256 FScanner: IBGRAScanner;
257 FMatrix: TAffineMatrix;
258 FTexCoord1,FDiff2,FDiff3,FStep: TPointF;
259 FCurTexCoord: TPointF;
260 FScanAtFunc: TScanAtFunction;
publicnull261 public
262 constructor Create(AScanner: IBGRAScanner; pt1,pt2,pt3: TPointF; tex1,tex2,tex3: TPointF);
263 procedure ScanMoveTo(X,Y: Integer); override;
264 procedure ScanMoveToF(X,Y: Single);
ScanAtnull265 function ScanAt(X,Y: Single): TBGRAPixel; override;
ScanNextPixelnull266 function ScanNextPixel: TBGRAPixel; override;
267 procedure ScanSkipPixels(ACount: integer); override;
268 end;
269
270 type
271 TPerspectiveTransform = class;
272
273 { TBGRAPerspectiveScannerTransform }
274
275 TBGRAPerspectiveScannerTransform = class(TBGRACustomScanner)
276 private
277 FTexture: IBGRAScanner;
278 FMatrix: TPerspectiveTransform;
279 FScanAtProc: TScanAtFunction;
functionnull280 function GetIncludeOppositePlane: boolean;
281 procedure SetIncludeOppositePlane(AValue: boolean);
282 public
283 constructor Create(texture: IBGRAScanner; texCoord1,texCoord2: TPointF; const quad: array of TPointF); overload;
284 constructor Create(texture: IBGRAScanner; const texCoordsQuad: array of TPointF; const quad: array of TPointF); overload;
285 destructor Destroy; override;
286 procedure ScanMoveTo(X, Y: Integer); override;
ScanAtnull287 function ScanAt(X, Y: Single): TBGRAPixel; override;
ScanNextPixelnull288 function ScanNextPixel: TBGRAPixel; override;
289 procedure ScanSkipPixels(ACount: integer); override;
290 property IncludeOppositePlane: boolean read GetIncludeOppositePlane write SetIncludeOppositePlane;
291 end;
292
293 { TPerspectiveTransform }
294
295 TPerspectiveTransform = class
296 private
297 sx ,shy ,w0 ,shx ,sy ,w1 ,tx ,ty ,w2 : single;
298 scanDenom,scanNumX,scanNumY: single;
299 FOutsideValue: TPointF;
300 FIncludeOppositePlane: boolean;
301 procedure Init;
302 public
303 constructor Create; overload;
304 constructor Create(x1,y1,x2,y2: single; const quad: array of TPointF); overload;
305 constructor Create(const quad: array of TPointF; x1,y1,x2,y2: single); overload;
306 constructor Create(const srcQuad,destQuad: array of TPointF); overload;
MapQuadToQuadnull307 function MapQuadToQuad(const srcQuad,destQuad: array of TPointF): boolean;
MapRectToQuadnull308 function MapRectToQuad(x1,y1,x2,y2: single; const quad: array of TPointF): boolean;
MapQuadToRectnull309 function MapQuadToRect(const quad: array of TPointF; x1,y1,x2,y2: single): boolean;
MapSquareToQuadnull310 function MapSquareToQuad(const quad: array of TPointF): boolean;
MapQuadToSquarenull311 function MapQuadToSquare(const quad: array of TPointF): boolean;
312 procedure AssignIdentity;
Invertnull313 function Invert: boolean;
314 procedure Translate(dx,dy: single);
315 procedure MultiplyBy(a: TPerspectiveTransform);
316 procedure PremultiplyBy(b: TPerspectiveTransform);
Duplicatenull317 function Duplicate: TPerspectiveTransform;
Applynull318 function Apply(pt: TPointF): TPointF;
319 procedure ScanMoveTo(x,y:single);
ScanNextnull320 function ScanNext: TPointF;
321 procedure ScanSkip(ACount: integer);
322 property OutsideValue: TPointF read FOutsideValue write FOutsideValue;
323 property IncludeOppositePlane: boolean read FIncludeOppositePlane write FIncludeOppositePlane;
324 end;
325
326 type
327 { TBGRATwirlScanner applies a twirl transformation.
328
329 Note : this scanner handles integer coordinates only, so
330 any further transformation applied after this one may not
331 render correctly. }
332
333 { TBGRATwirlScanner }
334
335 TBGRATwirlScanner = Class(TBGRACustomScanner)
336 protected
337 FScanner: IBGRAScanner;
338 FScanAtFunc: TScanAtFunction;
FCenternull339 FCenter: TPoint;
340 FTurn, FRadius, FExponent: Single;
341 public
342 constructor Create(AScanner: IBGRAScanner; ACenter: TPoint; ARadius: single; ATurn: single = 1; AExponent: single = 3);
ScanAtnull343 function ScanAt(X, Y: Single): TBGRAPixel; override;
344 property Radius: Single read FRadius;
345 property Center: TPoint read FCenter;
346 property Exponent: Single read FExponent;
347 end;
348
349 { TBGRASphereDeformationScanner }
350
351 TBGRASphereDeformationScanner = Class(TBGRACustomScanner)
352 protected
353 FScanner: IBGRAScanner;
354 FScanAtFunc: TScanAtFunction;
FCenternull355 FCenter: TPointF;
356 FRadiusX, FRadiusY: Single;
357 public
358 constructor Create(AScanner: IBGRAScanner; ACenter: TPointF; ARadiusX,ARadiusY: single);
ScanAtnull359 function ScanAt(X, Y: Single): TBGRAPixel; override;
360 property RadiusX: Single read FRadiusX;
361 property RadiusY: Single read FRadiusY;
362 end;
363
364 { TBGRAVerticalCylinderDeformationScanner }
365
366 TBGRAVerticalCylinderDeformationScanner = Class(TBGRACustomScanner)
367 protected
368 FScanner: IBGRAScanner;
369 FScanAtFunc: TScanAtFunction;
FCenterXnull370 FCenterX: single;
371 FRadiusX: Single;
372 public
373 constructor Create(AScanner: IBGRAScanner; ACenterX: single; ARadiusX: single);
ScanAtnull374 function ScanAt(X, Y: Single): TBGRAPixel; override;
375 property RadiusX: Single read FRadiusX;
376 end;
377
378
379 implementation
380
381 uses BGRABlend, Math;
382
AffineMatrixnull383 function AffineMatrix(m11, m12, m13, m21, m22, m23: single): TAffineMatrix;
384 begin
385 result[1,1] := m11;
386 result[1,2] := m12;
387 result[1,3] := m13;
388 result[2,1] := m21;
389 result[2,2] := m22;
390 result[2,3] := m23;
391 end;
392
AffineMatrixnull393 function AffineMatrix(AU, AV: TPointF; ATranslation: TPointF): TAffineMatrix;
394 begin
395 result:= AffineMatrix(AU.x, AV.x, ATranslation.x,
396 AU.y, AV.y, ATranslation.y);
397 end;
398
399 operator *(M, N: TAffineMatrix): TAffineMatrix;
400 begin
401 result[1,1] := M[1,1]*N[1,1] + M[1,2]*N[2,1];
402 result[1,2] := M[1,1]*N[1,2] + M[1,2]*N[2,2];
403 result[1,3] := M[1,1]*N[1,3] + M[1,2]*N[2,3] + M[1,3];
404
405 result[2,1] := M[2,1]*N[1,1] + M[2,2]*N[2,1];
406 result[2,2] := M[2,1]*N[1,2] + M[2,2]*N[2,2];
407 result[2,3] := M[2,1]*N[1,3] + M[2,2]*N[2,3] + M[2,3];
408 end;
409
410 operator=(M, N: TAffineMatrix): boolean;
411 begin
412 result := CompareMem(@M,@N,SizeOf(TAffineMatrix));
413 end;
414
415 operator*(M: TAffineMatrix; V: TPointF): TPointF;
416 begin
417 if isEmptyPointF(V) then
418 result := EmptyPointF
419 else
420 begin
421 result.X := V.X*M[1,1]+V.Y*M[1,2]+M[1,3];
422 result.Y := V.X*M[2,1]+V.Y*M[2,2]+M[2,3];
423 end;
424 end;
425
426 operator*(M: TAffineMatrix; A: array of TPointF): ArrayOfTPointF;
427 var
428 i: Int32or64;
429 ofs: TPointF;
430 begin
431 setlength(result, length(A));
432 if IsAffineMatrixTranslation(M) then
433 begin
434 ofs := PointF(M[1,3],M[2,3]);
435 for i := 0 to high(A) do
436 result[i] := A[i]+ofs;
437 end else
438 for i := 0 to high(A) do
439 result[i] := M*A[i];
440 end;
441
442 operator*(M: TAffineMatrix; ab: TAffineBox): TAffineBox;
443 begin
444 result.TopLeft := M*ab.TopLeft;
445 result.TopRight := M*ab.TopRight;
446 result.BottomLeft := M*ab.BottomLeft;
447 end;
448
IsAffineMatrixInversiblenull449 function IsAffineMatrixInversible(M: TAffineMatrix): boolean;
450 begin
451 result := M[1,1]*M[2,2]-M[1,2]*M[2,1] <> 0;
452 end;
453
IsAffineMatrixTranslationnull454 function IsAffineMatrixTranslation(M: TAffineMatrix): boolean;
455 begin
456 result := (m[1,1]=1) and (m[1,2]=0) and (m[2,1] = 0) and (m[2,2]=1);
457 end;
458
IsAffineMatrixScalenull459 function IsAffineMatrixScale(M: TAffineMatrix): boolean;
460 begin
461 result := (M[1,3]=0) and (M[2,3]=0) and
462 (M[1,2]=0) and (M[2,1]=0);
463 end;
464
IsAffineMatrixIdentitynull465 function IsAffineMatrixIdentity(M: TAffineMatrix): boolean;
466 begin
467 result := IsAffineMatrixTranslation(M) and (M[1,3]=0) and (M[2,3]=0);
468 end;
469
AffineMatrixInversenull470 function AffineMatrixInverse(M: TAffineMatrix): TAffineMatrix;
471 var det,f: single;
472 linearInverse: TAffineMatrix;
473 begin
474 det := M[1,1]*M[2,2]-M[1,2]*M[2,1];
475 if det = 0 then
476 raise Exception.Create('Not inversible');
477 f := 1/det;
478 linearInverse := AffineMatrix(M[2,2]*f,-M[1,2]*f,0,
479 -M[2,1]*f,M[1,1]*f,0);
480 result := linearInverse * AffineMatrixTranslation(-M[1,3],-M[2,3]);
481 end;
482
AffineMatrixTranslationnull483 function AffineMatrixTranslation(OfsX, OfsY: Single): TAffineMatrix;
484 begin
485 result := AffineMatrix(1, 0, OfsX,
486 0, 1, OfsY);
487 end;
488
AffineMatrixScalenull489 function AffineMatrixScale(sx, sy: single): TAffineMatrix;
490 begin
491 result := AffineMatrix(sx, 0, 0,
492 0, sy, 0);
493 end;
494
AffineMatrixScaledRotationnull495 function AffineMatrixScaledRotation(ASourceVector, ATargetVector: TPointF): TAffineMatrix;
496 var
497 prevScale, newScale, scale: Single;
498 u1,v1,u2,v2,w: TPointF;
499 begin
500 prevScale := VectLen(ASourceVector);
501 newScale := VectLen(ATargetVector);
502 if (prevScale = 0) or (newScale = 0) then
503 result := AffineMatrixIdentity
504 else
505 begin
506 scale := newScale/prevScale;
507 u1 := ASourceVector*(1/prevScale);
508 v1 := PointF(-u1.y,u1.x);
509 w := ATargetVector*(1/newScale);
510 u2 := PointF(w*u1, w*v1);
511 v2 := PointF(-u2.y,u2.x);
512 result := AffineMatrix(scale*u2,scale*v2,PointF(0,0));
513 end;
514 end;
515
AffineMatrixScaledRotationnull516 function AffineMatrixScaledRotation(ASourcePoint, ATargetPoint, AOrigin: TPointF): TAffineMatrix;
517 begin
518 result := AffineMatrixTranslation(AOrigin.x,AOrigin.y)*
519 AffineMatrixScaledRotation(ASourcePoint-AOrigin, ATargetPoint-AOrigin)*
520 AffineMatrixTranslation(-AOrigin.x,-AOrigin.y);
521 end;
522
AffineMatrixSkewXDegnull523 function AffineMatrixSkewXDeg(AngleCW: single): TAffineMatrix;
524 begin
525 result := AffineMatrix(1,tan(AngleCW*Pi/180),0,
526 0, 1, 0);
527 end;
528
AffineMatrixSkewYDegnull529 function AffineMatrixSkewYDeg(AngleCW: single): TAffineMatrix;
530 begin
531 result := AffineMatrix(1, 0, 0,
532 tan(AngleCW*Pi/180), 1, 0)
533 end;
534
AffineMatrixSkewXRadnull535 function AffineMatrixSkewXRad(AngleCCW: single): TAffineMatrix;
536 begin
537
538 result := AffineMatrix(1,tan(-AngleCCW),0,
539 0, 1, 0);
540 end;
541
AffineMatrixSkewYRadnull542 function AffineMatrixSkewYRad(AngleCCW: single): TAffineMatrix;
543 begin
544 result := AffineMatrix(1, 0, 0,
545 tan(-angleCCW), 1, 0)
546 end;
547
AffineMatrixLinearnull548 function AffineMatrixLinear(v1,v2: TPointF): TAffineMatrix;
549 begin
550 result := AffineMatrix(v1.x, v2.x, 0,
551 v1.y, v2.y, 0);
552 end;
553
AffineMatrixLinearnull554 function AffineMatrixLinear(const AMatrix: TAffineMatrix): TAffineMatrix;
555 begin
556 result := AffineMatrix(AMatrix[1,1],AMatrix[1,2],0,
557 AMatrix[2,1],AMatrix[2,2],0);
558 end;
559
AffineMatrixRotationRadnull560 function AffineMatrixRotationRad(AngleCCW: Single): TAffineMatrix;
561 begin
562 result := AffineMatrix(cos(AngleCCW), sin(AngleCCW), 0,
563 -sin(AngleCCW), cos(AngleCCW), 0);
564 end;
565
AffineMatrixRotationDegnull566 function AffineMatrixRotationDeg(AngleCW: Single): TAffineMatrix;
567 const DegToRad = -Pi/180;
568 begin
569 result := AffineMatrixRotationRad(AngleCW*DegToRad);
570 end;
571
AffineMatrixIdentitynull572 function AffineMatrixIdentity: TAffineMatrix;
573 begin
574 result := AffineMatrix(1, 0, 0,
575 0, 1, 0);
576 end;
577
IsAffineMatrixOrthogonalnull578 function IsAffineMatrixOrthogonal(M: TAffineMatrix): boolean;
579 begin
580 result := PointF(M[1,1],M[2,1])*PointF(M[1,2],M[2,2]) = 0;
581 end;
582
IsAffineMatrixScaledRotationnull583 function IsAffineMatrixScaledRotation(M: TAffineMatrix): boolean;
584 begin
585 result := IsAffineMatrixOrthogonal(M) and
586 (VectLen(PointF(M[1,1],M[2,1]))=VectLen(PointF(M[1,2],M[2,2])));
587 end;
588
589 { TBGRAVerticalCylinderDeformationScanner }
590
591 constructor TBGRAVerticalCylinderDeformationScanner.Create(
592 AScanner: IBGRAScanner; ACenterX: single; ARadiusX: single);
593 begin
594 FScanner := AScanner;
595 FScanAtFunc := @FScanner.ScanAt;
596 FCenterX := ACenterX;
597 FRadiusX := ARadiusX;
598 end;
599
ScanAtnull600 function TBGRAVerticalCylinderDeformationScanner.ScanAt(X, Y: Single): TBGRAPixel;
601 var
602 xn,len,fact: Single;
603 begin
604 xn := (x - FCenterX) / FRadiusX;
605 len := abs(xn);
606 if (len <= 1) then
607 begin
608 if (len > 0) then
609 begin
610 fact := 1 / len * arcsin(len) / (Pi / 2);
611 xn := xn * fact;
612 end;
613 result := FScanAtFunc(xn * FRadiusX + FCenterX, y);
614 end
615 else
616 result := BGRAPixelTransparent;
617 end;
618
619 { TBGRASphereDeformationScanner }
620
621 constructor TBGRASphereDeformationScanner.Create(AScanner: IBGRAScanner;
622 ACenter: TPointF; ARadiusX, ARadiusY: single);
623 begin
624 FScanner := AScanner;
625 FScanAtFunc := @FScanner.ScanAt;
626 FCenter := ACenter;
627 FRadiusX := ARadiusX;
628 FRadiusY := ARadiusY;
629 end;
630
ScanAtnull631 function TBGRASphereDeformationScanner.ScanAt(X, Y: Single): TBGRAPixel;
632 var
633 xn, yn, len,fact: Single;
634 begin
635 xn := (x - FCenter.X) / FRadiusX;
636 yn := (y - FCenter.Y) / FRadiusY;
637 len := sqrt(sqr(xn) + sqr(yn));
638 if (len <= 1) then
639 begin
640 if (len > 0) then
641 begin
642 fact := 1 / len * arcsin(len) / (Pi / 2);
643 xn := xn * fact;
644 yn := yn * fact;
645 end;
646 result := FScanAtFunc(xn * FRadiusX + FCenter.X, yn * FRadiusY + FCenter.Y);
647 end
648 else
649 result := BGRAPixelTransparent;
650 end;
651
652 { TBGRAExtendedBorderScanner }
653
654 constructor TBGRAExtendedBorderScanner.Create(ASource: IBGRAScanner;
655 ABounds: TRect);
656 begin
657 FSource := ASource;
658 FBounds := ABounds;
659 end;
660
ScanAtnull661 function TBGRAExtendedBorderScanner.ScanAt(X, Y: Single): TBGRAPixel;
662 begin
663 if x < FBounds.Left then x := FBounds.Left;
664 if y < FBounds.Top then y := FBounds.Top;
665 if x > FBounds.Right-1 then x := FBounds.Right-1;
666 if y > FBounds.Bottom-1 then y := FBounds.Bottom-1;
667 result := FSource.ScanAt(X,Y);
668 end;
669
670 { TBGRAScannerOffset }
671
672 constructor TBGRAScannerOffset.Create(ASource: IBGRAScanner; AOffset: TPoint);
673 begin
674 FSource := ASource;
675 FOffset := AOffset;
676 end;
677
678 destructor TBGRAScannerOffset.Destroy;
679 begin
680 fillchar(FSource,sizeof(FSource),0);
681 inherited Destroy;
682 end;
683
684 procedure TBGRAScannerOffset.ScanMoveTo(X, Y: Integer);
685 begin
686 FSource.ScanMoveTo(X-FOffset.X,Y-FOffset.Y);
687 end;
688
TBGRAScannerOffset.ScanNextPixelnull689 function TBGRAScannerOffset.ScanNextPixel: TBGRAPixel;
690 begin
691 Result:=FSource.ScanNextPixel;
692 end;
693
ScanAtnull694 function TBGRAScannerOffset.ScanAt(X, Y: Single): TBGRAPixel;
695 begin
696 Result:=FSource.ScanAt(X - FOffset.X, Y - FOffset.Y);
697 end;
698
IsScanPutPixelsDefinednull699 function TBGRAScannerOffset.IsScanPutPixelsDefined: boolean;
700 begin
701 Result:=FSource.IsScanPutPixelsDefined;
702 end;
703
704 procedure TBGRAScannerOffset.ScanPutPixels(pdest: PBGRAPixel; count: integer;
705 mode: TDrawMode);
706 begin
707 FSource.ScanPutPixels(pdest, count, mode);
708 end;
709
710 procedure TBGRAScannerOffset.ScanSkipPixels(ACount: integer);
711 begin
712 FSource.ScanSkipPixels(ACount);
713 end;
714
715 { TBGRABitmapScanner }
716
717 constructor TBGRABitmapScanner.Create(ASource: TBGRACustomBitmap; ARepeatX,
718 ARepeatY: boolean; AOrigin: TPoint);
719 begin
720 FSource := ASource;
721 FRepeatX := ARepeatX;
722 FRepeatY := ARepeatY;
723 FScanline := nil;
724 FOrigin := AOrigin;
725 end;
726
727 procedure TBGRABitmapScanner.ScanMoveTo(X, Y: Integer);
728 begin
729 if (FSource.NbPixels = 0) then
730 begin
731 FScanline := nil;
732 exit;
733 end;
734 Inc(Y,FOrigin.Y);
735 if FRepeatY then Y := PositiveMod(Y,FSource.Height);
736 if (Y < 0) or (Y >= FSource.Height) then
737 begin
738 FScanline := nil;
739 exit;
740 end;
741 FScanline := FSource.Scanline[Y];
742 FCurX := X+FOrigin.X;
743 if FRepeatX then FCurX := PositiveMod(FCurX, FSource.Width);
744 end;
745
TBGRABitmapScanner.ScanNextPixelnull746 function TBGRABitmapScanner.ScanNextPixel: TBGRAPixel;
747 begin
748 if (FScanline = nil) then
749 begin
750 result := BGRAPixelTransparent;
751 exit;
752 end;
753 if FRepeatX then
754 begin
755 result := (FScanline+FCurX)^;
756 inc(FCurX);
757 if FCurX = FSource.Width then FCurX := 0;
758 end else
759 begin
760 if (FCurX >= FSource.Width) then
761 begin
762 result := BGRAPixelTransparent;
763 exit;
764 end;
765 if FCurX < 0 then
766 result := BGRAPixelTransparent
767 else
768 result := (FScanline+FCurX)^;
769 inc(FCurX);
770 end;
771 end;
772
ScanAtnull773 function TBGRABitmapScanner.ScanAt(X, Y: Single): TBGRAPixel;
774 begin
775 Result := FSource.GetPixelCycle(X+FOrigin.X,Y+FOrigin.Y,rfLinear,FRepeatX,FRepeatY);
776 end;
777
778 procedure TBGRABitmapScanner.ScanSkipPixels(ACount: integer);
779 begin
780 if FScanLine <> nil then
781 begin
782 inc(FCurX, ACount);
783 if FCurX > FSource.Width then FCurX := PositiveMod(FCurX, FSource.Width);
784 end;
785 end;
786
787 { TBGRATriangleLinearMapping }
788
789 constructor TBGRATriangleLinearMapping.Create(AScanner: IBGRAScanner; pt1, pt2,
790 pt3: TPointF; tex1, tex2, tex3: TPointF);
791 begin
792 FScanner := AScanner;
793 FScanAtFunc := @FScanner.ScanAt;
794
795 FMatrix := AffineMatrix(pt2.X-pt1.X, pt3.X-pt1.X, 0,
796 pt2.Y-pt1.Y, pt3.Y-pt1.Y, 0);
797 if not IsAffineMatrixInversible(FMatrix) then
798 FMatrix := AffineMatrix(0,0,0,0,0,0)
799 else
800 FMatrix := AffineMatrixInverse(FMatrix) * AffineMatrixTranslation(-pt1.x,-pt1.y);
801
802 FTexCoord1 := tex1;
803 FDiff2 := tex2-tex1;
804 FDiff3 := tex3-tex1;
805 FStep := FDiff2*FMatrix[1,1]+FDiff3*FMatrix[2,1];
806 end;
807
808 procedure TBGRATriangleLinearMapping.ScanMoveTo(X, Y: Integer);
809 begin
810 ScanMoveToF(X, Y);
811 end;
812
813 procedure TBGRATriangleLinearMapping.ScanMoveToF(X, Y: Single);
814 var
815 Cur: TPointF;
816 begin
817 Cur := FMatrix*PointF(X,Y);
818 FCurTexCoord := FTexCoord1+FDiff2*Cur.X+FDiff3*Cur.Y;
819 end;
820
TBGRATriangleLinearMapping.ScanAtnull821 function TBGRATriangleLinearMapping.ScanAt(X, Y: Single): TBGRAPixel;
822 begin
823 ScanMoveToF(X,Y);
824 result := ScanNextPixel;
825 end;
826
TBGRATriangleLinearMapping.ScanNextPixelnull827 function TBGRATriangleLinearMapping.ScanNextPixel: TBGRAPixel;
828 begin
829 result := FScanAtFunc(FCurTexCoord.X,FCurTexCoord.Y);
830 FCurTexCoord.Offset(FStep);
831 end;
832
833 procedure TBGRATriangleLinearMapping.ScanSkipPixels(ACount: integer);
834 begin
835 FCurTexCoord.Offset(FStep*ACount);
836 end;
837
838 { TBGRAAffineScannerTransform }
839
840 constructor TBGRAAffineScannerTransform.Create(AScanner: IBGRAScanner);
841 begin
842 FScanner := AScanner;
843 FScanAtFunc := @FScanner.ScanAt;
844 GlobalOpacity := 255;
845 Reset;
846 end;
847
848 procedure TBGRAAffineScannerTransform.Reset;
849 begin
850 FMatrix := AffineMatrixIdentity;
851 FEmptyMatrix := False;
852 end;
853
854 procedure TBGRAAffineScannerTransform.Invert;
855 begin
856 if not FEmptyMatrix and IsAffineMatrixInversible(FMatrix) then
857 FMatrix := AffineMatrixInverse(FMatrix) else
858 FEmptyMatrix := True;
859 end;
860
TBGRAAffineScannerTransform.GetViewMatrixnull861 function TBGRAAffineScannerTransform.GetViewMatrix: TAffineMatrix;
862 begin
863 if FEmptyMatrix then
864 result := AffineMatrixIdentity
865 else
866 result := AffineMatrixInverse(FMatrix);
867 end;
868
869 procedure TBGRAAffineScannerTransform.SetViewMatrix(AValue: TAffineMatrix);
870 begin
871 Matrix := AValue;
872 Invert;
873 end;
874
875 procedure TBGRAAffineScannerTransform.SetMatrix(AMatrix: TAffineMatrix);
876 begin
877 FEmptyMatrix := False;
878 FMatrix := AMatrix;
879 end;
880
881 //transformations are inverted because the effect on the resulting image
882 //is the inverse of the transformation. This is due to the fact
883 //that the matrix is applied to source coordinates, not destination coordinates
884 procedure TBGRAAffineScannerTransform.Translate(OfsX, OfsY: Single);
885 begin
886 MultiplyBy(AffineMatrixTranslation(-OfsX,-OfsY));
887 end;
888
889 procedure TBGRAAffineScannerTransform.RotateDeg(AngleCW: Single);
890 begin
891 MultiplyBy(AffineMatrixRotationDeg(-AngleCW));
892 end;
893
894 procedure TBGRAAffineScannerTransform.RotateRad(AngleCCW: Single);
895 begin
896 MultiplyBy(AffineMatrixRotationRad(-AngleCCW));
897 end;
898
899 procedure TBGRAAffineScannerTransform.MultiplyBy(AMatrix: TAffineMatrix);
900 begin
901 FMatrix := FMatrix * AMatrix;
902 end;
903
904 procedure TBGRAAffineScannerTransform.Fit(Origin, HAxis, VAxis: TPointF);
905 begin
906 SetMatrix(AffineMatrix(HAxis.X-Origin.X, VAxis.X-Origin.X, 0,
907 HAxis.Y-Origin.Y, VAxis.Y-Origin.Y, 0));
908 Invert;
909 Translate(Origin.X,Origin.Y);
910 end;
911
912 procedure TBGRAAffineScannerTransform.Scale(sx, sy: single);
913 begin
914 if (sx=0) or (sy=0) then
915 begin
916 FEmptyMatrix := True;
917 exit;
918 end;
919
920 MultiplyBy(AffineMatrixScale(1/sx,1/sy));
921 end;
922
923 procedure TBGRAAffineScannerTransform.Scale(factor: single);
924 begin
925 Scale(factor,factor);
926 end;
927
TBGRAAffineScannerTransform.GetScanCustomColorspacenull928 function TBGRAAffineScannerTransform.GetScanCustomColorspace: TColorspaceAny;
929 begin
930 Result:= TBGRAPixelColorspace;
931 end;
932
933 procedure TBGRAAffineScannerTransform.ScanMoveTo(X, Y: Integer);
934 begin
935 ScanMoveToF(X,Y);
936 end;
937
938 procedure TBGRAAffineScannerTransform.ScanMoveToF(X, Y: single);
939 begin
940 FCur := FMatrix * PointF(X,Y);
941 end;
942
InternalScanCurrentPixelnull943 function TBGRAAffineScannerTransform.InternalScanCurrentPixel: TBGRAPixel;
944 begin
945 if FEmptyMatrix then
946 begin
947 result := BGRAPixelTransparent;
948 exit;
949 end;
950 result := FScanAtFunc(FCur.X,FCur.Y);
951 end;
952
TBGRAAffineScannerTransform.ScanNextPixelnull953 function TBGRAAffineScannerTransform.ScanNextPixel: TBGRAPixel;
954 begin
955 result := InternalScanCurrentPixel;
956 FCur.Offset(FMatrix[1,1], FMatrix[2,1]);
957 if GlobalOpacity <> 255 then result.alpha := ApplyOpacity(result.alpha,GlobalOpacity);
958 end;
959
960 procedure TBGRAAffineScannerTransform.ScanSkipPixels(ACount: integer);
961 begin
962 FCur.Offset(FMatrix[1,1]*ACount, FMatrix[2,1]*ACount);
963 end;
964
ScanAtnull965 function TBGRAAffineScannerTransform.ScanAt(X, Y: Single): TBGRAPixel;
966 begin
967 ScanMoveToF(X,Y);
968 result := InternalScanCurrentPixel;
969 if GlobalOpacity <> 255 then result.alpha := ApplyOpacity(result.alpha,GlobalOpacity);
970 end;
971
972 { TBGRAQuadLinearScanner }
973
GetTexColorAtnull974 function TBGRAQuadLinearScanner.GetTexColorAt(u, v: Single; detNeg: boolean
975 ): TBGRAPixel;
976 var isPadding: boolean;
977 begin
978 if detNeg then
979 begin
980 if not FShowC2 then
981 begin
982 result := BGRAPixelTransparent;
983 exit;
984 end;
985 end else
986 if not FShowC1 then
987 begin
988 result := BGRAPixelTransparent;
989 exit;
990 end;
991 GetTexColorAt(u,v,result,isPadding);
992 end;
993
994 procedure TBGRAQuadLinearScanner.ScanMoveToF(X, Y: single);
995 begin
996 if not (FHasC1 and FShowC1) and not (FHasC2 and FShowC2) then
997 begin
998 FScanFunc := @ScanNone;
999 exit;
1000 end;
1001 FCurXF := X;
1002 FCurYF := Y;
1003 if (FVectors[0].x = 0) and (FVectors[2].x = 0) then
1004 begin
1005 PrepareScanVert0;
1006 FScanFunc := @ScanVert0;
1007 end else
1008 if aa = 0 then
1009 begin
1010 PrepareScanPara;
1011 FScanFunc := @ScanPara
1012 end
1013 else
1014 FScanFunc := @ScanGeneral;
1015 end;
1016
1017 procedure TBGRAQuadLinearScanner.SetCulling(AValue: TFaceCulling);
1018 begin
1019 FShowC1 := AValue in [fcKeepCW,fcNone];
1020 FShowC2 := AValue in [fcKeepCCW,fcNone];
1021 end;
1022
1023 procedure TBGRAQuadLinearScanner.Init(ASource: IBGRAScanner;
1024 const APoints: array of TPointF; ATextureInterpolation: boolean);
1025 var
1026 i: Int32or64;
1027 v: TPointF;
1028 len: single;
1029 begin
1030 if length(APoints)<>4 then
1031 raise exception.Create('Expecting 4 points');
1032 FTextureInterpolation:= ATextureInterpolation;
1033 FSource := ASource;
1034 FSourceMatrix := AffineMatrixIdentity;
1035 FUVVector := PointF(0,0);
1036 for i := 0 to 3 do
1037 begin
1038 FPoints[i] := APoints[i];
1039 v := APoints[(i+1) mod 4] - APoints[i];
1040 len := sqrt(v*v);
1041 if len > 0 then FInvLengths[i] := 1/len
1042 else FInvLengths[i] := 0;
1043 FVectors[i] := v*FInvLengths[i];
1044 end;
1045
1046 FCoeffs[0] := FPoints[0];
1047 FCoeffs[1] := FPoints[1]-FPoints[0];
1048 FCoeffs[2] := FPoints[3]-FPoints[0];
1049 FCoeffs[3] := FPoints[0]+FPoints[2]-FPoints[1]-FPoints[3];
1050
1051 aa := VectDet(FCoeffs[3],FCoeffs[2]);
1052 bb0 := VectDet(FCoeffs[3],FCoeffs[0]) + VectDet(FCoeffs[1],FCoeffs[2]);
1053 cc0 := VectDet(FCoeffs[1],FCoeffs[0]);
1054 for i := 0 to 3 do
1055 FDets[i] := VectDet(FVectors[i],FVectors[(i+1) mod 4]);
1056 if aa <> 0 then inv2aa := 1/(2*aa) else inv2aa := 1;
1057
1058 FShowC1 := true;
1059 FShowC2 := true;
1060
1061 FHasC1 := false;
1062 FHasC2 := false;
1063 for i := 0 to 3 do
1064 if FDets[i] > 0 then FHasC1 := true
1065 else if FDets[i] < 0 then FHasC2 := true;
1066
1067 FBuffer := nil;
1068 FBufferSize := 0;
1069
1070 ScanMoveToF(0,0);
1071 end;
1072
TBGRAQuadLinearScanner.ScanAtnull1073 function TBGRAQuadLinearScanner.ScanAt(X, Y: Single): TBGRAPixel;
1074 begin
1075 ScanMoveToF(X,Y);
1076 Result:= FScanFunc();
1077 end;
1078
1079 procedure TBGRAQuadLinearScanner.ScanPutPixels(pdest: PBGRAPixel; count: integer;
1080 mode: TDrawMode);
1081 var
1082 n: Int32or64;
1083 p: PBGRAPixel;
1084 begin
1085 if mode = dmSet then
1086 p := pdest
1087 else
1088 begin
1089 if count > FBufferSize then
1090 begin
1091 FBufferSize := count;
1092 ReAllocMem(FBuffer, FBufferSize*sizeof(TBGRAPixel));
1093 end;
1094 p := FBuffer;
1095 end;
1096 for n := count-1 downto 0 do
1097 begin
1098 p^ := FScanFunc();
1099 inc(p);
1100 end;
1101 if mode <> dmSet then PutPixels(pdest,FBuffer,count,mode,255);
1102 end;
1103
IsScanPutPixelsDefinednull1104 function TBGRAQuadLinearScanner.IsScanPutPixelsDefined: boolean;
1105 begin
1106 result := true;
1107 end;
1108
1109 procedure TBGRAQuadLinearScanner.ScanMoveTo(X, Y: Integer);
1110 begin
1111 ScanMoveToF(X,Y);
1112 end;
1113
TBGRAQuadLinearScanner.ScanNextPixelnull1114 function TBGRAQuadLinearScanner.ScanNextPixel: TBGRAPixel;
1115 begin
1116 Result:= FScanFunc();
1117 end;
1118
1119 procedure TBGRAQuadLinearScanner.ScanSkipPixels(ACount: integer);
1120 begin
1121 ScanMoveToF(FCurXF+ACount,FCurYF);
1122 end;
1123
ScanGeneralnull1124 function TBGRAQuadLinearScanner.ScanGeneral: TBGRAPixel;
1125 var u1,u2,v1,v2,x,y: double;
1126 bb,cc,det,delta,denom: double;
1127 mergeC1,mergeC2: boolean;
1128 isPad1,isPad2: boolean;
1129 c1,c2: TBGRAPixel;
1130 begin
1131 x := FCurXF;
1132 y := FCurYF;
1133 IncF(FCurXF, 1);
1134 if (Y = FPoints[0].y) and (FVectors[0].y = 0) then
1135 begin
1136 if FVectors[0].x = 0 then
1137 begin
1138 result := BGRAPixelTransparent;
1139 exit;
1140 end;
1141 u1 := (X - FPoints[0].x)/(FPoints[1].x-FPoints[0].x);
1142 result := GetTexColorAt(u1,0,FDets[0]<0);
1143 exit;
1144 end;
1145 if (X = FPoints[1].x) and (FVectors[1].x = 0) then
1146 begin
1147 if FVectors[1].y = 0 then
1148 begin
1149 result := BGRAPixelTransparent;
1150 exit;
1151 end;
1152 v1 := (Y - FPoints[1].y)/(FPoints[2].y-FPoints[1].y);
1153 result := GetTexColorAt(0,v1,FDets[1]<0);
1154 end;
1155 if (Y = FPoints[2].y) and (FVectors[2].y = 0) then
1156 begin
1157 if FVectors[2].x = 0 then
1158 begin
1159 result := BGRAPixelTransparent;
1160 exit;
1161 end;
1162 u1 := (X - FPoints[3].x)/(FPoints[2].x-FPoints[3].x);
1163 result := GetTexColorAt(u1,1,FDets[2]<0);
1164 end;
1165 if (X = FPoints[3].x) and (FVectors[3].x = 0) then
1166 begin
1167 if FVectors[3].y = 0 then
1168 begin
1169 result := BGRAPixelTransparent;
1170 exit;
1171 end;
1172 v1 := (Y - FPoints[0].y)/(FPoints[3].y-FPoints[0].y);
1173 result := GetTexColorAt(0,v1,FDets[3]<0);
1174 end;
1175
1176 bb := bb0 + x*FCoeffs[3].y - y*FCoeffs[3].x;
1177 cc := cc0 + x*FCoeffs[1].y - y*FCoeffs[1].x;
1178 if cc = 0 then
1179 begin
1180 v1 := -bb*2*inv2aa;
1181 denom := FCoeffs[1].x+FCoeffs[3].x*v1;
1182 if denom = 0 then
1183 begin
1184 result := BGRAPixelTransparent;
1185 exit;
1186 end
1187 else
1188 u1 := (x-FCoeffs[0].x-FCoeffs[2].x*v1)/denom;
1189
1190 result := GetTexColorAt(u1,v1,bb<0);
1191 end else
1192 begin
1193 delta := bb*bb - 4*aa*cc;
1194
1195 if delta < 0 then
1196 begin
1197 result := BGRAPixelTransparent;
1198 exit;
1199 end;
1200 det := sqrt(delta);
1201
1202 if FHasC1 and FShowC1 then
1203 begin
1204 mergeC1 := true;
1205 v1 := (-bb+det)*inv2aa;
1206 if v1 = 0 then
1207 u1 := (FVectors[0]*FInvLengths[0])*(PointF(x,y)-FPoints[0])
1208 else if v1 = 1 then
1209 u1 := 1 - (FVectors[2]*FInvLengths[2])*(PointF(x,y)-FPoints[2])
1210 else
1211 begin
1212 denom := FCoeffs[1].x+FCoeffs[3].x*v1;
1213 if abs(denom)<1e-6 then
1214 begin
1215 u1 := (bb+det)*inv2aa;
1216 denom := FCoeffs[1].y+FCoeffs[3].y*u1;
1217 if denom = 0 then mergeC1 := false
1218 else v1 := (y-FCoeffs[0].y-FCoeffs[2].y*u1)/denom;
1219 end
1220 else u1 := (x-FCoeffs[0].x-FCoeffs[2].x*v1)/denom;
1221 end;
1222 end else
1223 begin
1224 u1 := 0;
1225 v1 := 0;
1226 mergeC1 := false;
1227 end;
1228
1229 if FHasC2 and FShowC2 then
1230 begin
1231 mergeC2 := true;
1232 v2 := (-bb-det)*inv2aa;
1233 if v2 = 0 then
1234 u2 := (FVectors[0]*FInvLengths[0])*(PointF(x,y)-FPoints[0])
1235 else if v2 = 1 then
1236 u2 := 1 - (FVectors[2]*FInvLengths[2])*(PointF(x,y)-FPoints[2])
1237 else
1238 begin
1239 denom := FCoeffs[1].x+FCoeffs[3].x*v2;
1240 if abs(denom)<1e-6 then
1241 begin
1242 u2 := (bb-det)*inv2aa;
1243 denom := FCoeffs[1].y+FCoeffs[3].y*u2;
1244 if denom = 0 then mergeC2 := false
1245 else v2 := (y-FCoeffs[0].y-FCoeffs[2].y*u2)/denom;
1246 end
1247 else u2 := (x-FCoeffs[0].x-FCoeffs[2].x*v2)/denom;
1248 end;
1249 end else
1250 begin
1251 u2 := 0;
1252 v2 := 0;
1253 mergeC2 := false;
1254 end;
1255
1256 if mergeC1 then
1257 begin
1258 if mergeC2 then
1259 begin
1260 GetTexColorAt(u1,v1,c1,isPad1);
1261 GetTexColorAt(u2,v2,c2,isPad2);
1262 if isPad1 then
1263 begin
1264 if isPad2 then result := MergeBGRA(c1,c2)
1265 else result := c2;
1266 end else
1267 begin
1268 if isPad2 then result := c1
1269 else result := MergeBGRA(c1,c2);
1270 end;
1271 end
1272 else GetTexColorAt(u1,v1,result,isPad1);
1273 end
1274 else
1275 if mergeC2 then
1276 GetTexColorAt(u2,v2,result,isPad2)
1277 else result := BGRAPixelTransparent;
1278 end;
1279 end;
1280
TBGRAQuadLinearScanner.GetCullingnull1281 function TBGRAQuadLinearScanner.GetCulling: TFaceCulling;
1282 begin
1283 if FShowC1 and FShowC2 then
1284 result := fcNone
1285 else if FShowC1 then
1286 result := fcKeepCW
1287 else
1288 result := fcKeepCCW;
1289 end;
1290
ScanNonenull1291 function TBGRAQuadLinearScanner.ScanNone: TBGRAPixel;
1292 begin
1293 result := BGRAPixelTransparent;
1294 end;
1295
1296 procedure TBGRAQuadLinearScanner.PrepareScanVert0;
1297 begin
1298 if (FVectors[1].x <> 0) then
1299 begin
1300 ScanVertVStep0 := 1/(FPoints[2].x-FPoints[1].x);
1301 ScanVertV0 := (FCurXF-FPoints[1].x)*ScanVertVStep0;
1302 ScanVertDenom0 := (FPoints[1].y-FPoints[0].y)*(1-ScanVertV0) + (FPoints[2].y-FPoints[3].y)*ScanVertV0;
1303 ScanVertDenomStep0 := (FPoints[2].y-FPoints[3].y-FPoints[1].y+FPoints[0].y)*ScanVertVStep0;
1304 end
1305 else
1306 begin
1307 ScanVertV0 := 0;
1308 ScanVertVStep0 := EmptySingle;
1309 end;
1310 end;
1311
TBGRAQuadLinearScanner.ScanVert0null1312 function TBGRAQuadLinearScanner.ScanVert0: TBGRAPixel;
1313 var u: single;
1314 isPad: boolean;
1315 begin
1316 IncF(FCurXF, 1);
1317 if ScanVertVStep0 = EmptySingle then
1318 begin
1319 result := BGRAPixelTransparent;
1320 exit;
1321 end;
1322 if ScanVertDenom0 = 0 then
1323 result := BGRAPixelTransparent
1324 else
1325 begin
1326 u := (FCurYF-(FPoints[0].y*(1-ScanVertV0) + FPoints[3].y*ScanVertV0))/ScanVertDenom0;
1327 GetTexColorAt(u,ScanVertV0,result,isPad);
1328 end;
1329 IncF(ScanVertV0, ScanVertVStep0);
1330 IncF(ScanVertDenom0, ScanVertDenomStep0);
1331 end;
1332
1333 procedure TBGRAQuadLinearScanner.PrepareScanPara;
1334 begin
1335 ScanParaBB := bb0 + FCurXF*FCoeffs[3].y - FCurYF*FCoeffs[3].x;
1336 ScanParaCC := cc0 + FCurXF*FCoeffs[1].y - FCurYF*FCoeffs[1].x;
1337 if ScanParaBB <> 0 then
1338 ScanParaBBInv := 1/ScanParaBB
1339 else
1340 ScanParaBBInv := 1;
1341 end;
1342
TBGRAQuadLinearScanner.ScanParanull1343 function TBGRAQuadLinearScanner.ScanPara: TBGRAPixel;
1344 var
1345 u,v,denom: Single;
1346 isPad: boolean;
1347 begin
1348 IncF(FCurXF, 1);
1349
1350 if ScanParaBB = 0 then
1351 result := BGRAPixelTransparent
1352 else
1353 begin
1354 v := -ScanParaCC*ScanParaBBInv;
1355 denom := FCoeffs[1].x+FCoeffs[3].x*v;
1356 if denom = 0 then
1357 result := BGRAPixelTransparent
1358 else
1359 begin
1360 u := (FCurXF-1-FCoeffs[0].x-FCoeffs[2].x*v)/denom;
1361 GetTexColorAt(u,v,result,isPad);
1362 end;
1363 end;
1364
1365 if FCoeffs[3].y <> 0 then
1366 begin
1367 IncF(ScanParaBB, FCoeffs[3].y);
1368 if ScanParaBB <> 0 then
1369 ScanParaBBInv := 1/ScanParaBB
1370 else
1371 ScanParaBBInv := 1;
1372 end;
1373 IncF(ScanParaCC, FCoeffs[1].y);
1374 end;
1375
1376 procedure TBGRAQuadLinearScanner.GetTexColorAt(u,v: Single; out AColor: TBGRAPixel; out AIsPadding: boolean);
1377 begin
1378 AIsPadding:= false;
1379 if u < 0 then begin if Padding then begin u := 0; AIsPadding := true end else begin AColor := BGRAPixelTransparent; exit end end;
1380 if u > 1 then begin if Padding then begin u := 1; AIsPadding := true end else begin AColor := BGRAPixelTransparent; exit end end;
1381 if v < 0 then begin if Padding then begin v := 0; AIsPadding := true end else begin AColor := BGRAPixelTransparent; exit end end;
1382 if v > 1 then begin if Padding then begin v := 1; AIsPadding := true end else begin AColor := BGRAPixelTransparent; exit end end;
1383 with (FSourceMatrix * PointF(u,v) + FUVVector*(u*v)) do
1384 if FTextureInterpolation then
1385 AColor := FSource.ScanAt(x,y)
1386 else
1387 AColor := FSource.ScanAtInteger(System.round(x),System.round(y));
1388 end;
1389
1390 constructor TBGRAQuadLinearScanner.Create(ASource: IBGRAScanner;
1391 ASourceMatrix: TAffineMatrix; const APoints: array of TPointF;
1392 ATextureInterpolation: boolean);
1393 begin
1394 Init(ASource, APoints, ATextureInterpolation);
1395 FSourceMatrix := ASourceMatrix;
1396 end;
1397
1398 constructor TBGRAQuadLinearScanner.Create(ASource: IBGRAScanner;
1399 const ATexCoords: array of TPointF; const APoints: array of TPointF;
1400 ATextureInterpolation: boolean);
1401 begin
1402 Init(ASource, APoints, ATextureInterpolation);
1403 FSourceMatrix := AffineMatrixTranslation(ATexCoords[0].x,ATexCoords[0].y)*
1404 AffineMatrixLinear(ATexCoords[1]-ATexCoords[0],ATexCoords[3]-ATexCoords[0]);
1405 FUVVector := ATexCoords[2] - (ATexCoords[1]+ATexCoords[3]-ATexCoords[0]);
1406 end;
1407
1408 destructor TBGRAQuadLinearScanner.Destroy;
1409 begin
1410 freemem(FBuffer);
1411 inherited Destroy;
1412 end;
1413
1414 { TBGRAAffineBitmapTransform }
1415
1416 procedure TBGRAAffineBitmapTransform.Init(ABitmap: TBGRACustomBitmap;
1417 ARepeatImageX: Boolean; ARepeatImageY: Boolean;
1418 AResampleFilter: TResampleFilter; AIncludeEdges: boolean = false);
1419 begin
1420 if (ABitmap.Width = 0) or (ABitmap.Height = 0) then
1421 raise Exception.Create('Empty image');
1422 inherited Create(ABitmap);
1423 FBitmap := ABitmap;
1424 FRepeatImageX := ARepeatImageX;
1425 FRepeatImageY := ARepeatImageY;
1426 FResampleFilter:= AResampleFilter;
1427 FBuffer := nil;
1428 FBufferSize:= 0;
1429 FIncludeEdges := AIncludeEdges;
1430 end;
1431
1432 constructor TBGRAAffineBitmapTransform.Create(ABitmap: TBGRACustomBitmap;
1433 ARepeatImage: Boolean; AResampleFilter: TResampleFilter = rfLinear; AIncludeEdges: boolean = false);
1434 begin
1435 Init(ABitmap,ARepeatImage,ARepeatImage,AResampleFilter,AIncludeEdges);
1436 end;
1437
1438 constructor TBGRAAffineBitmapTransform.Create(ABitmap: TBGRACustomBitmap;
1439 ARepeatImageX: Boolean; ARepeatImageY: Boolean;
1440 AResampleFilter: TResampleFilter; AIncludeEdges: boolean = false);
1441 begin
1442 Init(ABitmap,ARepeatImageX,ARepeatImageY,AResampleFilter,AIncludeEdges);
1443 end;
1444
1445 destructor TBGRAAffineBitmapTransform.Destroy;
1446 begin
1447 FreeMem(FBuffer);
1448 end;
1449
InternalScanCurrentPixelnull1450 function TBGRAAffineBitmapTransform.InternalScanCurrentPixel: TBGRAPixel;
1451 begin
1452 if FEmptyMatrix then
1453 begin
1454 result := BGRAPixelTransparent;
1455 exit;
1456 end;
1457 result := FBitmap.GetPixelCycle(FCur.X,FCur.Y,FResampleFilter,FRepeatImageX,FRepeatImageY);
1458 end;
1459
1460 procedure TBGRAAffineBitmapTransform.ScanPutPixels(pdest: PBGRAPixel;
1461 count: integer; mode: TDrawMode);
1462 const PrecisionShift = {$IFDEF CPU64}24{$ELSE}12{$ENDIF};
1463 Precision = 1 shl PrecisionShift;
1464 var p: PBGRAPixel;
1465 n: integer;
1466 posXPrecision, posYPrecision: Int32or64;
1467 deltaXPrecision,deltaYPrecision: Int32or64;
1468 ix,iy,shrMask,w,h: Int32or64;
1469 py0: PByte;
1470 deltaRow: Int32or64;
1471 begin
1472 w := FBitmap.Width;
1473 h := FBitmap.Height;
1474 if (w = 0) or (h = 0) then exit;
1475
1476 if GlobalOpacity = 0 then
1477 begin
1478 if mode = dmSet then
1479 FillDWord(pdest^, count, LongWord(BGRAPixelTransparent));
1480 FCur.Offset(FMatrix[1,1]*count, FMatrix[2,1]*count);
1481 exit;
1482 end;
1483
1484 posXPrecision := round(FCur.X*Precision);
1485 deltaXPrecision:= round(FMatrix[1,1]*Precision);
1486 posYPrecision := round(FCur.Y*Precision);
1487 deltaYPrecision:= round(FMatrix[2,1]*Precision);
1488 shrMask := -1;
1489 shrMask := shrMask shr PrecisionShift;
1490 shrMask := not shrMask;
1491
1492 if mode = dmSet then
1493 p := pdest
1494 else
1495 begin
1496 if count > FBufferSize then
1497 begin
1498 FBufferSize := count;
1499 ReAllocMem(FBuffer, FBufferSize*sizeof(TBGRAPixel));
1500 end;
1501 p := FBuffer;
1502 end;
1503
1504 if FResampleFilter = rfBox then
1505 begin
1506 inc(posXPrecision, Precision shr 1);
1507 inc(posYPrecision, Precision shr 1);
1508 py0 := PByte(FBitmap.ScanLine[0]);
1509 if FBitmap.LineOrder = riloTopToBottom then
1510 deltaRow := FBitmap.Width*sizeof(TBGRAPixel) else
1511 deltaRow := -FBitmap.Width*sizeof(TBGRAPixel);
1512 if FRepeatImageX or FRepeatImageY then
1513 begin
1514 for n := count-1 downto 0 do
1515 begin
1516 if posXPrecision < 0 then ix := (posXPrecision shr PrecisionShift) or shrMask else ix := posXPrecision shr PrecisionShift;
1517 if posYPrecision < 0 then iy := (posYPrecision shr PrecisionShift) or shrMask else iy := posYPrecision shr PrecisionShift;
1518 if FRepeatImageX then ix := PositiveMod(ix,w);
1519 if FRepeatImageY then iy := PositiveMod(iy,h);
1520 if (ix < 0) or (iy < 0) or (ix >= w) or (iy >= h) then
1521 p^ := BGRAPixelTransparent
1522 else
1523 p^ := (PBGRAPixel(py0 + iy*deltaRow)+ix)^;
1524 inc(p);
1525 inc(posXPrecision, deltaXPrecision);
1526 inc(posYPrecision, deltaYPrecision);
1527 end;
1528 end else
1529 begin
1530 for n := count-1 downto 0 do
1531 begin
1532 if posXPrecision < 0 then ix := (posXPrecision shr PrecisionShift) or shrMask else ix := posXPrecision shr PrecisionShift;
1533 if posYPrecision < 0 then iy := (posYPrecision shr PrecisionShift) or shrMask else iy := posYPrecision shr PrecisionShift;
1534 if (ix < 0) or (iy < 0) or (ix >= w) or (iy >= h) then
1535 p^ := BGRAPixelTransparent
1536 else
1537 p^ := (PBGRAPixel(py0 + iy*deltaRow)+ix)^;
1538 inc(p);
1539 inc(posXPrecision, deltaXPrecision);
1540 inc(posYPrecision, deltaYPrecision);
1541 end;
1542 end;
1543 end else
1544 begin
1545 if FRepeatImageX and FRepeatImageY then
1546 begin
1547 for n := count-1 downto 0 do
1548 begin
1549 if posXPrecision < 0 then ix := (posXPrecision shr PrecisionShift) or shrMask else ix := posXPrecision shr PrecisionShift;
1550 if posYPrecision < 0 then iy := (posYPrecision shr PrecisionShift) or shrMask else iy := posYPrecision shr PrecisionShift;
1551 p^ := FBitmap.GetPixelCycle256(ix,iy, (posXPrecision shr (PrecisionShift-8)) and 255, (posYPrecision shr (PrecisionShift-8)) and 255,FResampleFilter);
1552 inc(p);
1553 inc(posXPrecision, deltaXPrecision);
1554 inc(posYPrecision, deltaYPrecision);
1555 end;
1556 end else
1557 if FRepeatImageX or FRepeatImageY then
1558 begin
1559 for n := count-1 downto 0 do
1560 begin
1561 if posXPrecision < 0 then ix := (posXPrecision shr PrecisionShift) or shrMask else ix := posXPrecision shr PrecisionShift;
1562 if posYPrecision < 0 then iy := (posYPrecision shr PrecisionShift) or shrMask else iy := posYPrecision shr PrecisionShift;
1563 p^ := FBitmap.GetPixelCycle256(ix,iy, (posXPrecision shr (PrecisionShift-8)) and 255, (posYPrecision shr (PrecisionShift-8)) and 255,FResampleFilter, FRepeatImageX,FRepeatImageY);
1564 inc(p);
1565 inc(posXPrecision, deltaXPrecision);
1566 inc(posYPrecision, deltaYPrecision);
1567 end;
1568 end else
1569 begin
1570 for n := count-1 downto 0 do
1571 begin
1572 if posXPrecision < 0 then ix := (posXPrecision shr PrecisionShift) or shrMask else ix := posXPrecision shr PrecisionShift;
1573 if posYPrecision < 0 then iy := (posYPrecision shr PrecisionShift) or shrMask else iy := posYPrecision shr PrecisionShift;
1574 p^ := FBitmap.GetPixel256(ix,iy, (posXPrecision shr (PrecisionShift-8)) and 255, (posYPrecision shr (PrecisionShift-8)) and 255,FResampleFilter);
1575 inc(p);
1576 inc(posXPrecision, deltaXPrecision);
1577 inc(posYPrecision, deltaYPrecision);
1578 end;
1579 end;
1580 end;
1581
1582 if GlobalOpacity < 255 then
1583 begin
1584 if mode = dmSet then
1585 p := pdest
1586 else
1587 p := FBuffer;
1588 for n := count-1 downto 0 do
1589 begin
1590 p^.alpha := ApplyOpacity(p^.alpha,GlobalOpacity);
1591 if p^.alpha = 0 then p^ := BGRAPixelTransparent;
1592 inc(p);
1593 end;
1594 end;
1595
1596 if mode <> dmSet then PutPixels(pdest,FBuffer,count,mode,255);
1597 FCur.Offset(FMatrix[1,1]*count, FMatrix[2,1]*count);
1598 end;
1599
IsScanPutPixelsDefinednull1600 function TBGRAAffineBitmapTransform.IsScanPutPixelsDefined: boolean;
1601 begin
1602 Result:=true;
1603 end;
1604
1605 procedure TBGRAAffineBitmapTransform.Fit(Origin, HAxis, VAxis: TPointF);
1606 begin
1607 if (FBitmap.Width = 0) or (FBitmap.Height = 0) then exit;
1608 Matrix := AffineMatrix(HAxis.X-Origin.X, VAxis.X-Origin.X, Origin.X,
1609 HAxis.Y-Origin.Y, VAxis.Y-Origin.Y, Origin.Y);
1610 Invert;
1611 if FIncludeEdges then
1612 begin
1613 Matrix := AffineMatrixTranslation(-0.5,-0.5)*AffineMatrixScale(FBitmap.Width,FBitmap.Height)*Matrix;
1614 end else
1615 Matrix := AffineMatrixScale(FBitmap.Width-1,FBitmap.Height-1)*Matrix;
1616 end;
1617
1618 { TBGRAPerspectiveScannerTransform }
1619
GetIncludeOppositePlanenull1620 function TBGRAPerspectiveScannerTransform.GetIncludeOppositePlane: boolean;
1621 begin
1622 if FMatrix = nil then
1623 result := false
1624 else
1625 result := FMatrix.IncludeOppositePlane;
1626 end;
1627
1628 procedure TBGRAPerspectiveScannerTransform.SetIncludeOppositePlane(
1629 AValue: boolean);
1630 begin
1631 if FMatrix <> nil then
1632 FMatrix.IncludeOppositePlane := AValue;
1633 end;
1634
1635 constructor TBGRAPerspectiveScannerTransform.Create(texture: IBGRAScanner; texCoord1,texCoord2: TPointF; const quad: array of TPointF);
1636 begin
1637 if DoesQuadIntersect(quad[0],quad[1],quad[2],quad[3]) or not IsConvex(quad,False) or (texCoord1.x = texCoord2.x) or (texCoord1.y = texCoord2.y) then
1638 FMatrix := nil
1639 else
1640 begin
1641 FMatrix := TPerspectiveTransform.Create(quad,texCoord1.x,texCoord1.y,texCoord2.x,texCoord2.y);
1642 FMatrix.OutsideValue := EmptyPointF;
1643 end;
1644 FTexture := texture;
1645 FScanAtProc:= @FTexture.ScanAt;
1646 end;
1647
1648 constructor TBGRAPerspectiveScannerTransform.Create(texture: IBGRAScanner;
1649 const texCoordsQuad: array of TPointF; const quad: array of TPointF);
1650 begin
1651 if DoesQuadIntersect(quad[0],quad[1],quad[2],quad[3]) or not IsConvex(quad,False) or
1652 DoesQuadIntersect(texCoordsQuad[0],texCoordsQuad[1],texCoordsQuad[2],texCoordsQuad[3]) or not IsConvex(texCoordsQuad,False) then
1653 FMatrix := nil
1654 else
1655 begin
1656 FMatrix := TPerspectiveTransform.Create(quad,texCoordsQuad);
1657 FMatrix.OutsideValue := EmptyPointF;
1658 end;
1659 FTexture := texture;
1660 FScanAtProc:= @FTexture.ScanAt;
1661 end;
1662
1663 destructor TBGRAPerspectiveScannerTransform.Destroy;
1664 begin
1665 FMatrix.free;
1666 inherited Destroy;
1667 end;
1668
1669 procedure TBGRAPerspectiveScannerTransform.ScanMoveTo(X, Y: Integer);
1670 begin
1671 if FMatrix = nil then exit;
1672 FMatrix.ScanMoveTo(X,Y);
1673 end;
1674
TBGRAPerspectiveScannerTransform.ScanAtnull1675 function TBGRAPerspectiveScannerTransform.ScanAt(X, Y: Single): TBGRAPixel;
1676 var ptSource: TPointF;
1677 begin
1678 if FMatrix = nil then
1679 result := BGRAPixelTransparent else
1680 begin
1681 ptSource := FMatrix.Apply(PointF(X,Y));
1682 if ptSource.x = EmptySingle then
1683 result := BGRAPixelTransparent
1684 else
1685 Result:= FScanAtProc(ptSource.X, ptSource.Y);
1686 end;
1687 end;
1688
TBGRAPerspectiveScannerTransform.ScanNextPixelnull1689 function TBGRAPerspectiveScannerTransform.ScanNextPixel: TBGRAPixel;
1690 var ptSource: TPointF;
1691 begin
1692 if FMatrix = nil then
1693 result := BGRAPixelTransparent else
1694 begin
1695 ptSource := FMatrix.ScanNext;
1696 if ptSource.x = EmptySingle then
1697 result := BGRAPixelTransparent
1698 else
1699 Result:= FScanAtProc(ptSource.X, ptSource.Y);
1700 end;
1701 end;
1702
1703 procedure TBGRAPerspectiveScannerTransform.ScanSkipPixels(ACount: integer);
1704 begin
1705 if FMatrix<>nil then FMatrix.ScanSkip(ACount);
1706 end;
1707
1708 { TPerspectiveTransform }
1709
1710 procedure TPerspectiveTransform.Init;
1711 begin
1712 FOutsideValue := PointF(0,0);
1713 FIncludeOppositePlane:= True;
1714 end;
1715
1716 constructor TPerspectiveTransform.Create;
1717 begin
1718 Init;
1719 AssignIdentity;
1720 end;
1721
1722 constructor TPerspectiveTransform.Create(x1, y1, x2, y2: single;
1723 const quad: array of TPointF);
1724 begin
1725 Init;
1726 MapRectToQuad(x1 ,y1 ,x2 ,y2 ,quad );
1727 end;
1728
1729 constructor TPerspectiveTransform.Create(const quad: array of TPointF; x1, y1,
1730 x2, y2: single);
1731 begin
1732 Init;
1733 MapQuadToRect(quad, x1,y1,x2,y2);
1734 end;
1735
1736 constructor TPerspectiveTransform.Create(const srcQuad,
1737 destQuad: array of TPointF);
1738 begin
1739 Init;
1740 MapQuadToQuad(srcQuad,destQuad);
1741 end;
1742
1743 { Map a quad to quad. First compute quad to square, and then square to quad. }
MapQuadToQuadnull1744 function TPerspectiveTransform.MapQuadToQuad(const srcQuad,
1745 destQuad: array of TPointF): boolean;
1746 var
1747 p : TPerspectiveTransform;
1748 begin
1749 if not MapQuadToSquare(srcQuad ) then
1750 begin
1751 result:=false;
1752 exit;
1753 end;
1754
1755 p := TPerspectiveTransform.Create;
1756 if not p.MapSquareToQuad(destQuad) then
1757 begin
1758 p.Free;
1759 result:=false;
1760 exit;
1761 end;
1762
1763 //combine both transformations
1764 MultiplyBy(p);
1765 p.Free;
1766 result:=true;
1767 end;
1768
1769 //Map a rectangle to a quad. Make a polygon for the rectangle, and map it.
TPerspectiveTransform.MapRectToQuadnull1770 function TPerspectiveTransform.MapRectToQuad(x1, y1, x2, y2: single;
1771 const quad: array of TPointF): boolean;
1772 begin
1773 result := MapQuadToQuad([PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)], quad);
1774 end;
1775
1776 //Map a quad to a rectangle. Make a polygon for the rectangle, and map the quad into it.
MapQuadToRectnull1777 function TPerspectiveTransform.MapQuadToRect(const quad: array of TPointF; x1,
1778 y1, x2, y2: single): boolean;
1779 begin
1780 result := MapQuadToQuad(quad, [PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)]);
1781 end;
1782
1783 //Map a square to a quad
MapSquareToQuadnull1784 function TPerspectiveTransform.MapSquareToQuad(const quad: array of TPointF): boolean;
1785 var
1786 d,d1,d2: TPointF;
1787 den ,u ,v : double;
1788
1789 begin
1790 d := quad[0]-quad[1]+quad[2]-quad[3];
1791
1792 if (d.x = 0.0 ) and
1793 (d.y = 0.0 ) then
1794 begin
1795 // Affine case (parallelogram)
1796 sx :=quad[1].x - quad[0].x;
1797 shy:=quad[1].y - quad[0].y;
1798 w0 :=0.0;
1799 shx:=quad[2].x - quad[1].x;
1800 sy :=quad[2].y - quad[1].y;
1801 w1 :=0.0;
1802 tx :=quad[0].x;
1803 ty :=quad[0].y;
1804 w2 :=1.0;
1805
1806 end
1807 else
1808 begin
1809 d1 := quad[1]-quad[2];
1810 d2 := quad[3]-quad[2];
1811 den:=d1.x * d2.y - d2.x * d1.y;
1812
1813 if den = 0.0 then
1814 begin
1815 // Singular case
1816 sx :=0.0;
1817 shy:=0.0;
1818 w0 :=0.0;
1819 shx:=0.0;
1820 sy :=0.0;
1821 w1 :=0.0;
1822 tx :=0.0;
1823 ty :=0.0;
1824 w2 :=0.0;
1825 result:=false;
1826 exit;
1827 end;
1828
1829 // General case
1830 u:=(d.x * d2.y - d.y * d2.x ) / den;
1831 v:=(d.y * d1.x - d.x * d1.y ) / den;
1832
1833 sx :=quad[1].x - quad[0].x + u * quad[1].x;
1834 shy:=quad[1].y - quad[0].y + u * quad[1].y;
1835 w0 :=u;
1836 shx:=quad[3].x - quad[0].x + v * quad[3].x;
1837 sy :=quad[3].y - quad[0].y + v * quad[3].y;
1838 w1 :=v;
1839 tx :=quad[0].x;
1840 ty :=quad[0].y;
1841 w2 :=1.0;
1842
1843 end;
1844
1845 result:=true;
1846
1847 end;
1848
1849 //Map a quad to a square. Compute mapping from square to quad, then invert.
TPerspectiveTransform.MapQuadToSquarenull1850 function TPerspectiveTransform.MapQuadToSquare(const quad: array of TPointF): boolean;
1851 begin
1852 if not MapSquareToQuad(quad ) then
1853 result:=false
1854 else
1855 result := Invert;
1856 end;
1857
1858 procedure TPerspectiveTransform.AssignIdentity;
1859 begin
1860 sx :=1;
1861 shy:=0;
1862 w0 :=0;
1863 shx:=0;
1864 sy :=1;
1865 w1 :=0;
1866 tx :=0;
1867 ty :=0;
1868 w2 :=1;
1869 end;
1870
Invertnull1871 function TPerspectiveTransform.Invert: boolean;
1872 var
1873 d0, d1, d2, d : double;
1874 copy : TPerspectiveTransform;
1875
1876 begin
1877 d0:= sy * w2 - w1 * ty;
1878 d1:= w0 * ty - shy * w2;
1879 d2:= shy * w1 - w0 * sy;
1880 d := sx * d0 + shx * d1 + tx * d2;
1881
1882 if d = 0.0 then
1883 begin
1884 sx := 0.0;
1885 shy:= 0.0;
1886 w0 := 0.0;
1887 shx:= 0.0;
1888 sy := 0.0;
1889 w1 := 0.0;
1890 tx := 0.0;
1891 ty := 0.0;
1892 w2 := 0.0;
1893 result:= false;
1894 exit;
1895 end;
1896
1897 d:= 1.0 / d;
1898
1899 copy := Duplicate;
1900
1901 sx :=d * d0;
1902 shy:=d * d1;
1903 w0 :=d * d2;
1904 shx:=d * (copy.w1 * copy.tx - copy.shx * copy.w2 );
1905 sy :=d * (copy.sx * copy.w2 - copy.w0 * copy.tx );
1906 w1 :=d * (copy.w0 * copy.shx - copy.sx * copy.w1 );
1907 tx :=d * (copy.shx * copy.ty - copy.sy * copy.tx );
1908 ty :=d * (copy.shy * copy.tx - copy.sx * copy.ty );
1909 w2 :=d * (copy.sx * copy.sy - copy.shy * copy.shx );
1910
1911 copy.free;
1912
1913 result:=true;
1914 end;
1915
1916 procedure TPerspectiveTransform.Translate(dx, dy: single);
1917 begin
1918 tx:=tx + dx;
1919 ty:=ty + dy;
1920 end;
1921
1922 procedure TPerspectiveTransform.MultiplyBy(a: TPerspectiveTransform);
1923 var b: TPerspectiveTransform;
1924 begin
1925 b := Duplicate;
1926 sx :=a.sx * b.sx + a.shx * b.shy + a.tx * b.w0;
1927 shx:=a.sx * b.shx + a.shx * b.sy + a.tx * b.w1;
1928 tx :=a.sx * b.tx + a.shx * b.ty + a.tx * b.w2;
1929 shy:=a.shy * b.sx + a.sy * b.shy + a.ty * b.w0;
1930 sy :=a.shy * b.shx + a.sy * b.sy + a.ty * b.w1;
1931 ty :=a.shy * b.tx + a.sy * b.ty + a.ty * b.w2;
1932 w0 :=a.w0 * b.sx + a.w1 * b.shy + a.w2 * b.w0;
1933 w1 :=a.w0 * b.shx + a.w1 * b.sy + a.w2 * b.w1;
1934 w2 :=a.w0 * b.tx + a.w1 * b.ty + a.w2 * b.w2;
1935 b.Free;
1936 end;
1937
1938 procedure TPerspectiveTransform.PremultiplyBy(b: TPerspectiveTransform);
1939 var
1940 a : TPerspectiveTransform;
1941 begin
1942 a := Duplicate;
1943 sx :=a.sx * b.sx + a.shx * b.shy + a.tx * b.w0;
1944 shx:=a.sx * b.shx + a.shx * b.sy + a.tx * b.w1;
1945 tx :=a.sx * b.tx + a.shx * b.ty + a.tx * b.w2;
1946 shy:=a.shy * b.sx + a.sy * b.shy + a.ty * b.w0;
1947 sy :=a.shy * b.shx + a.sy * b.sy + a.ty * b.w1;
1948 ty :=a.shy * b.tx + a.sy * b.ty + a.ty * b.w2;
1949 w0 :=a.w0 * b.sx + a.w1 * b.shy + a.w2 * b.w0;
1950 w1 :=a.w0 * b.shx + a.w1 * b.sy + a.w2 * b.w1;
1951 w2 :=a.w0 * b.tx + a.w1 * b.ty + a.w2 * b.w2;
1952 a.Free;
1953 end;
1954
Duplicatenull1955 function TPerspectiveTransform.Duplicate: TPerspectiveTransform;
1956 begin
1957 result := TPerspectiveTransform.Create;
1958 result.sx :=sx;
1959 result.shy:=shy;
1960 result.w0 :=w0;
1961 result.shx:=shx;
1962 result.sy :=sy;
1963 result.w1 :=w1;
1964 result.tx :=tx;
1965 result.ty :=ty;
1966 result.w2 :=w2;
1967 end;
1968
Applynull1969 function TPerspectiveTransform.Apply(pt: TPointF): TPointF;
1970 var
1971 m : single;
1972 begin
1973 m:= pt.x * w0 + pt.y * w1 + w2;
1974 if (m=0) or (not FIncludeOppositePlane and (m < 0)) then
1975 result := FOutsideValue
1976 else
1977 begin
1978 m := 1/m;
1979 result.x := m * (pt.x * sx + pt.y * shx + tx );
1980 result.y := m * (pt.x * shy + pt.y * sy + ty );
1981 end;
1982 end;
1983
1984 procedure TPerspectiveTransform.ScanMoveTo(x, y: single);
1985 begin
1986 ScanDenom := x * w0 + y * w1 + w2;
1987 ScanNumX := x * sx + y * shx + tx;
1988 scanNumY := x * shy + y * sy + ty;
1989 end;
1990
ScanNextnull1991 function TPerspectiveTransform.ScanNext: TPointF;
1992 var m: single;
1993 begin
1994 if (ScanDenom = 0) or (not FIncludeOppositePlane and (ScanDenom < 0)) then
1995 result := FOutsideValue
1996 else
1997 begin
1998 m := 1/scanDenom;
1999 result.x := m * ScanNumX;
2000 result.y := m * scanNumY;
2001 end;
2002 IncF(ScanDenom, w0);
2003 IncF(ScanNumX, sx);
2004 IncF(scanNumY, shy);
2005 end;
2006
2007 procedure TPerspectiveTransform.ScanSkip(ACount: integer);
2008 begin
2009 IncF(ScanDenom, w0*ACount);
2010 IncF(ScanNumX, sx*ACount);
2011 IncF(scanNumY, shy*ACount);
2012 end;
2013
2014 { TBGRATwirlScanner }
2015
2016 constructor TBGRATwirlScanner.Create(AScanner: IBGRAScanner; ACenter: TPoint; ARadius: single; ATurn: single = 1; AExponent: single = 3);
2017 begin
2018 FScanner := AScanner;
2019 FScanAtFunc := @FScanner.ScanAt;
2020 FCenter := ACenter;
2021 FTurn := ATurn;
2022 FRadius := ARadius;
2023 FExponent := AExponent;
2024 end;
2025
ScanAtnull2026 function TBGRATwirlScanner.ScanAt(X, Y: Single): TBGRAPixel;
2027 var p: TPoint;
2028 d: single;
2029 a,cosa,sina: integer;
2030 begin
2031 p := Point(Round(X)-FCenter.X,Round(Y)-FCenter.Y);
2032 if (abs(p.x) < FRadius) and (abs(p.Y) < FRadius) then
2033 begin
2034 d := sqrt(p.x*p.x+p.y*p.y);
2035 if d < FRadius then
2036 begin
2037 d := (FRadius-d)/FRadius;
2038 if FExponent <> 1 then d := exp(ln(d)*FExponent);
2039 a := round(d*FTurn*65536);
2040 cosa := Cos65536(a)-32768;
2041 sina := Sin65536(a)-32768;
2042 result := FScanner.ScanAt((p.x*cosa+p.y*sina)/32768 + FCenter.X,
2043 (-p.x*sina+p.y*cosa)/32768 + FCenter.Y);
2044 exit;
2045 end;
2046 end;
2047 result := FScanAtFunc(X,Y);
2048 end;
2049
2050 end.
2051
2052