Changeset 522 for GraphicTest/Packages/Graphics32
- Timestamp:
- Apr 17, 2019, 10:42:18 AM (6 years ago)
- Location:
- GraphicTest/Packages/Graphics32
- Files:
-
- 106 added
- 16 deleted
- 45 edited
Legend:
- Unmodified
- Added
- Removed
-
GraphicTest/Packages/Graphics32
-
Property svn:ignore
set to
lib
-
Property svn:ignore
set to
-
GraphicTest/Packages/Graphics32/GR32.inc
r450 r522 174 174 ---------------- 175 175 176 177 178 179 176 If defined SSE2 optimizations are not used (omitted) 177 178 For faster pixel/color processing, SSE2 can be used which results in a huge 179 performance boost over PUREPASCAL code or native assembler code. 180 180 181 181 *) 182 182 183 183 {-$DEFINE OMIT_SSE2} 184 185 186 (* 187 Symbol: USEGR32GAMMA 188 -------------------- 189 190 If defined the polygon rasterizer will use the GR32 gamma correction LUT. 191 192 Disable for a slight performance increase. 193 *) 194 195 {$DEFINE USEGR32GAMMA} 196 197 198 199 (* 200 Symbol: CHANGENOTIFICATIONS 201 --------------------------- 202 203 If defined the polygon rasterizer will trigger change notifications. 204 205 Undefining this will avoid bounding box computations, which may 206 improve performance slightly. 207 *) 208 209 {$DEFINE CHANGENOTIFICATIONS} 210 211 212 213 (* 214 Symbol: USESTACKALLOC 215 --------------------- 216 217 If defined stack allocation routines will be used in some functions. 218 219 Allocating memory on the stack is usually more efficient than using the 220 memory manager. If a routine uses StackAllock/StackFree then it should 221 always be wrapped inside a {$W+}...{$W-} block in order to generate 222 a stack frame. 223 224 NOTE: Undefine this symbol if you get stack overflow errors. 225 *) 226 227 {-$DEFINE USESTACKALLOC} 228 229 (* 230 Symbol: RGBA_FORMAT 231 ------------------- 232 233 Assume RGBA pixel format instead of BGRA (used by e.g. OpenGL.) 234 *) 235 236 {-$DEFINE RGBA_FORMAT} 237 238 (* 239 Symbol: NOHINTING 240 ----------------- 241 242 Disables font hinting by default when using TextToPath() method. 243 244 It is usually preferrable to disable hinting when using a high quality 245 polygon renderer like VPR. However, hinting can sometimes improve 246 visual quality when rendering small text (text is adjusted to pixel 247 boundaries which makes it more crisp.) 248 *) 249 250 {$DEFINE NOHINTING} 251 252 253 (* 254 Symbol: NOHORIZONTALHINTING 255 --------------------------- 256 257 Disables horizontal font hinting when using TextToPath() method. 258 259 The following should not be used in conjunction with NOHINTING. 260 It will attempt to address the problem of extreme font hinting in the 261 GDI by disabling horizontal, but keeping vertical hinting. 262 *) 263 264 {-$DEFINE NOHORIZONTALHINTING} 265 266 267 (* 268 Symbol: USEKERNING 269 ----------------- 270 271 Enables font kerning when using TextToPath() method. 272 273 Kerning is the process of adjusting the spacing between characters in a 274 proportional font, usually to achieve a visually pleasing result. However, 275 parsing for kerning pairs is quite expensive in terms of CPU usage while the 276 effect is often very little. Thus kerning is not enabled by default. 277 *) 278 279 {-$DEFINE USEKERNING} 280 281 282 {-$DEFINE TEST_BLENDMEMRGB128SSE4} -
GraphicTest/Packages/Graphics32/GR32.pas
r450 r522 44 44 45 45 uses 46 {$IFDEF FPC} LCLIntf, LCLType, Types, Controls, Graphics,{$ELSE}47 Windows, Messages, Controls, Graphics,{$ENDIF}48 C lasses, SysUtils, GR32_System;49 46 {$IFDEF FPC} LCLIntf, LCLType, Types, {$ELSE} 47 {$IFDEF COMPILERXE2_UP}UITypes, Types, {$ENDIF} Windows, {$ENDIF} 48 Controls, Graphics, Classes, SysUtils; 49 50 50 { Version Control } 51 51 52 52 const 53 Graphics32Version = ' 1.9.1';53 Graphics32Version = '2.0.0 alpha'; 54 54 55 55 { 32-bit Color } … … 63 63 TArrayOfColor32 = array of TColor32; 64 64 65 {$IFNDEF RGBA_FORMAT} 65 66 TColor32Component = (ccBlue, ccGreen, ccRed, ccAlpha); 67 {$ELSE} 68 TColor32Component = (ccRed, ccGreen, ccBlue, ccAlpha); 69 {$ENDIF} 66 70 TColor32Components = set of TColor32Component; 67 71 … … 69 73 TColor32Entry = packed record 70 74 case Integer of 75 {$IFNDEF RGBA_FORMAT} 71 76 0: (B, G, R, A: Byte); 77 {$ELSE} 78 0: (R, G, B, A: Byte); 79 {$ENDIF} 72 80 1: (ARGB: TColor32); 73 81 2: (Planes: array[0..3] of Byte); … … 236 244 // Some semi-transparent color constants 237 245 clTrWhite32 = TColor32($7FFFFFFF); 246 clTrGray32 = TColor32($7F7F7F7F); 238 247 clTrBlack32 = TColor32($7F000000); 239 248 clTrRed32 = TColor32($7FFF0000); … … 258 267 function AlphaComponent(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} 259 268 function Intensity(Color32: TColor32): Integer; {$IFDEF USEINLINING} inline; {$ENDIF} 269 function InvertColor(Color32: TColor32): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} 260 270 function SetAlpha(Color32: TColor32; NewAlpha: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} 271 procedure ModifyAlpha(var Color32: TColor32; NewAlpha: Byte); {$IFDEF USEINLINING} inline; {$ENDIF} 272 procedure ScaleAlpha(var Color32: TColor32; Scale: Single); {$IFDEF USEINLINING} inline; {$ENDIF} 261 273 262 274 // Color space conversion 263 275 function HSLtoRGB(H, S, L: Single): TColor32; overload; 264 276 procedure RGBtoHSL(RGB: TColor32; out H, S, L : Single); overload; 265 function HSLtoRGB(H, S, L: Integer ): TColor32; overload;277 function HSLtoRGB(H, S, L: Integer; A: Integer = $ff): TColor32; overload; 266 278 procedure RGBtoHSL(RGB: TColor32; out H, S, L: Byte); overload; 279 function HSVtoRGB(H, S, V: Single): TColor32; 280 procedure RGBToHSV(Color: TColor32; out H, S, V: Single); 267 281 268 282 {$IFNDEF PLATFORM_INDEPENDENT} … … 277 291 PFixed = ^TFixed; 278 292 TFixed = type Integer; 279 293 {$NODEFINE TFixed} 294 295 {$NODEFINE PFixedRec} 280 296 PFixedRec = ^TFixedRec; 297 {$NODEFINE TFixedRec} 281 298 TFixedRec = packed record 282 299 case Integer of … … 315 332 TArrayOfArrayOfInteger = array of TArrayOfInteger; 316 333 334 PCardinalArray = ^TCardinalArray; 335 TCardinalArray = array [0..0] of Cardinal; 336 PArrayOfCardinal = ^TArrayOfCardinal; 337 TArrayOfCardinal = array of Cardinal; 338 PArrayOfArrayOfCardinal = ^TArrayOfArrayOfCardinal; 339 TArrayOfArrayOfCardinal = array of TArrayOfCardinal; 340 317 341 PSingleArray = ^TSingleArray; 318 342 TSingleArray = array [0..0] of Single; … … 330 354 FixedHalf = $7FFF; 331 355 FixedPI = Round(PI * FixedOne); 332 FixedToFloat = 1/FixedOne; 356 FixedToFloat = 1 / FixedOne; 357 358 COne255th = 1 / $FF; 333 359 334 360 function Fixed(S: Single): TFixed; overload; {$IFDEF USEINLINING} inline; {$ENDIF} … … 355 381 TFloatPoint = record 356 382 X, Y: TFloat; 383 {$IFDEF SUPPORT_ENHANCED_RECORDS} 384 public 385 {$IFNDEF FPC} 386 {$IFDEF COMPILERXE2_UP} 387 constructor Create(P: TPointF); overload; 388 {$ENDIF} 389 constructor Create(P: TPoint); overload; 390 constructor Create(X, Y: Integer); overload; 391 constructor Create(X, Y: Single); overload; 392 {$ENDIF} 393 394 // operator overloads 395 class operator Equal(const Lhs, Rhs: TFloatPoint): Boolean; 396 class operator NotEqual(const Lhs, Rhs: TFloatPoint): Boolean; 397 class operator Add(const Lhs, Rhs: TFloatPoint): TFloatPoint; 398 class operator Subtract(const Lhs, Rhs: TFloatPoint): TFloatPoint; 399 {$IFDEF COMPILERXE2_UP} 400 class operator Explicit(A: TPointF): TFloatPoint; 401 class operator Implicit(A: TPointF): TFloatPoint; 402 {$ENDIF} 403 404 class function Zero: TFloatPoint; inline; static; 405 {$ENDIF} 357 406 end; 358 407 … … 367 416 TFixedPoint = record 368 417 X, Y: TFixed; 369 end; 418 {$IFDEF SUPPORT_ENHANCED_RECORDS} 419 public 420 {$IFNDEF FPC} 421 {$IFDEF COMPILERXE2_UP} 422 constructor Create(P: TPointF); overload; 423 {$ENDIF} 424 constructor Create(P: TFloatPoint); overload; 425 constructor Create(X, Y: TFixed); overload; 426 constructor Create(X, Y: Integer); overload; 427 constructor Create(X, Y: TFloat); overload; 428 {$ENDIF} 429 430 // operator overloads 431 class operator Equal(const Lhs, Rhs: TFixedPoint): Boolean; 432 class operator NotEqual(const Lhs, Rhs: TFixedPoint): Boolean; 433 class operator Add(const Lhs, Rhs: TFixedPoint): TFixedPoint; 434 class operator Subtract(const Lhs, Rhs: TFixedPoint): TFixedPoint; 435 436 class function Zero: TFixedPoint; inline; static; 437 {$ENDIF} 438 end; 439 {$NODEFINE TFixedPoint} 370 440 371 441 PFixedPointArray = ^TFixedPointArray; … … 397 467 398 468 PFloatRect = ^TFloatRect; 469 {$NODEFINE TFloatRect} 470 {$IFDEF SupportsBoost} 471 (*$HPPEMIT '#include <boost/strong_typedef.hpp>'*) 472 {$ENDIF} 473 (*$HPPEMIT 'namespace Gr32 {'*) 474 {$IFDEF SupportsBoost} 475 (*$HPPEMIT 'BOOST_STRONG_TYPEDEF(int, TFixed)'*) 476 {$ELSE} 477 (*$HPPEMIT 'typedef int TFixed;'*) 478 {$ENDIF} 479 (*$HPPEMIT 'struct TFixedPoint { float X, Y; }; typedef struct TFixedPoint TFixedPoint;'*) 480 (*$HPPEMIT 'struct TFloatRect { float Left, Top, Right, Bottom; }; typedef struct TFloatRect TFloatRect;'*) 481 (*$HPPEMIT 'struct TFixedRect { TFixed Left, Top, Right, Bottom; }; typedef struct TFixedRect TFixedRect;'*) 482 (*$HPPEMIT '} // namespace Gr32 '*) 399 483 TFloatRect = packed record 400 484 case Integer of … … 403 487 end; 404 488 489 {$NODEFINE PFixedRect} 405 490 PFixedRect = ^TFixedRect; 491 {$NODEFINE TFixedRect} 406 492 TFixedRect = packed record 407 493 case Integer of … … 417 503 function MakeRect(const FXR: TFixedRect; Rounding: TRectRounding = rrClosest): TRect; overload; 418 504 function FixedRect(const L, T, R, B: TFixed): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} 505 function FixedRect(const TopLeft, BottomRight: TFixedPoint): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} 419 506 function FixedRect(const ARect: TRect): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} 420 507 function FixedRect(const FR: TFloatRect): TFixedRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} 421 508 function FloatRect(const L, T, R, B: TFloat): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} 509 function FloatRect(const TopLeft, BottomRight: TFloatPoint): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} 422 510 function FloatRect(const ARect: TRect): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} 423 511 function FloatRect(const FXR: TFixedRect): TFloatRect; overload; {$IFDEF USEINLINING} inline; {$ENDIF} … … 458 546 {$ENDIF} 459 547 460 { Gamma bias for line/pixel antialiasing }461 462 var463 GAMMA_TABLE: array [Byte] of Byte;464 465 procedure SetGamma(Gamma: Single = 0.7);466 467 548 type 468 549 { TPlainInterfacedPersistent } … … 475 556 protected 476 557 { IInterface } 477 function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 478 function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 479 function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF}IID: TGUID; out Obj): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 480 558 {$IFDEF FPC_HAS_CONSTREF} 559 function QueryInterface(constref iid: TGuid; out obj): HResult; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; 560 function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; 561 function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; 562 {$ELSE} 563 function QueryInterface(const iid: TGuid; out obj): HResult; stdcall; 564 function _AddRef: LongInt; stdcall; 565 function _Release: LongInt; stdcall; 566 {$ENDIF} 481 567 property RefCounted: Boolean read FRefCounted write FRefCounted; 482 568 public … … 535 621 procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); virtual; 536 622 public 623 constructor Create(Width, Height: Integer); reintroduce; overload; 624 537 625 procedure Delete; virtual; 538 626 function Empty: Boolean; virtual; … … 540 628 function SetSizeFrom(Source: TPersistent): Boolean; 541 629 function SetSize(NewWidth, NewHeight: Integer): Boolean; virtual; 630 542 631 property Height: Integer read FHeight write SetHeight; 543 632 property Width: Integer read FWidth write SetWidth; … … 602 691 603 692 {$IFDEF BITS_GETTER} 604 function GetBits: PColor32Array; 693 function GetBits: PColor32Array; {$IFDEF USEINLINING} inline; {$ENDIF} 605 694 {$ENDIF} 606 695 … … 618 707 procedure SetResampler(Resampler: TCustomResampler); 619 708 function GetResamplerClassName: string; 620 procedure SetResamplerClassName(Value: string); 709 procedure SetResamplerClassName(const Value: string); 710 function GetPenPos: TPoint; 711 procedure SetPenPos(const Value: TPoint); 712 function GetPenPosF: TFixedPoint; 713 procedure SetPenPosF(const Value: TFixedPoint); 621 714 protected 622 715 WrapProcHorz: TWrapProcEx; … … 638 731 procedure DefineProperties(Filer: TFiler); override; 639 732 640 procedure InitializeBackend ; virtual;733 procedure InitializeBackend(Backend: TCustomBackendClass); virtual; 641 734 procedure FinalizeBackend; virtual; 642 735 procedure SetBackend(const Backend: TCustomBackend); virtual; 643 736 644 function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; override; 737 {$IFDEF FPC_HAS_CONSTREF} 738 function QueryInterface(constref iid: TGuid; out obj): HResult; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; 739 {$ELSE} 740 function QueryInterface(const iid: TGuid; out obj): HResult; stdcall; 741 {$ENDIF} 645 742 646 743 function GetPixel(X, Y: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} … … 673 770 procedure SetPixelXW(X, Y: TFixed; Value: TColor32); 674 771 public 675 constructor Create; override; 772 constructor Create(Backend: TCustomBackendClass); reintroduce; overload; virtual; 773 constructor Create; reintroduce; overload; virtual; 774 constructor Create(Width, Height: Integer); reintroduce; overload; virtual; 676 775 destructor Destroy; override; 776 777 class function GetPlatformBackendClass: TCustomBackendClass; virtual; 677 778 678 779 procedure Assign(Source: TPersistent); override; … … 713 814 714 815 procedure DrawTo(Dst: TCustomBitmap32); overload; 816 procedure DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer); overload; 715 817 procedure DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer; const SrcRect: TRect); overload; 716 procedure DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer); overload;717 818 procedure DrawTo(Dst: TCustomBitmap32; const DstRect: TRect); overload; 718 819 procedure DrawTo(Dst: TCustomBitmap32; const DstRect, SrcRect: TRect); overload; … … 765 866 procedure LineToXSP(X, Y: TFixed); 766 867 procedure LineToFSP(X, Y: Single); 868 property PenPos: TPoint read GetPenPos write SetPenPos; 869 property PenPosF: TFixedPoint read GetPenPosF write SetPenPosF; 767 870 768 871 procedure FillRect(X1, Y1, X2, Y2: Integer; Value: TColor32); … … 840 943 private 841 944 FOnHandleChanged: TNotifyEvent; 842 945 843 946 procedure BackendChangedHandler(Sender: TObject); override; 844 947 procedure BackendChangingHandler(Sender: TObject); override; … … 855 958 procedure SetFont(Value: TFont); 856 959 protected 857 procedure InitializeBackend; override;858 960 procedure FinalizeBackend; override; 859 961 procedure SetBackend(const Backend: TCustomBackend); override; 860 962 861 963 procedure HandleChanged; virtual; 862 964 procedure CopyPropertiesTo(Dst: TCustomBitmap32); override; 863 965 public 966 class function GetPlatformBackendClass: TCustomBackendClass; override; 967 864 968 {$IFDEF BCB} 865 969 procedure Draw(const DstRect, SrcRect: TRect; hSrc: Cardinal); overload; … … 871 975 procedure DrawTo(hDst: Cardinal; DstX, DstY: Integer); overload; 872 976 procedure DrawTo(hDst: Cardinal; const DstRect, SrcRect: TRect); overload; 873 procedure TileTo(hDst: Cardinal; const DstRect, SrcRect: TRect); 977 procedure TileTo(hDst: Cardinal; const DstRect, SrcRect: TRect); overload; 874 978 {$ELSE} 875 procedure DrawTo(hDst: HDC; DstX , DstY: Integer); overload;979 procedure DrawTo(hDst: HDC; DstX: Integer = 0; DstY: Integer = 0); overload; 876 980 procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload; 877 procedure TileTo(hDst: HDC; const DstRect, SrcRect: TRect); 981 procedure TileTo(hDst: HDC; const DstRect, SrcRect: TRect); overload; 878 982 {$ENDIF} 879 983 984 {$IFDEF COMPILER2009_UP} 985 procedure DrawTo(Dst: TControlCanvas; DstX: Integer = 0; DstY: Integer = 0); overload; 986 procedure DrawTo(Dst: TControlCanvas; const DstRect, SrcRect: TRect); overload; 987 procedure TileTo(Dst: TControlCanvas; const DstRect, SrcRect: TRect); overload; 988 {$ENDIF} 989 880 990 procedure UpdateFont; 881 procedure Textout(X, Y: Integer; const Text: String); overload;882 procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: String); overload;883 procedure Textout( DstRect: TRect; const Flags: Cardinal; const Text: String); overload;884 function TextExtent(const Text: String): TSize;885 function TextHeight(const Text: String): Integer;886 function TextWidth(const Text: String): Integer;887 procedure RenderText(X, Y: Integer; const Text: String; AALevel: Integer; Color: TColor32);991 procedure Textout(X, Y: Integer; const Text: string); overload; 992 procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); overload; 993 procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); overload; 994 function TextExtent(const Text: string): TSize; 995 function TextHeight(const Text: string): Integer; 996 function TextWidth(const Text: string): Integer; 997 procedure RenderText(X, Y: Integer; const Text: string; AALevel: Integer; Color: TColor32); 888 998 procedure TextoutW(X, Y: Integer; const Text: Widestring); overload; 889 999 procedure TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); overload; 890 procedure TextoutW( DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload;1000 procedure TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload; 891 1001 function TextExtentW(const Text: Widestring): TSize; 892 1002 function TextHeightW(const Text: Widestring): Integer; … … 936 1046 function Empty: Boolean; virtual; 937 1047 938 procedure ChangeSize( varWidth, Height: Integer; NewWidth, NewHeight: Integer; ClearBuffer: Boolean = True); virtual;1048 procedure ChangeSize(out Width, Height: Integer; NewWidth, NewHeight: Integer; ClearBuffer: Boolean = True); virtual; 939 1049 940 1050 {$IFDEF BITS_GETTER} … … 992 1102 TCustomResamplerClass = class of TCustomResampler; 993 1103 994 function GetPlatformBackendClass: TCustomBackendClass;995 996 1104 var 997 1105 StockBitmap: TBitmap; 998 1106 1107 resourcestring 1108 RCStrUnmatchedReferenceCounting = 'Unmatched reference counting.'; 1109 RCStrCannotSetSize = 'Can''t set size from ''%s'''; 1110 RCStrInpropriateBackend = 'Inappropriate Backend'; 1111 999 1112 implementation 1000 1113 1001 1114 uses 1002 Math, GR32_Blend, GR32_ Filters, GR32_LowLevel, GR32_Math,1003 GR32_ Resamplers, GR32_Containers, GR32_Backends, GR32_Backends_Generic,1115 Math, GR32_Blend, GR32_LowLevel, GR32_Math, GR32_Resamplers, 1116 GR32_Containers, GR32_Gamma, GR32_Backends, GR32_Backends_Generic, 1004 1117 {$IFDEF FPC} 1005 1118 Clipbrd, … … 1019 1132 Clipbrd, GR32_Backends_VCL, 1020 1133 {$ENDIF} 1021 GR32_ DrawingEx;1134 GR32_VectorUtils; 1022 1135 1023 1136 type … … 1045 1158 const 1046 1159 ZERO_RECT: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0); 1047 1048 resourcestring1049 RCStrUnmatchedReferenceCounting = 'Unmatched reference counting.';1050 RCStrCannotSetSize = 'Can''t set size from ''%s''';1051 RCStrInpropriateBackend = 'Inpropriate Backend';1052 1160 1053 1161 { Color construction and conversion functions } … … 1128 1236 {$ENDIF} 1129 1237 // the alpha channel byte is set to zero! 1130 ROL EAX, 8 // ABGR -> BGRA1238 ROL EAX, 8 // ABGR -> RGBA 1131 1239 XOR AL, AL // BGRA -> BGR0 1132 1240 BSWAP EAX // BGR0 -> 0RGB … … 1199 1307 end; 1200 1308 1309 function InvertColor(Color32: TColor32): TColor32; 1310 begin 1311 TColor32Entry(Result).R := $FF - TColor32Entry(Color32).R; 1312 TColor32Entry(Result).G := $FF - TColor32Entry(Color32).G; 1313 TColor32Entry(Result).B := $FF - TColor32Entry(Color32).B; 1314 TColor32Entry(Result).A := TColor32Entry(Color32).A; 1315 end; 1316 1201 1317 function SetAlpha(Color32: TColor32; NewAlpha: Integer): TColor32; 1202 1318 begin 1203 if NewAlpha < 0 then NewAlpha := 0 1204 else if NewAlpha > 255 then NewAlpha := 255; 1319 if NewAlpha < 0 then 1320 NewAlpha := 0 1321 else if NewAlpha > $FF then 1322 NewAlpha := $FF; 1205 1323 Result := (Color32 and $00FFFFFF) or (TColor32(NewAlpha) shl 24); 1324 end; 1325 1326 procedure ModifyAlpha(var Color32: TColor32; NewAlpha: Byte); 1327 begin 1328 TColor32Entry(Color32).A := NewAlpha; 1329 end; 1330 1331 procedure ScaleAlpha(var Color32: TColor32; Scale: Single); 1332 begin 1333 TColor32Entry(Color32).A := Round(Scale * TColor32Entry(Color32).A); 1206 1334 end; 1207 1335 … … 1213 1341 var 1214 1342 M1, M2: Single; 1215 R, G, B: Byte;1216 1343 1217 1344 function HueToColor(Hue: Single): Byte; … … 1220 1347 begin 1221 1348 Hue := Hue - Floor(Hue); 1222 if 6 * Hue < 1 then V := M1 + (M2 - M1) * Hue * 6 1223 else if 2 * Hue < 1 then V := M2 1224 else if 3 * Hue < 2 then V := M1 + (M2 - M1) * (2 * OneOverThree - Hue) * 6 1349 if 6 * Hue < 1 then 1350 V := M1 + (M2 - M1) * Hue * 6 1351 else if 2 * Hue < 1 then 1352 V := M2 1353 else if 3 * Hue < 2 then 1354 V := M1 + (M2 - M1) * (2 * OneOverThree - Hue) * 6 1225 1355 else V := M1; 1226 Result := Round( 255* V);1356 Result := Round($FF * V); 1227 1357 end; 1228 1358 … … 1230 1360 if S = 0 then 1231 1361 begin 1232 R := Round(255 * L); 1233 G := R; 1234 B := R; 1235 end 1362 Result := Gray32(Round($FF * L)); 1363 Exit; 1364 end; 1365 1366 if L <= 0.5 then 1367 M2 := L * (1 + S) 1236 1368 else 1237 begin 1238 if L <= 0.5 then M2 := L * (1 + S) 1239 else M2 := L + S - L * S; 1240 M1 := 2 * L - M2; 1241 R := HueToColor(H + OneOverThree); 1242 G := HueToColor(H); 1243 B := HueToColor(H - OneOverThree) 1244 end; 1245 Result := Color32(R, G, B); 1369 M2 := L + S - L * S; 1370 M1 := 2 * L - M2; 1371 Result := Color32( 1372 HueToColor(H + OneOverThree), 1373 HueToColor(H), 1374 HueToColor(H - OneOverThree)); 1246 1375 end; 1247 1376 … … 1249 1378 const 1250 1379 // reciprocal mul. opt. 1251 R255 = 1 / 255;1252 1380 R6 = 1 / 6; 1253 1381 … … 1255 1383 R, G, B, D, Cmax, Cmin: Single; 1256 1384 begin 1257 R := RedComponent(RGB) * R255;1258 G := GreenComponent(RGB) * R255;1259 B := BlueComponent(RGB) * R255;1385 R := RedComponent(RGB) * COne255th; 1386 G := GreenComponent(RGB) * COne255th; 1387 B := BlueComponent(RGB) * COne255th; 1260 1388 Cmax := Max(R, Max(G, B)); 1261 1389 Cmin := Min(R, Min(G, B)); … … 1288 1416 end; 1289 1417 1290 function HSLtoRGB(H, S, L : Integer): TColor32;1418 function HSLtoRGB(H, S, L, A: Integer): TColor32; 1291 1419 var 1292 1420 V, M, M1, M2, VSF: Integer; … … 1306 1434 M2 := V - VSF; 1307 1435 case H shr 8 of 1308 0: Result := Color32(V, M1, M );1309 1: Result := Color32(M2, V, M );1310 2: Result := Color32(M, V, M1 );1311 3: Result := Color32(M, M2, V );1312 4: Result := Color32(M1, M, V );1313 5: Result := Color32(V, M, M2 );1436 0: Result := Color32(V, M1, M, A); 1437 1: Result := Color32(M2, V, M, A); 1438 2: Result := Color32(M, V, M1, A); 1439 3: Result := Color32(M, M2, V, A); 1440 4: Result := Color32(M1, M, V, A); 1441 5: Result := Color32(V, M, M2, A); 1314 1442 else 1315 1443 Result := 0; … … 1337 1465 else 1338 1466 begin 1339 D := (Cmax - Cmin) * 255;1467 D := (Cmax - Cmin) * $FF; 1340 1468 if L <= $7F then 1341 1469 S := D div (Cmax + Cmin) 1342 1470 else 1343 S := D div ( 255* 2 - Cmax - Cmin);1471 S := D div ($FF * 2 - Cmax - Cmin); 1344 1472 1345 1473 D := D * 6; 1346 1474 if R = Cmax then 1347 HL := (G - B) * 255 * 255div D1475 HL := (G - B) * $FF * $FF div D 1348 1476 else if G = Cmax then 1349 HL := 255 * 2 div 6 + (B - R) * 255 * 255div D1477 HL := $FF * 2 div 6 + (B - R) * $FF * $FF div D 1350 1478 else 1351 HL := 255 * 4 div 6 + (R - G) * 255 * 255div D;1352 1353 if HL < 0 then HL := HL + 255* 2;1479 HL := $FF * 4 div 6 + (R - G) * $FF * $FF div D; 1480 1481 if HL < 0 then HL := HL + $FF * 2; 1354 1482 H := HL; 1483 end; 1484 end; 1485 1486 function HSVtoRGB(H, S, V: Single): TColor32; 1487 var 1488 Tmp: TFloat; 1489 Sel, Q, P: Integer; 1490 begin 1491 V := 255 * V; 1492 if S = 0 then 1493 begin 1494 Result := Gray32(Trunc(V)); 1495 Exit; 1496 end; 1497 1498 H := H - Floor(H); 1499 Tmp := 6 * H - Floor(6 * H); 1500 1501 Sel := Trunc(6 * H); 1502 if (Sel mod 2) = 0 then 1503 Tmp := 1 - Tmp; 1504 1505 Q := Trunc(V * (1 - S)); 1506 P := Trunc(V * (1 - S * Tmp)); 1507 1508 case Sel of 1509 0: 1510 Result := Color32(Trunc(V), P, Q); 1511 1: 1512 Result := Color32(P, Trunc(V), Q); 1513 2: 1514 Result := Color32(Q, Trunc(V), P); 1515 3: 1516 Result := Color32(Q, P, Trunc(V)); 1517 4: 1518 Result := Color32(P, Q, Trunc(V)); 1519 5: 1520 Result := Color32(Trunc(V), Q, P); 1521 else 1522 Result := Gray32(0); 1523 end; 1524 end; 1525 1526 procedure RGBToHSV(Color: TColor32; out H, S, V: Single); 1527 var 1528 Delta, Min, Max: Single; 1529 R, G, B: Integer; 1530 const 1531 COneSixth = 1 / 6; 1532 begin 1533 R := RedComponent(Color); 1534 G := GreenComponent(Color); 1535 B := BlueComponent(Color); 1536 1537 Min := MinIntValue([R, G, B]); 1538 Max := MaxIntValue([R, G, B]); 1539 V := Max / 255; 1540 1541 Delta := Max - Min; 1542 if Max = 0 then 1543 S := 0 1544 else 1545 S := Delta / Max; 1546 1547 if S = 0.0 then 1548 H := 0 1549 else 1550 begin 1551 if R = Max then 1552 H := COneSixth * (G - B) / Delta 1553 else if G = Max then 1554 H := COneSixth * (2 + (B - R) / Delta) 1555 else if B = Max then 1556 H := COneSixth * (4 + (R - G) / Delta); 1557 1558 if H < 0.0 then 1559 H := H + 1; 1355 1560 end; 1356 1561 end; … … 1367 1572 L.palVersion := $300; 1368 1573 L.palNumEntries := 256; 1369 for I := 0 to 255do1574 for I := 0 to $FF do 1370 1575 begin 1371 1576 Cl := P[I]; … … 1386 1591 function Fixed(S: Single): TFixed; 1387 1592 begin 1388 Result := Round(S * 65536);1593 Result := Round(S * FixedOne); 1389 1594 end; 1390 1595 … … 1428 1633 1429 1634 function FloatPoint(const FXP: TFixedPoint): TFloatPoint; 1430 const1431 F = 1 / 65536;1432 1635 begin 1433 1636 with FXP do 1434 1637 begin 1435 Result.X := X * F; 1436 Result.Y := Y * F; 1437 end; 1438 end; 1638 Result.X := X * FixedToFloat; 1639 Result.Y := Y * FixedToFloat; 1640 end; 1641 end; 1642 1643 {$IFDEF SUPPORT_ENHANCED_RECORDS} 1644 {$IFNDEF FPC} 1645 constructor TFloatPoint.Create(P: TPoint); 1646 begin 1647 Self.X := P.X; 1648 Self.Y := P.Y; 1649 end; 1650 1651 {$IFDEF COMPILERXE2_UP} 1652 constructor TFloatPoint.Create(P: TPointF); 1653 begin 1654 Self.X := P.X; 1655 Self.Y := P.Y; 1656 end; 1657 {$ENDIF} 1658 1659 constructor TFloatPoint.Create(X, Y: Integer); 1660 begin 1661 Self.X := X; 1662 Self.Y := Y; 1663 end; 1664 1665 constructor TFloatPoint.Create(X, Y: TFloat); 1666 begin 1667 Self.X := X; 1668 Self.Y := Y; 1669 end; 1670 {$ENDIF} 1671 1672 // operator overloads 1673 class operator TFloatPoint.Equal(const Lhs, Rhs: TFloatPoint): Boolean; 1674 begin 1675 Result := (Lhs.X = Rhs.X) and (Lhs.Y = Rhs.Y); 1676 end; 1677 1678 class operator TFloatPoint.NotEqual(const Lhs, Rhs: TFloatPoint): Boolean; 1679 begin 1680 Result := (Lhs.X <> Rhs.X) or (Lhs.Y <> Rhs.Y); 1681 end; 1682 1683 class operator TFloatPoint.Add(const Lhs, Rhs: TFloatPoint): TFloatPoint; 1684 begin 1685 Result.X := Lhs.X + Rhs.X; 1686 Result.Y := Lhs.Y + Rhs.Y; 1687 end; 1688 1689 class operator TFloatPoint.Subtract(const Lhs, Rhs: TFloatPoint): TFloatPoint; 1690 begin 1691 Result.X := Lhs.X - Rhs.X; 1692 Result.Y := Lhs.Y - Rhs.Y; 1693 end; 1694 1695 {$IFDEF COMPILERXE2_UP} 1696 class operator TFloatPoint.Explicit(A: TPointF): TFloatPoint; 1697 begin 1698 Result.X := A.X; 1699 Result.Y := A.Y; 1700 end; 1701 1702 class operator TFloatPoint.Implicit(A: TPointF): TFloatPoint; 1703 begin 1704 Result.X := A.X; 1705 Result.Y := A.Y; 1706 end; 1707 {$ENDIF} 1708 1709 class function TFloatPoint.Zero: TFloatPoint; 1710 begin 1711 Result.X := 0; 1712 Result.Y := 0; 1713 end; 1714 1715 {$IFNDEF FPC} 1716 {$IFDEF COMPILERXE2_UP} 1717 constructor TFixedPoint.Create(P: TPointF); 1718 begin 1719 Self.X := Fixed(P.X); 1720 Self.Y := Fixed(P.Y); 1721 end; 1722 {$ENDIF} 1723 1724 constructor TFixedPoint.Create(P: TFloatPoint); 1725 begin 1726 Self.X := Fixed(P.X); 1727 Self.Y := Fixed(P.Y); 1728 end; 1729 1730 constructor TFixedPoint.Create(X, Y: TFixed); 1731 begin 1732 Self.X := X; 1733 Self.Y := Y; 1734 end; 1735 1736 constructor TFixedPoint.Create(X, Y: Integer); 1737 begin 1738 Self.X := Fixed(X); 1739 Self.Y := Fixed(Y); 1740 end; 1741 1742 constructor TFixedPoint.Create(X, Y: TFloat); 1743 begin 1744 Self.X := Fixed(X); 1745 Self.Y := Fixed(Y); 1746 end; 1747 {$ENDIF} 1748 1749 // operator overloads 1750 class operator TFixedPoint.Equal(const Lhs, Rhs: TFixedPoint): Boolean; 1751 begin 1752 Result := (Lhs.X = Rhs.X) and (Lhs.Y = Rhs.Y); 1753 end; 1754 1755 class operator TFixedPoint.NotEqual(const Lhs, Rhs: TFixedPoint): Boolean; 1756 begin 1757 Result := (Lhs.X <> Rhs.X) or (Lhs.Y <> Rhs.Y); 1758 end; 1759 1760 class operator TFixedPoint.Add(const Lhs, Rhs: TFixedPoint): TFixedPoint; 1761 begin 1762 Result.X := Lhs.X + Rhs.X; 1763 Result.Y := Lhs.Y + Rhs.Y; 1764 end; 1765 1766 class operator TFixedPoint.Subtract(const Lhs, Rhs: TFixedPoint): TFixedPoint; 1767 begin 1768 Result.X := Lhs.X - Rhs.X; 1769 Result.Y := Lhs.Y - Rhs.Y; 1770 end; 1771 1772 class function TFixedPoint.Zero: TFixedPoint; 1773 begin 1774 Result.X := 0; 1775 Result.Y := 0; 1776 end; 1777 {$ENDIF} 1439 1778 1440 1779 function FixedPoint(X, Y: Integer): TFixedPoint; overload; … … 1446 1785 function FixedPoint(X, Y: Single): TFixedPoint; overload; 1447 1786 begin 1448 Result.X := Round(X * 65536);1449 Result.Y := Round(Y * 65536);1787 Result.X := Round(X * FixedOne); 1788 Result.Y := Round(Y * FixedOne); 1450 1789 end; 1451 1790 … … 1458 1797 function FixedPoint(const FP: TFloatPoint): TFixedPoint; overload; 1459 1798 begin 1460 Result.X := Round(FP.X * 65536);1461 Result.Y := Round(FP.Y * 65536);1799 Result.X := Round(FP.X * FixedOne); 1800 Result.Y := Round(FP.Y * FixedOne); 1462 1801 end; 1463 1802 … … 1551 1890 end; 1552 1891 1892 function FixedRect(const TopLeft, BottomRight: TFixedPoint): TFixedRect; 1893 begin 1894 Result.TopLeft := TopLeft; 1895 Result.BottomRight := BottomRight; 1896 end; 1897 1553 1898 function FixedRect(const ARect: TRect): TFixedRect; 1554 1899 begin … … 1582 1927 Bottom := B; 1583 1928 end; 1929 end; 1930 1931 function FloatRect(const TopLeft, BottomRight: TFloatPoint): TFloatRect; 1932 begin 1933 Result.TopLeft := TopLeft; 1934 Result.BottomRight := BottomRight; 1584 1935 end; 1585 1936 … … 1745 2096 end; 1746 2097 1747 { Gamma / Pixel Shape Correction table }1748 1749 procedure SetGamma(Gamma: Single);1750 var1751 i: Integer;1752 begin1753 for i := 0 to 255 do1754 GAMMA_TABLE[i] := Round(255 * Power(i / 255, Gamma));1755 end;1756 1757 function GetPlatformBackendClass: TCustomBackendClass;1758 begin1759 {$IFDEF FPC}1760 Result := TLCLBackend;1761 {$ELSE}1762 Result := TGDIBackend;1763 {$ENDIF}1764 end;1765 1766 2098 { TSimpleInterfacedPersistent } 1767 2099 … … 1869 2201 1870 2202 { TCustomMap } 2203 2204 constructor TCustomMap.Create(Width, Height: Integer); 2205 begin 2206 Create; 2207 SetSize(Width, Height); 2208 end; 1871 2209 1872 2210 procedure TCustomMap.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); … … 1931 2269 { TCustomBitmap32 } 1932 2270 1933 constructor TCustomBitmap32.Create ;1934 begin 1935 inherited ;1936 1937 InitializeBackend ;2271 constructor TCustomBitmap32.Create(Backend: TCustomBackendClass); 2272 begin 2273 inherited Create; 2274 2275 InitializeBackend(Backend); 1938 2276 1939 2277 FOuterColor := $00000000; // by default as full transparency black … … 1949 2287 end; 1950 2288 2289 constructor TCustomBitmap32.Create; 2290 begin 2291 Create(GetPlatformBackendClass); 2292 end; 2293 1951 2294 destructor TCustomBitmap32.Destroy; 1952 2295 begin … … 1963 2306 end; 1964 2307 1965 procedure TCustomBitmap32.InitializeBackend ;1966 begin 1967 TMemoryBackend.Create(Self);2308 procedure TCustomBitmap32.InitializeBackend(Backend: TCustomBackendClass); 2309 begin 2310 Backend.Create(Self); 1968 2311 end; 1969 2312 … … 1988 2331 http://qc.codegear.com/wc/qcmain.aspx?d=9500 1989 2332 1990 If any backend interface is used within the same procedure in which2333 if any backend interface is used within the same procedure in which 1991 2334 the owner bitmap is also freed, the magic procedure cleanup will 1992 2335 clear that particular interface long after the bitmap and its backend … … 2239 2582 // this checks for transparency by comparing the pixel-color of the 2240 2583 // temporary bitmap (red masked) with the pixel of our 2241 // bitmap (white masked). If they match, make that pixel opaque2584 // bitmap (white masked). if they match, make that pixel opaque 2242 2585 if DstColor = (SrcP^ and $00FFFFFF) then 2243 2586 DstP^ := DstColor or $FF000000 … … 2292 2635 2293 2636 // Check if the icon was painted with a merged alpha channel. 2294 // Th ehappens transparently for new-style 32-bit icons.2637 // That happens transparently for new-style 32-bit icons. 2295 2638 // For all other bit depths GDI will reset our alpha channel to opaque. 2296 2639 ReassignFromMasked := True; … … 2320 2663 else if SrcGraphic is TMetaFile then 2321 2664 AssignFromGraphicMasked(TargetBitmap, SrcGraphic) 2665 {$IFDEF COMPILER2005_UP} 2666 else if SrcGraphic is TWICImage then 2667 AssignFromGraphicPlain(TargetBitmap, SrcGraphic, 0, False) 2668 {$ENDIF} 2322 2669 {$ENDIF} 2323 2670 else … … 2385 2732 end; 2386 2733 2734 constructor TCustomBitmap32.Create(Width, Height: Integer); 2735 begin 2736 Create; 2737 SetSize(Width, Height); 2738 end; 2739 2387 2740 {$IFDEF BITS_GETTER} 2388 2741 function TCustomBitmap32.GetBits: PColor32Array; … … 2391 2744 end; 2392 2745 {$ENDIF} 2746 2747 procedure TCustomBitmap32.SetPenPos(const Value: TPoint); 2748 begin 2749 MoveTo(Value.X, Value.Y); 2750 end; 2751 2752 procedure TCustomBitmap32.SetPenPosF(const Value: TFixedPoint); 2753 begin 2754 MoveTo(Value.X, Value.Y); 2755 end; 2393 2756 2394 2757 procedure TCustomBitmap32.SetPixel(X, Y: Integer; Value: TColor32); … … 2412 2775 begin 2413 2776 Result := @Bits[Y * FWidth]; 2777 end; 2778 2779 function TCustomBitmap32.GetPenPos: TPoint; 2780 begin 2781 Result.X := RasterX; 2782 Result.Y := RasterY; 2783 end; 2784 2785 function TCustomBitmap32.GetPenPosF: TFixedPoint; 2786 begin 2787 Result.X := RasterXF; 2788 Result.Y := RasterYF; 2414 2789 end; 2415 2790 … … 2438 2813 end; 2439 2814 2440 procedure TCustomBitmap32.Draw(DstX, DstY: Integer; const SrcRect: TRect; Src: TCustomBitmap32); 2815 procedure TCustomBitmap32.Draw(DstX, DstY: Integer; const SrcRect: TRect; 2816 Src: TCustomBitmap32); 2441 2817 begin 2442 2818 if Assigned(Src) then Src.DrawTo(Self, DstX, DstY, SrcRect); … … 2450 2826 procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32); 2451 2827 begin 2452 BlockTransfer(Dst, 0, 0, Dst.ClipRect, Self, BoundsRect, DrawMode, FOnPixelCombine); 2828 BlockTransfer(Dst, 0, 0, Dst.ClipRect, Self, BoundsRect, DrawMode, 2829 FOnPixelCombine); 2453 2830 end; 2454 2831 2455 2832 procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer); 2456 2833 begin 2457 BlockTransfer(Dst, DstX, DstY, Dst.ClipRect, Self, BoundsRect, DrawMode, FOnPixelCombine); 2458 end; 2459 2460 procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer; const SrcRect: TRect); 2461 begin 2462 BlockTransfer(Dst, DstX, DstY, Dst.ClipRect, Self, SrcRect, DrawMode, FOnPixelCombine); 2834 BlockTransfer(Dst, DstX, DstY, Dst.ClipRect, Self, BoundsRect, DrawMode, 2835 FOnPixelCombine); 2836 end; 2837 2838 procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; DstX, DstY: Integer; 2839 const SrcRect: TRect); 2840 begin 2841 BlockTransfer(Dst, DstX, DstY, Dst.ClipRect, Self, SrcRect, 2842 DrawMode, FOnPixelCombine); 2463 2843 end; 2464 2844 2465 2845 procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; const DstRect: TRect); 2466 2846 begin 2467 StretchTransfer(Dst, DstRect, Dst.ClipRect, Self, BoundsRect, Resampler, DrawMode, FOnPixelCombine); 2468 end; 2469 2470 procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; const DstRect, SrcRect: TRect); 2471 begin 2472 StretchTransfer(Dst, DstRect, Dst.ClipRect, Self, SrcRect, Resampler, DrawMode, FOnPixelCombine); 2847 StretchTransfer(Dst, DstRect, Dst.ClipRect, Self, BoundsRect, Resampler, 2848 DrawMode, FOnPixelCombine); 2849 end; 2850 2851 procedure TCustomBitmap32.DrawTo(Dst: TCustomBitmap32; const DstRect, 2852 SrcRect: TRect); 2853 begin 2854 StretchTransfer(Dst, DstRect, Dst.ClipRect, Self, SrcRect, Resampler, 2855 DrawMode, FOnPixelCombine); 2473 2856 end; 2474 2857 … … 2610 2993 begin 2611 2994 A := C shr 24; // opacity 2612 celx := A * GAMMA_ TABLE[flrx xor 255];2613 cely := GAMMA_ TABLE[flry xor 255];2614 flrx := A * GAMMA_ TABLE[flrx];2615 flry := GAMMA_ TABLE[flry];2995 celx := A * GAMMA_ENCODING_TABLE[flrx xor $FF]; 2996 cely := GAMMA_ENCODING_TABLE[flry xor $FF]; 2997 flrx := A * GAMMA_ENCODING_TABLE[flrx]; 2998 flry := GAMMA_ENCODING_TABLE[flry]; 2616 2999 2617 3000 CombineMem(C, P^, celx * cely shr 16); Inc(P); … … 2622 3005 else 2623 3006 begin 2624 celx := GAMMA_ TABLE[flrx xor 255];2625 cely := GAMMA_ TABLE[flry xor 255];2626 flrx := GAMMA_ TABLE[flrx];2627 flry := GAMMA_ TABLE[flry];2628 3007 celx := GAMMA_ENCODING_TABLE[flrx xor $FF]; 3008 cely := GAMMA_ENCODING_TABLE[flry xor $FF]; 3009 flrx := GAMMA_ENCODING_TABLE[flrx]; 3010 flry := GAMMA_ENCODING_TABLE[flry]; 3011 2629 3012 CombineMem(MergeReg(C, P^), P^, celx * cely shr 8); Inc(P); 2630 3013 CombineMem(MergeReg(C, P^), P^, flrx * cely shr 8); Inc(P, FWidth); … … 2663 3046 begin 2664 3047 A := C shr 24; // opacity 2665 celx := A * GAMMA_ TABLE[flrx xor 255];2666 cely := GAMMA_ TABLE[flry xor 255];2667 flrx := A * GAMMA_ TABLE[flrx];2668 flry := GAMMA_ TABLE[flry];3048 celx := A * GAMMA_ENCODING_TABLE[flrx xor $FF]; 3049 cely := GAMMA_ENCODING_TABLE[flry xor $FF]; 3050 flrx := A * GAMMA_ENCODING_TABLE[flrx]; 3051 flry := GAMMA_ENCODING_TABLE[flry]; 2669 3052 2670 3053 if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and … … 2687 3070 else 2688 3071 begin 2689 celx := GAMMA_ TABLE[flrx xor 255];2690 cely := GAMMA_ TABLE[flry xor 255];2691 flrx := GAMMA_ TABLE[flrx];2692 flry := GAMMA_ TABLE[flry];3072 celx := GAMMA_ENCODING_TABLE[flrx xor $FF]; 3073 cely := GAMMA_ENCODING_TABLE[flry xor $FF]; 3074 flrx := GAMMA_ENCODING_TABLE[flrx]; 3075 flry := GAMMA_ENCODING_TABLE[flry]; 2693 3076 2694 3077 if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and … … 2789 3172 begin 2790 3173 Pos := (X shr 8) + (Y shr 8) * FWidth; 2791 Result := Interpolator(GAMMA_ TABLE[X and $FF xor 255],2792 GAMMA_ TABLE[Y and $FF xor 255],3174 Result := Interpolator(GAMMA_ENCODING_TABLE[X and $FF xor $FF], 3175 GAMMA_ENCODING_TABLE[Y and $FF xor $FF], 2793 3176 @Bits[Pos], @Bits[Pos + FWidth]); 2794 3177 end; … … 2861 3244 {$ELSE} 2862 3245 asm 3246 {$IFDEF TARGET_x64} 3247 PUSH RBP 3248 SUB RSP,$30 3249 {$ENDIF} 2863 3250 ADD X, $7F 2864 3251 ADD Y, $7F … … 2873 3260 {$ENDIF} 2874 3261 3262 {$IFDEF TARGET_x64} 3263 LEA RSP,[RBP+$30] 3264 POP RBP 3265 {$ENDIF} 3266 2875 3267 {$ENDIF} 2876 3268 end; … … 2922 3314 WordRec(TFixedRec(Y).Frac).Hi); 2923 3315 EMMS; 3316 end; 3317 3318 class function TCustomBitmap32.GetPlatformBackendClass: TCustomBackendClass; 3319 begin 3320 Result := TMemoryBackend; 2924 3321 end; 2925 3322 … … 2986 3383 end; 2987 3384 FStippleCounter := Wrap(FStippleCounter, L); 3385 {$IFDEF FPC} 3386 PrevIndex := Trunc(FStippleCounter); 3387 {$ELSE} 2988 3388 PrevIndex := Round(FStippleCounter - 0.5); 2989 PrevWeight := 255 - Round(255 * (FStippleCounter - PrevIndex)); 3389 {$ENDIF} 3390 PrevWeight := $FF - Round($FF * (FStippleCounter - PrevIndex)); 2990 3391 if PrevIndex < 0 then FStippleCounter := L - 1; 2991 3392 NextIndex := PrevIndex + 1; 2992 3393 if NextIndex >= L then NextIndex := 0; 2993 if PrevWeight = 255then Result := FStipplePattern[PrevIndex]3394 if PrevWeight = $FF then Result := FStipplePattern[PrevIndex] 2994 3395 else 2995 3396 begin … … 3128 3529 if Wy > 0 then 3129 3530 begin 3130 CombineMem(Value, PDst^, GAMMA_ TABLE[(Wy * Wx1) shr 24]);3131 Wt := GAMMA_ TABLE[Wy shr 8];3531 CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wy * Wx1) shr 24]); 3532 Wt := GAMMA_ENCODING_TABLE[Wy shr 8]; 3132 3533 Inc(PDst); 3133 3534 for I := 0 to Count - 1 do … … 3136 3537 Inc(PDst); 3137 3538 end; 3138 CombineMem(Value, PDst^, GAMMA_ TABLE[(Wy * Wx2) shr 24]);3539 CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wy * Wx2) shr 24]); 3139 3540 end; 3140 3541 … … 3144 3545 if Wy > 0 then 3145 3546 begin 3146 CombineMem(Value, PDst^, GAMMA_ TABLE[(Wy * Wx1) shr 24]);3547 CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wy * Wx1) shr 24]); 3147 3548 Inc(PDst); 3148 Wt := GAMMA_ TABLE[Wy shr 8];3549 Wt := GAMMA_ENCODING_TABLE[Wy shr 8]; 3149 3550 for I := 0 to Count - 1 do 3150 3551 begin … … 3152 3553 Inc(PDst); 3153 3554 end; 3154 CombineMem(Value, PDst^, GAMMA_ TABLE[(Wy * Wx2) shr 24]);3555 CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wy * Wx2) shr 24]); 3155 3556 end; 3156 3557 … … 3322 3723 if Wx > 0 then 3323 3724 begin 3324 CombineMem(Value, PDst^, GAMMA_ TABLE[(Wx * Wy1) shr 24]);3325 Wt := GAMMA_ TABLE[Wx shr 8];3725 CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wx * Wy1) shr 24]); 3726 Wt := GAMMA_ENCODING_TABLE[Wx shr 8]; 3326 3727 Inc(PDst, FWidth); 3327 3728 for I := 0 to Count - 1 do … … 3330 3731 Inc(PDst, FWidth); 3331 3732 end; 3332 CombineMem(Value, PDst^, GAMMA_ TABLE[(Wx * Wy2) shr 24]);3733 CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wx * Wy2) shr 24]); 3333 3734 end; 3334 3735 … … 3338 3739 if Wx > 0 then 3339 3740 begin 3340 CombineMem(Value, PDst^, GAMMA_ TABLE[(Wx * Wy1) shr 24]);3741 CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wx * Wy1) shr 24]); 3341 3742 Inc(PDst, FWidth); 3342 Wt := GAMMA_ TABLE[Wx shr 8];3743 Wt := GAMMA_ENCODING_TABLE[Wx shr 8]; 3343 3744 for I := 0 to Count - 1 do 3344 3745 begin … … 3346 3747 Inc(PDst, FWidth); 3347 3748 end; 3348 CombineMem(Value, PDst^, GAMMA_ TABLE[(Wx * Wy2) shr 24]);3749 CombineMem(Value, PDst^, GAMMA_ENCODING_TABLE[(Wx * Wy2) shr 24]); 3349 3750 end; 3350 3751 … … 3545 3946 Inc(e, Dy2); 3546 3947 end; 3547 CheckAux := False; // to avoid ugly labelswe set this to omit the next check3948 CheckAux := False; // to avoid ugly goto we set this to omit the next check 3548 3949 end; 3549 3950 end; … … 3565 3966 end; 3566 3967 3567 // set auxiliary var to indicate that te mpis not clipped, since3568 // te mpstill has the unclipped value assigned at setup.3968 // set auxiliary var to indicate that term is not clipped, since 3969 // term still has the unclipped value assigned at setup. 3569 3970 CheckAux := False; 3570 3971 … … 3572 3973 if Y2 > Cy2 then 3573 3974 begin 3574 OC := Dx2* (Cy2 - Y1) + Dx;3975 OC := Int64(Dx2) * (Cy2 - Y1) + Dx; 3575 3976 term := X1 + OC div Dy2; 3576 3977 rem := OC mod Dy2; 3577 3978 if rem = 0 then Dec(term); 3578 CheckAux := True; // set auxiliary var to indicate that te mpis clipped3979 CheckAux := True; // set auxiliary var to indicate that term is clipped 3579 3980 end; 3580 3981 … … 3582 3983 begin 3583 3984 term := Cx2; 3584 CheckAux := True; // set auxiliary var to indicate that te mpis clipped3985 CheckAux := True; // set auxiliary var to indicate that term is clipped 3585 3986 end; 3586 3987 … … 3610 4011 end; 3611 4012 3612 // do we need to skip the last pixel of the line and is te mpnot clipped?4013 // do we need to skip the last pixel of the line and is term not clipped? 3613 4014 if not(L or CheckAux) then 3614 4015 begin … … 3814 4215 Inc(e, Dy2); 3815 4216 end; 3816 CheckAux := False; // to avoid ugly labelswe set this to omit the next check4217 CheckAux := False; // to avoid ugly goto we set this to omit the next check 3817 4218 end; 3818 4219 end; … … 3834 4235 end; 3835 4236 3836 // set auxiliary var to indicate that te mpis not clipped, since3837 // te mpstill has the unclipped value assigned at setup.4237 // set auxiliary var to indicate that term is not clipped, since 4238 // term still has the unclipped value assigned at setup. 3838 4239 CheckAux := False; 3839 4240 … … 3845 4246 rem := OC mod Dy2; 3846 4247 if rem = 0 then Dec(term); 3847 CheckAux := True; // set auxiliary var to indicate that te mpis clipped4248 CheckAux := True; // set auxiliary var to indicate that term is clipped 3848 4249 end; 3849 4250 … … 3851 4252 begin 3852 4253 term := Cx2; 3853 CheckAux := True; // set auxiliary var to indicate that te mpis clipped4254 CheckAux := True; // set auxiliary var to indicate that term is clipped 3854 4255 end; 3855 4256 … … 3879 4280 end; 3880 4281 3881 // do we need to skip the last pixel of the line and is te mpnot clipped?4282 // do we need to skip the last pixel of the line and is term not clipped? 3882 4283 if not(L or CheckAux) then 3883 4284 begin … … 3915 4316 var 3916 4317 n, i: Integer; 3917 nx, ny, hyp : Integer;4318 nx, ny, hyp, hypl: Integer; 3918 4319 A: TColor32; 3919 4320 h: Single; … … 3925 4326 Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127); 3926 4327 hyp := Hypot(nx, ny); 3927 if L then Inc(hyp, 65536); 3928 if hyp < 256 then Exit; 3929 n := hyp shr 16; 4328 if hyp = 0 then Exit; 4329 hypl := hyp + (Integer(L) * FixedOne); 4330 if (hypl < 256) then Exit; 4331 n := hypl shr 16; 3930 4332 if n > 0 then 3931 4333 begin … … 3940 4342 end; 3941 4343 A := Value shr 24; 3942 hyp := hyp - n shl 16;4344 hyp := hypl - n shl 16; 3943 4345 A := A * Cardinal(hyp) shl 8 and $FF000000; 3944 4346 SET_T256((X1 + X2 - nx) shr 9, (Y1 + Y2 - ny) shr 9, Value and $00FFFFFF + A); … … 3957 4359 var 3958 4360 n, i: Integer; 3959 ex, ey, nx, ny, hyp : Integer;4361 ex, ey, nx, ny, hyp, hypl: Integer; 3960 4362 A: TColor32; 3961 4363 h: Single; … … 3970 4372 // Check for visibility and clip the coordinates 3971 4373 if not ClipLine(Integer(X1), Integer(Y1), Integer(X2), Integer(Y2), 3972 FFixedClipRect.Left - $10000, FFixedClipRect.Top - $10000, 4374 FFixedClipRect.Left - $10000, 4375 FFixedClipRect.Top - $10000, 3973 4376 FFixedClipRect.Right, FFixedClipRect.Bottom) then Exit; 3974 4377 … … 3988 4391 end; 3989 4392 3990 // If we are still here, it means that the line touches one or several bitmap4393 // if we are still here, it means that the line touches one or several bitmap 3991 4394 // boundaries. Use the safe version of antialiased pixel routine 3992 4395 try … … 3994 4397 Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127); 3995 4398 hyp := Hypot(nx, ny); 3996 if L then Inc(Hyp, 65536); 3997 if hyp < 256 then Exit; 3998 n := hyp shr 16; 4399 if hyp = 0 then Exit; 4400 hypl := hyp + (Integer(L) * FixedOne); 4401 if hypl < 256 then Exit; 4402 n := hypl shr 16; 3999 4403 if n > 0 then 4000 4404 begin … … 4009 4413 end; 4010 4414 A := Value shr 24; 4011 hyp := hyp - n shl 16;4012 A := A * Longword(hyp) shl 8 and $FF000000;4415 hyp := hypl - n shl 16; 4416 A := A * Cardinal(hyp) shl 8 and $FF000000; 4013 4417 SET_TS256(SAR_9(X1 + X2 - nx), SAR_9(Y1 + Y2 - ny), Value and $00FFFFFF + A); 4014 4418 finally … … 4027 4431 var 4028 4432 n, i: Integer; 4029 nx, ny, hyp : Integer;4433 nx, ny, hyp, hypl: Integer; 4030 4434 A, C: TColor32; 4031 4435 ChangedRect: TRect; … … 4036 4440 Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127); 4037 4441 hyp := Hypot(nx, ny); 4038 if L then Inc(hyp, 65536); 4039 if hyp < 256 then Exit; 4040 n := hyp shr 16; 4442 if hyp = 0 then Exit; 4443 hypl := hyp + (Integer(L) * FixedOne); 4444 if hypl < 256 then Exit; 4445 n := hypl shr 16; 4041 4446 if n > 0 then 4042 4447 begin … … 4054 4459 C := GetStippleColor; 4055 4460 A := C shr 24; 4056 hyp := hyp - n shl 16;4461 hyp := hypl - n shl 16; 4057 4462 A := A * Longword(hyp) shl 8 and $FF000000; 4058 4463 SET_T256((X1 + X2 - nx) shr 9, (Y1 + Y2 - ny) shr 9, C and $00FFFFFF + A); … … 4070 4475 procedure TCustomBitmap32.LineXSP(X1, Y1, X2, Y2: TFixed; L: Boolean); 4071 4476 const 4072 StippleInc: array [Boolean] of Single= (0, 1);4477 StippleInc: array [Boolean] of Integer = (0, 1); 4073 4478 var 4074 4479 n, i: Integer; 4075 sx, sy, ex, ey, nx, ny, hyp : Integer;4480 sx, sy, ex, ey, nx, ny, hyp, hypl: Integer; 4076 4481 A, C: TColor32; 4077 4482 ChangedRect: TRect; … … 4110 4515 Integer((Y1 - sy) shr 16))); 4111 4516 4112 // If we are still here, it means that the line touches one or several bitmap4517 // if we are still here, it means that the line touches one or several bitmap 4113 4518 // boundaries. Use the safe version of antialiased pixel routine 4114 4519 nx := X2 - X1; ny := Y2 - Y1; 4115 4520 Inc(X1, 127); Inc(Y1, 127); Inc(X2, 127); Inc(Y2, 127); 4116 4521 hyp := GR32_Math.Hypot(nx, ny); 4117 if L then Inc(hyp, 65536); 4118 if hyp < 256 then Exit; 4119 n := hyp shr 16; 4522 if hyp = 0 then Exit; 4523 hypl := hyp + (Integer(L) * FixedOne); 4524 if hypl < 256 then Exit; 4525 n := hypl shr 16; 4120 4526 if n > 0 then 4121 4527 begin … … 4132 4538 C := GetStippleColor; 4133 4539 A := C shr 24; 4134 hyp := hyp - n shl 16;4540 hyp := hypl - n shl 16; 4135 4541 A := A * Longword(hyp) shl 8 and $FF000000; 4136 4542 SET_TS256(SAR_9(X1 + X2 - nx), SAR_9(Y1 + Y2 - ny), C and $00FFFFFF + A); … … 4199 4605 CI := EC shr 8; 4200 4606 P := @Bits[X1 + Y1 * Width]; 4201 BlendMemEx(Value, P^, GAMMA_ TABLE[CI xor 255]);4607 BlendMemEx(Value, P^, GAMMA_ENCODING_TABLE[CI xor $FF]); 4202 4608 Inc(P, Sx); 4203 BlendMemEx(Value, P^, GAMMA_ TABLE[CI]);4609 BlendMemEx(Value, P^, GAMMA_ENCODING_TABLE[CI]); 4204 4610 end; 4205 4611 end … … 4217 4623 CI := EC shr 8; 4218 4624 P := @Bits[X1 + Y1 * Width]; 4219 BlendMemEx(Value, P^, GAMMA_ TABLE[CI xor 255]);4625 BlendMemEx(Value, P^, GAMMA_ENCODING_TABLE[CI xor $FF]); 4220 4626 if Sy = 1 then Inc(P, Width) else Dec(P, Width); 4221 BlendMemEx(Value, P^, GAMMA_ TABLE[CI]);4627 BlendMemEx(Value, P^, GAMMA_ENCODING_TABLE[CI]); 4222 4628 end; 4223 4629 end; … … 4231 4637 var 4232 4638 Cx1, Cx2, Cy1, Cy2, PI, Sx, Sy, Dx, Dy, xd, yd, rem, term, tmp: Integer; 4233 CheckVert, CornerAA, Te mpClipped: Boolean;4639 CheckVert, CornerAA, TermClipped: Boolean; 4234 4640 D1, D2: PInteger; 4235 4641 EC, EA, ED, D: Word; … … 4376 4782 begin 4377 4783 Inc(xd, -Sx); 4378 BlendMemEx(Value, Bits[D1^ + D2^ * Width], GAMMA_ TABLE[ED shr 8]);4784 BlendMemEx(Value, Bits[D1^ + D2^ * Width], GAMMA_ENCODING_TABLE[ED shr 8]); 4379 4785 Dec(ED, EA); 4380 4786 end; … … 4395 4801 if Sy = -1 then yd := -yd; // negate back 4396 4802 xd := rem; // restore old xd 4397 CheckVert := False; // to avoid ugly labelswe set this to omit the next check4803 CheckVert := False; // to avoid ugly goto we set this to omit the next check 4398 4804 end; 4399 4805 end; … … 4413 4819 4414 4820 term := X2; 4415 Te mpClipped := False;4821 TermClipped := False; 4416 4822 CheckVert := False; 4417 4823 … … 4436 4842 end; 4437 4843 4438 Te mpClipped := True;4844 TermClipped := True; 4439 4845 end; 4440 4846 … … 4442 4848 begin 4443 4849 term := Cx2; 4444 Te mpClipped := True;4850 TermClipped := True; 4445 4851 end; 4446 4852 … … 4458 4864 if not CornerAA then 4459 4865 try 4460 // do we need to skip the last pixel of the line and is te mpnot clipped?4461 if not(L or Te mpClipped) and not CheckVert then4866 // do we need to skip the last pixel of the line and is term not clipped? 4867 if not(L or TermClipped) and not CheckVert then 4462 4868 begin 4463 4869 if xd < term then … … 4467 4873 end; 4468 4874 4469 Assert(term >= 0);4470 4875 while xd <> term do 4471 4876 begin 4472 4877 CI := EC shr 8; 4473 4878 P := @Bits[D1^ + D2^ * Width]; 4474 BlendMemEx(Value, P^, GAMMA_ TABLE[CI xor 255]);4879 BlendMemEx(Value, P^, GAMMA_ENCODING_TABLE[CI xor $FF]); 4475 4880 Inc(P, PI); 4476 BlendMemEx(Value, P^, GAMMA_ TABLE[CI]);4881 BlendMemEx(Value, P^, GAMMA_ENCODING_TABLE[CI]); 4477 4882 // check for overflow and jump to next line... 4478 4883 D := EC; … … 4492 4897 while xd <> rem do 4493 4898 begin 4494 BlendMemEx(Value, Bits[D1^ + D2^ * Width], GAMMA_ TABLE[EC shr 8 xor 255]);4899 BlendMemEx(Value, Bits[D1^ + D2^ * Width], GAMMA_ENCODING_TABLE[EC shr 8 xor $FF]); 4495 4900 Inc(EC, EA); 4496 4901 Inc(xd, Sx); … … 4758 5163 begin 4759 5164 C1 := SetAlpha(clWhite32, Clamp(Contrast * 512 div 100)); 4760 C2 := SetAlpha(clBlack32, Clamp(Contrast * 255div 100));5165 C2 := SetAlpha(clBlack32, Clamp(Contrast * $FF div 100)); 4761 5166 end 4762 5167 else if Contrast < 0 then 4763 5168 begin 4764 5169 Contrast := -Contrast; 4765 C1 := SetAlpha(clBlack32, Clamp(Contrast * 255div 100));5170 C1 := SetAlpha(clBlack32, Clamp(Contrast * $FF div 100)); 4766 5171 C2 := SetAlpha(clWhite32, Clamp(Contrast * 512 div 100)); 4767 5172 end … … 4862 5267 W := Width shl 2; 4863 5268 for I := Height - 1 downto 0 do 4864 Stream.WriteBuffer( PixelPtr[0,I]^, W);5269 Stream.WriteBuffer(ScanLine[I]^, W); 4865 5270 end 4866 5271 else … … 4991 5396 procedure TCustomBitmap32.ReadData(Stream: TStream); 4992 5397 var 4993 w, h: Integer;5398 Width, Height: Integer; 4994 5399 begin 4995 5400 try 4996 Stream.ReadBuffer( w, 4);4997 Stream.ReadBuffer( h, 4);4998 SetSize( w, h);5401 Stream.ReadBuffer(Width, 4); 5402 Stream.ReadBuffer(Height, 4); 5403 SetSize(Width, Height); 4999 5404 Stream.ReadBuffer(Bits[0], FWidth * FHeight * 4); 5000 5405 finally … … 5101 5506 OffsetRect(R, Dx, Dy); 5102 5507 IntersectRect(R, R, MakeRect(0, 0, Width, Height)); 5103 if R.Top > 0 then FillRect(0, 0, Width, R.Top, FillColor) 5104 else if R.Top = 0 then FillRect(0, R.Bottom, Width, Height, FillColor); 5105 if R.Left > 0 then FillRect(0, R.Top, R.Left, R.Bottom, FillColor) 5106 else if R.Left = 0 then FillRect(R.Right, R.Top, Width, R.Bottom, FillColor); 5508 if R.Top > 0 then 5509 FillRect(0, 0, Width, R.Top, FillColor) 5510 else 5511 if R.Top = 0 then 5512 FillRect(0, R.Bottom, Width, Height, FillColor); 5513 if R.Left > 0 then 5514 FillRect(0, R.Top, R.Left, R.Bottom, FillColor) 5515 else 5516 if R.Left = 0 then 5517 FillRect(R.Right, R.Top, Width, R.Bottom, FillColor); 5107 5518 end; 5108 5519 … … 5176 5587 for J := 0 to Height div 2 - 1 do 5177 5588 begin 5178 P1 := P ixelPtr[0, J];5179 P2 := P ixelPtr[0, J2];5589 P1 := PColor32(ScanLine[J]); 5590 P2 := PColor32(ScanLine[J2]); 5180 5591 MoveLongword(P1^, Buffer^, Width); 5181 5592 MoveLongword(P2^, P1^, Width); … … 5192 5603 for J := 0 to Height - 1 do 5193 5604 begin 5194 MoveLongword( PixelPtr[0, J]^, Dst.PixelPtr[0,J2]^, Width);5605 MoveLongword(ScanLine[J]^, Dst.ScanLine[J2]^, Width); 5195 5606 Dec(J2); 5196 5607 end; … … 5387 5798 end; 5388 5799 5389 procedure TCustomBitmap32.SetResamplerClassName( Value: string);5800 procedure TCustomBitmap32.SetResamplerClassName(const Value: string); 5390 5801 var 5391 5802 ResamplerClass: TCustomResamplerClass; … … 5399 5810 5400 5811 { TBitmap32 } 5401 5402 procedure TBitmap32.InitializeBackend;5403 begin5404 Backend := GetPlatformBackendClass.Create;5405 end;5406 5812 5407 5813 procedure TBitmap32.FinalizeBackend; … … 5466 5872 begin 5467 5873 Result := (FBackend as IDeviceContextSupport).Handle; 5874 end; 5875 5876 class function TBitmap32.GetPlatformBackendClass: TCustomBackendClass; 5877 begin 5878 {$IFDEF FPC} 5879 Result := TLCLBackend; 5880 {$ELSE} 5881 Result := TGDIBackend; 5882 {$ENDIF} 5468 5883 end; 5469 5884 … … 5567 5982 end; 5568 5983 5984 {$IFDEF COMPILER2009_UP} 5985 procedure TBitmap32.DrawTo(Dst: TControlCanvas; DstX, DstY: Integer); 5986 begin 5987 DrawTo(Dst.Handle, DstX, DstY); 5988 end; 5989 5990 procedure TBitmap32.DrawTo(Dst: TControlCanvas; const DstRect, SrcRect: TRect); 5991 begin 5992 DrawTo(Dst.Handle, DstRect, SrcRect); 5993 end; 5994 5995 procedure TBitmap32.TileTo(Dst: TControlCanvas; const DstRect, SrcRect: TRect); 5996 begin 5997 TileTo(Dst.Handle, DstRect, SrcRect); 5998 end; 5999 {$ENDIF} 6000 5569 6001 procedure TBitmap32.UpdateFont; 5570 6002 begin … … 5574 6006 // Text and Fonts // 5575 6007 5576 function TBitmap32.TextExtent(const Text: String): TSize;6008 function TBitmap32.TextExtent(const Text: string): TSize; 5577 6009 begin 5578 6010 Result := (FBackend as ITextSupport).TextExtent(Text); … … 5586 6018 // ------------------------------------------------------------------- 5587 6019 5588 procedure TBitmap32.Textout(X, Y: Integer; const Text: String);6020 procedure TBitmap32.Textout(X, Y: Integer; const Text: string); 5589 6021 begin 5590 6022 (FBackend as ITextSupport).Textout(X, Y, Text); … … 5598 6030 // ------------------------------------------------------------------- 5599 6031 5600 procedure TBitmap32.Textout(X, Y: Integer; const ClipRect: TRect; const Text: String);6032 procedure TBitmap32.Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); 5601 6033 begin 5602 6034 (FBackend as ITextSupport).Textout(X, Y, ClipRect, Text); … … 5610 6042 // ------------------------------------------------------------------- 5611 6043 5612 procedure TBitmap32.Textout( DstRect: TRect; const Flags: Cardinal; const Text: String);6044 procedure TBitmap32.Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); 5613 6045 begin 5614 6046 (FBackend as ITextSupport).Textout(DstRect, Flags, Text); 5615 6047 end; 5616 6048 5617 procedure TBitmap32.TextoutW( DstRect: TRect; const Flags: Cardinal; const Text: Widestring);6049 procedure TBitmap32.TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); 5618 6050 begin 5619 6051 (FBackend as ITextSupport).TextoutW(DstRect, Flags, Text); … … 5622 6054 // ------------------------------------------------------------------- 5623 6055 5624 function TBitmap32.TextHeight(const Text: String): Integer;6056 function TBitmap32.TextHeight(const Text: string): Integer; 5625 6057 begin 5626 6058 Result := (FBackend as ITextSupport).TextExtent(Text).cY; … … 5634 6066 // ------------------------------------------------------------------- 5635 6067 5636 function TBitmap32.TextWidth(const Text: String): Integer;6068 function TBitmap32.TextWidth(const Text: string): Integer; 5637 6069 begin 5638 6070 Result := (FBackend as ITextSupport).TextExtent(Text).cX; … … 5674 6106 lfCharSet := Byte(Font.Charset); 5675 6107 5676 // TODO DVT Added cast to fix TFontDataName to String warning. Need to verify is OK6108 // TODO DVT Added cast to fix TFontDataName to string warning. Need to verify is OK 5677 6109 if AnsiCompareText(Font.Name, 'Default') = 0 then // do not localize 5678 6110 StrPCopy(lfFaceName, string(DefFontData.Name)) … … 5746 6178 begin 5747 6179 Sz := 1 shl N - 1; 5748 Dst := B.PixelPtr[0, 0];6180 Dst := PColor32(B.ScanLine[0]); 5749 6181 for J := 0 to B.Height - 1 do 5750 6182 begin … … 5770 6202 end; 5771 6203 5772 procedure TBitmap32.RenderText(X, Y: Integer; const Text: String; AALevel: Integer; Color: TColor32);6204 procedure TBitmap32.RenderText(X, Y: Integer; const Text: string; AALevel: Integer; Color: TColor32); 5773 6205 var 5774 6206 B, B2: TBitmap32; 5775 6207 Sz: TSize; 5776 6208 Alpha: TColor32; 5777 PaddedText: String;6209 PaddedText: string; 5778 6210 begin 5779 6211 if Empty then Exit; … … 5835 6267 DrawMode := dmBlend; 5836 6268 MasterAlpha := Alpha; 5837 CombineMode := Self.CombineMode;6269 CombineMode := CombineMode; 5838 6270 5839 6271 DrawTo(Self, X, Y); … … 5879 6311 B := TBitmap32.Create; 5880 6312 try 5881 if AALevel = 0 then6313 if AALevel <= 0 then 5882 6314 begin 5883 6315 Sz := TextExtentW(PaddedText); … … 5997 6429 {$ENDIF} 5998 6430 5999 procedure TCustomBackend.ChangeSize( varWidth, Height: Integer; NewWidth, NewHeight: Integer; ClearBuffer: Boolean);6431 procedure TCustomBackend.ChangeSize(out Width, Height: Integer; NewWidth, NewHeight: Integer; ClearBuffer: Boolean); 6000 6432 begin 6001 6433 try -
GraphicTest/Packages/Graphics32/GR32_Backends.pas
r450 r522 44 44 Windows, Messages, Controls, Graphics, 45 45 {$ENDIF} 46 Classes, SysUtils, GR32, GR32_Containers, GR32_Image ;46 Classes, SysUtils, GR32, GR32_Containers, GR32_Image, GR32_Paths; 47 47 48 48 type 49 EBackend = class(Exception); 50 49 51 ITextSupport = interface(IUnknown) 50 52 ['{225997CC-958A-423E-8B60-9EDE0D3B53B5}'] … … 70 72 property Font: TFont read GetFont write SetFont; 71 73 property OnFontChange: TNotifyEvent read GetOnFontChange write SetOnFontChange; 74 end; 75 76 ITextToPathSupport = interface(IUnknown) 77 ['{6C4037E4-FF4D-4EE2-9C20-B9DB9C64B42D}'] 78 procedure TextToPath(Path: TCustomPath; const X, Y: TFloat; const Text: WideString); overload; 79 procedure TextToPath(Path: TCustomPath; const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal); overload; 80 function MeasureText(const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; 72 81 end; 73 82 … … 130 139 implementation 131 140 132 uses133 GR32_LowLevel;134 135 141 procedure RequireBackendSupport(TargetBitmap: TCustomBitmap32; 136 142 RequiredInterfaces: array of TGUID; … … 159 165 // TODO: Try to find a back-end that supports the required interfaces 160 166 // instead of resorting to the default platform back-end class... 161 TargetBitmap.Backend := GetPlatformBackendClass.Create;167 TargetBitmap.Backend := TargetBitmap.GetPlatformBackendClass.Create; 162 168 end 163 169 else -
GraphicTest/Packages/Graphics32/GR32_Backends_Generic.pas
r450 r522 49 49 ActiveX, 50 50 {$ENDIF} 51 SysUtils, Classes, GR32 , GR32_Backends;51 SysUtils, Classes, GR32; 52 52 53 53 type -
GraphicTest/Packages/Graphics32/GR32_Backends_LCL_Win.pas
r450 r522 42 42 {$IFDEF LCLWin32} Windows, {$ENDIF} LCLIntf, LCLType, Types, Controls, 43 43 SysUtils, Classes, Graphics, GR32, GR32_Backends, GR32_Backends_Generic, 44 GR32_Containers, GR32_Image ;44 GR32_Containers, GR32_Image, GR32_Paths; 45 45 46 46 type … … 51 51 TLCLBackend = class(TCustomBackend, IPaintSupport, 52 52 IBitmapContextSupport, IDeviceContextSupport, 53 ITextSupport, IFontSupport, I CanvasSupport)53 ITextSupport, IFontSupport, ITextToPathSupport, ICanvasSupport) 54 54 private 55 55 procedure FontChangedHandler(Sender: TObject); … … 104 104 105 105 { ITextSupport } 106 procedure Textout(X, Y: Integer; const Text: String); overload;107 procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: String); overload;108 procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: String); overload;109 function TextExtent(const Text: String): TSize;106 procedure Textout(X, Y: Integer; const Text: string); overload; 107 procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); overload; 108 procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); overload; 109 function TextExtent(const Text: string): TSize; 110 110 111 111 procedure TextoutW(X, Y: Integer; const Text: Widestring); overload; … … 123 123 property Font: TFont read GetFont write SetFont; 124 124 property OnFontChange: TNotifyEvent read FOnFontChange write FOnFontChange; 125 126 { ITextToPathSupport } 127 procedure TextToPath(Path: TCustomPath; const X, Y: TFloat; const Text: WideString); overload; 128 procedure TextToPath(Path: TCustomPath; const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal); overload; 129 function MeasureText(const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; 125 130 126 131 { ICanvasSupport } … … 182 187 implementation 183 188 189 uses 190 GR32_Text_LCL_Win; 191 184 192 var 185 193 StockFont: HFONT; … … 293 301 end; 294 302 295 function TLCLBackend.TextExtent(const Text: String): TSize;303 function TLCLBackend.TextExtent(const Text: string): TSize; 296 304 var 297 305 DC: HDC; … … 342 350 end; 343 351 344 procedure TLCLBackend.Textout(X, Y: Integer; const Text: String);352 procedure TLCLBackend.Textout(X, Y: Integer; const Text: string); 345 353 var 346 354 Extent: TSize; … … 360 368 end; 361 369 362 procedure TLCLBackend.TextoutW(X, Y: Integer; const Text: Wide String);370 procedure TLCLBackend.TextoutW(X, Y: Integer; const Text: Widestring); 363 371 var 364 372 Extent: TSize; … … 378 386 end; 379 387 380 procedure TLCLBackend.TextoutW(X, Y: Integer; const ClipRect: TRect; 381 const Text: Widestring); 388 procedure TLCLBackend.TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); 382 389 var 383 390 Extent: TSize; … … 386 393 387 394 if not FOwner.MeasuringMode then 388 ExtTextoutW(Handle, X, Y, ETO_CLIPPED, @ClipRect, PWideChar(Text), 389 Length(Text), nil); 395 ExtTextoutW(Handle, X, Y, ETO_CLIPPED, @ClipRect, PWideChar(Text), Length(Text), nil); 390 396 391 397 Extent := TextExtentW(Text); … … 393 399 end; 394 400 395 procedure TLCLBackend.Textout(X, Y: Integer; const ClipRect: TRect; 396 const Text: String); 401 procedure TLCLBackend.Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); 397 402 var 398 403 Extent: TSize; … … 407 412 end; 408 413 409 procedure TLCLBackend.TextoutW(var DstRect: TRect; const Flags: Cardinal; 410 const Text: Widestring); 414 procedure TLCLBackend.TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); 411 415 begin 412 416 UpdateFont; … … 435 439 end; 436 440 437 procedure TLCLBackend.Textout(var DstRect: TRect; const Flags: Cardinal; 438 const Text: String); 441 procedure TLCLBackend.TextToPath(Path: TCustomPath; const X, Y: TFloat; 442 const Text: WideString); 443 var 444 R: TFloatRect; 445 begin 446 R := FloatRect(X, Y, X, Y); 447 GR32_Text_LCL_Win.TextToPath(Font.Handle, Path, R, Text, 0); 448 end; 449 450 procedure TLCLBackend.TextToPath(Path: TCustomPath; const DstRect: TFloatRect; 451 const Text: WideString; Flags: Cardinal); 452 begin 453 GR32_Text_LCL_Win.TextToPath(Font.Handle, Path, DstRect, Text, Flags); 454 end; 455 456 function TLCLBackend.MeasureText(const DstRect: TFloatRect; 457 const Text: WideString; Flags: Cardinal): TFloatRect; 458 begin 459 Result := GR32_Text_LCL_Win.MeasureText(Font.Handle, DstRect, Text, Flags); 460 end; 461 462 procedure TLCLBackend.Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); 439 463 begin 440 464 UpdateFont; … … 703 727 procedure TLCLMemoryBackend.DrawTo(hDst: HDC; DstX, DstY: Integer); 704 728 var 705 Bitmap 706 DeviceContext 707 Buffer 708 OldObject 729 Bitmap: HBITMAP; 730 DeviceContext: HDC; 731 Buffer: Pointer; 732 OldObject: HGDIOBJ; 709 733 begin 710 734 {$IFDEF LCLWin32} … … 746 770 procedure TLCLMemoryBackend.DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); 747 771 var 748 Bitmap 749 DeviceContext 750 Buffer 751 OldObject 772 Bitmap: HBITMAP; 773 DeviceContext: HDC; 774 Buffer: Pointer; 775 OldObject: HGDIOBJ; 752 776 begin 753 777 {$IFDEF LCLWin32} … … 761 785 if DeviceContext <> 0 then 762 786 try 787 Buffer := nil; 763 788 Bitmap := CreateDIBSection(DeviceContext, FBitmapInfo, DIB_RGB_COLORS, 764 789 Buffer, 0, 0); -
GraphicTest/Packages/Graphics32/GR32_Backends_VCL.pas
r450 r522 40 40 uses 41 41 SysUtils, Classes, Windows, Graphics, GR32, GR32_Backends, GR32_Containers, 42 GR32_Image, GR32_Backends_Generic ;42 GR32_Image, GR32_Backends_Generic, GR32_Paths; 43 43 44 44 type … … 50 50 TGDIBackend = class(TCustomBackend, IPaintSupport, 51 51 IBitmapContextSupport, IDeviceContextSupport, 52 ITextSupport, IFontSupport, ICanvasSupport )52 ITextSupport, IFontSupport, ICanvasSupport, ITextToPathSupport) 53 53 private 54 54 procedure FontChangedHandler(Sender: TObject); … … 96 96 97 97 procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); overload; 98 procedure DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; DstX, DstY: Integer); overload;99 procedure DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect); overload;98 procedure DrawTo(hDst: HDC; DstX, DstY: Integer); overload; 99 procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload; 100 100 101 101 property Handle: HDC read GetHandle; 102 102 103 103 { ITextSupport } 104 procedure Textout(X, Y: Integer; const Text: String); overload;105 procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: String); overload;106 procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: String); overload;107 function TextExtent(const Text: String): TSize;104 procedure Textout(X, Y: Integer; const Text: string); overload; 105 procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); overload; 106 procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); overload; 107 function TextExtent(const Text: string): TSize; 108 108 109 109 procedure TextoutW(X, Y: Integer; const Text: Widestring); overload; … … 121 121 property Font: TFont read GetFont write SetFont; 122 122 property OnFontChange: TNotifyEvent read FOnFontChange write FOnFontChange; 123 124 { ITextToPathSupport } 125 procedure TextToPath(Path: TCustomPath; const X, Y: TFloat; const Text: WideString); overload; 126 procedure TextToPath(Path: TCustomPath; const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal); overload; 127 function MeasureText(const DstRect: TFloatRect; const Text: WideString; Flags: Cardinal): TFloatRect; 123 128 124 129 { ICanvasSupport } … … 158 163 procedure DoPaintRect(ABuffer: TBitmap32; ARect: TRect; ACanvas: TCanvas); 159 164 160 function GetHandle: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; // Dummy165 function GetHandle: HDC; // Dummy 161 166 protected 162 167 FBitmapInfo: TBitmapInfo; … … 173 178 174 179 { IDeviceContextSupport } 175 procedure Draw(const DstRect, SrcRect: TRect; hSrc: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}); overload;176 procedure DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; DstX, DstY: Integer); overload;177 procedure DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect); overload;180 procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); overload; 181 procedure DrawTo(hDst: HDC; DstX, DstY: Integer); overload; 182 procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload; 178 183 end; 179 184 180 185 implementation 186 187 uses 188 GR32_Text_VCL; 181 189 182 190 var … … 227 235 228 236 if FBits = nil then 229 raise E xception.Create(RCStrCannotAllocateDIBHandle);237 raise EBackend.Create(RCStrCannotAllocateDIBHandle); 230 238 231 239 FHDC := CreateCompatibleDC(0); … … 235 243 FBitmapHandle := 0; 236 244 FBits := nil; 237 raise E xception.Create(RCStrCannotCreateCompatibleDC);245 raise EBackend.Create(RCStrCannotCreateCompatibleDC); 238 246 end; 239 247 … … 245 253 FBitmapHandle := 0; 246 254 FBits := nil; 247 raise Exception.Create(RCStrCannotSelectAnObjectIntoDC); 248 end; 255 raise EBackend.Create(RCStrCannotSelectAnObjectIntoDC); 256 end; 257 end; 258 259 function TGDIBackend.MeasureText(const DstRect: TFloatRect; 260 const Text: WideString; Flags: Cardinal): TFloatRect; 261 begin 262 Result := GR32_Text_VCL.MeasureText(Font.Handle, DstRect, Text, Flags); 249 263 end; 250 264 … … 292 306 end; 293 307 294 function TGDIBackend.TextExtent(const Text: String): TSize;295 var 296 DC: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF};308 function TGDIBackend.TextExtent(const Text: string): TSize; 309 var 310 DC: HDC; 297 311 OldFont: HGDIOBJ; 298 312 begin … … 318 332 function TGDIBackend.TextExtentW(const Text: Widestring): TSize; 319 333 var 320 DC: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF};334 DC: HDC; 321 335 OldFont: HGDIOBJ; 322 336 begin … … 341 355 end; 342 356 343 procedure TGDIBackend.Textout(X, Y: Integer; const Text: String);357 procedure TGDIBackend.Textout(X, Y: Integer; const Text: string); 344 358 var 345 359 Extent: TSize; … … 390 404 end; 391 405 392 procedure TGDIBackend.Textout(X, Y: Integer; const ClipRect: TRect; const Text: String);406 procedure TGDIBackend.Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); 393 407 var 394 408 Extent: TSize; … … 411 425 412 426 FOwner.Changed(DstRect); 427 end; 428 429 procedure TGDIBackend.TextToPath(Path: TCustomPath; const X, Y: TFloat; 430 const Text: WideString); 431 var 432 R: TFloatRect; 433 begin 434 R := FloatRect(X, Y, X, Y); 435 GR32_Text_VCL.TextToPath(Font.Handle, Path, R, Text, 0); 436 end; 437 438 procedure TGDIBackend.TextToPath(Path: TCustomPath; const DstRect: TFloatRect; 439 const Text: WideString; Flags: Cardinal); 440 begin 441 GR32_Text_VCL.TextToPath(Font.Handle, Path, DstRect, Text, Flags); 413 442 end; 414 443 … … 430 459 end; 431 460 432 procedure TGDIBackend.Textout(var DstRect: TRect; const Flags: Cardinal; const Text: String);461 procedure TGDIBackend.Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); 433 462 begin 434 463 UpdateFont; … … 440 469 end; 441 470 442 procedure TGDIBackend.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; DstX, DstY: Integer);471 procedure TGDIBackend.DrawTo(hDst: HDC; DstX, DstY: Integer); 443 472 begin 444 473 StretchDIBits( … … 447 476 end; 448 477 449 procedure TGDIBackend.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; const DstRect, SrcRect: TRect);478 procedure TGDIBackend.DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); 450 479 begin 451 480 StretchBlt( … … 486 515 end; 487 516 488 function TGDIBackend.GetHandle: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF};517 function TGDIBackend.GetHandle: HDC; 489 518 begin 490 519 Result := FHDC; … … 512 541 end; 513 542 514 procedure TGDIBackend.Draw(const DstRect, SrcRect: TRect; hSrc: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF});543 procedure TGDIBackend.Draw(const DstRect, SrcRect: TRect; hSrc: HDC); 515 544 begin 516 545 if FOwner.Empty then Exit; … … 642 671 var 643 672 Bitmap : HBITMAP; 644 DeviceContext : {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF};673 DeviceContext : HDC; 645 674 Buffer : Pointer; 646 675 OldObject : HGDIOBJ; … … 671 700 end; 672 701 end else 673 raise E xception.Create('Can''t create compatible DC''');702 raise EBackend.Create(RCStrCannotCreateCompatibleDC); 674 703 finally 675 704 DeleteDC(DeviceContext); … … 678 707 end; 679 708 680 procedure TGDIMemoryBackend.Draw(const DstRect, SrcRect: TRect; hSrc: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF});709 procedure TGDIMemoryBackend.Draw(const DstRect, SrcRect: TRect; hSrc: HDC); 681 710 begin 682 711 if FOwner.Empty then Exit; 683 712 684 713 if not FOwner.MeasuringMode then 685 raise E xception.Create('Not supported!');714 raise EBackend.Create('Not supported!'); 686 715 687 716 FOwner.Changed(DstRect); 688 717 end; 689 718 690 procedure TGDIMemoryBackend.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF}; DstX, DstY: Integer);719 procedure TGDIMemoryBackend.DrawTo(hDst: HDC; DstX, DstY: Integer); 691 720 var 692 721 Bitmap : HBITMAP; 693 DeviceContext : {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF};722 DeviceContext : HDC; 694 723 Buffer : Pointer; 695 724 OldObject : HGDIOBJ; 696 725 begin 697 if SetDIBitsToDevice(hDst, DstX, DstY, 698 FOwner.Width, FOwner.Height, 0, 0, 0, FOwner.Height, FBits, FBitmapInfo, 699 DIB_RGB_COLORS) = 0 then 726 if SetDIBitsToDevice(hDst, DstX, DstY, FOwner.Width, FOwner.Height, 0, 0, 0, 727 FOwner.Height, FBits, FBitmapInfo, DIB_RGB_COLORS) = 0 then 700 728 begin 701 729 // create compatible device context … … 720 748 end; 721 749 end else 722 raise E xception.Create('Can''t create compatible DC''');750 raise EBackend.Create(RCStrCannotCreateCompatibleDC); 723 751 finally 724 752 DeleteDC(DeviceContext); … … 727 755 end; 728 756 729 procedure TGDIMemoryBackend.DrawTo(hDst: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF};757 procedure TGDIMemoryBackend.DrawTo(hDst: HDC; 730 758 const DstRect, SrcRect: TRect); 731 759 var 732 760 Bitmap : HBITMAP; 733 DeviceContext : {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF};761 DeviceContext : HDC; 734 762 Buffer : Pointer; 735 763 OldObject : HGDIOBJ; … … 761 789 end; 762 790 end else 763 raise E xception.Create('Can''t create compatible DC''');791 raise EBackend.Create(RCStrCannotCreateCompatibleDC); 764 792 finally 765 793 DeleteDC(DeviceContext); … … 768 796 end; 769 797 770 function TGDIMemoryBackend.GetHandle: {$IFDEF BCB}Cardinal{$ELSE}HDC{$ENDIF};798 function TGDIMemoryBackend.GetHandle: HDC; 771 799 begin 772 800 Result := 0; -
GraphicTest/Packages/Graphics32/GR32_Bindings.pas
r450 r522 80 80 procedure Clear; 81 81 82 procedure Add(FunctionID: Integer; Proc: Pointer; CPUFeatures: TCPUFeatures = []; Flags: Integer = 0); 82 procedure Add(FunctionID: Integer; Proc: Pointer; CPUFeatures: TCPUFeatures = []; 83 Flags: Integer = 0); 83 84 84 85 // function rebinding support … … 116 117 Registers := TList.Create; 117 118 Result := TFunctionRegistry.Create; 119 {$IFDEF NEXTGEN} 120 Result.__ObjAddRef; 121 {$ENDIF} 118 122 Result.Name := Name; 119 123 Registers.Add(Result); -
GraphicTest/Packages/Graphics32/GR32_Blend.pas
r450 r522 41 41 * - 2004/08/25 - ColorDiv 42 42 * 43 * Christian-W. Budde 44 * - 2019/04/01 - Refactoring 45 * 43 46 * ***** END LICENSE BLOCK ***** *) 44 47 … … 48 51 49 52 uses 50 GR32, GR32_ System, GR32_Bindings, SysUtils;53 GR32, GR32_Bindings, SysUtils; 51 54 52 55 var … … 57 60 TBlendReg = function(F, B: TColor32): TColor32; 58 61 TBlendMem = procedure(F: TColor32; var B: TColor32); 62 TBlendMems = procedure(F: TColor32; B: PColor32; Count: Integer); 59 63 TBlendRegEx = function(F, B, M: TColor32): TColor32; 60 64 TBlendMemEx = procedure(F: TColor32; var B: TColor32; M: TColor32); 65 TBlendRegRGB = function(F, B, W: TColor32): TColor32; 66 TBlendMemRGB = procedure(F: TColor32; var B: TColor32; W: TColor32); 67 {$IFDEF TEST_BLENDMEMRGB128SSE4} 68 TBlendMemRGB128 = procedure(F: TColor32; var B: TColor32; W: UInt64); 69 {$ENDIF} 61 70 TBlendLine = procedure(Src, Dst: PColor32; Count: Integer); 62 71 TBlendLineEx = procedure(Src, Dst: PColor32; Count: Integer; M: TColor32); 72 TBlendLine1 = procedure(Src: TColor32; Dst: PColor32; Count: Integer); 63 73 TCombineReg = function(X, Y, W: TColor32): TColor32; 64 74 TCombineMem = procedure(X: TColor32; var Y: TColor32; W: TColor32); … … 74 84 BlendReg: TBlendReg; 75 85 BlendMem: TBlendMem; 86 BlendMems: TBlendMems; 76 87 77 88 BlendRegEx: TBlendRegEx; 78 89 BlendMemEx: TBlendMemEx; 79 90 91 BlendRegRGB: TBlendRegRGB; 92 BlendMemRGB: TBlendMemRGB; 93 {$IFDEF TEST_BLENDMEMRGB128SSE4} 94 BlendMemRGB128: TBlendMemRGB128; 95 {$ENDIF} 96 80 97 BlendLine: TBlendLine; 81 98 BlendLineEx: TBlendLineEx; 99 BlendLine1: TBlendLine1; 82 100 83 101 CombineReg: TCombineReg; … … 93 111 MergeLine: TBlendLine; 94 112 MergeLineEx: TBlendLineEx; 113 MergeLine1: TBlendLine1; 95 114 96 115 { Color algebra functions } … … 105 124 ColorExclusion: TBlendReg; 106 125 ColorScale: TBlendReg; 126 ColorScreen: TBlendReg; 127 ColorDodge: TBlendReg; 128 ColorBurn: TBlendReg; 129 130 { Blended color algebra functions } 131 BlendColorAdd: TBlendReg; 132 BlendColorModulate: TBlendReg; 107 133 108 134 { Special LUT pointers } … … 119 145 { Access to alpha composite functions corresponding to a combine mode } 120 146 147 type 148 PBlendReg = ^TBlendReg; 149 PBlendMem = ^TBlendMem; 150 PBlendRegEx = ^TBlendRegEx; 151 PBlendMemEx = ^TBlendMemEx; 152 PBlendLine = ^TBlendLine; 153 PBlendLineEx = ^TBlendLineEx; 154 155 TBlendRegCombineModeArray = array[TCombineMode] of PBlendReg; 156 TBlendMemCombineModeArray = array[TCombineMode] of PBlendMem; 157 TBlendRegExCombineModeArray = array[TCombineMode] of PBlendRegEx; 158 TBlendMemExCombineModeArray = array[TCombineMode] of PBlendMemEx; 159 TBlendLineCombineModeArray = array[TCombineMode] of PBlendLine; 160 TBlendLineExCombineModeArray = array[TCombineMode] of PBlendLineEx; 161 121 162 const 122 BLEND_REG: array[TCombineMode] of ^TBlendReg= ((@@BlendReg),(@@MergeReg));123 BLEND_MEM: array[TCombineMode] of ^TBlendMem= ((@@BlendMem),(@@MergeMem));124 BLEND_REG_EX: array[TCombineMode] of ^TBlendRegEx= ((@@BlendRegEx),(@@MergeRegEx));125 BLEND_MEM_EX: array[TCombineMode] of ^TBlendMemEx= ((@@BlendMemEx),(@@MergeMemEx));126 BLEND_LINE: array[TCombineMode] of ^TBlendLine= ((@@BlendLine),(@@MergeLine));127 BLEND_LINE_EX: array[TCombineMode] of ^TBlendLineEx= ((@@BlendLineEx),(@@MergeLineEx));163 BLEND_REG: TBlendRegCombineModeArray = ((@@BlendReg),(@@MergeReg)); 164 BLEND_MEM: TBlendMemCombineModeArray = ((@@BlendMem),(@@MergeMem)); 165 BLEND_REG_EX: TBlendRegExCombineModeArray = ((@@BlendRegEx),(@@MergeRegEx)); 166 BLEND_MEM_EX: TBlendMemExCombineModeArray = ((@@BlendMemEx),(@@MergeMemEx)); 167 BLEND_LINE: TBlendLineCombineModeArray = ((@@BlendLine),(@@MergeLine)); 168 BLEND_LINE_EX: TBlendLineExCombineModeArray = ((@@BlendLineEx),(@@MergeLineEx)); 128 169 129 170 var … … 134 175 {$ENDIF} 135 176 136 implementation137 138 {$IFDEF TARGET_x86}139 uses GR32_LowLevel;140 {$ENDIF}141 142 177 var 143 178 RcTable: array [Byte, Byte] of Byte; 144 179 DivTable: array [Byte, Byte] of Byte; 180 181 implementation 182 183 uses 184 GR32_LowLevel, 185 {$IFNDEF PUREPASCAL} 186 GR32_BlendASM, 187 {$IFNDEF OMIT_MMX} 188 GR32_BlendMMX, 189 {$ENDIF} 190 {$IFNDEF OMIT_SSE2} 191 GR32_BlendSSE2, 192 {$ENDIF} 193 {$ENDIF} 194 GR32_System; 145 195 146 196 {$IFDEF OMIT_MMX} … … 173 223 end; 174 224 225 Af := @DivTable[FA]; 226 Ab := @DivTable[not FA]; 175 227 with BX do 176 228 begin 177 Af := @DivTable[FA];178 Ab := @DivTable[not FA];179 229 R := Af[FX.R] + Ab[R]; 180 230 G := Af[FX.G] + Ab[G]; 181 231 B := Af[FX.B] + Ab[B]; 232 A := $FF; 182 233 end; 183 234 Result := B; … … 201 252 end; 202 253 254 Af := @DivTable[FA]; 255 Ab := @DivTable[not FA]; 203 256 with BX do 204 257 begin 205 Af := @DivTable[FA];206 Ab := @DivTable[not FA];207 258 R := Af[FX.R] + Ab[R]; 208 259 G := Af[FX.G] + Ab[G]; 209 260 B := Af[FX.B] + Ab[B]; 261 A := $FF; 262 end; 263 end; 264 265 procedure BlendMems_Pas(F: TColor32; B: PColor32; Count: Integer); 266 begin 267 while Count > 0 do 268 begin 269 BlendMem(F, B^); 270 Inc(B); 271 Dec(Count); 210 272 end; 211 273 end; … … 233 295 end; 234 296 297 Ab := @DivTable[255 - M]; 235 298 with BX do 236 299 begin 237 Af := @DivTable[M];238 Ab := @DivTable[255 - M];239 300 R := Af[FX.R] + Ab[R]; 240 301 G := Af[FX.G] + Ab[G]; 241 302 B := Af[FX.B] + Ab[B]; 303 A := $FF; 242 304 end; 243 305 Result := B; … … 265 327 end; 266 328 329 Ab := @DivTable[255 - M]; 267 330 with BX do 268 331 begin 269 Af := @DivTable[M];270 Ab := @DivTable[255 - M];271 332 R := Af[FX.R] + Ab[R]; 272 333 G := Af[FX.G] + Ab[G]; 273 334 B := Af[FX.B] + Ab[B]; 335 A := $FF; 336 end; 337 end; 338 339 function BlendRegRGB_Pas(F, B, W: TColor32): TColor32; 340 var 341 FX: TColor32Entry absolute F; 342 BX: TColor32Entry absolute B; 343 WX: TColor32Entry absolute W; 344 RX: TColor32Entry absolute Result; 345 begin 346 RX.R := (FX.R - BX.R) * WX.B div 255 + BX.R; 347 RX.G := (FX.G - BX.G) * WX.G div 255 + BX.G; 348 RX.B := (FX.B - BX.B) * WX.R div 255 + BX.B; 349 end; 350 351 procedure BlendMemRGB_Pas(F: TColor32; var B: TColor32; W: TColor32); 352 var 353 FX: TColor32Entry absolute F; 354 BX: TColor32Entry absolute B; 355 WX: TColor32Entry absolute W; 356 begin 357 BX.R := (FX.R - BX.R) * WX.B div 255 + BX.R; 358 BX.G := (FX.G - BX.G) * WX.G div 255 + BX.G; 359 BX.B := (FX.B - BX.B) * WX.R div 255 + BX.B; 360 end; 361 362 procedure BlendLine1_Pas(Src: TColor32; Dst: PColor32; Count: Integer); 363 begin 364 while Count > 0 do 365 begin 366 BlendMem(Src, Dst^); 367 Inc(Dst); 368 Dec(Count); 274 369 end; 275 370 end; … … 315 410 end; 316 411 412 Af := @DivTable[W]; 413 Ab := @DivTable[255 - W]; 317 414 with Xe do 318 415 begin 319 Af := @DivTable[W];320 Ab := @DivTable[255 - W];321 416 R := Ab[Ye.R] + Af[R]; 322 417 G := Ab[Ye.G] + Af[G]; 323 418 B := Ab[Ye.B] + Af[B]; 419 A := Ab[Ye.A] + Af[A]; 324 420 end; 325 421 Result := X; … … 343 439 end; 344 440 441 Af := @DivTable[W]; 442 Ab := @DivTable[255 - W]; 345 443 with Xe do 346 444 begin 347 Af := @DivTable[W];348 Ab := @DivTable[255 - W];349 445 R := Ab[Ye.R] + Af[R]; 350 446 G := Ab[Ye.G] + Af[G]; 351 447 B := Ab[Ye.B] + Af[B]; 448 A := Ab[Ye.A] + Af[A]; 352 449 end; 353 450 Y := X; … … 367 464 function MergeReg_Pas(F, B: TColor32): TColor32; 368 465 var 369 Fa, Ba, Wa: TColor32;370 Fw, Bw: PByteArray;371 Fx: TColor32Entry absolute F;372 Bx: TColor32Entry absolute B;373 Rx: TColor32Entry absolute Result;374 begin 375 Fa := F shr 24;376 Ba := B shr 24;377 if Fa = $FF then378 Result := F379 else if Fa = $0 then380 Result := B381 else if Ba = $0 then382 Result := F383 else384 begin385 Rx.A := DivTable[Fa xor 255, Ba xor 255] xor 255;386 Wa := RcTable[Rx.A, Fa];387 Fw := @DivTable[Wa];388 Bw := @DivTable[Wa xor $ff];389 Rx.R := Fw[Fx.R] + Bw[Bx.R];390 Rx.G := Fw[Fx.G] + Bw[Bx.G];391 Rx.B := Fw[Fx.B] + Bw[Bx.B];392 end;466 Fa, Ba, Wa: TColor32; 467 Fw, Bw: PByteArray; 468 Fx: TColor32Entry absolute F; 469 Bx: TColor32Entry absolute B; 470 Rx: TColor32Entry absolute Result; 471 begin 472 Fa := F shr 24; 473 Ba := B shr 24; 474 if Fa = $FF then 475 Result := F 476 else if Fa = $0 then 477 Result := B 478 else if Ba = $0 then 479 Result := F 480 else 481 begin 482 Rx.A := DivTable[Fa xor 255, Ba xor 255] xor 255; 483 Wa := RcTable[Rx.A, Fa]; 484 Fw := @DivTable[Wa]; 485 Bw := @DivTable[Wa xor $FF]; 486 Rx.R := Fw[Fx.R] + Bw[Bx.R]; 487 Rx.G := Fw[Fx.G] + Bw[Bx.G]; 488 Rx.B := Fw[Fx.B] + Bw[Bx.B]; 489 end; 393 490 end; 394 491 … … 406 503 begin 407 504 B := MergeReg(DivTable[M, F shr 24] shl 24 or F and $00FFFFFF, B); 505 end; 506 507 procedure MergeLine1_Pas(Src: TColor32; Dst: PColor32; Count: Integer); 508 begin 509 while Count > 0 do 510 begin 511 Dst^ := MergeReg(Src, Dst^); 512 Inc(Dst); 513 Dec(Count); 514 end; 408 515 end; 409 516 … … 435 542 procedure EMMS_Pas; 436 543 begin 437 //Dummy544 // Dummy 438 545 end; 439 546 440 547 function LightenReg_Pas(C: TColor32; Amount: Integer): TColor32; 441 548 var 442 r, g, b , a: Integer;549 r, g, b: Integer; 443 550 CX: TColor32Entry absolute C; 444 551 RX: TColor32Entry absolute Result; 445 552 begin 446 a := CX.A;447 553 r := CX.R; 448 554 g := CX.G; … … 457 563 if b > 255 then b := 255 else if b < 0 then b := 0; 458 564 459 RX.A := a; 565 // preserve alpha 566 RX.A := CX.A; 460 567 RX.R := r; 461 568 RX.G := g; … … 467 574 function ColorAdd_Pas(C1, C2: TColor32): TColor32; 468 575 var 469 r1, g1, b1, a1: Integer; 470 r2, g2, b2, a2: Integer; 471 begin 472 a1 := C1 shr 24; 473 r1 := C1 and $00FF0000; 474 g1 := C1 and $0000FF00; 475 b1 := C1 and $000000FF; 476 477 a2 := C2 shr 24; 478 r2 := C2 and $00FF0000; 479 g2 := C2 and $0000FF00; 480 b2 := C2 and $000000FF; 481 482 a1 := a1 + a2; 483 r1 := r1 + r2; 484 g1 := g1 + g2; 485 b1 := b1 + b2; 486 487 if a1 > $FF then a1 := $FF; 488 if r1 > $FF0000 then r1 := $FF0000; 489 if g1 > $FF00 then g1 := $FF00; 490 if b1 > $FF then b1 := $FF; 491 492 Result := a1 shl 24 + r1 + g1 + b1; 576 Xe: TColor32Entry absolute C1; 577 Ye: TColor32Entry absolute C2; 578 R: TColor32Entry absolute Result; 579 begin 580 R.A := Clamp(Xe.A + Ye.A, 255); 581 R.R := Clamp(Xe.R + Ye.R, 255); 582 R.G := Clamp(Xe.G + Ye.G, 255); 583 R.B := Clamp(Xe.B + Ye.B, 255); 493 584 end; 494 585 495 586 function ColorSub_Pas(C1, C2: TColor32): TColor32; 496 587 var 497 r1, g1, b1, a1: Integer; 498 r2, g2, b2, a2: Integer; 499 begin 500 a1 := C1 shr 24; 501 r1 := C1 and $00FF0000; 502 g1 := C1 and $0000FF00; 503 b1 := C1 and $000000FF; 504 505 r1 := r1 shr 16; 506 g1 := g1 shr 8; 507 508 a2 := C2 shr 24; 509 r2 := C2 and $00FF0000; 510 g2 := C2 and $0000FF00; 511 b2 := C2 and $000000FF; 512 513 r2 := r2 shr 16; 514 g2 := g2 shr 8; 515 516 a1 := a1 - a2; 517 r1 := r1 - r2; 518 g1 := g1 - g2; 519 b1 := b1 - b2; 520 521 if a1 < 0 then a1 := 0; 522 if r1 < 0 then r1 := 0; 523 if g1 < 0 then g1 := 0; 524 if b1 < 0 then b1 := 0; 525 526 Result := a1 shl 24 + r1 shl 16 + g1 shl 8 + b1; 588 Xe: TColor32Entry absolute C1; 589 Ye: TColor32Entry absolute C2; 590 R: TColor32Entry absolute Result; 591 Temp: SmallInt; 592 begin 593 Temp := Xe.A - Ye.A; 594 if Temp < 0 then 595 R.A := 0 596 else 597 R.A := Temp; 598 Temp := Xe.R - Ye.R; 599 if Temp < 0 then 600 R.R := 0 601 else 602 R.R := Temp; 603 Temp := Xe.G - Ye.G; 604 if Temp < 0 then 605 R.G := 0 606 else 607 R.G := Temp; 608 Temp := Xe.B - Ye.B; 609 if Temp < 0 then 610 R.B := 0 611 else 612 R.B := Temp; 527 613 end; 528 614 529 615 function ColorDiv_Pas(C1, C2: TColor32): TColor32; 530 616 var 531 r1, g1, b1, a1: Integer; 532 r2, g2, b2, a2: Integer; 533 begin 534 a1 := C1 shr 24; 535 r1 := (C1 and $00FF0000) shr 16; 536 g1 := (C1 and $0000FF00) shr 8; 537 b1 := C1 and $000000FF; 538 539 a2 := C2 shr 24; 540 r2 := (C2 and $00FF0000) shr 16; 541 g2 := (C2 and $0000FF00) shr 8; 542 b2 := C2 and $000000FF; 543 544 if a1 = 0 then a1:=$FF 545 else a1 := (a2 shl 8) div a1; 546 if r1 = 0 then r1:=$FF 547 else r1 := (r2 shl 8) div r1; 548 if g1 = 0 then g1:=$FF 549 else g1 := (g2 shl 8) div g1; 550 if b1 = 0 then b1:=$FF 551 else b1 := (b2 shl 8) div b1; 552 553 if a1 > $FF then a1 := $FF; 554 if r1 > $FF then r1 := $FF; 555 if g1 > $FF then g1 := $FF; 556 if b1 > $FF then b1 := $FF; 557 558 Result := a1 shl 24 + r1 shl 16 + g1 shl 8 + b1; 617 C1e: TColor32Entry absolute C1; 618 C2e: TColor32Entry absolute C2; 619 Re: TColor32Entry absolute Result; 620 Temp: Word; 621 begin 622 if C1e.A = 0 then 623 Re.A := $FF 624 else 625 begin 626 Temp := (C2e.A shl 8) div C1e.A; 627 if Temp > $FF then 628 Re.A := $FF 629 else 630 Re.A := Temp; 631 end; 632 633 if C1e.R = 0 then 634 Re.R := $FF 635 else 636 begin 637 Temp := (C2e.R shl 8) div C1e.R; 638 if Temp > $FF then 639 Re.R := $FF 640 else 641 Re.R := Temp; 642 end; 643 644 if C1e.G = 0 then 645 Re.G := $FF 646 else 647 begin 648 Temp := (C2e.G shl 8) div C1e.G; 649 if Temp > $FF then 650 Re.G := $FF 651 else 652 Re.G := Temp; 653 end; 654 655 if C1e.B = 0 then 656 Re.B := $FF 657 else 658 begin 659 Temp := (C2e.B shl 8) div C1e.B; 660 if Temp > $FF then 661 Re.B := $FF 662 else 663 Re.B := Temp; 664 end; 559 665 end; 560 666 561 667 function ColorModulate_Pas(C1, C2: TColor32): TColor32; 562 668 var 563 REnt: TColor32Entry absolute Result;564 C2 Ent: TColor32Entry absolute C2;565 begin 566 Result := C1; 567 R Ent.A := (C2Ent.A * REnt.A) shr 8;568 R Ent.R := (C2Ent.R * REnt.R) shr 8;569 R Ent.G := (C2Ent.G * REnt.G) shr 8;570 R Ent.B := (C2Ent.B * REnt.B) shr 8;669 C1e: TColor32Entry absolute C2; 670 C2e: TColor32Entry absolute C2; 671 Re: TColor32Entry absolute Result; 672 begin 673 Re.A := (C2e.A * C1e.A + $80) shr 8; 674 Re.R := (C2e.R * C1e.R + $80) shr 8; 675 Re.G := (C2e.G * C1e.G + $80) shr 8; 676 Re.B := (C2e.B * C1e.B + $80) shr 8; 571 677 end; 572 678 … … 603 709 function ColorDifference_Pas(C1, C2: TColor32): TColor32; 604 710 var 605 r1, g1, b1, a1: TColor32; 606 r2, g2, b2, a2: TColor32; 607 begin 608 a1 := C1 shr 24; 609 r1 := C1 and $00FF0000; 610 g1 := C1 and $0000FF00; 611 b1 := C1 and $000000FF; 612 613 r1 := r1 shr 16; 614 g1 := g1 shr 8; 615 616 a2 := C2 shr 24; 617 r2 := C2 and $00FF0000; 618 g2 := C2 and $0000FF00; 619 b2 := C2 and $000000FF; 620 621 r2 := r2 shr 16; 622 g2 := g2 shr 8; 623 624 a1 := abs(a2 - a1); 625 r1 := abs(r2 - r1); 626 g1 := abs(g2 - g1); 627 b1 := abs(b2 - b1); 628 629 Result := a1 shl 24 + r1 shl 16 + g1 shl 8 + b1; 711 Xe: TColor32Entry absolute C1; 712 Ye: TColor32Entry absolute C2; 713 R: TColor32Entry absolute Result; 714 begin 715 R.A := Abs(Xe.A - Ye.A); 716 R.R := Abs(Xe.R - Ye.R); 717 R.G := Abs(Xe.G - Ye.G); 718 R.B := Abs(Xe.B - Ye.B); 630 719 end; 631 720 632 721 function ColorExclusion_Pas(C1, C2: TColor32): TColor32; 633 722 var 634 r1, g1, b1, a1: TColor32; 635 r2, g2, b2, a2: TColor32; 636 begin 637 a1 := C1 shr 24; 638 r1 := C1 and $00FF0000; 639 g1 := C1 and $0000FF00; 640 b1 := C1 and $000000FF; 641 642 r1 := r1 shr 16; 643 g1 := g1 shr 8; 644 645 a2 := C2 shr 24; 646 r2 := C2 and $00FF0000; 647 g2 := C2 and $0000FF00; 648 b2 := C2 and $000000FF; 649 650 r2 := r2 shr 16; 651 g2 := g2 shr 8; 652 653 a1 := a1 + a2 - (a1 * a2 shr 7); 654 r1 := r1 + r2 - (r1 * r2 shr 7); 655 g1 := g1 + g2 - (g1 * g2 shr 7); 656 b1 := b1 + b2 - (b1 * b2 shr 7); 657 658 Result := a1 shl 24 + r1 shl 16 + g1 shl 8 + b1; 723 Xe: TColor32Entry absolute C1; 724 Ye: TColor32Entry absolute C2; 725 R: TColor32Entry absolute Result; 726 begin 727 R.A := Xe.A + Ye.A - ((Xe.A * Ye.A) shl 7); 728 R.R := Xe.R + Ye.R - ((Xe.R * Ye.R) shr 7); 729 R.G := Xe.G + Ye.G - ((Xe.G * Ye.G) shr 7); 730 R.B := Xe.B + Ye.B - ((Xe.B * Ye.B) shr 7); 659 731 end; 660 732 … … 674 746 function ColorScale_Pas(C, W: TColor32): TColor32; 675 747 var 748 Ce: TColor32Entry absolute C; 749 var 676 750 r1, g1, b1, a1: Cardinal; 677 751 begin 678 a1 := C shr 24; 679 r1 := C and $00FF0000; 680 g1 := C and $0000FF00; 681 b1 := C and $000000FF; 682 683 r1 := r1 shr 16; 684 g1 := g1 shr 8; 685 686 a1 := a1 * W shr 8; 687 r1 := r1 * W shr 8; 688 g1 := g1 * W shr 8; 689 b1 := b1 * W shr 8; 752 a1 := Ce.A * W shr 8; 753 r1 := Ce.R * W shr 8; 754 g1 := Ce.G * W shr 8; 755 b1 := Ce.B * W shr 8; 690 756 691 757 if a1 > 255 then a1 := 255; … … 697 763 end; 698 764 765 function ColorScreen_Pas(B, S: TColor32): TColor32; 766 var 767 Be: TColor32Entry absolute B; 768 Se: TColor32Entry absolute S; 769 R: TColor32Entry absolute Result; 770 begin 771 R.A := Be.A + Se.A - (Be.A * Se.A) div 255; 772 R.R := Be.R + Se.R - (Be.R * Se.R) div 255; 773 R.G := Be.G + Se.G - (Be.G * Se.G) div 255; 774 R.B := Be.B + Se.B - (Be.B * Se.B) div 255; 775 end; 776 777 function ColorDodge_Pas(B, S: TColor32): TColor32; 778 779 function Dodge(B, S: Byte): Byte; 780 begin 781 if B = 0 then 782 Result := 0 783 else 784 if S = 255 then 785 Result := 255 786 else 787 Result := Clamp((255 * B) div (255 - S), 255); 788 end; 789 790 var 791 Be: TColor32Entry absolute B; 792 Se: TColor32Entry absolute S; 793 R: TColor32Entry absolute Result; 794 begin 795 R.A := Dodge(Be.A, Se.A); 796 R.R := Dodge(Be.R, Se.R); 797 R.G := Dodge(Be.G, Se.G); 798 R.B := Dodge(Be.B, Se.B); 799 end; 800 801 function ColorBurn_Pas(B, S: TColor32): TColor32; 802 803 function Burn(B, S: Byte): Byte; 804 begin 805 if B = 255 then 806 Result := 255 807 else 808 if S = 0 then 809 Result := 0 810 else 811 Result := 255 - Clamp(255 * (255 - B) div S, 255); 812 end; 813 814 var 815 Be: TColor32Entry absolute B; 816 Se: TColor32Entry absolute S; 817 R: TColor32Entry absolute Result; 818 begin 819 R.A := Burn(Be.A, Se.A); 820 R.R := Burn(Be.R, Se.R); 821 R.G := Burn(Be.G, Se.G); 822 R.B := Burn(Be.B, Se.B); 823 end; 824 825 826 { Blended color algebra } 827 828 function BlendColorAdd_Pas(C1, C2: TColor32): TColor32; 829 var 830 Xe: TColor32Entry absolute C1; 831 Ye: TColor32Entry absolute C2; 832 R: TColor32Entry absolute Result; 833 Af, Ab: PByteArray; 834 begin 835 Af := @DivTable[Xe.A]; 836 Ab := @DivTable[not Xe.A]; 837 R.A := Af[Clamp(Xe.A + Ye.A, 255)] + Ab[Ye.A]; 838 R.R := Af[Clamp(Xe.R + Ye.R, 255)] + Ab[Ye.R]; 839 R.G := Af[Clamp(Xe.G + Ye.G, 255)] + Ab[Ye.G]; 840 R.B := Af[Clamp(Xe.B + Ye.B, 255)] + Ab[Ye.B]; 841 end; 842 843 function BlendColorModulate_Pas(C1, C2: TColor32): TColor32; 844 var 845 C1e: TColor32Entry absolute C1; 846 C2e: TColor32Entry absolute C2; 847 R: TColor32Entry absolute Result; 848 Af, Ab: PByteArray; 849 begin 850 Af := @DivTable[C1e.A]; 851 Ab := @DivTable[not C1e.A]; 852 R.A := Af[(C2e.A * C1e.A + $80) shr 8] + Ab[C2e.A]; 853 R.R := Af[(C2e.R * C1e.R + $80) shr 8] + Ab[C2e.R]; 854 R.G := Af[(C2e.G * C1e.G + $80) shr 8] + Ab[C2e.G]; 855 R.B := Af[(C2e.B * C1e.B + $80) shr 8] + Ab[C2e.B]; 856 end; 857 699 858 {$IFNDEF PUREPASCAL} 700 701 { Assembler versions }702 703 const704 bias = $00800080;705 706 707 function BlendReg_ASM(F, B: TColor32): TColor32;708 asm709 // blend foreground color (F) to a background color (B),710 // using alpha channel value of F711 // Result Z = Fa * Frgb + (1 - Fa) * Brgb712 713 {$IFDEF TARGET_x86}714 // EAX <- F715 // EDX <- B716 717 // Test Fa = 255 ?718 CMP EAX,$FF000000 // Fa = 255 ? => Result = EAX719 JNC @2720 721 // Test Fa = 0 ?722 TEST EAX,$FF000000 // Fa = 0 ? => Result = EDX723 JZ @1724 725 // Get weight W = Fa * M726 MOV ECX,EAX // ECX <- Fa Fr Fg Fb727 SHR ECX,24 // ECX <- 00 00 00 Fa728 729 PUSH EBX730 731 // P = W * F732 MOV EBX,EAX // EBX <- Fa Fr Fg Fb733 AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb734 AND EBX,$FF00FF00 // EBX <- Fa 00 Fg 00735 IMUL EAX,ECX // EAX <- Pr ** Pb **736 SHR EBX,8 // EBX <- 00 Fa 00 Fg737 IMUL EBX,ECX // EBX <- Pa ** Pg **738 ADD EAX,bias739 AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00740 SHR EAX,8 // EAX <- 00 Pr ** Pb741 ADD EBX,bias742 AND EBX,$FF00FF00 // EBX <- Pa 00 Pg 00743 OR EAX,EBX // EAX <- Pa Pr Pg Pb744 745 // W = 1 - W; Q = W * B746 XOR ECX,$000000FF // ECX <- 1 - ECX747 MOV EBX,EDX // EBX <- Ba Br Bg Bb748 AND EDX,$00FF00FF // EDX <- 00 Br 00 Bb749 AND EBX,$FF00FF00 // EBX <- Ba 00 Bg 00750 IMUL EDX,ECX // EDX <- Qr ** Qb **751 SHR EBX,8 // EBX <- 00 Ba 00 Bg752 IMUL EBX,ECX // EBX <- Qa ** Qg **753 ADD EDX,bias754 AND EDX,$FF00FF00 // EDX <- Qr 00 Qb 00755 SHR EDX,8 // EDX <- 00 Qr ** Qb756 ADD EBX,bias757 AND EBX,$FF00FF00 // EBX <- Qa 00 Qg 00758 OR EBX,EDX // EBX <- Qa Qr Qg Qb759 760 // Z = P + Q (assuming no overflow at each byte)761 ADD EAX,EBX // EAX <- Za Zr Zg Zb762 763 POP EBX764 {$IFDEF FPC}765 JMP @2766 {$ELSE}767 RET768 {$ENDIF}769 770 @1: MOV EAX,EDX771 @2:772 {$ENDIF}773 774 // EAX <- F775 // EDX <- B776 {$IFDEF TARGET_x64}777 MOV RAX, RCX778 779 // Test Fa = 255 ?780 CMP EAX,$FF000000 // Fa = 255 ? => Result = EAX781 JNC @2782 783 // Test Fa = 0 ?784 TEST EAX,$FF000000 // Fa = 0 ? => Result = EDX785 JZ @1786 787 // Get weight W = Fa * M788 MOV ECX,EAX // ECX <- Fa Fr Fg Fb789 SHR ECX,24 // ECX <- 00 00 00 Fa790 791 // P = W * F792 MOV R9D,EAX // R9D <- Fa Fr Fg Fb793 AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb794 AND R9D,$FF00FF00 // R9D <- Fa 00 Fg 00795 IMUL EAX,ECX // EAX <- Pr ** Pb **796 SHR R9D,8 // R9D <- 00 Fa 00 Fg797 IMUL R9D,ECX // R9D <- Pa ** Pg **798 ADD EAX,bias799 AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00800 SHR EAX,8 // EAX <- 00 Pr ** Pb801 ADD R9D,bias802 AND R9D,$FF00FF00 // R9D <- Pa 00 Pg 00803 OR EAX,R9D // EAX <- Pa Pr Pg Pb804 805 // W = 1 - W; Q = W * B806 XOR ECX,$000000FF // ECX <- 1 - ECX807 MOV R9D,EDX // R9D <- Ba Br Bg Bb808 AND EDX,$00FF00FF // EDX <- 00 Br 00 Bb809 AND R9D,$FF00FF00 // R9D <- Ba 00 Bg 00810 IMUL EDX,ECX // EDX <- Qr ** Qb **811 SHR R9D,8 // R9D <- 00 Ba 00 Bg812 IMUL R9D,ECX // R9D <- Qa ** Qg **813 ADD EDX,bias814 AND EDX,$FF00FF00 // EDX <- Qr 00 Qb 00815 SHR EDX,8 // EDX <- 00 Qr ** Qb816 ADD R9D,bias817 AND R9D,$FF00FF00 // R9D <- Qa 00 Qg 00818 OR R9D,EDX // R9D <- Qa Qr Qg Qb819 820 // Z = P + Q (assuming no overflow at each byte)821 ADD EAX,R9D // EAX <- Za Zr Zg Zb822 {$IFDEF FPC}823 JMP @2824 {$ELSE}825 RET826 {$ENDIF}827 828 @1: MOV EAX,EDX829 @2:830 {$ENDIF}831 end;832 833 procedure BlendMem_ASM(F: TColor32; var B: TColor32);834 asm835 {$IFDEF TARGET_x86}836 // EAX <- F837 // [EDX] <- B838 839 // Test Fa = 0 ?840 TEST EAX,$FF000000 // Fa = 0 ? => do not write841 JZ @2842 843 // Get weight W = Fa * M844 MOV ECX,EAX // ECX <- Fa Fr Fg Fb845 SHR ECX,24 // ECX <- 00 00 00 Fa846 847 // Test Fa = 255 ?848 CMP ECX,$FF849 JZ @1850 851 PUSH EBX852 PUSH ESI853 854 // P = W * F855 MOV EBX,EAX // EBX <- Fa Fr Fg Fb856 AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb857 AND EBX,$FF00FF00 // EBX <- Fa 00 Fg 00858 IMUL EAX,ECX // EAX <- Pr ** Pb **859 SHR EBX,8 // EBX <- 00 Fa 00 Fg860 IMUL EBX,ECX // EBX <- Pa ** Pg **861 ADD EAX,bias862 AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00863 SHR EAX,8 // EAX <- 00 Pr ** Pb864 ADD EBX,bias865 AND EBX,$FF00FF00 // EBX <- Pa 00 Pg 00866 OR EAX,EBX // EAX <- Pa Pr Pg Pb867 868 MOV ESI,[EDX]869 870 // W = 1 - W; Q = W * B871 XOR ECX,$000000FF // ECX <- 1 - ECX872 MOV EBX,ESI // EBX <- Ba Br Bg Bb873 AND ESI,$00FF00FF // ESI <- 00 Br 00 Bb874 AND EBX,$FF00FF00 // EBX <- Ba 00 Bg 00875 IMUL ESI,ECX // ESI <- Qr ** Qb **876 SHR EBX,8 // EBX <- 00 Ba 00 Bg877 IMUL EBX,ECX // EBX <- Qa ** Qg **878 ADD ESI,bias879 AND ESI,$FF00FF00 // ESI <- Qr 00 Qb 00880 SHR ESI,8 // ESI <- 00 Qr ** Qb881 ADD EBX,bias882 AND EBX,$FF00FF00 // EBX <- Qa 00 Qg 00883 OR EBX,ESI // EBX <- Qa Qr Qg Qb884 885 // Z = P + Q (assuming no overflow at each byte)886 ADD EAX,EBX // EAX <- Za Zr Zg Zb887 888 MOV [EDX],EAX889 POP ESI890 POP EBX891 {$IFDEF FPC}892 JMP @2893 {$ELSE}894 RET895 {$ENDIF}896 897 @1: MOV [EDX],EAX898 @2:899 {$ENDIF}900 901 {$IFDEF TARGET_x64}902 // ECX <- F903 // [RDX] <- B904 905 // Test Fa = 0 ?906 TEST ECX,$FF000000 // Fa = 0 ? => do not write907 JZ @2908 909 MOV EAX, ECX // EAX <- Fa Fr Fg Fb910 911 // Get weight W = Fa * M912 SHR ECX,24 // ECX <- 00 00 00 Fa913 914 // Test Fa = 255 ?915 CMP ECX,$FF916 JZ @1917 918 // P = W * F919 MOV R8D,EAX // R8D <- Fa Fr Fg Fb920 AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb921 AND R8D,$FF00FF00 // R8D <- Fa 00 Fg 00922 IMUL EAX,ECX // EAX <- Pr ** Pb **923 SHR R8D,8 // R8D <- 00 Fa 00 Fg924 IMUL R8D,ECX // R8D <- Pa ** Pg **925 ADD EAX,bias926 AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00927 SHR EAX,8 // EAX <- 00 Pr ** Pb928 ADD R8D,bias929 AND R8D,$FF00FF00 // R8D <- Pa 00 Pg 00930 OR EAX,R8D // EAX <- Pa Pr Pg Pb931 932 MOV R9D,[RDX]933 934 // W = 1 - W; Q = W * B935 XOR ECX,$000000FF // ECX <- 1 - ECX936 MOV R8D,R9D // R8D <- Ba Br Bg Bb937 AND R9D,$00FF00FF // R9D <- 00 Br 00 Bb938 AND R8D,$FF00FF00 // R8D <- Ba 00 Bg 00939 IMUL R9D,ECX // R9D <- Qr ** Qb **940 SHR R8D,8 // R8D <- 00 Ba 00 Bg941 IMUL R8D,ECX // R8D <- Qa ** Qg **942 ADD R9D,bias943 AND R9D,$FF00FF00 // R9D <- Qr 00 Qb 00944 SHR R9D,8 // R9D <- 00 Qr ** Qb945 ADD R8D,bias946 AND R8D,$FF00FF00 // R8D <- Qa 00 Qg 00947 OR R8D,R9D // R8D <- Qa Qr Qg Qb948 949 // Z = P + Q (assuming no overflow at each byte)950 ADD EAX,R8D // EAX <- Za Zr Zg Zb951 952 MOV [RDX],EAX953 {$IFDEF FPC}954 JMP @2955 {$ELSE}956 RET957 {$ENDIF}958 959 @1: MOV [RDX],EAX960 @2:961 {$ENDIF}962 end;963 964 function BlendRegEx_ASM(F, B, M: TColor32): TColor32;965 asm966 // blend foreground color (F) to a background color (B),967 // using alpha channel value of F multiplied by master alpha (M)968 // no checking for M = $FF, in this case Graphics32 uses BlendReg969 // Result Z = Fa * M * Frgb + (1 - Fa * M) * Brgb970 // EAX <- F971 // EDX <- B972 // ECX <- M973 974 {$IFDEF TARGET_x86}975 976 // Check Fa > 0 ?977 TEST EAX,$FF000000 // Fa = 0? => Result := EDX978 JZ @2979 980 PUSH EBX981 982 // Get weight W = Fa * M983 MOV EBX,EAX // EBX <- Fa Fr Fg Fb984 INC ECX // 255:256 range bias985 SHR EBX,24 // EBX <- 00 00 00 Fa986 IMUL ECX,EBX // ECX <- 00 00 W **987 SHR ECX,8 // ECX <- 00 00 00 W988 JZ @1 // W = 0 ? => Result := EDX989 990 // P = W * F991 MOV EBX,EAX // EBX <- ** Fr Fg Fb992 AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb993 AND EBX,$0000FF00 // EBX <- 00 00 Fg 00994 IMUL EAX,ECX // EAX <- Pr ** Pb **995 SHR EBX,8 // EBX <- 00 00 00 Fg996 IMUL EBX,ECX // EBX <- 00 00 Pg **997 ADD EAX,bias998 AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 00999 SHR EAX,8 // EAX <- 00 Pr ** Pb1000 ADD EBX,bias1001 AND EBX,$0000FF00 // EBX <- 00 00 Pg 001002 OR EAX,EBX // EAX <- 00 Pr Pg Pb1003 1004 // W = 1 - W; Q = W * B1005 XOR ECX,$000000FF // ECX <- 1 - ECX1006 MOV EBX,EDX // EBX <- 00 Br Bg Bb1007 AND EDX,$00FF00FF // EDX <- 00 Br 00 Bb1008 AND EBX,$0000FF00 // EBX <- 00 00 Bg 001009 IMUL EDX,ECX // EDX <- Qr ** Qb **1010 SHR EBX,8 // EBX <- 00 00 00 Bg1011 IMUL EBX,ECX // EBX <- 00 00 Qg **1012 ADD EDX,bias1013 AND EDX,$FF00FF00 // EDX <- Qr 00 Qb 001014 SHR EDX,8 // EDX <- 00 Qr ** Qb1015 ADD EBX,bias1016 AND EBX,$0000FF00 // EBX <- 00 00 Qg 001017 OR EBX,EDX // EBX <- 00 Qr Qg Qb1018 1019 // Z = P + Q (assuming no overflow at each byte)1020 ADD EAX,EBX // EAX <- 00 Zr Zg Zb1021 1022 POP EBX1023 {$IFDEF FPC}1024 JMP @31025 {$ELSE}1026 RET1027 {$ENDIF}1028 1029 @1:1030 POP EBX1031 1032 @2: MOV EAX,EDX1033 @3:1034 {$ENDIF}1035 1036 {$IFDEF TARGET_x64}1037 MOV EAX,ECX // EAX <- Fa Fr Fg Fb1038 TEST EAX,$FF000000 // Fa = 0? => Result := EDX1039 JZ @11040 1041 // Get weight W = Fa * M1042 INC R8D // 255:256 range bias1043 SHR ECX,24 // ECX <- 00 00 00 Fa1044 IMUL R8D,ECX // R8D <- 00 00 W **1045 SHR R8D,8 // R8D <- 00 00 00 W1046 JZ @1 // W = 0 ? => Result := EDX1047 1048 // P = W * F1049 MOV ECX,EAX // ECX <- ** Fr Fg Fb1050 AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb1051 AND ECX,$0000FF00 // ECX <- 00 00 Fg 001052 IMUL EAX,R8D // EAX <- Pr ** Pb **1053 SHR ECX,8 // ECX <- 00 00 00 Fg1054 IMUL ECX,R8D // ECX <- 00 00 Pg **1055 ADD EAX,bias1056 AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 001057 SHR EAX,8 // EAX <- 00 Pr ** Pb1058 ADD ECX,bias1059 AND ECX,$0000FF00 // ECX <- 00 00 Pg 001060 OR EAX,ECX // EAX <- 00 Pr Pg Pb1061 1062 // W = 1 - W; Q = W * B1063 XOR R8D,$000000FF // R8D <- 1 - R8D1064 MOV ECX,EDX // ECX <- 00 Br Bg Bb1065 AND EDX,$00FF00FF // EDX <- 00 Br 00 Bb1066 AND ECX,$0000FF00 // ECX <- 00 00 Bg 001067 IMUL EDX,R8D // EDX <- Qr ** Qb **1068 SHR ECX,8 // ECX <- 00 00 00 Bg1069 IMUL ECX,R8D // ECX <- 00 00 Qg **1070 ADD EDX,bias1071 AND EDX,$FF00FF00 // EDX <- Qr 00 Qb 001072 SHR EDX,8 // EDX <- 00 Qr ** Qb1073 ADD ECX,bias1074 AND ECX,$0000FF00 // ECX <- 00 00 Qg 001075 OR ECX,EDX // ECX <- 00 Qr Qg Qb1076 1077 // Z = P + Q (assuming no overflow at each byte)1078 ADD EAX,ECX // EAX <- 00 Zr Zg Zb1079 1080 {$IFDEF FPC}1081 JMP @21082 {$ELSE}1083 RET1084 {$ENDIF}1085 1086 @1: MOV EAX,EDX1087 @2:1088 {$ENDIF}1089 end;1090 1091 procedure BlendMemEx_ASM(F: TColor32; var B: TColor32; M: TColor32);1092 asm1093 {$IFDEF TARGET_x86}1094 // EAX <- F1095 // [EDX] <- B1096 // ECX <- M1097 1098 // Check Fa > 0 ?1099 TEST EAX,$FF000000 // Fa = 0? => write nothing1100 JZ @21101 1102 PUSH EBX1103 1104 // Get weight W = Fa * M1105 MOV EBX,EAX // EBX <- Fa Fr Fg Fb1106 INC ECX // 255:256 range bias1107 SHR EBX,24 // EBX <- 00 00 00 Fa1108 IMUL ECX,EBX // ECX <- 00 00 W **1109 SHR ECX,8 // ECX <- 00 00 00 W1110 JZ @1 // W = 0 ? => write nothing1111 1112 PUSH ESI1113 1114 // P = W * F1115 MOV EBX,EAX // EBX <- ** Fr Fg Fb1116 AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb1117 AND EBX,$0000FF00 // EBX <- 00 00 Fg 001118 IMUL EAX,ECX // EAX <- Pr ** Pb **1119 SHR EBX,8 // EBX <- 00 00 00 Fg1120 IMUL EBX,ECX // EBX <- 00 00 Pg **1121 ADD EAX,bias1122 AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 001123 SHR EAX,8 // EAX <- 00 Pr ** Pb1124 ADD EBX,bias1125 AND EBX,$0000FF00 // EBX <- 00 00 Pg 001126 OR EAX,EBX // EAX <- 00 Pr Pg Pb1127 1128 // W = 1 - W; Q = W * B1129 MOV ESI,[EDX]1130 XOR ECX,$000000FF // ECX <- 1 - ECX1131 MOV EBX,ESI // EBX <- 00 Br Bg Bb1132 AND ESI,$00FF00FF // ESI <- 00 Br 00 Bb1133 AND EBX,$0000FF00 // EBX <- 00 00 Bg 001134 IMUL ESI,ECX // ESI <- Qr ** Qb **1135 SHR EBX,8 // EBX <- 00 00 00 Bg1136 IMUL EBX,ECX // EBX <- 00 00 Qg **1137 ADD ESI,bias1138 AND ESI,$FF00FF00 // ESI <- Qr 00 Qb 001139 SHR ESI,8 // ESI <- 00 Qr ** Qb1140 ADD EBX,bias1141 AND EBX,$0000FF00 // EBX <- 00 00 Qg 001142 OR EBX,ESI // EBX <- 00 Qr Qg Qb1143 1144 // Z = P + Q (assuming no overflow at each byte)1145 ADD EAX,EBX // EAX <- 00 Zr Zg Zb1146 1147 MOV [EDX],EAX1148 POP ESI1149 1150 @1: POP EBX1151 @2:1152 {$ENDIF}1153 1154 {$IFDEF TARGET_x64}1155 // ECX <- F1156 // [RDX] <- B1157 // R8 <- M1158 1159 // ECX <- F1160 // [EDX] <- B1161 // R8 <- M1162 1163 // Check Fa > 0 ?1164 TEST ECX,$FF000000 // Fa = 0? => write nothing1165 JZ @11166 1167 // Get weight W = Fa * M1168 MOV EAX,ECX // EAX <- Fa Fr Fg Fb1169 INC R8D // 255:256 range bias1170 SHR EAX,24 // EAX <- 00 00 00 Fa1171 IMUL R8D,EAX // R8D <- 00 00 W **1172 SHR R8D,8 // R8D <- 00 00 00 W1173 JZ @1 // W = 0 ? => write nothing1174 1175 // P = W * F1176 MOV EAX,ECX // EAX <- ** Fr Fg Fb1177 AND ECX,$00FF00FF // ECX <- 00 Fr 00 Fb1178 AND EAX,$0000FF00 // EAX <- 00 00 Fg 001179 IMUL ECX,R8D // ECX <- Pr ** Pb **1180 SHR EAX,8 // EAX <- 00 00 00 Fg1181 IMUL EAX,R8D // EAX <- 00 00 Pg **1182 ADD ECX,bias1183 AND ECX,$FF00FF00 // ECX <- Pr 00 Pb 001184 SHR ECX,8 // ECX <- 00 Pr ** Pb1185 ADD EAX,bias1186 AND EAX,$0000FF00 // EAX <- 00 00 Pg 001187 OR ECX,EAX // ECX <- 00 Pr Pg Pb1188 1189 // W = 1 - W; Q = W * B1190 MOV R9D,[RDX]1191 XOR R8D,$000000FF // R8D <- 1 - R81192 MOV EAX,R9D // EAX <- 00 Br Bg Bb1193 AND R9D,$00FF00FF // R9D <- 00 Br 00 Bb1194 AND EAX,$0000FF00 // EAX <- 00 00 Bg 001195 IMUL R9D,R8D // R9D <- Qr ** Qb **1196 SHR EAX,8 // EAX <- 00 00 00 Bg1197 IMUL EAX,R8D // EAX <- 00 00 Qg **1198 ADD R9D,bias1199 AND R9D,$FF00FF00 // R9D <- Qr 00 Qb 001200 SHR R9D,8 // R9D <- 00 Qr ** Qb1201 ADD EAX,bias1202 AND EAX,$0000FF00 // EAX <- 00 00 Qg 001203 OR EAX,R9D // EAX <- 00 Qr Qg Qb1204 1205 // Z = P + Q (assuming no overflow at each byte)1206 ADD ECX,EAX // ECX <- 00 Zr Zg Zb1207 1208 MOV [RDX],ECX1209 1210 @1:1211 {$ENDIF}1212 end;1213 1214 procedure BlendLine_ASM(Src, Dst: PColor32; Count: Integer);1215 asm1216 {$IFDEF TARGET_x86}1217 // EAX <- Src1218 // EDX <- Dst1219 // ECX <- Count1220 1221 // test the counter for zero or negativity1222 TEST ECX,ECX1223 JS @41224 1225 PUSH EBX1226 PUSH ESI1227 PUSH EDI1228 1229 MOV ESI,EAX // ESI <- Src1230 MOV EDI,EDX // EDI <- Dst1231 1232 // loop start1233 @1: MOV EAX,[ESI]1234 TEST EAX,$FF0000001235 JZ @3 // complete transparency, proceed to next point1236 1237 PUSH ECX // store counter1238 1239 // Get weight W = Fa * M1240 MOV ECX,EAX // ECX <- Fa Fr Fg Fb1241 SHR ECX,24 // ECX <- 00 00 00 Fa1242 1243 // Test Fa = 255 ?1244 CMP ECX,$FF1245 JZ @21246 1247 // P = W * F1248 MOV EBX,EAX // EBX <- Fa Fr Fg Fb1249 AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb1250 AND EBX,$FF00FF00 // EBX <- Fa 00 Fg 001251 IMUL EAX,ECX // EAX <- Pr ** Pb **1252 SHR EBX,8 // EBX <- 00 Fa 00 Fg1253 IMUL EBX,ECX // EBX <- Pa ** Pg **1254 ADD EAX,bias1255 AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 001256 SHR EAX,8 // EAX <- 00 Pr ** Pb1257 ADD EBX,bias1258 AND EBX,$FF00FF00 // EBX <- Pa 00 Pg 001259 OR EAX,EBX // EAX <- Pa Pr Pg Pb1260 1261 // W = 1 - W; Q = W * B1262 MOV EDX,[EDI]1263 XOR ECX,$000000FF // ECX <- 1 - ECX1264 MOV EBX,EDX // EBX <- Ba Br Bg Bb1265 AND EDX,$00FF00FF // ESI <- 00 Br 00 Bb1266 AND EBX,$FF00FF00 // EBX <- Ba 00 Bg 001267 IMUL EDX,ECX // ESI <- Qr ** Qb **1268 SHR EBX,8 // EBX <- 00 Ba 00 Bg1269 IMUL EBX,ECX // EBX <- Qa ** Qg **1270 ADD EDX,bias1271 AND EDX,$FF00FF00 // ESI <- Qr 00 Qb 001272 SHR EDX,8 // ESI <- 00 Qr ** Qb1273 ADD EBX,bias1274 AND EBX,$FF00FF00 // EBX <- Qa 00 Qg 001275 OR EBX,EDX // EBX <- Qa Qr Qg Qb1276 1277 // Z = P + Q (assuming no overflow at each byte)1278 ADD EAX,EBX // EAX <- Za Zr Zg Zb1279 @2:1280 MOV [EDI],EAX1281 1282 POP ECX // restore counter1283 1284 @3:1285 ADD ESI,41286 ADD EDI,41287 1288 // loop end1289 DEC ECX1290 JNZ @11291 1292 POP EDI1293 POP ESI1294 POP EBX1295 1296 @4:1297 {$ENDIF}1298 1299 {$IFDEF TARGET_x64}1300 // RCX <- Src1301 // RDX <- Dst1302 // R8 <- Count1303 1304 // test the counter for zero or negativity1305 TEST R8D,R8D1306 JS @41307 1308 MOV R10,RCX // R10 <- Src1309 MOV R11,RDX // R11 <- Dst1310 MOV ECX,R8D // RCX <- Count1311 1312 // loop start1313 @1:1314 MOV EAX,[R10]1315 TEST EAX,$FF0000001316 JZ @3 // complete transparency, proceed to next point1317 1318 // Get weight W = Fa * M1319 MOV R9D,EAX // R9D <- Fa Fr Fg Fb1320 SHR R9D,24 // R9D <- 00 00 00 Fa1321 1322 // Test Fa = 255 ?1323 CMP R9D,$FF1324 JZ @21325 1326 // P = W * F1327 MOV R8D,EAX // R8D <- Fa Fr Fg Fb1328 AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb1329 AND R8D,$FF00FF00 // R8D <- Fa 00 Fg 001330 IMUL EAX,R9D // EAX <- Pr ** Pb **1331 SHR R8D,8 // R8D <- 00 Fa 00 Fg1332 IMUL R8D,R9D // R8D <- Pa ** Pg **1333 ADD EAX,bias1334 AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 001335 SHR EAX,8 // EAX <- 00 Pr ** Pb1336 ADD R8D,bias1337 AND R8D,$FF00FF00 // R8D <- Pa 00 Pg 001338 OR EAX,R8D // EAX <- Pa Pr Pg Pb1339 1340 // W = 1 - W; Q = W * B1341 MOV EDX,[R11]1342 XOR R9D,$000000FF // R9D <- 1 - R9D1343 MOV R8D,EDX // R8D <- Ba Br Bg Bb1344 AND EDX,$00FF00FF // ESI <- 00 Br 00 Bb1345 AND R8D,$FF00FF00 // R8D <- Ba 00 Bg 001346 IMUL EDX,R9D // ESI <- Qr ** Qb **1347 SHR R8D,8 // R8D <- 00 Ba 00 Bg1348 IMUL R8D,R9D // R8D <- Qa ** Qg **1349 ADD EDX,bias1350 AND EDX,$FF00FF00 // ESI <- Qr 00 Qb 001351 SHR EDX,8 // ESI <- 00 Qr ** Qb1352 ADD R8D,bias1353 AND R8D,$FF00FF00 // R8D <- Qa 00 Qg 001354 OR R8D,EDX // R8D <- Qa Qr Qg Qb1355 1356 // Z = P + Q (assuming no overflow at each byte)1357 ADD EAX,R8D // EAX <- Za Zr Zg Zb1358 @2:1359 MOV [R11],EAX1360 1361 @3:1362 ADD R10,41363 ADD R11,41364 1365 // loop end1366 DEC ECX1367 JNZ @11368 1369 @4:1370 {$ENDIF}1371 end;1372 1373 {$IFDEF TARGET_x86}1374 1375 function MergeReg_ASM(F, B: TColor32): TColor32;1376 asm1377 // EAX <- F1378 // EDX <- B1379 1380 // if F.A = 0 then1381 TEST EAX,$FF0000001382 JZ @exit01383 1384 // else if B.A = 255 then1385 CMP EDX,$FF0000001386 JNC @blend1387 1388 // else if F.A = 255 then1389 CMP EAX,$FF0000001390 JNC @Exit1391 1392 // else if B.A = 0 then1393 TEST EDX,$FF0000001394 JZ @Exit1395 1396 @4:1397 PUSH EBX1398 PUSH ESI1399 PUSH EDI1400 ADD ESP,-$0C1401 MOV [ESP+$04],EDX1402 MOV [ESP],EAX1403 1404 // AH <- F.A1405 // DL, CL <- B.A1406 SHR EAX,161407 AND EAX,$0000FF001408 SHR EDX,241409 MOV CL,DL1410 NOP1411 NOP1412 NOP1413 1414 // EDI <- PF1415 // EDX <- PB1416 // ESI <- PR1417 1418 // PF := @DivTable[F.A];1419 LEA EDI,[EAX+DivTable]1420 // PB := @DivTable[B.A];1421 SHL EDX,$081422 LEA EDX,[EDX+DivTable]1423 // Result.A := B.A + F.A - PB[F.A];1424 SHR EAX,81425 //ADD CL,al1426 ADD ECX,EAX1427 //SUB CL,[EDX+EAX]1428 SUB ECX,[EDX+EAX]1429 MOV [ESP+$0B],CL1430 // PR := @RcTable[Result.A];1431 SHL ECX,$081432 AND ECX,$0000FFFF1433 LEA ESI,[ECX+RcTable]1434 1435 { Red component }1436 1437 // Result.R := PB[B.R];1438 XOR EAX,EAX1439 MOV AL,[ESP+$06]1440 MOV CL,[EDX+EAX]1441 MOV [ESP+$0a],CL1442 // X := F.R - Result.R;1443 MOV AL,[ESP+$02]1444 XOR EBX,EBX1445 MOV BL,CL1446 SUB EAX,EBX1447 // if X >= 0 then1448 JL @51449 // Result.R := PR[PF[X] + Result.R]1450 MOVZX EAX,BYTE PTR[EDI+EAX]1451 AND ECX,$000000FF1452 ADD EAX,ECX1453 MOV AL,[ESI+EAX]1454 MOV [ESP+$0a],al1455 JMP @61456 @5:1457 // Result.R := PR[Result.R - PF[-X]];1458 NEG EAX1459 MOVZX EAX,BYTE PTR[EDI+EAX]1460 XOR ECX,ECX1461 MOV CL,[ESP+$0A]1462 SUB ECX,EAX1463 MOV AL,[ESI+ECX]1464 MOV [ESP+$0A],al1465 1466 1467 { Green component }1468 1469 @6:1470 // Result.G := PB[B.G];1471 XOR EAX,EAX1472 MOV AL,[ESP+$05]1473 MOV CL,[EDX+EAX]1474 MOV [ESP+$09],CL1475 // X := F.G - Result.G;1476 MOV AL,[ESP+$01]1477 XOR EBX,EBX1478 MOV BL,CL1479 SUB EAX,EBX1480 // if X >= 0 then1481 JL @71482 // Result.G := PR[PF[X] + Result.G]1483 MOVZX EAX,BYTE PTR[EDI+EAX]1484 AND ECX,$000000FF1485 ADD EAX,ECX1486 MOV AL,[ESI+EAX]1487 MOV [ESP+$09],AL1488 JMP @81489 @7:1490 // Result.G := PR[Result.G - PF[-X]];1491 NEG EAX1492 MOVZX EAX,BYTE PTR[EDI+EAX]1493 XOR ECX,ECX1494 MOV CL,[ESP+$09]1495 SUB ECX,EAX1496 MOV AL,[ESI+ECX]1497 MOV [ESP+$09],AL1498 1499 1500 { Blue component }1501 @8:1502 // Result.B := PB[B.B];1503 XOR EAX,EAX1504 MOV AL,[ESP+$04]1505 MOV CL,[EDX+EAX]1506 MOV [ESP+$08],CL1507 // X := F.B - Result.B;1508 MOV AL,[ESP]1509 XOR EDX,EDX1510 MOV DL,CL1511 SUB EAX,EDX1512 // if X >= 0 then1513 JL @91514 // Result.B := PR[PF[X] + Result.B]1515 MOVZX EAX,BYTE PTR[EDI+EAX]1516 XOR EDX,EDX1517 MOV DL,CL1518 ADD EAX,EDX1519 MOV AL,[ESI+EAX]1520 MOV [ESP+$08],al1521 JMP @101522 @9:1523 // Result.B := PR[Result.B - PF[-X]];1524 NEG EAX1525 MOVZX EAX,BYTE PTR[EDI+EAX]1526 XOR EDX,EDX1527 MOV DL,CL1528 SUB EDX,EAX1529 MOV AL,[ESI+EDX]1530 MOV [ESP+$08],AL1531 1532 @10:1533 // EAX <- Result1534 MOV EAX,[ESP+$08]1535 1536 // end;1537 ADD ESP,$0C1538 POP EDI1539 POP ESI1540 POP EBX1541 {$IFDEF FPC}1542 JMP @Exit1543 {$ELSE}1544 RET1545 {$ENDIF}1546 @blend:1547 CALL DWORD PTR [BlendReg]1548 OR EAX,$FF0000001549 {$IFDEF FPC}1550 JMP @Exit1551 {$ELSE}1552 RET1553 {$ENDIF}1554 @exit0:1555 MOV EAX,EDX1556 @Exit:1557 end;1558 1559 {$ENDIF}1560 1561 function CombineReg_ASM(X, Y, W: TColor32): TColor32;1562 asm1563 // combine RGBA channels of colors X and Y with the weight of X given in W1564 // Result Z = W * X + (1 - W) * Y (all channels are combined, including alpha)1565 {$IFDEF TARGET_x86}1566 // EAX <- X1567 // EDX <- Y1568 // ECX <- W1569 1570 // W = 0 or $FF?1571 JCXZ @1 // CX = 0 ? => Result := EDX1572 CMP ECX,$FF // CX = $FF ? => Result := EDX1573 JE @21574 1575 PUSH EBX1576 1577 // P = W * X1578 MOV EBX,EAX // EBX <- Xa Xr Xg Xb1579 AND EAX,$00FF00FF // EAX <- 00 Xr 00 Xb1580 AND EBX,$FF00FF00 // EBX <- Xa 00 Xg 001581 IMUL EAX,ECX // EAX <- Pr ** Pb **1582 SHR EBX,8 // EBX <- 00 Xa 00 Xg1583 IMUL EBX,ECX // EBX <- Pa ** Pg **1584 ADD EAX,bias1585 AND EAX,$FF00FF00 // EAX <- Pa 00 Pg 001586 SHR EAX,8 // EAX <- 00 Pr 00 Pb1587 ADD EBX,bias1588 AND EBX,$FF00FF00 // EBX <- Pa 00 Pg 001589 OR EAX,EBX // EAX <- Pa Pr Pg Pb1590 1591 // W = 1 - W; Q = W * Y1592 XOR ECX,$000000FF // ECX <- 1 - ECX1593 MOV EBX,EDX // EBX <- Ya Yr Yg Yb1594 AND EDX,$00FF00FF // EDX <- 00 Yr 00 Yb1595 AND EBX,$FF00FF00 // EBX <- Ya 00 Yg 001596 IMUL EDX,ECX // EDX <- Qr ** Qb **1597 SHR EBX,8 // EBX <- 00 Ya 00 Yg1598 IMUL EBX,ECX // EBX <- Qa ** Qg **1599 ADD EDX,bias1600 AND EDX,$FF00FF00 // EDX <- Qr 00 Qb 001601 SHR EDX,8 // EDX <- 00 Qr ** Qb1602 ADD EBX,bias1603 AND EBX,$FF00FF00 // EBX <- Qa 00 Qg 001604 OR EBX,EDX // EBX <- Qa Qr Qg Qb1605 1606 // Z = P + Q (assuming no overflow at each byte)1607 ADD EAX,EBX // EAX <- Za Zr Zg Zb1608 1609 POP EBX1610 {$IFDEF FPC}1611 JMP @21612 {$ELSE}1613 RET1614 {$ENDIF}1615 1616 @1: MOV EAX,EDX1617 @2:1618 {$ENDIF}1619 1620 {$IFDEF TARGET_x64}1621 // ECX <- X1622 // EDX <- Y1623 // R8D <- W1624 1625 // W = 0 or $FF?1626 TEST R8D,R8D1627 JZ @1 // W = 0 ? => Result := EDX1628 MOV EAX,ECX // EAX <- Xa Xr Xg Xb1629 CMP R8B,$FF // W = $FF ? => Result := EDX1630 JE @21631 1632 // P = W * X1633 AND EAX,$00FF00FF // EAX <- 00 Xr 00 Xb1634 AND ECX,$FF00FF00 // ECX <- Xa 00 Xg 001635 IMUL EAX,R8D // EAX <- Pr ** Pb **1636 SHR ECX,8 // ECX <- 00 Xa 00 Xg1637 IMUL ECX,R8D // ECX <- Pa ** Pg **1638 ADD EAX,bias1639 AND EAX,$FF00FF00 // EAX <- Pa 00 Pg 001640 SHR EAX,8 // EAX <- 00 Pr 00 Pb1641 ADD ECX,bias1642 AND ECX,$FF00FF00 // ECX <- Pa 00 Pg 001643 OR EAX,ECX // EAX <- Pa Pr Pg Pb1644 1645 // W = 1 - W; Q = W * Y1646 XOR R8D,$000000FF // R8D <- 1 - R8D1647 MOV ECX,EDX // ECX <- Ya Yr Yg Yb1648 AND EDX,$00FF00FF // EDX <- 00 Yr 00 Yb1649 AND ECX,$FF00FF00 // ECX <- Ya 00 Yg 001650 IMUL EDX,R8D // EDX <- Qr ** Qb **1651 SHR ECX,8 // ECX <- 00 Ya 00 Yg1652 IMUL ECX,R8D // ECX <- Qa ** Qg **1653 ADD EDX,bias1654 AND EDX,$FF00FF00 // EDX <- Qr 00 Qb 001655 SHR EDX,8 // EDX <- 00 Qr ** Qb1656 ADD ECX,bias1657 AND ECX,$FF00FF00 // ECX <- Qa 00 Qg 001658 OR ECX,EDX // ECX <- Qa Qr Qg Qb1659 1660 // Z = P + Q (assuming no overflow at each byte)1661 ADD EAX,ECX // EAX <- Za Zr Zg Zb1662 1663 {$IFDEF FPC}1664 JMP @21665 {$ELSE}1666 RET1667 {$ENDIF}1668 1669 @1: MOV EAX,EDX1670 @2:1671 {$ENDIF}1672 end;1673 1674 procedure CombineMem_ASM(X: TColor32; var Y: TColor32; W: TColor32);1675 asm1676 {$IFDEF TARGET_x86}1677 // EAX <- F1678 // [EDX] <- B1679 // ECX <- W1680 1681 // Check W1682 JCXZ @1 // W = 0 ? => write nothing1683 CMP ECX,$FF // W = 255? => write F1684 {$IFDEF FPC}1685 DB $74,$76 //Prob with FPC 2.2.2 and below1686 {$ELSE}1687 JZ @21688 {$ENDIF}1689 1690 1691 PUSH EBX1692 PUSH ESI1693 1694 // P = W * F1695 MOV EBX,EAX // EBX <- ** Fr Fg Fb1696 AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb1697 AND EBX,$FF00FF00 // EBX <- Fa 00 Fg 001698 IMUL EAX,ECX // EAX <- Pr ** Pb **1699 SHR EBX,8 // EBX <- 00 Fa 00 Fg1700 IMUL EBX,ECX // EBX <- 00 00 Pg **1701 ADD EAX,bias1702 AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 001703 SHR EAX,8 // EAX <- 00 Pr 00 Pb1704 ADD EBX,bias1705 AND EBX,$FF00FF00 // EBX <- Pa 00 Pg 001706 OR EAX,EBX // EAX <- 00 Pr Pg Pb1707 1708 // W = 1 - W; Q = W * B1709 MOV ESI,[EDX]1710 XOR ECX,$000000FF // ECX <- 1 - ECX1711 MOV EBX,ESI // EBX <- Ba Br Bg Bb1712 AND ESI,$00FF00FF // ESI <- 00 Br 00 Bb1713 AND EBX,$FF00FF00 // EBX <- Ba 00 Bg 001714 IMUL ESI,ECX // ESI <- Qr ** Qb **1715 SHR EBX,8 // EBX <- 00 Ba 00 Bg1716 IMUL EBX,ECX // EBX <- Qa 00 Qg **1717 ADD ESI,bias1718 AND ESI,$FF00FF00 // ESI <- Qr 00 Qb 001719 SHR ESI,8 // ESI <- 00 Qr ** Qb1720 ADD EBX,bias1721 AND EBX,$FF00FF00 // EBX <- Qa 00 Qg 001722 OR EBX,ESI // EBX <- 00 Qr Qg Qb1723 1724 // Z = P + Q (assuming no overflow at each byte)1725 ADD EAX,EBX // EAX <- 00 Zr Zg Zb1726 1727 MOV [EDX],EAX1728 1729 POP ESI1730 POP EBX1731 {$IFDEF FPC}1732 @1: JMP @31733 {$ELSE}1734 @1: RET1735 {$ENDIF}1736 1737 @2: MOV [EDX],EAX1738 @3:1739 {$ENDIF}1740 1741 {$IFDEF TARGET_x64}1742 // ECX <- F1743 // [RDX] <- B1744 // R8 <- W1745 1746 // Check W1747 TEST R8D,R8D // Set flags for R81748 JZ @2 // W = 0 ? => Result := EDX1749 MOV EAX,ECX // EAX <- ** Fr Fg Fb1750 CMP R8B,$FF // W = 255? => write F1751 JZ @11752 1753 // P = W * F1754 AND EAX,$00FF00FF // EAX <- 00 Fr 00 Fb1755 AND ECX,$FF00FF00 // ECX <- Fa 00 Fg 001756 IMUL EAX,R8D // EAX <- Pr ** Pb **1757 SHR ECX,8 // ECX <- 00 Fa 00 Fg1758 IMUL ECX,R8D // ECX <- 00 00 Pg **1759 ADD EAX,bias1760 AND EAX,$FF00FF00 // EAX <- Pr 00 Pb 001761 SHR EAX,8 // EAX <- 00 Pr 00 Pb1762 ADD ECX,bias1763 AND ECX,$FF00FF00 // ECX <- Pa 00 Pg 001764 OR EAX,ECX // EAX <- 00 Pr Pg Pb1765 1766 // W = 1 - W; Q = W * B1767 MOV R9D,[RDX]1768 XOR R8D,$000000FF // R8D <- 1 - R8D1769 MOV ECX,R9D // ECX <- Ba Br Bg Bb1770 AND R9D,$00FF00FF // R9D <- 00 Br 00 Bb1771 AND ECX,$FF00FF00 // ECX <- Ba 00 Bg 001772 IMUL R9D,R8D // R9D <- Qr ** Qb **1773 SHR ECX,8 // ECX <- 00 Ba 00 Bg1774 IMUL ECX,R8D // ECX <- Qa 00 Qg **1775 ADD R9D,bias1776 AND R9D,$FF00FF00 // R9D <- Qr 00 Qb 001777 SHR R9D,8 // R9D <- 00 Qr ** Qb1778 ADD ECX,bias1779 AND ECX,$FF00FF00 // ECX <- Qa 00 Qg 001780 OR ECX,R9D // ECX <- 00 Qr Qg Qb1781 1782 // Z = P + Q (assuming no overflow at each byte)1783 ADD EAX,ECX // EAX <- 00 Zr Zg Zb1784 1785 @1: MOV [RDX],EAX1786 @2:1787 1788 {$ENDIF}1789 end;1790 1791 procedure EMMS_ASM;1792 asm1793 end;1794 859 1795 860 procedure GenAlphaTable; … … 1830 895 FreeMem(AlphaTable); 1831 896 end; 1832 1833 {$IFNDEF OMIT_MMX}1834 1835 { MMX versions }1836 1837 function BlendReg_MMX(F, B: TColor32): TColor32;1838 asm1839 // blend foreground color (F) to a background color (B),1840 // using alpha channel value of F1841 {$IFDEF TARGET_x86}1842 // EAX <- F1843 // EDX <- B1844 // Result := Fa * (Frgb - Brgb) + Brgb1845 MOVD MM0,EAX1846 PXOR MM3,MM31847 MOVD MM2,EDX1848 PUNPCKLBW MM0,MM31849 MOV ECX,bias_ptr1850 PUNPCKLBW MM2,MM31851 MOVQ MM1,MM01852 PUNPCKHWD MM1,MM11853 PSUBW MM0,MM21854 PUNPCKHDQ MM1,MM11855 PSLLW MM2,81856 PMULLW MM0,MM11857 PADDW MM2,[ECX]1858 PADDW MM2,MM01859 PSRLW MM2,81860 PACKUSWB MM2,MM31861 MOVD EAX,MM21862 {$ENDIF}1863 1864 {$IFDEF TARGET_x64}1865 // ECX <- F1866 // EDX <- B1867 // Result := Fa * (Frgb - Brgb) + Brgb1868 MOVD MM0,ECX1869 PXOR MM3,MM31870 MOVD MM2,EDX1871 PUNPCKLBW MM0,MM31872 MOV RAX,bias_ptr1873 PUNPCKLBW MM2,MM31874 MOVQ MM1,MM01875 PUNPCKHWD MM1,MM11876 PSUBW MM0,MM21877 PUNPCKHDQ MM1,MM11878 PSLLW MM2,81879 PMULLW MM0,MM11880 PADDW MM2,[RAX]1881 PADDW MM2,MM01882 PSRLW MM2,81883 PACKUSWB MM2,MM31884 MOVD EAX,MM21885 {$ENDIF}1886 end;1887 1888 {$IFDEF TARGET_x86}1889 1890 procedure BlendMem_MMX(F: TColor32; var B: TColor32);1891 asm1892 // EAX - Color X1893 // [EDX] - Color Y1894 // Result := W * (X - Y) + Y1895 1896 TEST EAX,$FF0000001897 JZ @11898 CMP EAX,$FF0000001899 JNC @21900 1901 PXOR MM3,MM31902 MOVD MM0,EAX1903 MOVD MM2,[EDX]1904 PUNPCKLBW MM0,MM31905 MOV ECX,bias_ptr1906 PUNPCKLBW MM2,MM31907 MOVQ MM1,MM01908 PUNPCKHWD MM1,MM11909 PSUBW MM0,MM21910 PUNPCKHDQ MM1,MM11911 PSLLW MM2,81912 PMULLW MM0,MM11913 PADDW MM2,[ECX]1914 PADDW MM2,MM01915 PSRLW MM2,81916 PACKUSWB MM2,MM31917 MOVD [EDX],MM21918 1919 {$IFDEF FPC}1920 @1: JMP @31921 {$ELSE}1922 @1: RET1923 {$ENDIF}1924 1925 @2: MOV [EDX],EAX1926 @3:1927 end;1928 1929 function BlendRegEx_MMX(F, B, M: TColor32): TColor32;1930 asm1931 // blend foreground color (F) to a background color (B),1932 // using alpha channel value of F1933 // EAX <- F1934 // EDX <- B1935 // ECX <- M1936 // Result := M * Fa * (Frgb - Brgb) + Brgb1937 PUSH EBX1938 MOV EBX,EAX1939 SHR EBX,241940 INC ECX // 255:256 range bias1941 IMUL ECX,EBX1942 SHR ECX,81943 JZ @11944 1945 PXOR MM0,MM01946 MOVD MM1,EAX1947 SHL ECX,41948 MOVD MM2,EDX1949 PUNPCKLBW MM1,MM01950 PUNPCKLBW MM2,MM01951 ADD ECX,alpha_ptr1952 PSUBW MM1,MM21953 PMULLW MM1,[ECX]1954 PSLLW MM2,81955 MOV ECX,bias_ptr1956 PADDW MM2,[ECX]1957 PADDW MM1,MM21958 PSRLW MM1,81959 PACKUSWB MM1,MM01960 MOVD EAX,MM11961 1962 POP EBX1963 {$IFDEF FPC}1964 JMP @21965 {$ELSE}1966 RET1967 {$ENDIF}1968 1969 @1: MOV EAX,EDX1970 POP EBX1971 @2:1972 end;1973 1974 {$ENDIF}1975 1976 procedure BlendMemEx_MMX(F: TColor32; var B:TColor32; M: TColor32);1977 asm1978 {$IFDEF TARGET_x86}1979 // blend foreground color (F) to a background color (B),1980 // using alpha channel value of F1981 // EAX <- F1982 // [EDX] <- B1983 // ECX <- M1984 // Result := M * Fa * (Frgb - Brgb) + Brgb1985 TEST EAX,$FF0000001986 JZ @21987 1988 PUSH EBX1989 MOV EBX,EAX1990 SHR EBX,241991 INC ECX // 255:256 range bias1992 IMUL ECX,EBX1993 SHR ECX,81994 JZ @11995 1996 PXOR MM0,MM01997 MOVD MM1,EAX1998 SHL ECX,41999 MOVD MM2,[EDX]2000 PUNPCKLBW MM1,MM02001 PUNPCKLBW MM2,MM02002 ADD ECX,alpha_ptr2003 PSUBW MM1,MM22004 PMULLW MM1,[ECX]2005 PSLLW MM2,82006 MOV ECX,bias_ptr2007 PADDW MM2,[ECX]2008 PADDW MM1,MM22009 PSRLW MM1,82010 PACKUSWB MM1,MM02011 MOVD [EDX],MM12012 2013 @1: POP EBX2014 2015 @2:2016 {$ENDIF}2017 2018 {$IFDEF TARGET_x64}2019 // blend foreground color (F) to a background color (B),2020 // using alpha channel value of F2021 // ECX <- F2022 // [EDX] <- B2023 // R8 <- M2024 // Result := M * Fa * (Frgb - Brgb) + Brgb2025 TEST ECX,$FF0000002026 JZ @12027 2028 MOV EAX,ECX2029 SHR EAX,242030 INC R8D // 255:256 range bias2031 IMUL R8D,EAX2032 SHR R8D,82033 JZ @12034 2035 PXOR MM0,MM02036 MOVD MM1,ECX2037 SHL R8D,42038 MOVD MM2,[RDX]2039 PUNPCKLBW MM1,MM02040 PUNPCKLBW MM2,MM02041 ADD R8,alpha_ptr2042 PSUBW MM1,MM22043 PMULLW MM1,[R8]2044 PSLLW MM2,82045 MOV RAX,bias_ptr2046 PADDW MM2,[RAX]2047 PADDW MM1,MM22048 PSRLW MM1,82049 PACKUSWB MM1,MM02050 MOVD [RDX],MM12051 2052 @1:2053 {$ENDIF}2054 end;2055 2056 {$IFDEF TARGET_x86}2057 procedure BlendLine_MMX(Src, Dst: PColor32; Count: Integer);2058 asm2059 // EAX <- Src2060 // EDX <- Dst2061 // ECX <- Count2062 2063 // test the counter for zero or negativity2064 TEST ECX,ECX2065 JS @42066 2067 PUSH ESI2068 PUSH EDI2069 2070 MOV ESI,EAX // ESI <- Src2071 MOV EDI,EDX // EDI <- Dst2072 2073 // loop start2074 @1: MOV EAX,[ESI]2075 TEST EAX,$FF0000002076 JZ @3 // complete transparency, proceed to next point2077 CMP EAX,$FF0000002078 JNC @2 // opaque pixel, copy without blending2079 2080 // blend2081 MOVD MM0,EAX // MM0 <- 00 00 00 00 Fa Fr Fg Fb2082 PXOR MM3,MM3 // MM3 <- 00 00 00 00 00 00 00 002083 MOVD MM2,[EDI] // MM2 <- 00 00 00 00 Ba Br Bg Bb2084 PUNPCKLBW MM0,MM3 // MM0 <- 00 Fa 00 Fr 00 Fg 00 Fb2085 MOV EAX,bias_ptr2086 PUNPCKLBW MM2,MM3 // MM2 <- 00 Ba 00 Br 00 Bg 00 Bb2087 MOVQ MM1,MM0 // MM1 <- 00 Fa 00 Fr 00 Fg 00 Fb2088 PUNPCKHWD MM1,MM1 // MM1 <- 00 Fa 00 Fa 00 ** 00 **2089 PSUBW MM0,MM2 // MM0 <- 00 Da 00 Dr 00 Dg 00 Db2090 PUNPCKHDQ MM1,MM1 // MM1 <- 00 Fa 00 Fa 00 Fa 00 Fa2091 PSLLW MM2,8 // MM2 <- Ba 00 Br 00 Bg 00 Bb 002092 PMULLW MM0,MM1 // MM2 <- Pa ** Pr ** Pg ** Pb **2093 PADDW MM2,[EAX] // add bias2094 PADDW MM2,MM0 // MM2 <- Qa ** Qr ** Qg ** Qb **2095 PSRLW MM2,8 // MM2 <- 00 Qa 00 Qr 00 Qg 00 Qb2096 PACKUSWB MM2,MM3 // MM2 <- 00 00 00 00 Qa Qr Qg Qb2097 MOVD EAX,MM22098 2099 @2: MOV [EDI],EAX2100 2101 @3: ADD ESI,42102 ADD EDI,42103 2104 // loop end2105 DEC ECX2106 JNZ @12107 2108 POP EDI2109 POP ESI2110 2111 @4:2112 end;2113 2114 procedure BlendLineEx_MMX(Src, Dst: PColor32; Count: Integer; M: TColor32);2115 asm2116 // EAX <- Src2117 // EDX <- Dst2118 // ECX <- Count2119 2120 // test the counter for zero or negativity2121 TEST ECX,ECX2122 JS @42123 2124 PUSH ESI2125 PUSH EDI2126 PUSH EBX2127 2128 MOV ESI,EAX // ESI <- Src2129 MOV EDI,EDX // EDI <- Dst2130 MOV EDX,M // EDX <- Master Alpha2131 2132 // loop start2133 @1: MOV EAX,[ESI]2134 TEST EAX,$FF0000002135 JZ @3 // complete transparency, proceed to next point2136 MOV EBX,EAX2137 SHR EBX,242138 INC EBX // 255:256 range bias2139 IMUL EBX,EDX2140 SHR EBX,82141 JZ @3 // complete transparency, proceed to next point2142 2143 // blend2144 PXOR MM0,MM02145 MOVD MM1,EAX2146 SHL EBX,42147 MOVD MM2,[EDI]2148 PUNPCKLBW MM1,MM02149 PUNPCKLBW MM2,MM02150 ADD EBX,alpha_ptr2151 PSUBW MM1,MM22152 PMULLW MM1,[EBX]2153 PSLLW MM2,82154 MOV EBX,bias_ptr2155 PADDW MM2,[EBX]2156 PADDW MM1,MM22157 PSRLW MM1,82158 PACKUSWB MM1,MM02159 MOVD EAX,MM12160 2161 @2: MOV [EDI],EAX2162 2163 @3: ADD ESI,42164 ADD EDI,42165 2166 // loop end2167 DEC ECX2168 JNZ @12169 2170 POP EBX2171 POP EDI2172 POP ESI2173 @4:2174 end;2175 2176 {$ENDIF}2177 2178 function CombineReg_MMX(X, Y, W: TColor32): TColor32;2179 asm2180 {$IFDEF TARGET_X86}2181 // EAX - Color X2182 // EDX - Color Y2183 // ECX - Weight of X [0..255]2184 // Result := W * (X - Y) + Y2185 2186 MOVD MM1,EAX2187 PXOR MM0,MM02188 SHL ECX,42189 2190 MOVD MM2,EDX2191 PUNPCKLBW MM1,MM02192 PUNPCKLBW MM2,MM02193 2194 ADD ECX,alpha_ptr2195 2196 PSUBW MM1,MM22197 PMULLW MM1,[ECX]2198 PSLLW MM2,82199 2200 MOV ECX,bias_ptr2201 2202 PADDW MM2,[ECX]2203 PADDW MM1,MM22204 PSRLW MM1,82205 PACKUSWB MM1,MM02206 MOVD EAX,MM12207 {$ENDIF}2208 2209 {$IFDEF TARGET_X64}2210 // ECX - Color X2211 // EDX - Color Y2212 // R8 - Weight of X [0..255]2213 // Result := W * (X - Y) + Y2214 2215 MOVD MM1,ECX2216 PXOR MM0,MM02217 SHL R8D,42218 2219 MOVD MM2,EDX2220 PUNPCKLBW MM1,MM02221 PUNPCKLBW MM2,MM02222 2223 ADD R8,alpha_ptr2224 2225 PSUBW MM1,MM22226 PMULLW MM1,[R8]2227 PSLLW MM2,82228 2229 MOV RAX,bias_ptr2230 2231 PADDW MM2,[RAX]2232 PADDW MM1,MM22233 PSRLW MM1,82234 PACKUSWB MM1,MM02235 MOVD EAX,MM12236 {$ENDIF}2237 end;2238 2239 procedure CombineMem_MMX(F: TColor32; var B: TColor32; W: TColor32);2240 asm2241 {$IFDEF TARGET_X86}2242 // EAX - Color X2243 // [EDX] - Color Y2244 // ECX - Weight of X [0..255]2245 // Result := W * (X - Y) + Y2246 2247 JCXZ @12248 CMP ECX,$FF2249 JZ @22250 2251 MOVD MM1,EAX2252 PXOR MM0,MM02253 2254 SHL ECX,42255 2256 MOVD MM2,[EDX]2257 PUNPCKLBW MM1,MM02258 PUNPCKLBW MM2,MM02259 2260 ADD ECX,alpha_ptr2261 2262 PSUBW MM1,MM22263 PMULLW MM1,[ECX]2264 PSLLW MM2,82265 2266 MOV ECX,bias_ptr2267 2268 PADDW MM2,[ECX]2269 PADDW MM1,MM22270 PSRLW MM1,82271 PACKUSWB MM1,MM02272 MOVD [EDX],MM12273 2274 {$IFDEF FPC}2275 @1: JMP @32276 {$ELSE}2277 @1: RET2278 {$ENDIF}2279 2280 @2: MOV [EDX],EAX2281 @3:2282 {$ENDIF}2283 2284 {$IFDEF TARGET_x64}2285 // ECX - Color X2286 // [RDX] - Color Y2287 // R8 - Weight of X [0..255]2288 // Result := W * (X - Y) + Y2289 2290 TEST R8D,R8D // Set flags for R82291 JZ @1 // W = 0 ? => Result := EDX2292 CMP R8D,$FF2293 JZ @22294 2295 MOVD MM1,ECX2296 PXOR MM0,MM02297 2298 SHL R8D,42299 2300 MOVD MM2,[RDX]2301 PUNPCKLBW MM1,MM02302 PUNPCKLBW MM2,MM02303 2304 ADD R8,alpha_ptr2305 2306 PSUBW MM1,MM22307 PMULLW MM1,[R8]2308 PSLLW MM2,82309 2310 MOV RAX,bias_ptr2311 2312 PADDW MM2,[RAX]2313 PADDW MM1,MM22314 PSRLW MM1,82315 PACKUSWB MM1,MM02316 MOVD [RDX],MM12317 2318 {$IFDEF FPC}2319 @1: JMP @32320 {$ELSE}2321 @1: RET2322 {$ENDIF}2323 2324 @2: MOV [RDX],RCX2325 @3:2326 {$ENDIF}2327 end;2328 2329 {$IFDEF TARGET_x86}2330 2331 procedure CombineLine_MMX(Src, Dst: PColor32; Count: Integer; W: TColor32);2332 asm2333 // EAX <- Src2334 // EDX <- Dst2335 // ECX <- Count2336 2337 // Result := W * (X - Y) + Y2338 2339 TEST ECX,ECX2340 JS @32341 2342 PUSH EBX2343 MOV EBX,W2344 2345 TEST EBX,EBX2346 JZ @2 // weight is zero2347 2348 CMP EBX,$FF2349 JZ @4 // weight = 255 => copy src to dst2350 2351 SHL EBX,42352 ADD EBX,alpha_ptr2353 MOVQ MM3,[EBX]2354 MOV EBX,bias_ptr2355 MOVQ MM4,[EBX]2356 2357 // loop start2358 @1: MOVD MM1,[EAX]2359 PXOR MM0,MM02360 MOVD MM2,[EDX]2361 PUNPCKLBW MM1,MM02362 PUNPCKLBW MM2,MM02363 2364 PSUBW MM1,MM22365 PMULLW MM1,MM32366 PSLLW MM2,82367 2368 PADDW MM2,MM42369 PADDW MM1,MM22370 PSRLW MM1,82371 PACKUSWB MM1,MM02372 MOVD [EDX],MM12373 2374 ADD EAX,42375 ADD EDX,42376 2377 DEC ECX2378 JNZ @12379 @2: POP EBX2380 POP EBP2381 @3: RET $00042382 2383 @4: CALL GR32_LowLevel.MoveLongword2384 POP EBX2385 end;2386 2387 {$ENDIF}2388 2389 procedure EMMS_MMX;2390 asm2391 EMMS2392 end;2393 2394 function LightenReg_MMX(C: TColor32; Amount: Integer): TColor32;2395 asm2396 {$IFDEF TARGET_X86}2397 MOVD MM0,EAX2398 TEST EDX,EDX2399 JL @12400 IMUL EDX,$0101012401 MOVD MM1,EDX2402 PADDUSB MM0,MM12403 MOVD EAX,MM02404 RET2405 @1: NEG EDX2406 IMUL EDX,$0101012407 MOVD MM1,EDX2408 PSUBUSB MM0,MM12409 MOVD EAX,MM02410 {$ENDIF}2411 2412 {$IFDEF TARGET_X64}2413 MOVD MM0,ECX2414 TEST EDX,EDX2415 JL @12416 IMUL EDX,$0101012417 MOVD MM1,EDX2418 PADDUSB MM0,MM12419 MOVD EAX,MM02420 RET2421 @1: NEG EDX2422 IMUL EDX,$0101012423 MOVD MM1,EDX2424 PSUBUSB MM0,MM12425 MOVD EAX,MM02426 {$ENDIF}2427 end;2428 2429 { MMX Color algebra versions }2430 2431 function ColorAdd_MMX(C1, C2: TColor32): TColor32;2432 asm2433 {$IFDEF TARGET_X86}2434 MOVD MM0,EAX2435 MOVD MM1,EDX2436 PADDUSB MM0,MM12437 MOVD EAX,MM02438 {$ENDIF}2439 2440 {$IFDEF TARGET_X64}2441 MOVD MM0,ECX2442 MOVD MM1,EDX2443 PADDUSB MM0,MM12444 MOVD EAX,MM02445 {$ENDIF}2446 end;2447 2448 function ColorSub_MMX(C1, C2: TColor32): TColor32;2449 asm2450 {$IFDEF TARGET_X86}2451 MOVD MM0,EAX2452 MOVD MM1,EDX2453 PSUBUSB MM0,MM12454 MOVD EAX,MM02455 {$ENDIF}2456 2457 {$IFDEF TARGET_X64}2458 MOVD MM0,ECX2459 MOVD MM1,EDX2460 PSUBUSB MM0,MM12461 MOVD EAX,MM02462 {$ENDIF}2463 end;2464 2465 function ColorModulate_MMX(C1, C2: TColor32): TColor32;2466 asm2467 {$IFDEF TARGET_X86}2468 PXOR MM2,MM22469 MOVD MM0,EAX2470 PUNPCKLBW MM0,MM22471 MOVD MM1,EDX2472 PUNPCKLBW MM1,MM22473 PMULLW MM0,MM12474 PSRLW MM0,82475 PACKUSWB MM0,MM22476 MOVD EAX,MM02477 {$ENDIF}2478 2479 {$IFDEF TARGET_X64}2480 PXOR MM2,MM22481 MOVD MM0,ECX2482 PUNPCKLBW MM0,MM22483 MOVD MM1,EDX2484 PUNPCKLBW MM1,MM22485 PMULLW MM0,MM12486 PSRLW MM0,82487 PACKUSWB MM0,MM22488 MOVD EAX,MM02489 {$ENDIF}2490 end;2491 2492 function ColorMax_EMMX(C1, C2: TColor32): TColor32;2493 asm2494 {$IFDEF TARGET_X86}2495 MOVD MM0,EAX2496 MOVD MM1,EDX2497 PMAXUB MM0,MM12498 MOVD EAX,MM02499 {$ENDIF}2500 2501 {$IFDEF TARGET_X64}2502 MOVD MM0,ECX2503 MOVD MM1,EDX2504 PMAXUB MM0,MM12505 MOVD EAX,MM02506 {$ENDIF}2507 end;2508 2509 function ColorMin_EMMX(C1, C2: TColor32): TColor32;2510 asm2511 {$IFDEF TARGET_X86}2512 MOVD MM0,EAX2513 MOVD MM1,EDX2514 PMINUB MM0,MM12515 MOVD EAX,MM02516 {$ENDIF}2517 2518 {$IFDEF TARGET_X64}2519 MOVD MM0,ECX2520 MOVD MM1,EDX2521 PMINUB MM0,MM12522 MOVD EAX,MM02523 {$ENDIF}2524 end;2525 2526 function ColorDifference_MMX(C1, C2: TColor32): TColor32;2527 asm2528 {$IFDEF TARGET_X86}2529 MOVD MM0,EAX2530 MOVD MM1,EDX2531 MOVQ MM2,MM02532 PSUBUSB MM0,MM12533 PSUBUSB MM1,MM22534 POR MM0,MM12535 MOVD EAX,MM02536 {$ENDIF}2537 2538 {$IFDEF TARGET_X64}2539 MOVD MM0,ECX2540 MOVD MM1,EDX2541 MOVQ MM2,MM02542 PSUBUSB MM0,MM12543 PSUBUSB MM1,MM22544 POR MM0,MM12545 MOVD EAX,MM02546 {$ENDIF}2547 end;2548 2549 function ColorExclusion_MMX(C1, C2: TColor32): TColor32;2550 asm2551 {$IFDEF TARGET_X86}2552 PXOR MM2,MM22553 MOVD MM0,EAX2554 PUNPCKLBW MM0,MM22555 MOVD MM1,EDX2556 PUNPCKLBW MM1,MM22557 MOVQ MM3,MM02558 PADDW MM0,MM12559 PMULLW MM1,MM32560 PSRLW MM1,72561 PSUBUSW MM0,MM12562 PACKUSWB MM0,MM22563 MOVD EAX,MM02564 {$ENDIF}2565 2566 {$IFDEF TARGET_X64}2567 PXOR MM2,MM22568 MOVD MM0,ECX2569 PUNPCKLBW MM0,MM22570 MOVD MM1,EDX2571 PUNPCKLBW MM1,MM22572 MOVQ MM3,MM02573 PADDW MM0,MM12574 PMULLW MM1,MM32575 PSRLW MM1,72576 PSUBUSW MM0,MM12577 PACKUSWB MM0,MM22578 MOVD EAX,MM02579 {$ENDIF}2580 end;2581 2582 function ColorScale_MMX(C, W: TColor32): TColor32;2583 asm2584 {$IFDEF TARGET_X86}2585 PXOR MM2,MM22586 SHL EDX,42587 MOVD MM0,EAX2588 PUNPCKLBW MM0,MM22589 ADD EDX,alpha_ptr2590 PMULLW MM0,[EDX]2591 PSRLW MM0,82592 PACKUSWB MM0,MM22593 MOVD EAX,MM02594 {$ENDIF}2595 2596 {$IFDEF TARGET_X64}2597 PXOR MM2,MM22598 SHL RDX,42599 MOVD MM0,ECX2600 PUNPCKLBW MM0,MM22601 ADD RDX,alpha_ptr2602 PMULLW MM0,[RDX]2603 PSRLW MM0,82604 PACKUSWB MM0,MM22605 MOVD EAX,MM02606 {$ENDIF}2607 end;2608 {$ENDIF}2609 2610 2611 { SSE2 versions }2612 2613 {$IFNDEF OMIT_SSE2}2614 2615 function BlendReg_SSE2(F, B: TColor32): TColor32;2616 asm2617 // blend foreground color (F) to a background color (B),2618 // using alpha channel value of F2619 // EAX <- F2620 // EDX <- B2621 // Result := Fa * (Frgb - Brgb) + Brgb2622 2623 {$IFDEF TARGET_x86}2624 MOVD XMM0,EAX2625 PXOR XMM3,XMM32626 MOVD XMM2,EDX2627 PUNPCKLBW XMM0,XMM32628 MOV ECX,bias_ptr2629 PUNPCKLBW XMM2,XMM32630 MOVQ XMM1,XMM02631 PSHUFLW XMM1,XMM1, $FF2632 PSUBW XMM0,XMM22633 PSLLW XMM2,82634 PMULLW XMM0,XMM12635 PADDW XMM2,[ECX]2636 PADDW XMM2,XMM02637 PSRLW XMM2,82638 PACKUSWB XMM2,XMM32639 MOVD EAX,XMM22640 {$ENDIF}2641 2642 {$IFDEF TARGET_x64}2643 MOVD XMM0,ECX2644 PXOR XMM3,XMM32645 MOVD XMM2,EDX2646 PUNPCKLBW XMM0,XMM32647 MOV RAX,bias_ptr2648 PUNPCKLBW XMM2,XMM32649 MOVQ XMM1,XMM02650 PSHUFLW XMM1,XMM1, $FF2651 PSUBW XMM0,XMM22652 PSLLW XMM2,82653 PMULLW XMM0,XMM12654 PADDW XMM2,[RAX]2655 PADDW XMM2,XMM02656 PSRLW XMM2,82657 PACKUSWB XMM2,XMM32658 MOVD EAX,XMM22659 {$ENDIF}2660 end;2661 2662 procedure BlendMem_SSE2(F: TColor32; var B: TColor32);2663 asm2664 {$IFDEF TARGET_x86}2665 // EAX - Color X2666 // [EDX] - Color Y2667 // Result := W * (X - Y) + Y2668 2669 TEST EAX,$FF0000002670 JZ @12671 CMP EAX,$FF0000002672 JNC @22673 2674 PXOR XMM3,XMM32675 MOVD XMM0,EAX2676 MOVD XMM2,[EDX]2677 PUNPCKLBW XMM0,XMM32678 MOV ECX,bias_ptr2679 PUNPCKLBW XMM2,XMM32680 MOVQ XMM1,XMM02681 PSHUFLW XMM1,XMM1, $FF2682 PSUBW XMM0,XMM22683 PSLLW XMM2,82684 PMULLW XMM0,XMM12685 PADDW XMM2,[ECX]2686 PADDW XMM2,XMM02687 PSRLW XMM2,82688 PACKUSWB XMM2,XMM32689 MOVD [EDX],XMM22690 2691 {$IFDEF FPC}2692 @1: JMP @32693 {$ELSE}2694 @1: RET2695 {$ENDIF}2696 2697 @2: MOV [EDX], EAX2698 @3:2699 {$ENDIF}2700 2701 {$IFDEF TARGET_x64}2702 // ECX - Color X2703 // [EDX] - Color Y2704 // Result := W * (X - Y) + Y2705 2706 TEST ECX,$FF0000002707 JZ @12708 CMP ECX,$FF0000002709 JNC @22710 2711 PXOR XMM3,XMM32712 MOVD XMM0,ECX2713 MOVD XMM2,[RDX]2714 PUNPCKLBW XMM0,XMM32715 MOV RAX,bias_ptr2716 PUNPCKLBW XMM2,XMM32717 MOVQ XMM1,XMM02718 PSHUFLW XMM1,XMM1, $FF2719 PSUBW XMM0,XMM22720 PSLLW XMM2,82721 PMULLW XMM0,XMM12722 PADDW XMM2,[RAX]2723 PADDW XMM2,XMM02724 PSRLW XMM2,82725 PACKUSWB XMM2,XMM32726 MOVD [RDX],XMM22727 2728 {$IFDEF FPC}2729 @1: JMP @32730 {$ELSE}2731 @1: RET2732 {$ENDIF}2733 2734 @2: MOV [RDX], ECX2735 @3:2736 {$ENDIF}2737 end;2738 2739 function BlendRegEx_SSE2(F, B, M: TColor32): TColor32;2740 asm2741 // blend foreground color (F) to a background color (B),2742 // using alpha channel value of F2743 // Result := M * Fa * (Frgb - Brgb) + Brgb2744 2745 {$IFDEF TARGET_x86}2746 // EAX <- F2747 // EDX <- B2748 // ECX <- M2749 PUSH EBX2750 MOV EBX,EAX2751 SHR EBX,242752 INC ECX // 255:256 range bias2753 IMUL ECX,EBX2754 SHR ECX,82755 JZ @12756 2757 PXOR XMM0,XMM02758 MOVD XMM1,EAX2759 SHL ECX,42760 MOVD XMM2,EDX2761 PUNPCKLBW XMM1,XMM02762 PUNPCKLBW XMM2,XMM02763 ADD ECX,alpha_ptr2764 PSUBW XMM1,XMM22765 PMULLW XMM1,[ECX]2766 PSLLW XMM2,82767 MOV ECX,bias_ptr2768 PADDW XMM2,[ECX]2769 PADDW XMM1,XMM22770 PSRLW XMM1,82771 PACKUSWB XMM1,XMM02772 MOVD EAX,XMM12773 2774 POP EBX2775 {$IFDEF FPC}2776 JMP @22777 {$ELSE}2778 RET2779 {$ENDIF}2780 2781 @1: MOV EAX,EDX2782 POP EBX2783 @2:2784 {$ENDIF}2785 2786 {$IFDEF TARGET_x64}2787 // ECX <- F2788 // EDX <- B2789 // R8D <- M2790 2791 MOV EAX,ECX2792 SHR EAX,242793 INC R8D // 255:256 range bias2794 IMUL R8D,EAX2795 SHR R8D,82796 JZ @12797 2798 PXOR XMM0,XMM02799 MOVD XMM1,ECX2800 SHL R8D,42801 MOVD XMM2,EDX2802 PUNPCKLBW XMM1,XMM02803 PUNPCKLBW XMM2,XMM02804 ADD R8,alpha_ptr2805 PSUBW XMM1,XMM22806 PMULLW XMM1,[R8]2807 PSLLW XMM2,82808 MOV R8,bias_ptr2809 PADDW XMM2,[R8]2810 PADDW XMM1,XMM22811 PSRLW XMM1,82812 PACKUSWB XMM1,XMM02813 MOVD EAX,XMM12814 {$IFDEF FPC}2815 JMP @22816 {$ELSE}2817 RET2818 {$ENDIF}2819 2820 @1: MOV EAX,EDX2821 @2:2822 {$ENDIF}2823 end;2824 2825 procedure BlendMemEx_SSE2(F: TColor32; var B:TColor32; M: TColor32);2826 asm2827 {$IFDEF TARGET_x86}2828 // blend foreground color (F) to a background color (B),2829 // using alpha channel value of F2830 // EAX <- F2831 // [EDX] <- B2832 // ECX <- M2833 // Result := M * Fa * (Frgb - Brgb) + Brgb2834 TEST EAX,$FF0000002835 JZ @22836 2837 PUSH EBX2838 MOV EBX,EAX2839 SHR EBX,242840 INC ECX // 255:256 range bias2841 IMUL ECX,EBX2842 SHR ECX,82843 JZ @12844 2845 PXOR XMM0,XMM02846 MOVD XMM1,EAX2847 SHL ECX,42848 MOVD XMM2,[EDX]2849 PUNPCKLBW XMM1,XMM02850 PUNPCKLBW XMM2,XMM02851 ADD ECX,alpha_ptr2852 PSUBW XMM1,XMM22853 PMULLW XMM1,[ECX]2854 PSLLW XMM2,82855 MOV ECX,bias_ptr2856 PADDW XMM2,[ECX]2857 PADDW XMM1,XMM22858 PSRLW XMM1,82859 PACKUSWB XMM1,XMM02860 MOVD [EDX],XMM12861 2862 @1:2863 POP EBX2864 2865 @2:2866 {$ENDIF}2867 2868 {$IFDEF TARGET_x64}2869 // blend foreground color (F) to a background color (B),2870 // using alpha channel value of F2871 // RCX <- F2872 // [RDX] <- B2873 // R8 <- M2874 // Result := M * Fa * (Frgb - Brgb) + Brgb2875 2876 TEST ECX, $FF0000002877 JZ @12878 2879 MOV R9D,ECX2880 SHR R9D,242881 INC R8D // 255:256 range bias2882 IMUL R8D,R9D2883 SHR R8D,82884 JZ @12885 2886 PXOR XMM0,XMM02887 MOVD XMM1,ECX2888 SHL R8D,42889 MOVD XMM2,[RDX]2890 PUNPCKLBW XMM1,XMM02891 PUNPCKLBW XMM2,XMM02892 ADD R8,alpha_ptr2893 PSUBW XMM1,XMM22894 PMULLW XMM1,[R8]2895 PSLLW XMM2,82896 MOV R8,bias_ptr2897 PADDW XMM2,[R8]2898 PADDW XMM1,XMM22899 PSRLW XMM1,82900 PACKUSWB XMM1,XMM02901 MOVD DWORD PTR [RDX],XMM12902 @1:2903 {$ENDIF}2904 end;2905 2906 procedure BlendLine_SSE2(Src, Dst: PColor32; Count: Integer);2907 asm2908 {$IFDEF TARGET_X86}2909 // EAX <- Src2910 // EDX <- Dst2911 // ECX <- Count2912 2913 TEST ECX,ECX2914 JZ @42915 2916 PUSH EBX2917 2918 MOV EBX,EAX2919 2920 @1: MOV EAX,[EBX]2921 TEST EAX,$FF0000002922 JZ @32923 CMP EAX,$FF0000002924 JNC @22925 2926 MOVD XMM0,EAX2927 PXOR XMM3,XMM32928 MOVD XMM2,[EDX]2929 PUNPCKLBW XMM0,XMM32930 MOV EAX,bias_ptr2931 PUNPCKLBW XMM2,XMM32932 MOVQ XMM1,XMM02933 PUNPCKLBW XMM1,XMM32934 PUNPCKHWD XMM1,XMM12935 PSUBW XMM0,XMM22936 PUNPCKHDQ XMM1,XMM12937 PSLLW XMM2,82938 PMULLW XMM0,XMM12939 PADDW XMM2,[EAX]2940 PADDW XMM2,XMM02941 PSRLW XMM2,82942 PACKUSWB XMM2,XMM32943 MOVD EAX, XMM22944 2945 @2: MOV [EDX],EAX2946 2947 @3: ADD EBX,42948 ADD EDX,42949 2950 DEC ECX2951 JNZ @12952 2953 POP EBX2954 2955 @4:2956 {$ENDIF}2957 2958 {$IFDEF TARGET_X64}2959 // ECX <- Src2960 // EDX <- Dst2961 // R8D <- Count2962 2963 TEST R8D,R8D2964 JZ @42965 2966 @1: MOV EAX,[RCX]2967 TEST EAX,$FF0000002968 JZ @32969 CMP EAX,$FF0000002970 JNC @22971 2972 MOVD XMM0,EAX2973 PXOR XMM3,XMM32974 MOVD XMM2,[RDX]2975 PUNPCKLBW XMM0,XMM32976 MOV RAX,bias_ptr2977 PUNPCKLBW XMM2,XMM32978 MOVQ XMM1,XMM02979 PUNPCKLBW XMM1,XMM32980 PUNPCKHWD XMM1,XMM12981 PSUBW XMM0,XMM22982 PUNPCKHDQ XMM1,XMM12983 PSLLW XMM2,82984 PMULLW XMM0,XMM12985 PADDW XMM2,[RAX]2986 PADDW XMM2,XMM02987 PSRLW XMM2,82988 PACKUSWB XMM2,XMM32989 MOVD EAX, XMM22990 2991 @2: MOV [RDX],EAX2992 2993 @3: ADD RCX,42994 ADD RDX,42995 2996 DEC R8D2997 JNZ @12998 2999 @4:3000 {$ENDIF}3001 end;3002 3003 3004 procedure BlendLineEx_SSE2(Src, Dst: PColor32; Count: Integer; M: TColor32);3005 asm3006 {$IFDEF TARGET_X86}3007 // EAX <- Src3008 // EDX <- Dst3009 // ECX <- Count3010 3011 // test the counter for zero or negativity3012 TEST ECX,ECX3013 JS @43014 3015 PUSH ESI3016 PUSH EDI3017 PUSH EBX3018 3019 MOV ESI,EAX // ESI <- Src3020 MOV EDI,EDX // EDI <- Dst3021 MOV EDX,M // EDX <- Master Alpha3022 3023 // loop start3024 @1: MOV EAX,[ESI]3025 TEST EAX,$FF0000003026 JZ @3 // complete transparency, proceed to next point3027 MOV EBX,EAX3028 SHR EBX,243029 INC EBX // 255:256 range bias3030 IMUL EBX,EDX3031 SHR EBX,83032 JZ @3 // complete transparency, proceed to next point3033 3034 // blend3035 PXOR XMM0,XMM03036 MOVD XMM1,EAX3037 SHL EBX,43038 MOVD XMM2,[EDI]3039 PUNPCKLBW XMM1,XMM03040 PUNPCKLBW XMM2,XMM03041 ADD EBX,alpha_ptr3042 PSUBW XMM1,XMM23043 PMULLW XMM1,[EBX]3044 PSLLW XMM2,83045 MOV EBX,bias_ptr3046 PADDW XMM2,[EBX]3047 PADDW XMM1,XMM23048 PSRLW XMM1,83049 PACKUSWB XMM1,XMM03050 MOVD EAX,XMM13051 3052 @2: MOV [EDI],EAX3053 3054 @3: ADD ESI,43055 ADD EDI,43056 3057 // loop end3058 DEC ECX3059 JNZ @13060 3061 POP EBX3062 POP EDI3063 POP ESI3064 @4:3065 {$ENDIF}3066 3067 {$IFDEF TARGET_X64}3068 // ECX <- Src3069 // EDX <- Dst3070 // R8D <- Count3071 // R9D <- M3072 3073 // test the counter for zero or negativity3074 TEST R8D,R8D3075 JS @43076 TEST R9D,R9D3077 JZ @43078 3079 MOV R10,RCX // ESI <- Src3080 3081 // loop start3082 @1: MOV ECX,[R10]3083 TEST ECX,$FF0000003084 JZ @3 // complete transparency, proceed to next point3085 MOV EAX,ECX3086 SHR EAX,243087 INC EAX // 255:256 range bias3088 IMUL EAX,R9D3089 SHR EAX,83090 JZ @3 // complete transparency, proceed to next point3091 3092 // blend3093 PXOR XMM0,XMM03094 MOVD XMM1,ECX3095 SHL EAX,43096 MOVD XMM2,[RDX]3097 PUNPCKLBW XMM1,XMM03098 PUNPCKLBW XMM2,XMM03099 ADD RAX,alpha_ptr3100 PSUBW XMM1,XMM23101 PMULLW XMM1,[RAX]3102 PSLLW XMM2,83103 MOV RAX,bias_ptr3104 PADDW XMM2,[RAX]3105 PADDW XMM1,XMM23106 PSRLW XMM1,83107 PACKUSWB XMM1,XMM03108 MOVD ECX,XMM13109 3110 @2: MOV [RDX],ECX3111 3112 @3: ADD R10,43113 ADD RDX,43114 3115 // loop end3116 DEC R8D3117 JNZ @13118 @4:3119 {$ENDIF}3120 end;3121 3122 function CombineReg_SSE2(X, Y, W: TColor32): TColor32;3123 asm3124 {$IFDEF TARGET_X86}3125 // EAX - Color X3126 // EDX - Color Y3127 // ECX - Weight of X [0..255]3128 // Result := W * (X - Y) + Y3129 3130 MOVD XMM1,EAX3131 PXOR XMM0,XMM03132 SHL ECX,43133 3134 MOVD XMM2,EDX3135 PUNPCKLBW XMM1,XMM03136 PUNPCKLBW XMM2,XMM03137 3138 ADD ECX,alpha_ptr3139 3140 PSUBW XMM1,XMM23141 PMULLW XMM1,[ECX]3142 PSLLW XMM2,83143 3144 MOV ECX,bias_ptr3145 3146 PADDW XMM2,[ECX]3147 PADDW XMM1,XMM23148 PSRLW XMM1,83149 PACKUSWB XMM1,XMM03150 MOVD EAX,XMM13151 {$ENDIF}3152 3153 {$IFDEF TARGET_X64}3154 // ECX - Color X3155 // EDX - Color Y3156 // R8D - Weight of X [0..255]3157 // Result := W * (X - Y) + Y3158 3159 MOVD XMM1,ECX3160 PXOR XMM0,XMM03161 SHL R8D,43162 3163 MOVD XMM2,EDX3164 PUNPCKLBW XMM1,XMM03165 PUNPCKLBW XMM2,XMM03166 3167 ADD R8,alpha_ptr3168 3169 PSUBW XMM1,XMM23170 PMULLW XMM1,[R8]3171 PSLLW XMM2,83172 3173 MOV R8,bias_ptr3174 3175 PADDW XMM2,[R8]3176 PADDW XMM1,XMM23177 PSRLW XMM1,83178 PACKUSWB XMM1,XMM03179 MOVD EAX,XMM13180 {$ENDIF}3181 end;3182 3183 procedure CombineMem_SSE2(F: TColor32; var B: TColor32; W: TColor32);3184 asm3185 {$IFDEF TARGET_X86}3186 // EAX - Color X3187 // [EDX] - Color Y3188 // ECX - Weight of X [0..255]3189 // Result := W * (X - Y) + Y3190 3191 JCXZ @13192 3193 CMP ECX,$FF3194 JZ @23195 3196 MOVD XMM1,EAX3197 PXOR XMM0,XMM03198 3199 SHL ECX,43200 3201 MOVD XMM2,[EDX]3202 PUNPCKLBW XMM1,XMM03203 PUNPCKLBW XMM2,XMM03204 3205 ADD ECX,alpha_ptr3206 3207 PSUBW XMM1,XMM23208 PMULLW XMM1,[ECX]3209 PSLLW XMM2,83210 3211 MOV ECX,bias_ptr3212 3213 PADDW XMM2,[ECX]3214 PADDW XMM1,XMM23215 PSRLW XMM1,83216 PACKUSWB XMM1,XMM03217 MOVD [EDX],XMM13218 3219 {$IFDEF FPC}3220 @1: JMP @33221 {$ELSE}3222 @1: RET3223 {$ENDIF}3224 3225 @2: MOV [EDX],EAX3226 @3:3227 {$ENDIF}3228 3229 {$IFDEF TARGET_X64}3230 // ECX - Color X3231 // [RDX] - Color Y3232 // R8D - Weight of X [0..255]3233 // Result := W * (X - Y) + Y3234 3235 TEST R8D,R8D // Set flags for R83236 JZ @1 // W = 0 ? => Result := EDX3237 CMP R8D,$FF3238 JZ @23239 3240 MOVD XMM1,ECX3241 PXOR XMM0,XMM03242 3243 SHL R8D,43244 3245 MOVD XMM2,[RDX]3246 PUNPCKLBW XMM1,XMM03247 PUNPCKLBW XMM2,XMM03248 3249 ADD R8,alpha_ptr3250 3251 PSUBW XMM1,XMM23252 PMULLW XMM1,[R8]3253 PSLLW XMM2,83254 3255 MOV RAX,bias_ptr3256 3257 PADDW XMM2,[RAX]3258 PADDW XMM1,XMM23259 PSRLW XMM1,83260 PACKUSWB XMM1,XMM03261 MOVD [RDX],XMM13262 3263 {$IFDEF FPC}3264 @1: JMP @33265 {$ELSE}3266 @1: RET3267 {$ENDIF}3268 3269 @2: MOV [RDX],ECX3270 @3:3271 {$ENDIF}3272 end;3273 3274 3275 procedure CombineLine_SSE2(Src, Dst: PColor32; Count: Integer; W: TColor32);3276 asm3277 {$IFDEF TARGET_X86}3278 // EAX <- Src3279 // EDX <- Dst3280 // ECX <- Count3281 3282 // Result := W * (X - Y) + Y3283 3284 TEST ECX,ECX3285 JZ @33286 3287 PUSH EBX3288 MOV EBX,W3289 3290 TEST EBX,EBX3291 JZ @23292 3293 CMP EBX,$FF3294 JZ @43295 3296 SHL EBX,43297 ADD EBX,alpha_ptr3298 MOVQ XMM3,[EBX]3299 MOV EBX,bias_ptr3300 MOVQ XMM4,[EBX]3301 3302 @1: MOVD XMM1,[EAX]3303 PXOR XMM0,XMM03304 MOVD XMM2,[EDX]3305 PUNPCKLBW XMM1,XMM03306 PUNPCKLBW XMM2,XMM03307 3308 PSUBW XMM1,XMM23309 PMULLW XMM1,XMM33310 PSLLW XMM2,83311 3312 PADDW XMM2,XMM43313 PADDW XMM1,XMM23314 PSRLW XMM1,83315 PACKUSWB XMM1,XMM03316 MOVD [EDX],XMM13317 3318 ADD EAX,43319 ADD EDX,43320 3321 DEC ECX3322 JNZ @13323 3324 @2: POP EBX3325 POP EBP3326 3327 @3: RET $00043328 3329 @4: SHL ECX,23330 CALL Move3331 POP EBX3332 {$ENDIF}3333 3334 {$IFDEF TARGET_X64}3335 // ECX <- Src3336 // EDX <- Dst3337 // R8D <- Count3338 3339 // Result := W * (X - Y) + Y3340 3341 TEST R8D,R8D3342 JZ @23343 3344 TEST R9D,R9D3345 JZ @23346 3347 CMP R9D,$FF3348 JZ @33349 3350 SHL R9D,43351 ADD R9,alpha_ptr3352 MOVQ XMM3,[R9]3353 MOV R9,bias_ptr3354 MOVQ XMM4,[R9]3355 3356 @1: MOVD XMM1,[RCX]3357 PXOR XMM0,XMM03358 MOVD XMM2,[RDX]3359 PUNPCKLBW XMM1,XMM03360 PUNPCKLBW XMM2,XMM03361 3362 PSUBW XMM1,XMM23363 PMULLW XMM1,XMM33364 PSLLW XMM2,83365 3366 PADDW XMM2,XMM43367 PADDW XMM1,XMM23368 PSRLW XMM1,83369 PACKUSWB XMM1,XMM03370 MOVD [RDX],XMM13371 3372 ADD RCX,43373 ADD RDX,43374 3375 DEC R8D3376 JNZ @13377 3378 {$IFDEF FPC}3379 @2: JMP @43380 {$ELSE}3381 @2: RET3382 {$ENDIF}3383 3384 @3: SHL R8D,23385 CALL Move3386 @4:3387 {$ENDIF}3388 end;3389 3390 function MergeReg_SSE2(F, B: TColor32): TColor32;3391 asm3392 { This is an implementation of the merge formula, as described3393 in a paper by Bruce Wallace in 1981. Merging is associative,3394 that is, A over (B over C) = (A over B) over C. The formula is,3395 3396 Ra = Fa + Ba - Fa * Ba3397 Rc = (Fa (Fc - Bc * Ba) + Bc * Ba) / Ra3398 3399 where3400 3401 Rc is the resultant color,3402 Ra is the resultant alpha,3403 Fc is the foreground color,3404 Fa is the foreground alpha,3405 Bc is the background color,3406 Ba is the background alpha.3407 3408 Implementation:3409 3410 Ra := 1 - (1 - Fa) * (1 - Ba);3411 Wa := Fa / Ra;3412 Rc := Bc + Wa * (Fc - Bc);3413 // Rc := Bc + Wa * (Fc - Bc)3414 3415 (1 - Fa) * (1 - Ba) = 1 - Fa - Ba + Fa * Ba = (1 - Ra)3416 }3417 3418 {$IFDEF TARGET_X86}3419 TEST EAX,$FF000000 // foreground completely transparent =>3420 JZ @1 // result = background3421 CMP EAX,$FF000000 // foreground completely opaque =>3422 JNC @2 // result = foreground3423 TEST EDX,$FF000000 // background completely transparent =>3424 JZ @2 // result = foreground3425 3426 PXOR XMM7,XMM7 // XMM7 <- 003427 MOVD XMM0,EAX // XMM0 <- Fa Fr Fg Fb3428 SHR EAX,24 // EAX <- Fa3429 ROR EDX,243430 MOVZX ECX,DL // ECX <- Ba3431 PUNPCKLBW XMM0,XMM7 // XMM0 <- 00 Fa 00 Fr 00 Fg 00 Fb3432 SUB EAX,$FF // EAX <- (Fa - 1)3433 XOR ECX,$FF // ECX <- (1 - Ba)3434 IMUL ECX,EAX // ECX <- (Fa - 1) * (1 - Ba) = Ra - 13435 IMUL ECX,$8081 // ECX <- Xa 00 00 003436 ADD ECX,$8081*$FF*$FF3437 SHR ECX,15 // ECX <- Ra3438 MOV DL,CH // EDX <- Br Bg Bb Ra3439 ROR EDX,8 // EDX <- Ra Br Bg Bb3440 MOVD XMM1,EDX // XMM1 <- Ra Br Bg Bb3441 PUNPCKLBW XMM1,XMM7 // XMM1 <- 00 Ra 00 Br 00 Bg 00 Bb3442 SHL EAX,20 // EAX <- Fa 00 003443 PSUBW XMM0,XMM1 // XMM0 <- ** Da ** Dr ** Dg ** Db3444 ADD EAX,$0FF010003445 PSLLW XMM0,43446 XOR EDX,EDX // EDX <- 003447 DIV ECX // EAX <- Fa / Ra = Wa3448 MOVD XMM4,EAX // XMM3 <- Wa3449 PSHUFLW XMM4,XMM4,$C0 // XMM3 <- 00 00 ** Wa ** Wa ** Wa3450 PMULHW XMM0,XMM4 // XMM0 <- 00 00 ** Pr ** Pg ** Pb3451 PADDW XMM0,XMM1 // XMM0 <- 00 Ra 00 Rr 00 Rg 00 Rb3452 PACKUSWB XMM0,XMM7 // XMM0 <- Ra Rr Rg Rb3453 MOVD EAX,XMM03454 3455 {$IFDEF FPC}3456 JMP @23457 {$ELSE}3458 RET3459 {$ENDIF}3460 @1: MOV EAX,EDX3461 @2:3462 {$ENDIF}3463 3464 {$IFDEF TARGET_X64}3465 TEST ECX,$FF000000 // foreground completely transparent =>3466 JZ @1 // result = background3467 MOV EAX,ECX // EAX <- Fa3468 CMP EAX,$FF000000 // foreground completely opaque =>3469 JNC @2 // result = foreground3470 TEST EDX,$FF000000 // background completely transparent =>3471 JZ @2 // result = foreground3472 3473 PXOR XMM7,XMM7 // XMM7 <- 003474 MOVD XMM0,EAX // XMM0 <- Fa Fr Fg Fb3475 SHR EAX,24 // EAX <- Fa3476 ROR EDX,243477 MOVZX ECX,DL // ECX <- Ba3478 PUNPCKLBW XMM0,XMM7 // XMM0 <- 00 Fa 00 Fr 00 Fg 00 Fb3479 SUB EAX,$FF // EAX <- (Fa - 1)3480 XOR ECX,$FF // ECX <- (1 - Ba)3481 IMUL ECX,EAX // ECX <- (Fa - 1) * (1 - Ba) = Ra - 13482 IMUL ECX,$8081 // ECX <- Xa 00 00 003483 ADD ECX,$8081*$FF*$FF3484 SHR ECX,15 // ECX <- Ra3485 MOV DL,CH // EDX <- Br Bg Bb Ra3486 ROR EDX,8 // EDX <- Ra Br Bg Bb3487 MOVD XMM1,EDX // XMM1 <- Ra Br Bg Bb3488 PUNPCKLBW XMM1,XMM7 // XMM1 <- 00 Ra 00 Br 00 Bg 00 Bb3489 SHL EAX,20 // EAX <- Fa 00 003490 PSUBW XMM0,XMM1 // XMM0 <- ** Da ** Dr ** Dg ** Db3491 ADD EAX,$0FF010003492 PSLLW XMM0,43493 XOR EDX,EDX // EDX <- 003494 DIV ECX // EAX <- Fa / Ra = Wa3495 MOVD XMM4,EAX // XMM3 <- Wa3496 PSHUFLW XMM4,XMM4,$C0 // XMM3 <- 00 00 ** Wa ** Wa ** Wa3497 PMULHW XMM0,XMM4 // XMM0 <- 00 00 ** Pr ** Pg ** Pb3498 PADDW XMM0,XMM1 // XMM0 <- 00 Ra 00 Rr 00 Rg 00 Rb3499 PACKUSWB XMM0,XMM7 // XMM0 <- Ra Rr Rg Rb3500 MOVD EAX,XMM03501 3502 {$IFDEF FPC}3503 JMP @23504 {$ELSE}3505 RET3506 {$ENDIF}3507 @1: MOV EAX,EDX3508 @2:3509 {$ENDIF}3510 end;3511 3512 procedure EMMS_SSE2;3513 asm3514 end;3515 3516 3517 function LightenReg_SSE2(C: TColor32; Amount: Integer): TColor32;3518 asm3519 {$IFDEF TARGET_X86}3520 MOVD XMM0,EAX3521 TEST EDX,EDX3522 JL @13523 IMUL EDX,$0101013524 MOVD XMM1,EDX3525 PADDUSB XMM0,XMM13526 MOVD EAX,XMM03527 RET3528 @1: NEG EDX3529 IMUL EDX,$0101013530 MOVD XMM1,EDX3531 PSUBUSB XMM0,XMM13532 MOVD EAX,XMM03533 {$ENDIF}3534 3535 {$IFDEF TARGET_X64}3536 MOVD XMM0,ECX3537 TEST EDX,EDX3538 JL @13539 IMUL EDX,$0101013540 MOVD XMM1,EDX3541 PADDUSB XMM0,XMM13542 MOVD EAX,XMM03543 RET3544 @1: NEG EDX3545 IMUL EDX,$0101013546 MOVD XMM1,EDX3547 PSUBUSB XMM0,XMM13548 MOVD EAX,XMM03549 {$ENDIF}3550 end;3551 3552 3553 { SSE2 Color algebra}3554 3555 function ColorAdd_SSE2(C1, C2: TColor32): TColor32;3556 asm3557 {$IFDEF TARGET_X86}3558 MOVD XMM0,EAX3559 MOVD XMM1,EDX3560 PADDUSB XMM0,XMM13561 MOVD EAX,XMM03562 {$ENDIF}3563 3564 {$IFDEF TARGET_X64}3565 MOVD XMM0,ECX3566 MOVD XMM1,EDX3567 PADDUSB XMM0,XMM13568 MOVD EAX,XMM03569 {$ENDIF}3570 end;3571 3572 function ColorSub_SSE2(C1, C2: TColor32): TColor32;3573 asm3574 {$IFDEF TARGET_X86}3575 MOVD XMM0,EAX3576 MOVD XMM1,EDX3577 PSUBUSB XMM0,XMM13578 MOVD EAX,XMM03579 {$ENDIF}3580 3581 {$IFDEF TARGET_X64}3582 MOVD XMM0,ECX3583 MOVD XMM1,EDX3584 PSUBUSB XMM0,XMM13585 MOVD EAX,XMM03586 {$ENDIF}3587 end;3588 3589 function ColorModulate_SSE2(C1, C2: TColor32): TColor32;3590 asm3591 {$IFDEF TARGET_X86}3592 PXOR XMM2,XMM23593 MOVD XMM0,EAX3594 PUNPCKLBW XMM0,XMM23595 MOVD XMM1,EDX3596 PUNPCKLBW XMM1,XMM23597 PMULLW XMM0,XMM13598 PSRLW XMM0,83599 PACKUSWB XMM0,XMM23600 MOVD EAX,XMM03601 {$ENDIF}3602 3603 {$IFDEF TARGET_X64}3604 PXOR XMM2,XMM23605 MOVD XMM0,ECX3606 PUNPCKLBW XMM0,XMM23607 MOVD XMM1,EDX3608 PUNPCKLBW XMM1,XMM23609 PMULLW XMM0,XMM13610 PSRLW XMM0,83611 PACKUSWB XMM0,XMM23612 MOVD EAX,XMM03613 {$ENDIF}3614 end;3615 3616 function ColorMax_SSE2(C1, C2: TColor32): TColor32;3617 asm3618 {$IFDEF TARGET_X86}3619 MOVD XMM0,EAX3620 MOVD XMM1,EDX3621 PMAXUB XMM0,XMM13622 MOVD EAX,XMM03623 {$ENDIF}3624 3625 {$IFDEF TARGET_X64}3626 MOVD XMM0,ECX3627 MOVD XMM1,EDX3628 PMAXUB XMM0,XMM13629 MOVD EAX,XMM03630 {$ENDIF}3631 end;3632 3633 function ColorMin_SSE2(C1, C2: TColor32): TColor32;3634 asm3635 {$IFDEF TARGET_X86}3636 MOVD XMM0,EAX3637 MOVD XMM1,EDX3638 PMINUB XMM0,XMM13639 MOVD EAX,XMM03640 {$ENDIF}3641 3642 {$IFDEF TARGET_X64}3643 MOVD XMM0,ECX3644 MOVD XMM1,EDX3645 PMINUB XMM0,XMM13646 MOVD EAX,XMM03647 {$ENDIF}3648 end;3649 3650 function ColorDifference_SSE2(C1, C2: TColor32): TColor32;3651 asm3652 {$IFDEF TARGET_X86}3653 MOVD XMM0,EAX3654 MOVD XMM1,EDX3655 MOVQ XMM2,XMM03656 PSUBUSB XMM0,XMM13657 PSUBUSB XMM1,XMM23658 POR XMM0,XMM13659 MOVD EAX,XMM03660 {$ENDIF}3661 3662 {$IFDEF TARGET_X64}3663 MOVD XMM0,ECX3664 MOVD XMM1,EDX3665 MOVQ XMM2,XMM03666 PSUBUSB XMM0,XMM13667 PSUBUSB XMM1,XMM23668 POR XMM0,XMM13669 MOVD EAX,XMM03670 {$ENDIF}3671 end;3672 3673 function ColorExclusion_SSE2(C1, C2: TColor32): TColor32;3674 asm3675 {$IFDEF TARGET_X86}3676 PXOR XMM2,XMM23677 MOVD XMM0,EAX3678 PUNPCKLBW XMM0,XMM23679 MOVD XMM1,EDX3680 PUNPCKLBW XMM1,XMM23681 MOVQ XMM3,XMM03682 PADDW XMM0,XMM13683 PMULLW XMM1,XMM33684 PSRLW XMM1,73685 PSUBUSW XMM0,XMM13686 PACKUSWB XMM0,XMM23687 MOVD EAX,XMM03688 {$ENDIF}3689 3690 {$IFDEF TARGET_X64}3691 PXOR XMM2,XMM23692 MOVD XMM0,ECX3693 PUNPCKLBW XMM0,XMM23694 MOVD XMM1,EDX3695 PUNPCKLBW XMM1,XMM23696 MOVQ XMM3,XMM03697 PADDW XMM0,XMM13698 PMULLW XMM1,XMM33699 PSRLW XMM1,73700 PSUBUSW XMM0,XMM13701 PACKUSWB XMM0,XMM23702 MOVD EAX,XMM03703 {$ENDIF}3704 end;3705 3706 function ColorScale_SSE2(C, W: TColor32): TColor32;3707 asm3708 {$IFDEF TARGET_X86}3709 PXOR XMM2,XMM23710 SHL EDX,43711 MOVD XMM0,EAX3712 PUNPCKLBW XMM0,XMM23713 ADD EDX,alpha_ptr3714 PMULLW XMM0,[EDX]3715 PSRLW XMM0,83716 PACKUSWB XMM0,XMM23717 MOVD EAX,XMM03718 {$ENDIF}3719 3720 {$IFDEF TARGET_X64}3721 PXOR XMM2,XMM23722 SHL RDX,43723 MOVD XMM0,ECX3724 PUNPCKLBW XMM0,XMM23725 ADD RDX,alpha_ptr3726 PMULLW XMM0,[RDX]3727 PSRLW XMM0,83728 PACKUSWB XMM0,XMM23729 MOVD EAX,XMM03730 {$ENDIF}3731 end;3732 3733 {$ENDIF}3734 897 {$ENDIF} 3735 898 … … 3744 907 var 3745 908 I, J: Integer; 3746 const3747 OneByteth : Double = 1 / 255;3748 909 begin 3749 910 for J := 0 to 255 do 3750 for I := 0 to 255 do 911 begin 912 DivTable[0, J] := 0; 913 RcTable[0, J] := 0; 914 end; 915 for J := 0 to 255 do 916 for I := 1 to 255 do 3751 917 begin 3752 DivTable[I, J] := Round(I * J * OneByteth); 3753 if I > 0 then 3754 RcTable[I, J] := Round(J * 255 / I) 3755 else 3756 RcTable[I, J] := 0; 918 DivTable[I, J] := Round(I * J * COne255th); 919 RcTable[I, J] := Round(J * 255 / I) 3757 920 end; 3758 921 end; … … 3763 926 FID_MERGEMEM = 2; 3764 927 FID_MERGELINE = 3; 3765 FID_MERGEREGEX = 4; 3766 FID_MERGEMEMEX = 5; 3767 FID_MERGELINEEX = 6; 3768 FID_COMBINEREG = 7; 3769 FID_COMBINEMEM = 8; 3770 FID_COMBINELINE = 9; 3771 3772 FID_BLENDREG = 10; 3773 FID_BLENDMEM = 11; 3774 FID_BLENDLINE = 12; 3775 FID_BLENDREGEX = 13; 3776 FID_BLENDMEMEX = 14; 3777 FID_BLENDLINEEX = 15; 3778 3779 FID_COLORMAX = 16; 3780 FID_COLORMIN = 17; 3781 FID_COLORAVERAGE = 18; 3782 FID_COLORADD = 19; 3783 FID_COLORSUB = 20; 3784 FID_COLORDIV = 21; 3785 FID_COLORMODULATE = 22; 3786 FID_COLORDIFFERENCE = 23; 3787 FID_COLOREXCLUSION = 24; 3788 FID_COLORSCALE = 25; 3789 FID_Lighten = 26; 928 FID_MERGELINE1 = 4; 929 FID_MERGEREGEX = 5; 930 FID_MERGEMEMEX = 6; 931 FID_MERGELINEEX = 7; 932 FID_COMBINEREG = 8; 933 FID_COMBINEMEM = 9; 934 FID_COMBINELINE = 10; 935 936 FID_BLENDREG = 11; 937 FID_BLENDMEM = 12; 938 FID_BLENDMEMS = 13; 939 FID_BLENDLINE = 14; 940 FID_BLENDREGEX = 15; 941 FID_BLENDMEMEX = 16; 942 FID_BLENDLINEEX = 17; 943 FID_BLENDLINE1 = 18; 944 945 FID_COLORMAX = 19; 946 FID_COLORMIN = 20; 947 FID_COLORAVERAGE = 21; 948 FID_COLORADD = 22; 949 FID_COLORSUB = 23; 950 FID_COLORDIV = 24; 951 FID_COLORMODULATE = 25; 952 FID_COLORDIFFERENCE = 26; 953 FID_COLOREXCLUSION = 27; 954 FID_COLORSCALE = 28; 955 FID_COLORSCREEN = 29; 956 FID_COLORDODGE = 30; 957 FID_COLORBURN = 31; 958 FID_BLENDCOLORADD = 32; 959 FID_BLENDCOLORMODULATE = 33; 960 FID_LIGHTEN = 34; 961 962 FID_BLENDREGRGB = 35; 963 FID_BLENDMEMRGB = 36; 964 {$IFDEF TEST_BLENDMEMRGB128SSE4} 965 FID_BLENDMEMRGB128 = 37; 966 {$ENDIF} 967 968 const 969 BlendBindingFlagPascal = $0001; 970 3790 971 3791 972 procedure RegisterBindings; … … 3807 988 BlendRegistry.RegisterBinding(FID_BLENDREG, @@BlendReg); 3808 989 BlendRegistry.RegisterBinding(FID_BLENDMEM, @@BlendMem); 990 BlendRegistry.RegisterBinding(FID_BLENDMEMS, @@BlendMems); 3809 991 BlendRegistry.RegisterBinding(FID_BLENDLINE, @@BlendLine); 3810 992 BlendRegistry.RegisterBinding(FID_BLENDREGEX, @@BlendRegEx); 3811 993 BlendRegistry.RegisterBinding(FID_BLENDMEMEX, @@BlendMemEx); 3812 994 BlendRegistry.RegisterBinding(FID_BLENDLINEEX, @@BlendLineEx); 995 BlendRegistry.RegisterBinding(FID_BLENDLINE1, @@BlendLine1); 3813 996 3814 997 BlendRegistry.RegisterBinding(FID_COLORMAX, @@ColorMax); … … 3822 1005 BlendRegistry.RegisterBinding(FID_COLOREXCLUSION, @@ColorExclusion); 3823 1006 BlendRegistry.RegisterBinding(FID_COLORSCALE, @@ColorScale); 1007 BlendRegistry.RegisterBinding(FID_COLORSCREEN, @@ColorScreen); 1008 BlendRegistry.RegisterBinding(FID_COLORDODGE, @@ColorDodge); 1009 BlendRegistry.RegisterBinding(FID_COLORBURN, @@ColorBurn); 1010 1011 BlendRegistry.RegisterBinding(FID_BLENDCOLORADD, @@BlendColorAdd); 1012 BlendRegistry.RegisterBinding(FID_BLENDCOLORMODULATE, @@BlendColorModulate); 3824 1013 3825 1014 BlendRegistry.RegisterBinding(FID_LIGHTEN, @@LightenReg); 1015 BlendRegistry.RegisterBinding(FID_BLENDREGRGB, @@BlendRegRGB); 1016 BlendRegistry.RegisterBinding(FID_BLENDMEMRGB, @@BlendMemRGB); 1017 {$IFDEF TEST_BLENDMEMRGB128SSE4} 1018 BlendRegistry.RegisterBinding(FID_BLENDMEMRGB128, @@BlendMemRGB128); 1019 {$ENDIF} 3826 1020 3827 1021 // pure pascal 3828 BlendRegistry.Add(FID_EMMS, @EMMS_Pas); 3829 BlendRegistry.Add(FID_MERGEREG, @MergeReg_Pas); 3830 BlendRegistry.Add(FID_MERGEMEM, @MergeMem_Pas); 3831 BlendRegistry.Add(FID_MERGEMEMEX, @MergeMemEx_Pas); 3832 BlendRegistry.Add(FID_MERGEREGEX, @MergeRegEx_Pas); 3833 BlendRegistry.Add(FID_MERGELINE, @MergeLine_Pas); 3834 BlendRegistry.Add(FID_MERGELINEEX, @MergeLineEx_Pas); 3835 BlendRegistry.Add(FID_COLORDIV, @ColorDiv_Pas); 3836 BlendRegistry.Add(FID_COLORAVERAGE, @ColorAverage_Pas); 3837 BlendRegistry.Add(FID_COMBINEREG, @CombineReg_Pas); 3838 BlendRegistry.Add(FID_COMBINEMEM, @CombineMem_Pas); 3839 BlendRegistry.Add(FID_COMBINELINE, @CombineLine_Pas); 3840 BlendRegistry.Add(FID_BLENDREG, @BlendReg_Pas); 3841 BlendRegistry.Add(FID_BLENDMEM, @BlendMem_Pas); 3842 BlendRegistry.Add(FID_BLENDLINE, @BlendLine_Pas); 3843 BlendRegistry.Add(FID_BLENDREGEX, @BlendRegEx_Pas); 3844 BlendRegistry.Add(FID_BLENDMEMEX, @BlendMemEx_Pas); 3845 BlendRegistry.Add(FID_BLENDLINEEX, @BlendLineEx_Pas); 3846 BlendRegistry.Add(FID_COLORMAX, @ColorMax_Pas); 3847 BlendRegistry.Add(FID_COLORMIN, @ColorMin_Pas); 3848 BlendRegistry.Add(FID_COLORADD, @ColorAdd_Pas); 3849 BlendRegistry.Add(FID_COLORSUB, @ColorSub_Pas); 3850 BlendRegistry.Add(FID_COLORMODULATE, @ColorModulate_Pas); 3851 BlendRegistry.Add(FID_COLORDIFFERENCE, @ColorDifference_Pas); 3852 BlendRegistry.Add(FID_COLOREXCLUSION, @ColorExclusion_Pas); 3853 BlendRegistry.Add(FID_COLORSCALE, @ColorScale_Pas); 3854 BlendRegistry.Add(FID_LIGHTEN, @LightenReg_Pas); 1022 BlendRegistry.Add(FID_EMMS, @EMMS_Pas, [], BlendBindingFlagPascal); 1023 BlendRegistry.Add(FID_MERGEREG, @MergeReg_Pas, [], BlendBindingFlagPascal); 1024 BlendRegistry.Add(FID_MERGEMEM, @MergeMem_Pas, [], BlendBindingFlagPascal); 1025 BlendRegistry.Add(FID_MERGEMEMEX, @MergeMemEx_Pas, [], BlendBindingFlagPascal); 1026 BlendRegistry.Add(FID_MERGEREGEX, @MergeRegEx_Pas, [], BlendBindingFlagPascal); 1027 BlendRegistry.Add(FID_MERGELINE, @MergeLine_Pas, [], BlendBindingFlagPascal); 1028 BlendRegistry.Add(FID_MERGELINEEX, @MergeLineEx_Pas, [], BlendBindingFlagPascal); 1029 BlendRegistry.Add(FID_MERGELINE1, @MergeLine1_Pas, [], BlendBindingFlagPascal); 1030 BlendRegistry.Add(FID_COLORDIV, @ColorDiv_Pas, [], BlendBindingFlagPascal); 1031 BlendRegistry.Add(FID_COLORAVERAGE, @ColorAverage_Pas, [], BlendBindingFlagPascal); 1032 BlendRegistry.Add(FID_COMBINEREG, @CombineReg_Pas, [], BlendBindingFlagPascal); 1033 BlendRegistry.Add(FID_COMBINEMEM, @CombineMem_Pas, [], BlendBindingFlagPascal); 1034 BlendRegistry.Add(FID_COMBINELINE, @CombineLine_Pas, [], BlendBindingFlagPascal); 1035 BlendRegistry.Add(FID_BLENDREG, @BlendReg_Pas, [], BlendBindingFlagPascal); 1036 BlendRegistry.Add(FID_BLENDMEM, @BlendMem_Pas, [], BlendBindingFlagPascal); 1037 BlendRegistry.Add(FID_BLENDMEMS, @BlendMems_Pas, [], BlendBindingFlagPascal); 1038 BlendRegistry.Add(FID_BLENDLINE, @BlendLine_Pas, [], BlendBindingFlagPascal); 1039 BlendRegistry.Add(FID_BLENDREGEX, @BlendRegEx_Pas, [], BlendBindingFlagPascal); 1040 BlendRegistry.Add(FID_BLENDMEMEX, @BlendMemEx_Pas, [], BlendBindingFlagPascal); 1041 BlendRegistry.Add(FID_BLENDLINEEX, @BlendLineEx_Pas, [], BlendBindingFlagPascal); 1042 BlendRegistry.Add(FID_BLENDLINE1, @BlendLine1_Pas, [], BlendBindingFlagPascal); 1043 BlendRegistry.Add(FID_COLORMAX, @ColorMax_Pas, [], BlendBindingFlagPascal); 1044 BlendRegistry.Add(FID_COLORMIN, @ColorMin_Pas, [], BlendBindingFlagPascal); 1045 BlendRegistry.Add(FID_COLORADD, @ColorAdd_Pas, [], BlendBindingFlagPascal); 1046 BlendRegistry.Add(FID_COLORSUB, @ColorSub_Pas, [], BlendBindingFlagPascal); 1047 BlendRegistry.Add(FID_COLORMODULATE, @ColorModulate_Pas, [], BlendBindingFlagPascal); 1048 BlendRegistry.Add(FID_COLORDIFFERENCE, @ColorDifference_Pas, [], BlendBindingFlagPascal); 1049 BlendRegistry.Add(FID_COLOREXCLUSION, @ColorExclusion_Pas, [], BlendBindingFlagPascal); 1050 BlendRegistry.Add(FID_COLORSCALE, @ColorScale_Pas, [], BlendBindingFlagPascal); 1051 BlendRegistry.Add(FID_COLORSCREEN, @ColorScreen_Pas, [], BlendBindingFlagPascal); 1052 BlendRegistry.Add(FID_COLORDODGE, @ColorDodge_Pas, [], BlendBindingFlagPascal); 1053 BlendRegistry.Add(FID_COLORBURN, @ColorBurn_Pas, [], BlendBindingFlagPascal); 1054 BlendRegistry.Add(FID_BLENDCOLORADD, @BlendColorAdd_Pas, [], BlendBindingFlagPascal); 1055 BlendRegistry.Add(FID_BLENDCOLORMODULATE, @BlendColorModulate_Pas, [], BlendBindingFlagPascal); 1056 BlendRegistry.Add(FID_LIGHTEN, @LightenReg_Pas, [], BlendBindingFlagPascal); 1057 BlendRegistry.Add(FID_BLENDREGRGB, @BlendRegRGB_Pas, [], BlendBindingFlagPascal); 1058 BlendRegistry.Add(FID_BLENDMEMRGB, @BlendMemRGB_Pas, [], BlendBindingFlagPascal); 3855 1059 3856 1060 {$IFNDEF PUREPASCAL} … … 3860 1064 BlendRegistry.Add(FID_BLENDREG, @BlendReg_ASM, []); 3861 1065 BlendRegistry.Add(FID_BLENDMEM, @BlendMem_ASM, []); 1066 BlendRegistry.Add(FID_BLENDMEMS, @BlendMems_ASM, []); 3862 1067 BlendRegistry.Add(FID_BLENDREGEX, @BlendRegEx_ASM, []); 3863 1068 BlendRegistry.Add(FID_BLENDMEMEX, @BlendMemEx_ASM, []); 3864 1069 BlendRegistry.Add(FID_BLENDLINE, @BlendLine_ASM, []); 3865 BlendRegistry.Add(FID_LIGHTEN, @LightenReg_Pas, []); // no ASM version available 1070 BlendRegistry.Add(FID_BLENDLINE1, @BlendLine1_ASM, []); 1071 {$IFNDEF TARGET_x64} 1072 BlendRegistry.Add(FID_MERGEREG, @MergeReg_ASM, []); 1073 {$ENDIF} 3866 1074 {$IFNDEF OMIT_MMX} 3867 1075 BlendRegistry.Add(FID_EMMS, @EMMS_MMX, [ciMMX]); … … 3884 1092 BlendRegistry.Add(FID_COLORSCALE, @ColorScale_MMX, [ciMMX]); 3885 1093 BlendRegistry.Add(FID_LIGHTEN, @LightenReg_MMX, [ciMMX]); 1094 BlendRegistry.Add(FID_BLENDREGRGB, @BlendRegRGB_MMX, [ciMMX]); 1095 BlendRegistry.Add(FID_BLENDMEMRGB, @BlendMemRGB_MMX, [ciMMX]); 3886 1096 {$ENDIF} 3887 1097 {$IFNDEF OMIT_SSE2} … … 3893 1103 BlendRegistry.Add(FID_BLENDREG, @BlendReg_SSE2, [ciSSE2]); 3894 1104 BlendRegistry.Add(FID_BLENDMEM, @BlendMem_SSE2, [ciSSE2]); 1105 BlendRegistry.Add(FID_BLENDMEMS, @BlendMems_SSE2, [ciSSE2]); 3895 1106 BlendRegistry.Add(FID_BLENDMEMEX, @BlendMemEx_SSE2, [ciSSE2]); 3896 1107 BlendRegistry.Add(FID_BLENDLINE, @BlendLine_SSE2, [ciSSE2]); … … 3906 1117 BlendRegistry.Add(FID_COLORSCALE, @ColorScale_SSE2, [ciSSE2]); 3907 1118 BlendRegistry.Add(FID_LIGHTEN, @LightenReg_SSE2, [ciSSE]); 3908 {$ENDIF} 3909 {$IFNDEF TARGET_x64} 3910 BlendRegistry.Add(FID_MERGEREG, @MergeReg_ASM, []); 1119 BlendRegistry.Add(FID_BLENDREGRGB, @BlendRegRGB_SSE2, [ciSSE2]); 1120 BlendRegistry.Add(FID_BLENDMEMRGB, @BlendMemRGB_SSE2, [ciSSE2]); 1121 {$IFDEF TEST_BLENDMEMRGB128SSE4} 1122 BlendRegistry.Add(FID_BLENDMEMRGB128, @BlendMemRGB128_SSE4, [ciSSE2]); 1123 {$ENDIF} 3911 1124 {$ENDIF} 3912 1125 {$ENDIF} … … 3916 1129 3917 1130 initialization 1131 BlendColorAdd := BlendColorAdd_Pas; 1132 3918 1133 RegisterBindings; 3919 1134 MakeMergeTables; … … 3929 1144 finalization 3930 1145 {$IFNDEF PUREPASCAL} 3931 {$IFNDEF OMIT_MMX} 3932 if (ciMMX in CPUFeatures) then FreeAlphaTable; 3933 {$ENDIF} 1146 if [ciMMX, ciSSE2] * CPUFeatures <> [] then 1147 FreeAlphaTable; 3934 1148 {$ENDIF} 3935 1149 -
GraphicTest/Packages/Graphics32/GR32_Compiler.inc
r450 r522 49 49 COMPILERXE1 - Delphi XE 50 50 COMPILERXE2 - Delphi XE2 51 COMPILERXE3 - Delphi XE3 52 COMPILERXE4 - Delphi XE4 53 COMPILERXE5 - Delphi XE5 54 COMPILERXE6 - Delphi XE6 55 COMPILERXE7 - Delphi XE7 56 COMPILERXE8 - Delphi XE8 57 COMPILERRX - Delphi RX 58 COMPILERRX1 - Delphi RX1 59 COMPILERRX2 - Delphi RX2 (10.2 Tokyo) 60 COMPILERRX3 - Delphi RX3 (10.3 Rio) 51 61 52 62 … … 66 76 {$ENDIF} 67 77 78 {$IFDEF VER_LATEST} // adjust for newer version (always use latest version) 79 {$DEFINE COMPILERRX3} 80 {$IFNDEF BCB} 81 {$DEFINE DELPHIRX3} 82 {$ELSE} 83 {$DEFINE BCBRX3} 84 {$ENDIF} 85 {$UNDEF VER_LATEST} 86 {$ENDIF} 87 88 {$IFDEF VER330} 89 {$DEFINE COMPILERRX3} 90 {$IFNDEF BCB} 91 {$DEFINE DELPHIRX3} 92 {$ELSE} 93 {$DEFINE BCBRX3} 94 {$ENDIF} 95 {$ENDIF} 96 97 {$IFDEF VER320} 98 {$DEFINE COMPILERRX2} 99 {$IFNDEF BCB} 100 {$DEFINE DELPHIRX2} 101 {$ELSE} 102 {$DEFINE BCBRX2} 103 {$ENDIF} 104 {$ENDIF} 105 106 {$IFDEF VER310} 107 {$DEFINE COMPILERRX1} 108 {$IFNDEF BCB} 109 {$DEFINE DELPHIRX1} 110 {$ELSE} 111 {$DEFINE BCBRX1} 112 {$ENDIF} 113 {$ENDIF} 114 115 {$IFDEF VER300} 116 {$DEFINE COMPILERRX} 117 {$IFNDEF BCB} 118 {$DEFINE DELPHIRX} 119 {$ELSE} 120 {$DEFINE BCBRX} 121 {$ENDIF} 122 {$ENDIF} 123 124 {$IFDEF VER290} 125 {$DEFINE COMPILERXE8} 126 {$IFNDEF BCB} 127 {$DEFINE DELPHIXE8} 128 {$ELSE} 129 {$DEFINE BCBXE8} 130 {$ENDIF} 131 {$ENDIF} 132 133 {$IFDEF VER280} 134 {$DEFINE COMPILERXE7} 135 {$IFNDEF BCB} 136 {$DEFINE DELPHIXE7} 137 {$ELSE} 138 {$DEFINE BCBXE7} 139 {$ENDIF} 140 {$ENDIF} 141 142 {$IFDEF VER270} 143 {$DEFINE COMPILERXE6} 144 {$IFNDEF BCB} 145 {$DEFINE DELPHIXE6} 146 {$ELSE} 147 {$DEFINE BCBXE6} 148 {$ENDIF} 149 {$ENDIF} 150 151 {$IFDEF VER260} 152 {$DEFINE COMPILERXE5} 153 {$IFNDEF BCB} 154 {$DEFINE DELPHIXE5} 155 {$ELSE} 156 {$DEFINE BCBXE5} 157 {$ENDIF} 158 {$ENDIF} 159 160 {$IFDEF VER250} 161 {$DEFINE COMPILERXE4} 162 {$IFNDEF BCB} 163 {$DEFINE DELPHIXE4} 164 {$ELSE} 165 {$DEFINE BCBXE4} 166 {$ENDIF} 167 {$ENDIF} 168 169 {$IFDEF VER240} 170 {$DEFINE COMPILERXE3} 171 {$IFNDEF BCB} 172 {$DEFINE DELPHIXE3} 173 {$ELSE} 174 {$DEFINE BCBXE3} 175 {$ENDIF} 176 {$ENDIF} 177 68 178 {$IFDEF VER230} 69 179 {$DEFINE COMPILERXE2} 70 180 {$IFNDEF BCB} 71 {$DEFINE DELPHIXE1}72 181 {$DEFINE DELPHIXE2} 73 182 {$ELSE} 74 {$DEFINE BCB 7}183 {$DEFINE BCBXE2} 75 184 {$ENDIF} 76 185 {$ENDIF} … … 81 190 {$DEFINE DELPHIXE1} 82 191 {$ELSE} 83 {$DEFINE BCB 7}192 {$DEFINE BCBXE1} 84 193 {$ENDIF} 85 194 {$ENDIF} … … 90 199 {$DEFINE DELPHI2010} 91 200 {$ELSE} 92 {$DEFINE BCB 7}201 {$DEFINE BCB14} 93 202 {$ENDIF} 94 203 {$ENDIF} … … 99 208 {$DEFINE DELPHI2009} 100 209 {$ELSE} 101 {$DEFINE BCB 7}210 {$DEFINE BCB12} 102 211 {$ENDIF} 103 212 {$ENDIF} … … 108 217 {$DEFINE DELPHI2007} 109 218 {$ELSE} 110 {$DEFINE BCB 7}219 {$DEFINE BCB11} 111 220 {$ENDIF} 112 221 {$ENDIF} … … 117 226 {$DEFINE DELPHI2006} 118 227 {$ELSE} 119 {$DEFINE BCB 7}228 {$DEFINE BCB10} 120 229 {$ENDIF} 121 230 {$ENDIF} … … 126 235 {$DEFINE DELPHI2005} 127 236 {$ELSE} 128 {$DEFINE BCB 7}237 {$DEFINE BCB8} 129 238 {$ENDIF} 130 239 {$ENDIF} … … 146 255 {$DEFINE BCB6} 147 256 {$ENDIF} 257 {$ENDIF} 258 259 {$IFDEF COMPILERRX3} 260 {$DEFINE COMPILERRX3_UP} 261 {$DEFINE COMPILERRX2_UP} 262 {$DEFINE COMPILERRX1_UP} 263 {$DEFINE COMPILERRX_UP} 264 {$DEFINE COMPILERXE8_UP} 265 {$DEFINE COMPILERXE7_UP} 266 {$DEFINE COMPILERXE6_UP} 267 {$DEFINE COMPILERXE5_UP} 268 {$DEFINE COMPILERXE4_UP} 269 {$DEFINE COMPILERXE3_UP} 270 {$DEFINE COMPILERXE2_UP} 271 {$DEFINE COMPILERXE1_UP} 272 {$DEFINE COMPILER2010_UP} 273 {$DEFINE COMPILER2009_UP} 274 {$DEFINE COMPILER2007_UP} 275 {$DEFINE COMPILER2006_UP} 276 {$DEFINE COMPILER2005_UP} 277 {$DEFINE COMPILER7_UP} 278 {$DEFINE COMPILER6_UP} 279 {$ENDIF} 280 281 {$IFDEF COMPILERRX2} 282 {$DEFINE COMPILERRX2_UP} 283 {$DEFINE COMPILERRX1_UP} 284 {$DEFINE COMPILERRX_UP} 285 {$DEFINE COMPILERXE8_UP} 286 {$DEFINE COMPILERXE7_UP} 287 {$DEFINE COMPILERXE6_UP} 288 {$DEFINE COMPILERXE5_UP} 289 {$DEFINE COMPILERXE4_UP} 290 {$DEFINE COMPILERXE3_UP} 291 {$DEFINE COMPILERXE2_UP} 292 {$DEFINE COMPILERXE1_UP} 293 {$DEFINE COMPILER2010_UP} 294 {$DEFINE COMPILER2009_UP} 295 {$DEFINE COMPILER2007_UP} 296 {$DEFINE COMPILER2006_UP} 297 {$DEFINE COMPILER2005_UP} 298 {$DEFINE COMPILER7_UP} 299 {$DEFINE COMPILER6_UP} 300 {$ENDIF} 301 302 {$IFDEF COMPILERRX1} 303 {$DEFINE COMPILERRX1_UP} 304 {$DEFINE COMPILERRX_UP} 305 {$DEFINE COMPILERXE8_UP} 306 {$DEFINE COMPILERXE7_UP} 307 {$DEFINE COMPILERXE6_UP} 308 {$DEFINE COMPILERXE5_UP} 309 {$DEFINE COMPILERXE4_UP} 310 {$DEFINE COMPILERXE3_UP} 311 {$DEFINE COMPILERXE2_UP} 312 {$DEFINE COMPILERXE1_UP} 313 {$DEFINE COMPILER2010_UP} 314 {$DEFINE COMPILER2009_UP} 315 {$DEFINE COMPILER2007_UP} 316 {$DEFINE COMPILER2006_UP} 317 {$DEFINE COMPILER2005_UP} 318 {$DEFINE COMPILER7_UP} 319 {$DEFINE COMPILER6_UP} 320 {$ENDIF} 321 322 {$IFDEF COMPILERRX} 323 {$DEFINE COMPILERRX_UP} 324 {$DEFINE COMPILERXE8_UP} 325 {$DEFINE COMPILERXE7_UP} 326 {$DEFINE COMPILERXE6_UP} 327 {$DEFINE COMPILERXE5_UP} 328 {$DEFINE COMPILERXE4_UP} 329 {$DEFINE COMPILERXE3_UP} 330 {$DEFINE COMPILERXE2_UP} 331 {$DEFINE COMPILERXE1_UP} 332 {$DEFINE COMPILER2010_UP} 333 {$DEFINE COMPILER2009_UP} 334 {$DEFINE COMPILER2007_UP} 335 {$DEFINE COMPILER2006_UP} 336 {$DEFINE COMPILER2005_UP} 337 {$DEFINE COMPILER7_UP} 338 {$DEFINE COMPILER6_UP} 339 {$ENDIF} 340 341 {$IFDEF COMPILERXE8} 342 {$DEFINE COMPILERXE8_UP} 343 {$DEFINE COMPILERXE7_UP} 344 {$DEFINE COMPILERXE6_UP} 345 {$DEFINE COMPILERXE5_UP} 346 {$DEFINE COMPILERXE4_UP} 347 {$DEFINE COMPILERXE3_UP} 348 {$DEFINE COMPILERXE2_UP} 349 {$DEFINE COMPILERXE1_UP} 350 {$DEFINE COMPILER2010_UP} 351 {$DEFINE COMPILER2009_UP} 352 {$DEFINE COMPILER2007_UP} 353 {$DEFINE COMPILER2006_UP} 354 {$DEFINE COMPILER2005_UP} 355 {$DEFINE COMPILER7_UP} 356 {$DEFINE COMPILER6_UP} 357 {$ENDIF} 358 359 {$IFDEF COMPILERXE7} 360 {$DEFINE COMPILERXE7_UP} 361 {$DEFINE COMPILERXE6_UP} 362 {$DEFINE COMPILERXE5_UP} 363 {$DEFINE COMPILERXE4_UP} 364 {$DEFINE COMPILERXE3_UP} 365 {$DEFINE COMPILERXE2_UP} 366 {$DEFINE COMPILERXE1_UP} 367 {$DEFINE COMPILER2010_UP} 368 {$DEFINE COMPILER2009_UP} 369 {$DEFINE COMPILER2007_UP} 370 {$DEFINE COMPILER2006_UP} 371 {$DEFINE COMPILER2005_UP} 372 {$DEFINE COMPILER7_UP} 373 {$DEFINE COMPILER6_UP} 374 {$ENDIF} 375 376 {$IFDEF COMPILERXE6} 377 {$DEFINE COMPILERXE6_UP} 378 {$DEFINE COMPILERXE5_UP} 379 {$DEFINE COMPILERXE4_UP} 380 {$DEFINE COMPILERXE3_UP} 381 {$DEFINE COMPILERXE2_UP} 382 {$DEFINE COMPILERXE1_UP} 383 {$DEFINE COMPILER2010_UP} 384 {$DEFINE COMPILER2009_UP} 385 {$DEFINE COMPILER2007_UP} 386 {$DEFINE COMPILER2006_UP} 387 {$DEFINE COMPILER2005_UP} 388 {$DEFINE COMPILER7_UP} 389 {$DEFINE COMPILER6_UP} 390 {$ENDIF} 391 392 {$IFDEF COMPILERXE5} 393 {$DEFINE COMPILERXE5_UP} 394 {$DEFINE COMPILERXE4_UP} 395 {$DEFINE COMPILERXE3_UP} 396 {$DEFINE COMPILERXE2_UP} 397 {$DEFINE COMPILERXE1_UP} 398 {$DEFINE COMPILER2010_UP} 399 {$DEFINE COMPILER2009_UP} 400 {$DEFINE COMPILER2007_UP} 401 {$DEFINE COMPILER2006_UP} 402 {$DEFINE COMPILER2005_UP} 403 {$DEFINE COMPILER7_UP} 404 {$DEFINE COMPILER6_UP} 405 {$ENDIF} 406 407 {$IFDEF COMPILERXE4} 408 {$DEFINE COMPILERXE4_UP} 409 {$DEFINE COMPILERXE3_UP} 410 {$DEFINE COMPILERXE2_UP} 411 {$DEFINE COMPILERXE1_UP} 412 {$DEFINE COMPILER2010_UP} 413 {$DEFINE COMPILER2009_UP} 414 {$DEFINE COMPILER2007_UP} 415 {$DEFINE COMPILER2006_UP} 416 {$DEFINE COMPILER2005_UP} 417 {$DEFINE COMPILER7_UP} 418 {$DEFINE COMPILER6_UP} 419 {$ENDIF} 420 421 {$IFDEF COMPILERXE3} 422 {$DEFINE COMPILERXE3_UP} 423 {$DEFINE COMPILERXE2_UP} 424 {$DEFINE COMPILERXE1_UP} 425 {$DEFINE COMPILER2010_UP} 426 {$DEFINE COMPILER2009_UP} 427 {$DEFINE COMPILER2007_UP} 428 {$DEFINE COMPILER2006_UP} 429 {$DEFINE COMPILER2005_UP} 430 {$DEFINE COMPILER7_UP} 431 {$DEFINE COMPILER6_UP} 148 432 {$ENDIF} 149 433 … … 223 507 {$DEFINE PLATFORM_INDEPENDENT} 224 508 {$MODE Delphi} 225 {$ASMMODE INTEL}226 509 {$ENDIF} 227 510 … … 275 558 // target is an Intel 80386 or later. 276 559 {$DEFINE TARGET_x86} 560 {$ASMMODE INTEL} 277 561 {$ENDIF} 278 562 … … 280 564 // target is a 64-bit processor (AMD or INTEL). 281 565 {$DEFINE TARGET_x64} 566 {$ASMMODE INTEL} 282 567 {$ENDIF} 283 568 … … 293 578 // target is a 64-bit processor (AMD or INTEL). 294 579 {$DEFINE TARGET_x64} 580 {$ASMMODE INTEL} 581 {$ENDIF} 582 583 {$IFDEF CPUARM} 584 // target is an ARM processor. 585 {$DEFINE TARGET_ARM} 295 586 {$ENDIF} 296 587 {$ELSE} … … 338 629 339 630 {$IFDEF COMPILERFPC} 340 { $DEFINE PUREPASCAL}631 {-$DEFINE PUREPASCAL} 341 632 {$ENDIF} 342 633 343 634 {$IFDEF TARGET_x64} 344 635 {-$DEFINE PUREPASCAL} 636 {$ENDIF} 637 638 {$IFDEF TARGET_ARM} 639 {$DEFINE PUREPASCAL} 640 {$DEFINE OMIT_MMX} 641 {$DEFINE OMIT_SSE2} 345 642 {$ENDIF} 346 643 … … 433 730 {$R-}{$Q-} // switch off overflow and range checking 434 731 435 {$IFDEF COMPILER6 }732 {$IFDEF COMPILER6_UP} 436 733 {$DEFINE EXT_PROP_EDIT} 734 {$ENDIF} 735 736 {$IFDEF COMPILER2005_UP} 737 {$DEFINE HasParentBackground} 738 {$ENDIF} 739 740 {$IFDEF COMPILER2010_UP} 741 {$DEFINE SUPPORT_ENHANCED_RECORDS} 437 742 {$ENDIF} 438 743 … … 486 791 {$DEFINE COMPILERXE2} 487 792 {$ENDIF} 793 794 {$IFDEF COMPILERXE3_UP} 795 {$DEFINE COMPILERXE3} 796 {$ENDIF} 797 798 {$IFDEF COMPILERXE4_UP} 799 {$DEFINE COMPILERXE4} 800 {$ENDIF} 801 802 {$IFDEF COMPILERXE5_UP} 803 {$DEFINE COMPILERXE5} 804 {$ENDIF} 805 806 {$IFDEF COMPILERXE6_UP} 807 {$DEFINE COMPILERXE6} 808 {$ENDIF} 809 810 {$IFDEF COMPILERXE7_UP} 811 {$DEFINE COMPILERXE7} 812 {$ENDIF} 813 814 {$IFDEF COMPILERXE8_UP} 815 {$DEFINE COMPILERXE8} 816 {$ENDIF} 817 818 {$IFDEF COMPILERRX_UP} 819 {$DEFINE COMPILERRX8} 820 {$ENDIF} 821 822 {$IFDEF COMPILERRX1_UP} 823 {$DEFINE COMPILERRX1} 824 {$ENDIF} 825 826 {$IFDEF COMPILERRX2_UP} 827 {$DEFINE COMPILERRX2} 828 {$ENDIF} -
GraphicTest/Packages/Graphics32/GR32_Containers.pas
r450 r522 40 40 uses 41 41 {$IFDEF FPC} 42 Types,43 42 {$IFDEF Windows} 44 43 Windows, 44 {$ELSE} 45 Types, 45 46 {$ENDIF} 46 47 {$ELSE} 47 Windows,48 Types, Windows, 48 49 {$ENDIF} 49 50 RTLConsts, 50 GR32, SysUtils, GR32_LowLevel,Classes, TypInfo;51 GR32, SysUtils, Classes, TypInfo; 51 52 52 53 const … … 180 181 function First: TClass; 181 182 function Last: TClass; 182 function Find( AClassName: string): TClass;183 function Find(const AClassName: string): TClass; 183 184 procedure GetClassNames(Strings: TStrings); 184 185 procedure Insert(Index: Integer; AClass: TClass); … … 231 232 implementation 232 233 234 uses 235 GR32_LowLevel; 236 233 237 procedure SmartAssign(Src, Dst: TPersistent; TypeKinds: TTypeKinds = tkProperties); 234 238 var … … 247 251 Count := GetPropList(Src.ClassInfo, TypeKinds, Props, False); 248 252 253 {$IFNDEF NEXTGEN} 249 254 for I := 0 to Count - 1 do 250 255 with Props^[I]^ do … … 262 267 SetPropValue(Dst, string(Name), GetPropValue(Src, string(Name), True)); 263 268 end; 269 {$ENDIF} 264 270 finally 265 271 FreeMem(Props, Count * SizeOf(PPropInfo)); … … 422 428 I: Integer; 423 429 begin 430 {$IFDEF HAS_NATIVEINT} 431 BucketIndex := NativeUInt(Item) shr 8 and BUCKET_MASK; // KISS pointer hash(TM) 432 {$ELSE} 424 433 BucketIndex := Cardinal(Item) shr 8 and BUCKET_MASK; // KISS pointer hash(TM) 434 {$ENDIF} 425 435 // due to their randomness, pointers most commonly differ at byte 1, we use 426 436 // this characteristic for our hash and just apply the mask to it. … … 444 454 begin 445 455 if not Exists(Item, BucketIndex, ItemIndex) then 456 {$IFDEF FPC} 457 raise EListError.CreateFmt(SItemNotFound, [Item]) 458 {$ELSE} 459 {$IFDEF HAS_NATIVEINT} 460 raise EListError.CreateFmt(SItemNotFound, [NativeInt(Item)]) 461 {$ELSE} 446 462 raise EListError.CreateFmt(SItemNotFound, [Integer(Item)]) 463 {$ENDIF} 464 {$ENDIF} 447 465 else 448 466 Result := FBuckets[BucketIndex].Items[ItemIndex].Data; … … 454 472 begin 455 473 if not Exists(Item, BucketIndex, ItemIndex) then 474 {$IFDEF FPC} 475 raise EListError.CreateFmt(SItemNotFound, [Item]) 476 {$ELSE} 477 {$IFDEF HAS_NATIVEINT} 478 raise EListError.CreateFmt(SItemNotFound, [NativeInt(Item)]) 479 {$ELSE} 456 480 raise EListError.CreateFmt(SItemNotFound, [Integer(Item)]) 481 {$ENDIF} 482 {$ENDIF} 457 483 else 458 484 FBuckets[BucketIndex].Items[ItemIndex].Data := Data; … … 644 670 end; 645 671 646 function TClassList.Find( AClassName: string): TClass;672 function TClassList.Find(const AClassName: string): TClass; 647 673 var 648 674 I: Integer; -
GraphicTest/Packages/Graphics32/GR32_Dsgn_Bitmap.pas
r450 r522 43 43 {$ELSE} 44 44 Windows, ExtDlgs, ToolWin, Registry, ImgList, Consts, DesignIntf, 45 DesignEditors, VCLEditors,45 DesignEditors, VCLEditors, 46 46 {$ENDIF} 47 47 Forms, Controls, ComCtrls, ExtCtrls, StdCtrls, Graphics, Dialogs, Menus, … … 373 373 BitmapEditor := TBitmap32Editor.Create(nil); 374 374 try 375 {$IFDEF FPC} 376 BitmapEditor.Bitmap32 := TBitmap32(GetObjectValue); 377 {$ELSE} 375 378 BitmapEditor.Bitmap32 := TBitmap32(Pointer(GetOrdValue)); 379 {$ENDIF} 376 380 if BitmapEditor.Execute then 377 381 begin -
GraphicTest/Packages/Graphics32/GR32_Dsgn_Color.pas
r450 r522 47 47 Consts, 48 48 DesignIntf, DesignEditors, VCLEditors, 49 Windows, Registry, Graphics, Dialogs, Forms, 49 Windows, Registry, Graphics, Dialogs, Forms, Controls, 50 50 {$ENDIF} 51 51 GR32, GR32_Image; … … 70 70 procedure RemoveColor(const AName: string); 71 71 end; 72 73 {$IFDEF COMPILER2010_UP} 74 TColor32Dialog = class(TCommonDialog) 75 private 76 FColor: TColor32; 77 FCustomColors: TStrings; 78 procedure SetCustomColors(Value: TStrings); 79 public 80 function Execute(ParentWnd: HWND): Boolean; override; 81 published 82 property Color: TColor32 read FColor write FColor default clBlack32; 83 property CustomColors: TStrings read FCustomColors write SetCustomColors; 84 property Ctl3D default True; 85 end; 86 {$ENDIF} 72 87 73 88 { TColor32Property } … … 106 121 107 122 implementation 123 124 {$IFDEF COMPILER2010_UP} 125 uses 126 GR32_Dsgn_ColorPicker; 127 {$ENDIF} 108 128 109 129 { TColorManager } … … 387 407 388 408 409 { TColor32Dialog } 410 411 {$IFDEF COMPILER2010_UP} 412 procedure TColor32Dialog.SetCustomColors(Value: TStrings); 413 begin 414 FCustomColors.Assign(Value); 415 end; 416 417 function TColor32Dialog.Execute(ParentWnd: HWND): Boolean; 418 var 419 ColorPicker: TFormColorPicker; 420 begin 421 ColorPicker := TFormColorPicker.Create(nil); 422 try 423 ColorPicker.Color := FColor; 424 Result := ColorPicker.ShowModal = mrOK; 425 if Result then 426 FColor := ColorPicker.Color; 427 finally 428 ColorPicker.Free; 429 end; 430 end; 431 {$ENDIF} 432 433 389 434 { TColor32Property } 390 435 … … 392 437 procedure TColor32Property.Edit; 393 438 var 439 {$IFDEF COMPILER2010_UP} 440 ColorDialog: TColor32Dialog; 441 {$ELSE} 394 442 ColorDialog: TColorDialog; 443 {$ENDIF} 395 444 IniFile: TRegIniFile; 396 445 … … 427 476 begin 428 477 IniFile := nil; 478 {$IFDEF COMPILER2010_UP} 479 ColorDialog := TColor32Dialog.Create(Application); 480 {$ELSE} 429 481 ColorDialog := TColorDialog.Create(Application); 482 {$ENDIF} 430 483 try 431 484 GetCustomColors; 432 ColorDialog.Color := WinColor(GetOrdValue);485 ColorDialog.Color := GetOrdValue; 433 486 ColorDialog.HelpContext := 25010; 487 {$IFNDEF COMPILER2010_UP} 434 488 ColorDialog.Options := [cdShowHelp]; 489 {$ENDIF} 435 490 if ColorDialog.Execute then 436 SetOrdValue(Cardinal(Color 32(ColorDialog.Color)));491 SetOrdValue(Cardinal(ColorDialog.Color)); 437 492 SaveCustomColors; 438 493 finally … … 446 501 begin 447 502 Result := [paMultiSelect, {$IFDEF EXT_PROP_EDIT}paDialog,{$ENDIF} paValueList, 448 paRevertable];503 paRevertable]; 449 504 end; 450 505 -
GraphicTest/Packages/Graphics32/GR32_ExtImage.pas
r450 r522 309 309 FDest := Dst; 310 310 FDstRect := DstRect; 311 Priority := tpNormal;312 311 {$IFDEF USETHREADRESUME} 313 312 if not Suspended then Resume; -
GraphicTest/Packages/Graphics32/GR32_Filters.pas
r450 r522 50 50 Windows, 51 51 {$ENDIF} 52 Classes, SysUtils, GR32 , GR32_Blend, GR32_System, GR32_Bindings;52 Classes, SysUtils, GR32; 53 53 54 54 { Basic processing } … … 83 83 84 84 uses 85 {$IFDEF COMPILERXE2_UP}Types, {$ENDIF} GR32_System, GR32_Bindings, 85 86 GR32_Lowlevel; 86 87 … … 89 90 SEmptySource = 'The source is nil'; 90 91 SEmptyDestination = 'Destination is nil'; 91 SNoInPlace = 'In-place operation is not supported here';92 92 93 93 type … … 115 115 (@@LogicalMaskLineOr) 116 116 ); 117 117 118 118 LOGICAL_MASK_LINE_EX: array[TLogicalOperator] of ^TLogicalMaskLineEx = ( 119 119 (@@LogicalMaskLineXorEx), … … 181 181 with Dst do 182 182 begin 183 IntersectRect(SrcRect, SrcRect, Src.BoundsRect);183 GR32.IntersectRect(SrcRect, SrcRect, Src.BoundsRect); 184 184 if (SrcRect.Right < SrcRect.Left) or (SrcRect.Bottom < SrcRect.Top) then Exit; 185 185 … … 187 187 DstY := Clamp(DstY, 0, Height); 188 188 189 DstRect.TopLeft := Point(DstX, DstY);189 DstRect.TopLeft := GR32.Point(DstX, DstY); 190 190 DstRect.Right := DstX + SrcRect.Right - SrcRect.Left; 191 191 DstRect.Bottom := DstY + SrcRect.Bottom - SrcRect.Top; 192 192 193 IntersectRect(DstRect, DstRect, BoundsRect);194 IntersectRect(DstRect, DstRect, ClipRect);193 GR32.IntersectRect(DstRect, DstRect, BoundsRect); 194 GR32.IntersectRect(DstRect, DstRect, ClipRect); 195 195 if (DstRect.Right < DstRect.Left) or (DstRect.Bottom < DstRect.Top) then Exit; 196 196 … … 480 480 with Dst do 481 481 begin 482 IntersectRect(SrcRect, SrcRect, Src.BoundsRect);482 GR32.IntersectRect(SrcRect, SrcRect, Src.BoundsRect); 483 483 if (SrcRect.Right < SrcRect.Left) or (SrcRect.Bottom < SrcRect.Top) then Exit; 484 484 … … 486 486 DstY := Clamp(DstY, 0, Height); 487 487 488 DstRect.TopLeft := Point(DstX, DstY);488 DstRect.TopLeft := GR32.Point(DstX, DstY); 489 489 DstRect.Right := DstX + SrcRect.Right - SrcRect.Left; 490 490 DstRect.Bottom := DstY + SrcRect.Bottom - SrcRect.Top; 491 491 492 IntersectRect(DstRect, DstRect, Dst.BoundsRect);493 IntersectRect(DstRect, DstRect, Dst.ClipRect);494 if (DstRect.Right < DstRect.Left) or (DstRect.Bottom < DstRect.Top) then Exit;495 492 GR32.IntersectRect(DstRect, DstRect, Dst.BoundsRect); 493 GR32.IntersectRect(DstRect, DstRect, Dst.ClipRect); 494 if (DstRect.Right < DstRect.Left) or (DstRect.Bottom < DstRect.Top) then 495 Exit; 496 496 497 497 if not MeasuringMode then … … 530 530 with ABitmap do 531 531 begin 532 IntersectRect(ARect, ARect, BoundsRect);533 IntersectRect(ARect, ARect, ClipRect);532 GR32.IntersectRect(ARect, ARect, BoundsRect); 533 GR32.IntersectRect(ARect, ARect, ClipRect); 534 534 if (ARect.Right < ARect.Left) or (ARect.Bottom < ARect.Top) then Exit; 535 535 -
GraphicTest/Packages/Graphics32/GR32_Geometry.pas
r450 r522 27 27 * Michael Hansen <dyster_tid@hotmail.com> 28 28 * 29 * Portions created by the Initial Developers are Copyright (C) 2005-20 0929 * Portions created by the Initial Developers are Copyright (C) 2005-2012 30 30 * the Initial Developers. All Rights Reserved. 31 31 * … … 38 38 39 39 uses 40 Math, GR32, GR32_Math;40 Math, Types, GR32; 41 41 42 42 type 43 PFixedVector = ^TFixedVector; 44 TFixedVector = TFixedPoint; 45 46 PFloatVector = ^TFloatVector; 47 TFloatVector = TFloatPoint; 48 49 function Add(const V1, V2: TFloatVector): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 50 function Add(const V: TFloatVector; Value: TFloat): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 51 function Sub(const V1, V2: TFloatVector): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 52 function Sub(const V: TFloatVector; Value: TFloat): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 53 function Mul(const V1, V2: TFloatVector): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 54 function Mul(const V: TFloatVector; Multiplier: TFloat): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 55 function Divide(const V: TFloatVector; Divisor: TFloat): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 56 function Divide(const V1, V2: TFloatVector): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 57 58 function Combine(const V1, V2: TFloatVector; W: TFloat): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 59 function AbsV(const V: TFloatVector): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 60 function Neg(const V: TFloatVector): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 61 function Average(const V1, V2: TFloatVector): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 62 function Max(const V1, V2: TFloatVector): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 63 function Min(const V1, V2: TFloatVector): TFloatVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 64 65 function Dot(const V1, V2: TFloatVector): TFloat; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 66 function Distance(const V1, V2: TFloatVector): TFloat; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 67 function SqrDistance(const V1, V2: TFloatVector): TFloat; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 68 69 // Fixed Overloads 70 function Add(const V1, V2: TFixedVector): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 71 function Add(const V: TFixedVector; Value: TFixed): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 72 function Sub(const V1, V2: TFixedVector): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 73 function Sub(const V: TFixedVector; Value: TFixed): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 74 function Mul(const V1, V2: TFixedVector): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 75 function Mul(const V: TFixedVector; Multiplier: TFixed): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 76 function Divide(const V: TFixedVector; Divisor: TFixed): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 77 function Divide(const V1, V2: TFixedVector): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 78 79 function Combine(const V1, V2: TFixedVector; W: TFixed): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 80 function AbsV(const V: TFixedVector): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 81 function Neg(const V: TFixedVector): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 82 function Average(const V1, V2: TFixedVector): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 83 function Max(const V1, V2: TFixedVector): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 84 function Min(const V1, V2: TFixedVector): TFixedVector; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 85 86 function Dot(const V1, V2: TFixedVector): TFixed; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 87 function Distance(const V1, V2: TFixedVector): TFixed; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 88 function SqrDistance(const V1, V2: TFixedVector): TFixed; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 43 TLinePos = (lpStart, lpEnd, lpBoth, lpNeither); 44 45 // TFloat Overloads 46 function Average(const V1, V2: TFloatPoint): TFloatPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 47 function CrossProduct(V1, V2: TFloatPoint): TFloat; overload; {$IFDEF USEINLINING} inline; {$ENDIF} 48 function Dot(const V1, V2: TFloatPoint): TFloat; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 49 function Distance(const V1, V2: TFloatPoint): TFloat; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 50 function SqrDistance(const V1, V2: TFloatPoint): TFloat; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 51 function GetPointAtAngleFromPoint(const Pt: TFloatPoint; const Dist, Radians: Single): TFloatPoint; overload; 52 function GetAngleOfPt2FromPt1(const Pt1, Pt2: TFloatPoint): Single; overload; 53 function GetUnitNormal(const Pt1, Pt2: TFloatPoint): TFloatPoint; overload; 54 function GetUnitVector(const Pt1, Pt2: TFloatPoint): TFloatPoint; overload; 55 function OffsetPoint(const Pt: TFloatPoint; DeltaX, DeltaY: TFloat): TFloatPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 56 function OffsetPoint(const Pt, Delta: TFloatPoint): TFloatPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 57 function OffsetRect(const Rct: TFloatRect; const DeltaX, DeltaY: TFloat): TFloatRect; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 58 function OffsetRect(const Rct: TFloatRect; const Delta: TFloatPoint): TFloatRect; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 59 function Shorten(const Pts: TArrayOfFloatPoint; 60 Delta: TFloat; LinePos: TLinePos): TArrayOfFloatPoint; overload; 61 function PointInPolygon(const Pt: TFloatPoint; const Pts: TArrayOfFloatPoint): Boolean; overload; 62 function SegmentIntersect(const P1, P2, P3, P4: TFloatPoint; 63 out IntersectPoint: TFloatPoint): Boolean; overload; 64 function PerpendicularDistance(const P, P1, P2: TFloatPoint): TFloat; overload; 65 66 67 // TFixed Overloads 68 function Average(const V1, V2: TFixedPoint): TFixedPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 69 function CrossProduct(V1, V2: TFixedPoint): TFixed; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 70 function Dot(const V1, V2: TFixedPoint): TFixed; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 71 function Distance(const V1, V2: TFixedPoint): TFixed; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 72 function SqrDistance(const V1, V2: TFixedPoint): TFixed; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 73 function GetPointAtAngleFromPoint(const Pt: TFixedPoint; const Dist, Radians: Single): TFixedPoint; overload; 74 function GetAngleOfPt2FromPt1(Pt1, Pt2: TFixedPoint): Single; overload; 75 function GetUnitVector(const Pt1, Pt2: TFixedPoint): TFloatPoint; overload; 76 function GetUnitNormal(const Pt1, Pt2: TFixedPoint): TFloatPoint; overload; 77 function OffsetPoint(const Pt: TFixedPoint; DeltaX, DeltaY: TFixed): TFixedPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 78 function OffsetPoint(const Pt: TFixedPoint; DeltaX, DeltaY: TFloat): TFixedPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 79 function OffsetPoint(const Pt: TFixedPoint; const Delta: TFixedPoint): TFixedPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 80 function OffsetPoint(const Pt: TFixedPoint; const Delta: TFloatPoint): TFixedPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 81 function OffsetRect(const Rct: TFixedRect; const DeltaX, DeltaY: TFixed): TFixedRect; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 82 function OffsetRect(const Rct: TFixedRect; const DeltaX, DeltaY: TFloat): TFixedRect; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 83 function OffsetRect(const Rct: TFixedRect; const Delta: TFixedPoint): TFixedRect; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 84 function OffsetRect(const Rct: TFixedRect; const Delta: TFloatPoint): TFixedRect; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 85 function Shorten(const Pts: TArrayOfFixedPoint; 86 Delta: TFloat; LinePos: TLinePos): TArrayOfFixedPoint; overload; 87 function PointInPolygon(const Pt: TFixedPoint; const Pts: array of TFixedPoint): Boolean; overload; 88 function SegmentIntersect(const P1, P2, P3, P4: TFixedPoint; 89 out IntersectPoint: TFixedPoint): Boolean; overload; 90 function PerpendicularDistance(const P, P1, P2: TFixedPoint): TFixed; overload; 91 92 // Integer Overloads 93 function Average(const V1, V2: TPoint): TPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 94 function CrossProduct(V1, V2: TPoint): Integer; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 95 function Dot(const V1, V2: TPoint): Integer; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 96 function Distance(const V1, V2: TPoint): TFloat; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 97 function SqrDistance(const V1, V2: TPoint): Integer; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 98 function OffsetPoint(const Pt: TPoint; DeltaX, DeltaY: Integer): TPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 99 function OffsetPoint(const Pt, Delta: TPoint): TPoint; overload;{$IFDEF USEINLINING} inline; {$ENDIF} 100 function PerpendicularDistance(const P, P1, P2: TPoint): TFloat; overload; 101 102 const 103 CRad01 = Pi / 180; 104 CRad30 = Pi / 6; 105 CRad45 = Pi / 4; 106 CRad60 = Pi / 3; 107 CRad90 = Pi / 2; 108 CRad180 = Pi; 109 CRad270 = CRad90 * 3; 110 CRad360 = CRad180 * 2; 111 CDegToRad = Pi / 180; 112 CRadToDeg = 180 / Pi; 89 113 90 114 implementation 91 115 92 function Add(const V1, V2: TFloatVector): TFloatVector; 93 begin 94 Result.X := V1.X + V2.X; 95 Result.Y := V1.Y + V2.Y; 96 end; 97 98 function Add(const V: TFloatVector; Value: TFloat): TFloatVector; 99 begin 100 Result.X := V.X + Value; 101 Result.Y := V.Y + Value; 102 end; 103 104 function Sub(const V1, V2: TFloatVector): TFloatVector; 105 begin 106 Result.X := V1.X - V2.X; 107 Result.Y := V1.Y - V2.Y; 108 end; 109 110 function Sub(const V: TFloatVector; Value: TFloat): TFloatVector; 111 begin 112 Result.X := V.X - Value; 113 Result.Y := V.Y - Value; 114 end; 115 116 function Mul(const V1, V2: TFloatVector): TFloatVector; 117 begin 118 Result.X := V1.X * V2.X; 119 Result.Y := V1.Y * V2.Y; 120 end; 121 122 function Mul(const V: TFloatVector; Multiplier: TFloat): TFloatVector; 123 begin 124 Result.X := V.X * Multiplier; 125 Result.Y := V.Y * Multiplier; 126 end; 127 128 function Divide(const V: TFloatVector; Divisor: TFloat): TFloatVector; 129 begin 130 Divisor := 1 / Divisor; 131 Result.X := V.X * Divisor; 132 Result.Y := V.Y * Divisor; 133 end; 134 135 function Divide(const V1, V2: TFloatVector): TFloatVector; 136 begin 137 Result.X := V1.X / V2.X; 138 Result.Y := V1.Y / V2.Y; 139 end; 140 141 function Combine(const V1, V2: TFloatVector; W: TFloat): TFloatVector; 142 begin 143 Result.X := V2.X + (V1.X - V2.X) * W; 144 Result.Y := V2.Y + (V1.Y - V2.Y) * W; 145 end; 146 147 function AbsV(const V: TFloatVector): TFloatVector; 148 begin 149 Result.X := System.Abs(V.X); 150 Result.Y := System.Abs(V.Y); 151 end; 152 153 function Neg(const V: TFloatVector): TFloatVector; 154 begin 155 Result.X := - V.X; 156 Result.Y := - V.Y; 157 end; 158 159 function Average(const V1, V2: TFloatVector): TFloatVector; 116 uses 117 GR32_Math; 118 119 function Average(const V1, V2: TFloatPoint): TFloatPoint; 160 120 begin 161 121 Result.X := (V1.X + V2.X) * 0.5; … … 163 123 end; 164 124 165 function Max(const V1, V2: TFloatVector): TFloatVector; 166 begin 167 Result := V1; 168 if V2.X > V1.X then Result.X := V2.X; 169 if V2.Y > V1.Y then Result.Y := V2.Y; 170 end; 171 172 function Min(const V1, V2: TFloatVector): TFloatVector; 173 begin 174 Result := V1; 175 if V2.X < V1.X then Result.X := V2.X; 176 if V2.Y < V1.Y then Result.Y := V2.Y; 177 end; 178 179 function Dot(const V1, V2: TFloatVector): TFloat; 125 function CrossProduct(V1, V2: TFloatPoint): TFloat; 126 begin 127 Result := V1.X * V2.Y - V1.Y * V2.X; 128 end; 129 130 function Dot(const V1, V2: TFloatPoint): TFloat; 180 131 begin 181 132 Result := V1.X * V2.X + V1.Y * V2.Y; 182 133 end; 183 134 184 function Distance(const V1, V2: TFloat Vector): TFloat;185 begin 186 Result := Hypot(V2.X - V1.X, V2.Y - V1.Y);187 end; 188 189 function SqrDistance(const V1, V2: TFloat Vector): TFloat;135 function Distance(const V1, V2: TFloatPoint): TFloat; 136 begin 137 Result := GR32_Math.Hypot(V2.X - V1.X, V2.Y - V1.Y); 138 end; 139 140 function SqrDistance(const V1, V2: TFloatPoint): TFloat; 190 141 begin 191 142 Result := Sqr(V2.X - V1.X) + Sqr(V2.Y - V1.Y); 192 143 end; 193 144 145 function GetPointAtAngleFromPoint(const Pt: TFloatPoint; 146 const Dist, Radians: TFloat): TFloatPoint; overload; 147 var 148 SinAng, CosAng: TFloat; 149 begin 150 GR32_Math.SinCos(Radians, SinAng, CosAng); 151 Result.X := Dist * CosAng + Pt.X; 152 Result.Y := -Dist * SinAng + Pt.Y; // Y axis is positive down 153 end; 154 155 function GetAngleOfPt2FromPt1(const Pt1, Pt2: TFloatPoint): Single; 156 var 157 X, Y: TFloat; 158 begin 159 X := Pt2.X - Pt1.X; 160 Y := Pt2.Y - Pt1.Y; 161 if X = 0 then 162 begin 163 if Y > 0 then Result := CRad270 else Result := CRad90; 164 end else 165 begin 166 Result := ArcTan2(-Y, X); 167 if Result < 0 then Result := Result + CRad360; 168 end; 169 end; 170 171 function GetUnitVector(const Pt1, Pt2: TFloatPoint): TFloatPoint; 172 var 173 Delta: TFloatPoint; 174 Temp: TFloat; 175 begin 176 Delta.X := (Pt2.X - Pt1.X); 177 Delta.Y := (Pt2.Y - Pt1.Y); 178 if (Delta.X = 0) and (Delta.Y = 0) then 179 Result := FloatPoint(0, 0) 180 else 181 begin 182 Temp := 1 / GR32_Math.Hypot(Delta.X, Delta.Y); 183 Result.X := Delta.X * Temp; 184 Result.Y := Delta.Y * Temp; 185 end; 186 end; 187 188 function GetUnitNormal(const Pt1, Pt2: TFloatPoint): TFloatPoint; 189 var 190 Delta: TFloatPoint; 191 Temp: TFloat; 192 begin 193 Delta.X := (Pt2.X - Pt1.X); 194 Delta.Y := (Pt2.Y - Pt1.Y); 195 196 if (Delta.X = 0) and (Delta.Y = 0) then 197 Result := FloatPoint(0, 0) 198 else 199 begin 200 Temp := 1 / GR32_Math.Hypot(Delta.X, Delta.Y); 201 Delta.X := Delta.X * Temp; 202 Delta.Y := Delta.Y * Temp; 203 end; 204 Result.X := Delta.Y; // ie perpendicular to 205 Result.Y := -Delta.X; // the unit vector 206 end; 207 208 function OffsetPoint(const Pt: TFloatPoint; DeltaX, DeltaY: TFloat): TFloatPoint; 209 begin 210 Result.X := Pt.X + DeltaX; 211 Result.Y := Pt.Y + DeltaY; 212 end; 213 214 function OffsetPoint(const Pt, Delta: TFloatPoint): TFloatPoint; 215 begin 216 Result.X := Pt.X + Delta.X; 217 Result.Y := Pt.Y + Delta.Y; 218 end; 219 220 function OffsetRect(const Rct: TFloatRect; const DeltaX, DeltaY: TFloat): TFloatRect; 221 begin 222 Result.TopLeft := OffsetPoint(Rct.TopLeft, DeltaX, DeltaY); 223 Result.BottomRight := OffsetPoint(Rct.BottomRight, DeltaX, DeltaY); 224 end; 225 226 function OffsetRect(const Rct: TFloatRect; const Delta: TFloatPoint): TFloatRect; 227 begin 228 Result.TopLeft := OffsetPoint(Rct.TopLeft, Delta); 229 Result.BottomRight := OffsetPoint(Rct.BottomRight, Delta); 230 end; 231 232 233 function Shorten(const Pts: TArrayOfFloatPoint; 234 Delta: TFloat; LinePos: TLinePos): TArrayOfFloatPoint; 235 var 236 Index, HighI: integer; 237 Dist, DeltaSqr: TFloat; 238 UnitVec: TFloatPoint; 239 240 procedure FixStart; 241 begin 242 Index := 1; 243 while (Index < HighI) and (SqrDistance(Pts[Index], Pts[0]) < DeltaSqr) do 244 Inc(Index); 245 UnitVec := GetUnitVector(Pts[Index], Pts[0]); 246 Dist := Distance(Pts[Index], Pts[0]) - Delta; 247 if Index > 1 then 248 begin 249 HighI := HighI - Index + 1; 250 Move(Result[Index], Result[1], SizeOf(TFloatPoint) * HighI); 251 SetLength(Result, HighI + 1); 252 end; 253 Result[0] := OffsetPoint(Result[1], UnitVec.X * Dist, UnitVec.Y * Dist); 254 end; 255 256 procedure FixEnd; 257 begin 258 Index := HighI - 1; 259 while (Index > 0) and (SqrDistance(Pts[Index],Pts[HighI]) < DeltaSqr) do 260 Dec(Index); 261 UnitVec := GetUnitVector(Pts[Index],Pts[HighI]); 262 Dist := Distance(Pts[Index], Pts[HighI]) - Delta; 263 if Index + 1 < HighI then SetLength(Result, Index + 2); 264 Result[Index + 1] := OffsetPoint(Result[Index], UnitVec.X * Dist, UnitVec.Y * Dist); 265 end; 266 267 begin 268 Result := Pts; 269 HighI := High(Pts); 270 DeltaSqr := Delta * Delta; 271 if HighI < 1 then Exit; 272 273 case LinePos of 274 lpStart: FixStart; 275 lpEnd : FixEnd; 276 lpBoth : begin FixStart; FixEnd; end; 277 end; 278 end; 279 280 function PointInPolygon(const Pt: TFloatPoint; const Pts: TArrayOfFloatPoint): Boolean; 281 var 282 Index: Integer; 283 iPt, jPt: PFloatPoint; 284 begin 285 Result := False; 286 iPt := @Pts[0]; 287 jPt := @Pts[High(Pts)]; 288 for Index := 0 to High(Pts) do 289 begin 290 Result := Result xor (((Pt.Y >= iPt.Y) xor (Pt.Y >= jPt.Y)) and 291 ((Pt.X - iPt.X) < ((jPt.X - iPt.X) * (Pt.Y -iPt.Y) / (jPt.Y - iPt.Y)))); 292 jPt := iPt; 293 Inc(iPt); 294 end; 295 end; 296 297 function SegmentIntersect(const P1, P2, P3, P4: TFloatPoint; 298 out IntersectPoint: TFloatPoint): Boolean; 299 var 300 m1, b1, m2, b2: TFloat; 301 begin 302 // see http://astronomy.swin.edu.au/~pbourke/geometry/lineline2d/ 303 Result := False; 304 if (P2.X = P1.X) then 305 begin 306 if (P4.X = P3.X) then Exit; // parallel lines 307 m2 := (P4.Y - P3.Y) / (P4.X - P3.X); 308 b2 := P3.Y - m2 * P3.X; 309 IntersectPoint.X := P1.X; 310 IntersectPoint.Y := m2 * P1.X + b2; 311 Result := (((IntersectPoint.Y < P2.Y) = (IntersectPoint.Y > P1.Y)) or 312 (IntersectPoint.Y = P2.Y) or (IntersectPoint.Y = P1.Y)) and 313 (((IntersectPoint.Y < P3.Y) = (IntersectPoint.Y > P4.Y)) or 314 (IntersectPoint.Y = P3.Y) or (IntersectPoint.Y = P4.Y)); 315 end 316 else if (P4.X = P3.X) then 317 begin 318 m1 := (P2.Y - P1.Y) / (P2.X - P1.X); 319 b1 := P1.Y - m1 * P1.X; 320 IntersectPoint.X := P3.X; 321 IntersectPoint.Y := m1 * P3.X + b1; 322 Result := (((IntersectPoint.Y < P2.Y) = (IntersectPoint.Y > P1.Y)) or 323 (IntersectPoint.Y = P2.Y) or (IntersectPoint.Y = P1.Y)) and 324 (((IntersectPoint.Y < P3.Y) = (IntersectPoint.Y > P4.Y)) or 325 (IntersectPoint.Y = P3.Y) or (IntersectPoint.Y = P4.Y)); 326 end else 327 begin 328 m1 := (P2.Y - P1.Y) / (P2.X - P1.X); 329 b1 := P1.Y - m1 * P1.X; 330 m2 := (P4.Y - P3.Y) / (P4.X - P3.X); 331 b2 := P3.Y - m2 * P3.X; 332 if m1 = m2 then Exit; // parallel lines 333 IntersectPoint.X := (b2 - b1) / (m1 - m2); 334 IntersectPoint.Y := m1 * IntersectPoint.X + b1; 335 Result := (((IntersectPoint.X < P2.X) = (IntersectPoint.X > P1.X)) or 336 (IntersectPoint.X = P2.X) or (IntersectPoint.X = P1.X)) and 337 (((IntersectPoint.X < P3.X) = (IntersectPoint.X > P4.X)) or 338 (IntersectPoint.X = P3.X) or (IntersectPoint.X = P4.X)); 339 end; 340 end; 341 342 function PerpendicularDistance(const P, P1, P2: TFloatPoint): TFloat; 343 begin 344 Result := Abs((P.x - P2.x) * (P1.y - P2.y) - (P.y - P2.y) * (P1.x - P2.x)) / 345 GR32_Math.Hypot(P1.x - P2.x, P1.y - P2.y); 346 end; 347 348 194 349 // Fixed overloads 195 350 196 function Add(const V1, V2: TFixedVector): TFixedVector; 197 begin 198 Result.X := V1.X + V2.X; 199 Result.Y := V1.Y + V2.Y; 200 end; 201 202 function Add(const V: TFixedVector; Value: TFixed): TFixedVector; 203 begin 204 Result.X := V.X + Value; 205 Result.Y := V.Y + Value; 206 end; 207 208 function Sub(const V1, V2: TFixedVector): TFixedVector; 209 begin 210 Result.X := V1.X - V2.X; 211 Result.Y := V1.Y - V2.Y; 212 end; 213 214 function Sub(const V: TFixedVector; Value: TFixed): TFixedVector; 215 begin 216 Result.X := V.X - Value; 217 Result.Y := V.Y - Value; 218 end; 219 220 function Mul(const V1, V2: TFixedVector): TFixedVector; 221 begin 222 Result.X := FixedMul(V1.X, V2.X); 223 Result.Y := FixedMul(V1.Y, V2.Y); 224 end; 225 226 function Mul(const V: TFixedVector; Multiplier: TFixed): TFixedVector; 227 begin 228 Result.X := FixedMul(V.X, Multiplier); 229 Result.Y := FixedMul(V.Y, Multiplier); 230 end; 231 232 function Divide(const V: TFixedVector; Divisor: TFixed): TFixedVector; 233 var 234 D: TFloat; 235 begin 236 D := FIXEDONE / Divisor; 237 Result.X := Round(V.X * D); 238 Result.Y := Round(V.Y * D); 239 end; 240 241 function Divide(const V1, V2: TFixedVector): TFixedVector; 242 begin 243 Result.X := FixedDiv(V1.X, V2.X); 244 Result.Y := FixedDiv(V1.Y, V2.Y); 245 end; 246 247 function Combine(const V1, V2: TFixedVector; W: TFixed): TFixedVector; 248 begin 249 Result.X := V2.X + FixedMul(V1.X - V2.X, W); 250 Result.Y := V2.Y + FixedMul(V1.Y - V2.Y, W); 251 end; 252 253 function AbsV(const V: TFixedVector): TFixedVector; 254 begin 255 Result.X := System.Abs(V.X); 256 Result.Y := System.Abs(V.Y); 257 end; 258 259 function Neg(const V: TFixedVector): TFixedVector; 260 begin 261 Result.X := - V.X; 262 Result.Y := - V.Y; 263 end; 264 265 function Average(const V1, V2: TFixedVector): TFixedVector; 351 function Average(const V1, V2: TFixedPoint): TFixedPoint; 266 352 begin 267 353 Result.X := (V1.X + V2.X) div 2; … … 269 355 end; 270 356 271 function Max(const V1, V2: TFixedVector): TFixedVector; 272 begin 273 Result := V1; 274 if V2.X > V1.X then Result.X := V2.X; 275 if V2.Y > V1.Y then Result.Y := V2.Y; 276 end; 277 278 function Min(const V1, V2: TFixedVector): TFixedVector; 279 begin 280 Result := V1; 281 if V2.X < V1.X then Result.X := V2.X; 282 if V2.Y < V1.Y then Result.Y := V2.Y; 283 end; 284 285 function Dot(const V1, V2: TFixedVector): TFixed; 357 function CrossProduct(V1, V2: TFixedPoint): TFixed; 358 begin 359 Result := FixedMul(V1.X, V2.Y) - FixedMul(V1.Y, V2.X); 360 end; 361 362 function Dot(const V1, V2: TFixedPoint): TFixed; 286 363 begin 287 364 Result := FixedMul(V1.X, V2.X) + FixedMul(V1.Y, V2.Y); 288 365 end; 289 366 290 function Distance(const V1, V2: TFixedVector): TFixed; 291 begin 292 Result := Fixed(Hypot((V2.X - V1.X) * FixedToFloat, (V2.Y - V1.Y) * FixedToFloat)); 293 end; 294 295 function SqrDistance(const V1, V2: TFixedVector): TFixed; 367 function Distance(const V1, V2: TFixedPoint): TFixed; 368 begin 369 Result := 370 Fixed(Hypot((V2.X - V1.X) * FixedToFloat, (V2.Y - V1.Y) * FixedToFloat)); 371 end; 372 373 function SqrDistance(const V1, V2: TFixedPoint): TFixed; 296 374 begin 297 375 Result := FixedSqr(V2.X - V1.X) + FixedSqr(V2.Y - V1.Y); 298 376 end; 299 377 378 function GetPointAtAngleFromPoint(const Pt: TFixedPoint; 379 const Dist, Radians: TFloat): TFixedPoint; 380 var 381 SinAng, CosAng: TFloat; 382 begin 383 GR32_Math.SinCos(Radians, SinAng, CosAng); 384 Result.X := Round(Dist * CosAng * FixedOne) + Pt.X; 385 Result.Y := -Round(Dist * SinAng * FixedOne) + Pt.Y; // Y axis is positive down 386 end; 387 388 function GetAngleOfPt2FromPt1(Pt1, Pt2: TFixedPoint): Single; 389 begin 390 with Pt2 do 391 begin 392 X := X - Pt1.X; 393 Y := Y - Pt1.Y; 394 if X = 0 then 395 begin 396 if Y > 0 then Result := CRad270 else Result := CRad90; 397 end else 398 begin 399 Result := ArcTan2(-Y,X); 400 if Result < 0 then Result := Result + CRad360; 401 end; 402 end; 403 end; 404 405 function GetUnitVector(const Pt1, Pt2: TFixedPoint): TFloatPoint; 406 var 407 Delta: TFloatPoint; 408 Temp: Single; 409 begin 410 Delta.X := (Pt2.X - Pt1.X) * FixedToFloat; 411 Delta.Y := (Pt2.Y - Pt1.Y) * FixedToFloat; 412 if (Delta.X = 0) and (Delta.Y = 0) then 413 begin 414 Result := FloatPoint(0,0); 415 end else 416 begin 417 Temp := 1 / GR32_Math.Hypot(Delta.X, Delta.Y); 418 Result.X := Delta.X * Temp; 419 Result.Y := Delta.Y * Temp; 420 end; 421 end; 422 423 function GetUnitNormal(const Pt1, Pt2: TFixedPoint): TFloatPoint; 424 var 425 Delta: TFloatPoint; 426 Temp: Single; 427 begin 428 Delta.X := (Pt2.X - Pt1.X) * FixedToFloat; 429 Delta.Y := (Pt2.Y - Pt1.Y) * FixedToFloat; 430 431 if (Delta.X = 0) and (Delta.Y = 0) then 432 begin 433 Result := FloatPoint(0,0); 434 end else 435 begin 436 Temp := 1 / GR32_Math.Hypot(Delta.X, Delta.Y); 437 Delta.X := Delta.X * Temp; 438 Delta.Y := Delta.Y * Temp; 439 end; 440 Result.X := Delta.Y; // ie perpendicular to 441 Result.Y := -Delta.X; // the unit vector 442 end; 443 444 function OffsetPoint(const Pt: TFixedPoint; DeltaX, DeltaY: TFixed): TFixedPoint; 445 begin 446 Result.X := Pt.X + DeltaX; 447 Result.Y := Pt.Y + DeltaY; 448 end; 449 450 function OffsetPoint(const Pt: TFixedPoint; DeltaX, DeltaY: TFloat): TFixedPoint; 451 begin 452 Result.X := Pt.X + Fixed(DeltaX); 453 Result.Y := Pt.Y + Fixed(DeltaY); 454 end; 455 456 function OffsetPoint(const Pt: TFixedPoint; const Delta: TFixedPoint): TFixedPoint; 457 begin 458 Result.X := Pt.X + Delta.X; 459 Result.Y := Pt.Y + Delta.Y; 460 end; 461 462 function OffsetPoint(const Pt: TFixedPoint; const Delta: TFloatPoint): TFixedPoint; 463 begin 464 Result.X := Pt.X + Fixed(Delta.X); 465 Result.Y := Pt.Y + Fixed(Delta.Y); 466 end; 467 468 function OffsetRect(const Rct: TFixedRect; const DeltaX, DeltaY: TFixed): TFixedRect; 469 begin 470 Result.TopLeft := OffsetPoint(Rct.TopLeft, DeltaX, DeltaY); 471 Result.BottomRight := OffsetPoint(Rct.BottomRight, DeltaX, DeltaY); 472 end; 473 474 function OffsetRect(const Rct: TFixedRect; const Delta: TFixedPoint): TFixedRect; 475 begin 476 Result.TopLeft := OffsetPoint(Rct.TopLeft, Delta); 477 Result.BottomRight := OffsetPoint(Rct.BottomRight, Delta); 478 end; 479 480 function OffsetRect(const Rct: TFixedRect; const DeltaX, DeltaY: TFloat): TFixedRect; 481 var 482 DX, DY: TFixed; 483 begin 484 DX := Fixed(DeltaX); 485 DY := Fixed(DeltaY); 486 Result.TopLeft := OffsetPoint(Rct.TopLeft, DX, DY); 487 Result.BottomRight := OffsetPoint(Rct.BottomRight, DX, DY); 488 end; 489 490 function OffsetRect(const Rct: TFixedRect; const Delta: TFloatPoint): TFixedRect; 491 var 492 DX, DY: TFixed; 493 begin 494 DX := Fixed(Delta.X); 495 DY := Fixed(Delta.Y); 496 Result.TopLeft := OffsetPoint(Rct.TopLeft, DX, DY); 497 Result.BottomRight := OffsetPoint(Rct.BottomRight, DX, DY); 498 end; 499 500 function Shorten(const Pts: TArrayOfFixedPoint; 501 Delta: TFloat; LinePos: TLinePos): TArrayOfFixedPoint; 502 var 503 Index, HighI: integer; 504 Dist, DeltaSqr: TFloat; 505 UnitVec: TFloatPoint; 506 507 procedure FixStart; 508 begin 509 Index := 1; 510 while (Index < HighI) and (SqrDistance(Pts[Index],Pts[0]) < DeltaSqr) do Inc(Index); 511 UnitVec := GetUnitVector(Pts[Index], Pts[0]); 512 Dist := Distance(Pts[Index],Pts[0]) - Delta; 513 if Index > 1 then 514 begin 515 Move(Result[Index], Result[1], SizeOf(TFloatPoint) * (HighI - Index + 1)); 516 SetLength(Result, HighI - Index + 2); 517 HighI := HighI - Index + 1; 518 end; 519 Result[0] := OffsetPoint(Result[1], UnitVec.X * Dist, UnitVec.Y * Dist); 520 end; 521 522 procedure FixEnd; 523 begin 524 Index := HighI -1; 525 while (Index > 0) and (SqrDistance(Pts[Index],Pts[HighI]) < DeltaSqr) do Dec(Index); 526 UnitVec := GetUnitVector(Pts[Index],Pts[HighI]); 527 Dist := Distance(Pts[Index],Pts[HighI]) - Delta; 528 if Index + 1 < HighI then SetLength(Result, Index + 2); 529 Result[Index + 1] := OffsetPoint(Result[Index], UnitVec.X * Dist, UnitVec.Y * Dist); 530 end; 531 532 begin 533 Result := Pts; 534 HighI := High(Pts); 535 DeltaSqr := Delta * Delta; 536 if HighI < 1 then Exit; 537 538 case LinePos of 539 lpStart: FixStart; 540 lpEnd : FixEnd; 541 lpBoth : begin FixStart; FixEnd; end; 542 end; 543 end; 544 545 function PointInPolygon(const Pt: TFixedPoint; const Pts: array of TFixedPoint): Boolean; 546 var 547 I: Integer; 548 iPt, jPt: PFixedPoint; 549 begin 550 Result := False; 551 iPt := @Pts[0]; 552 jPt := @Pts[High(Pts)]; 553 for I := 0 to High(Pts) do 554 begin 555 Result := Result xor (((Pt.Y >= iPt.Y) xor (Pt.Y >= jPt.Y)) and 556 (Pt.X - iPt.X < MulDiv(jPt.X - iPt.X, Pt.Y - iPt.Y, jPt.Y - iPt.Y))); 557 jPt := iPt; 558 Inc(iPt); 559 end; 560 end; 561 562 function SegmentIntersect(const P1, P2, P3, P4: TFixedPoint; 563 out IntersectPoint: TFixedPoint): Boolean; 564 var 565 m1,b1,m2,b2: TFloat; 566 begin 567 Result := False; 568 if (P2.X = P1.X) then 569 begin 570 if (P4.X = P3.X) then Exit; // parallel lines 571 m2 := (P4.Y - P3.Y) / (P4.X - P3.X); 572 b2 := P3.Y - m2 * P3.X; 573 IntersectPoint.X := P1.X; 574 IntersectPoint.Y := Round(m2 * P1.X + b2); 575 Result := (IntersectPoint.Y < P2.Y) = (IntersectPoint.Y > P1.Y); 576 end 577 else if (P4.X = P3.X) then 578 begin 579 m1 := (P2.Y - P1.Y) / (P2.X - P1.X); 580 b1 := P1.Y - m1 * P1.X; 581 IntersectPoint.X := P3.X; 582 IntersectPoint.Y := Round(m1 * P3.X + b1); 583 Result := (IntersectPoint.Y < P3.Y) = (IntersectPoint.Y > P4.Y); 584 end else 585 begin 586 m1 := (P2.Y - P1.Y) / (P2.X - P1.X); 587 b1 := P1.Y - m1 * P1.X; 588 m2 := (P4.Y - P3.Y) / (P4.X - P3.X); 589 b2 := P3.Y - m2 * P3.X; 590 if m1 = m2 then Exit; // parallel lines 591 IntersectPoint.X := Round((b2 - b1) / (m1 - m2)); 592 IntersectPoint.Y := Round(m1 * IntersectPoint.X + b1); 593 Result := ((IntersectPoint.X < P2.X) = (IntersectPoint.X > P1.X)); 594 end; 595 end; 596 597 function PerpendicularDistance(const P, P1, P2: TFixedPoint): TFixed; 598 begin 599 Result := Fixed(Abs((P.x - P2.x) * (P1.y - P2.y) - (P.y - P2.y) * 600 (P1.x - P2.x)) * FixedToFloat / Hypot((P1.x - P2.x) * FixedToFloat, 601 (P1.y - P2.y) * FixedToFloat)); 602 end; 603 604 605 // Integer overloads 606 607 function Average(const V1, V2: TPoint): TPoint; 608 begin 609 Result.X := (V1.X + V2.X) div 2; 610 Result.Y := (V1.Y + V2.Y) div 2; 611 end; 612 613 function CrossProduct(V1, V2: TPoint): Integer; 614 begin 615 Result := V1.X * V2.Y - V1.Y * V2.X; 616 end; 617 618 function Dot(const V1, V2: TPoint): Integer; 619 begin 620 Result := V1.X * V2.X + V1.Y * V2.Y; 621 end; 622 623 function Distance(const V1, V2: TPoint): TFloat; 624 begin 625 Result := Hypot(Integer(V2.X - V1.X), Integer(V2.Y - V1.Y)); 626 end; 627 628 function SqrDistance(const V1, V2: TPoint): Integer; 629 begin 630 Result := Sqr(V2.X - V1.X) + Sqr(V2.Y - V1.Y); 631 end; 632 633 function OffsetPoint(const Pt: TPoint; DeltaX, DeltaY: Integer): TPoint; 634 begin 635 Result.X := Pt.X + DeltaX; 636 Result.Y := Pt.Y + DeltaY; 637 end; 638 639 function OffsetPoint(const Pt, Delta: TPoint): TPoint; 640 begin 641 Result.X := Pt.X + Delta.X; 642 Result.Y := Pt.Y + Delta.Y; 643 end; 644 645 function PerpendicularDistance(const P, P1, P2: TPoint): TFloat; 646 begin 647 Result := Abs((P.x - P2.x) * (P1.y - P2.y) - (P.y - P2.y) * (P1.x - P2.x)) / 648 Math.Hypot(P1.x - P2.x, P1.y - P2.y); 649 end; 650 300 651 end. -
GraphicTest/Packages/Graphics32/GR32_Image.pas
r450 r522 49 49 {$ENDIF} 50 50 Graphics, Controls, Forms, 51 Classes, SysUtils, GR32, GR32_Layers, GR32_RangeBars, GR32_ LowLevel,52 GR32_ System, GR32_Containers, GR32_RepaintOpt;51 Classes, SysUtils, GR32, GR32_Layers, GR32_RangeBars, GR32_Containers, 52 GR32_RepaintOpt; 53 53 54 54 const … … 118 118 procedure CMMouseEnter(var Message: TLMessage); message LM_MOUSEENTER; 119 119 procedure CMMouseLeave(var Message: TLMessage); message LM_MOUSELEAVE; 120 procedure CMInvalidate(var Message: TLMessage); message CM_INVALIDATE;121 120 {$ELSE} 122 121 procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND; … … 278 277 procedure InvalidateCache; 279 278 function InvalidRectsAvailable: Boolean; override; 280 procedure DblClick; override;281 279 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); overload; override; 282 280 procedure MouseMove(Shift: TShiftState; X, Y: Integer); overload; override; … … 366 364 property OnClick; 367 365 property OnChange; 366 property OnContextPopup; 368 367 property OnDblClick; 369 368 property OnGDIOverlay; … … 653 652 { TCustomPaintBox32 } 654 653 655 {$IFDEF FPC} 656 procedure TCustomPaintBox32.CMInvalidate(var Message: TLMessage); 657 begin 658 if CustomRepaint and HandleAllocated then 659 PostMessage(Handle, LM_PAINT, 0, 0) 660 else 661 inherited; 662 end; 663 {$ELSE} 664 654 {$IFNDEF FPC} 665 655 procedure TCustomPaintBox32.CMInvalidate(var Message: TMessage); 666 656 begin … … 848 838 end; 849 839 850 procedure TCustomPaintBox32.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 840 procedure TCustomPaintBox32.MouseDown(Button: TMouseButton; Shift: TShiftState; 841 X, Y: Integer); 851 842 begin 852 843 if (pboAutoFocus in Options) and CanFocus then SetFocus; … … 874 865 875 866 if FRepaintOptimizer.Enabled then 876 begin877 867 FRepaintOptimizer.BeginPaint; 878 end;879 868 880 869 if not FBufferValid then … … 984 973 procedure TCustomPaintBox32.WMGetDlgCode(var Msg: {$IFDEF FPC}TLMessage{$ELSE}TWmGetDlgCode{$ENDIF}); 985 974 begin 986 with Msg do if pboWantArrowKeys in Options then 987 Result:= Result or DLGC_WANTARROWS 988 else 989 Result:= Result and not DLGC_WANTARROWS; 975 with Msg do 976 if pboWantArrowKeys in Options then 977 Result:= Result or DLGC_WANTARROWS 978 else 979 Result:= Result and not DLGC_WANTARROWS; 990 980 end; 991 981 … … 1050 1040 { TCustomImage32 } 1051 1041 1042 constructor TCustomImage32.Create(AOwner: TComponent); 1043 begin 1044 inherited; 1045 ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, 1046 csDoubleClicks, csReplicatable, csOpaque]; 1047 FBitmap := TBitmap32.Create; 1048 FBitmap.OnResize := BitmapResizeHandler; 1049 1050 FLayers := TLayerCollection.Create(Self); 1051 with TLayerCollectionAccess(FLayers) do 1052 begin 1053 OnChange := LayerCollectionChangeHandler; 1054 OnGDIUpdate := LayerCollectionGDIUpdateHandler; 1055 OnGetViewportScale := LayerCollectionGetViewportScaleHandler; 1056 OnGetViewportShift := LayerCollectionGetViewportShiftHandler; 1057 end; 1058 1059 FRepaintOptimizer.RegisterLayerCollection(FLayers); 1060 RepaintMode := rmFull; 1061 1062 FPaintStages := TPaintStages.Create; 1063 FScaleX := 1; 1064 FScaleY := 1; 1065 SetXForm(0, 0, 1, 1); 1066 1067 InitDefaultStages; 1068 end; 1069 1070 destructor TCustomImage32.Destroy; 1071 begin 1072 BeginUpdate; 1073 FPaintStages.Free; 1074 FRepaintOptimizer.UnregisterLayerCollection(FLayers); 1075 FLayers.Free; 1076 FBitmap.Free; 1077 inherited; 1078 end; 1079 1052 1080 procedure TCustomImage32.BeginUpdate; 1053 1081 begin … … 1104 1132 end; 1105 1133 1106 function TCustomImage32.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;1107 var1108 W, H: Integer;1109 begin1110 InvalidateCache;1111 Result := True;1112 W := Bitmap.Width;1113 H := Bitmap.Height;1114 if ScaleMode = smScale then1115 begin1116 W := Round(W * Scale);1117 H := Round(H * Scale);1118 end;1119 if not (csDesigning in ComponentState) or (W > 0) and (H > 0) then1120 begin1121 if Align in [alNone, alLeft, alRight] then NewWidth := W;1122 if Align in [alNone, alTop, alBottom] then NewHeight := H;1123 end;1124 end;1125 1126 procedure TCustomImage32.Changed;1127 begin1128 if FUpdateCount = 0 then1129 begin1130 Invalidate;1131 if Assigned(FOnChange) then FOnChange(Self);1132 end;1133 end;1134 1135 procedure TCustomImage32.Update(const Rect: TRect);1136 begin1137 if FRepaintOptimizer.Enabled then1138 FRepaintOptimizer.AreaUpdateHandler(Self, Rect, AREAINFO_RECT);1139 end;1140 1141 1134 procedure TCustomImage32.BitmapResizeHandler(Sender: TObject); 1142 1135 begin … … 1150 1143 end; 1151 1144 1152 procedure TCustomImage32.BitmapAreaChangeHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); 1145 procedure TCustomImage32.BitmapAreaChangeHandler(Sender: TObject; 1146 const Area: TRect; const Info: Cardinal); 1153 1147 var 1154 1148 T, R: TRect; … … 1185 1179 end; 1186 1180 1187 procedure TCustomImage32.BitmapDirectAreaChangeHandler(Sender: TObject; const Area: TRect; const Info: Cardinal); 1181 procedure TCustomImage32.BitmapDirectAreaChangeHandler(Sender: TObject; 1182 const Area: TRect; const Info: Cardinal); 1188 1183 var 1189 1184 T, R: TRect; … … 1224 1219 end; 1225 1220 1226 procedure TCustomImage32.LayerCollectionChangeHandler(Sender: TObject); 1227 begin 1228 Changed; 1229 end; 1230 1231 procedure TCustomImage32.LayerCollectionGDIUpdateHandler(Sender: TObject); 1232 begin 1233 Paint; 1234 end; 1235 1236 procedure TCustomImage32.LayerCollectionGetViewportScaleHandler(Sender: TObject; 1237 out ScaleX, ScaleY: TFloat); 1238 begin 1239 UpdateCache; 1240 ScaleX := CachedScaleX; 1241 ScaleY := CachedScaleY; 1242 end; 1243 1244 procedure TCustomImage32.LayerCollectionGetViewportShiftHandler(Sender: TObject; 1245 out ShiftX, ShiftY: TFloat); 1246 begin 1247 UpdateCache; 1248 ShiftX := CachedShiftX; 1249 ShiftY := CachedShiftY; 1221 function TCustomImage32.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; 1222 var 1223 W, H: Integer; 1224 begin 1225 InvalidateCache; 1226 Result := True; 1227 W := Bitmap.Width; 1228 H := Bitmap.Height; 1229 if ScaleMode = smScale then 1230 begin 1231 W := Round(W * Scale); 1232 H := Round(H * Scale); 1233 end; 1234 if not (csDesigning in ComponentState) or (W > 0) and (H > 0) then 1235 begin 1236 if Align in [alNone, alLeft, alRight] then NewWidth := W; 1237 if Align in [alNone, alTop, alBottom] then NewHeight := H; 1238 end; 1239 end; 1240 1241 procedure TCustomImage32.Changed; 1242 begin 1243 if FUpdateCount = 0 then 1244 begin 1245 Invalidate; 1246 if Assigned(FOnChange) then FOnChange(Self); 1247 end; 1250 1248 end; 1251 1249 … … 1285 1283 Result.Y := (Y - CachedShiftY) * CachedRecScaleY; 1286 1284 end; 1287 end;1288 1289 1290 constructor TCustomImage32.Create(AOwner: TComponent);1291 begin1292 inherited;1293 ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,1294 csDoubleClicks, csReplicatable, csOpaque];1295 FBitmap := TBitmap32.Create;1296 FBitmap.OnResize := BitmapResizeHandler;1297 1298 FLayers := TLayerCollection.Create(Self);1299 with TLayerCollectionAccess(FLayers) do1300 begin1301 OnChange := LayerCollectionChangeHandler;1302 OnGDIUpdate := LayerCollectionGDIUpdateHandler;1303 OnGetViewportScale := LayerCollectionGetViewportScaleHandler;1304 OnGetViewportShift := LayerCollectionGetViewportShiftHandler;1305 end;1306 1307 FRepaintOptimizer.RegisterLayerCollection(FLayers);1308 RepaintMode := rmFull;1309 1310 FPaintStages := TPaintStages.Create;1311 FScaleX := 1;1312 FScaleY := 1;1313 SetXForm(0, 0, 1, 1);1314 1315 InitDefaultStages;1316 end;1317 1318 procedure TCustomImage32.DblClick;1319 begin1320 Layers.MouseListener := nil;1321 MouseUp(mbLeft, [], 0, 0);1322 inherited;1323 end;1324 1325 destructor TCustomImage32.Destroy;1326 begin1327 BeginUpdate;1328 FPaintStages.Free;1329 FRepaintOptimizer.UnregisterLayerCollection(FLayers);1330 FLayers.Free;1331 FBitmap.Free;1332 inherited;1333 1285 end; 1334 1286 … … 1674 1626 procedure TCustomImage32.InvalidateCache; 1675 1627 begin 1676 if FRepaintOptimizer.Enabled then FRepaintOptimizer.Reset; 1628 if FRepaintOptimizer.Enabled and CacheValid then 1629 FRepaintOptimizer.Reset; 1677 1630 CacheValid := False; 1678 1631 end; 1679 1632 1633 function TCustomImage32.InvalidRectsAvailable: Boolean; 1634 begin 1635 // avoid calling inherited, we have a totally different behaviour here... 1636 DoPrepareInvalidRects; 1637 Result := FInvalidRects.Count > 0; 1638 end; 1639 1640 procedure TCustomImage32.LayerCollectionChangeHandler(Sender: TObject); 1641 begin 1642 Changed; 1643 end; 1644 1645 procedure TCustomImage32.LayerCollectionGDIUpdateHandler(Sender: TObject); 1646 begin 1647 Paint; 1648 end; 1649 1650 procedure TCustomImage32.LayerCollectionGetViewportScaleHandler(Sender: TObject; 1651 out ScaleX, ScaleY: TFloat); 1652 begin 1653 UpdateCache; 1654 ScaleX := CachedScaleX; 1655 ScaleY := CachedScaleY; 1656 end; 1657 1658 procedure TCustomImage32.LayerCollectionGetViewportShiftHandler(Sender: TObject; 1659 out ShiftX, ShiftY: TFloat); 1660 begin 1661 UpdateCache; 1662 ShiftX := CachedShiftX; 1663 ShiftY := CachedShiftY; 1664 end; 1665 1680 1666 procedure TCustomImage32.Loaded; 1681 1667 begin … … 1691 1677 1692 1678 if TabStop and CanFocus then SetFocus; 1693 1679 1694 1680 if Layers.MouseEvents then 1695 1681 Layer := TLayerCollectionAccess(Layers).MouseDown(Button, Shift, X, Y) … … 1720 1706 var 1721 1707 Layer: TCustomLayer; 1722 begin 1708 MouseListener: TCustomLayer; 1709 begin 1710 MouseListener := TLayerCollectionAccess(Layers).MouseListener; 1711 1723 1712 if Layers.MouseEvents then 1724 1713 Layer := TLayerCollectionAccess(Layers).MouseUp(Button, Shift, X, Y) … … 1727 1716 1728 1717 // unlock the capture using same criteria as was used to acquire it 1729 if (Button = mbLeft) or ( TLayerCollectionAccess(Layers).MouseListener <> nil) then1718 if (Button = mbLeft) or ((MouseListener <> nil) and (TLayerCollectionAccess(Layers).MouseListener = nil)) then 1730 1719 MouseCapture := False; 1731 1720 … … 1736 1725 Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); 1737 1726 begin 1738 if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y, Layer); 1727 if Assigned(FOnMouseDown) then 1728 FOnMouseDown(Self, Button, Shift, X, Y, Layer); 1739 1729 end; 1740 1730 … … 1742 1732 Layer: TCustomLayer); 1743 1733 begin 1744 if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y, Layer); 1734 if Assigned(FOnMouseMove) then 1735 FOnMouseMove(Self, Shift, X, Y, Layer); 1745 1736 end; 1746 1737 … … 1748 1739 X, Y: Integer; Layer: TCustomLayer); 1749 1740 begin 1750 if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X, Y, Layer); 1741 if Assigned(FOnMouseUp) then 1742 FOnMouseUp(Self, Button, Shift, X, Y, Layer); 1751 1743 end; 1752 1744 … … 1933 1925 end; 1934 1926 1935 procedure TCustomImage32.UpdateCache;1936 begin1937 if CacheValid then Exit;1938 CachedBitmapRect := GetBitmapRect;1939 1940 if Bitmap.Empty then1941 SetXForm(0, 0, 1, 1)1942 else1943 SetXForm(1944 CachedBitmapRect.Left, CachedBitmapRect.Top,1945 (CachedBitmapRect.Right - CachedBitmapRect.Left) / Bitmap.Width,1946 (CachedBitmapRect.Bottom - CachedBitmapRect.Top) / Bitmap.Height1947 );1948 1949 CacheValid := True;1950 end;1951 1952 function TCustomImage32.InvalidRectsAvailable: Boolean;1953 begin1954 // avoid calling inherited, we have a totally different behaviour here...1955 DoPrepareInvalidRects;1956 Result := FInvalidRects.Count > 0;1957 end;1958 1959 1927 procedure TCustomImage32.SetRepaintMode(const Value: TRepaintMode); 1960 1928 begin … … 1977 1945 end; 1978 1946 end; 1947 1948 procedure TCustomImage32.Update(const Rect: TRect); 1949 begin 1950 if FRepaintOptimizer.Enabled then 1951 FRepaintOptimizer.AreaUpdateHandler(Self, Rect, AREAINFO_RECT); 1952 end; 1953 1954 procedure TCustomImage32.UpdateCache; 1955 begin 1956 if CacheValid then Exit; 1957 CachedBitmapRect := GetBitmapRect; 1958 1959 if Bitmap.Empty then 1960 SetXForm(0, 0, 1, 1) 1961 else 1962 SetXForm( 1963 CachedBitmapRect.Left, CachedBitmapRect.Top, 1964 (CachedBitmapRect.Right - CachedBitmapRect.Left) / Bitmap.Width, 1965 (CachedBitmapRect.Bottom - CachedBitmapRect.Top) / Bitmap.Height 1966 ); 1967 1968 CacheValid := True; 1969 end; 1970 1979 1971 1980 1972 { TIVScrollProperties } … … 2404 2396 begin 2405 2397 if W > Sz.Cx + 2 * ScaledOversize then // Viewport is bigger than scaled Bitmap 2406 OffsetHorz := (W - Sz.Cx) / 22398 OffsetHorz := (W - Sz.Cx) * 0.5 2407 2399 else 2408 2400 OffsetHorz := -HScroll.Position + ScaledOversize; 2409 2401 2410 2402 if H > Sz.Cy + 2 * ScaledOversize then // Viewport is bigger than scaled Bitmap 2411 OffsetVert := (H - Sz.Cy) / 22403 OffsetVert := (H - Sz.Cy) * 0.5 2412 2404 else 2413 2405 OffsetVert := -VScroll.Position + ScaledOversize; -
GraphicTest/Packages/Graphics32/GR32_Layers.pas
r450 r522 63 63 TCustomLayer = class; 64 64 TPositionedLayer = class; 65 TRubberbandLayer = class; 65 66 TLayerClass = class of TCustomLayer; 66 67 … … 111 112 function MouseMove(Shift: TShiftState; X, Y: Integer): TCustomLayer; 112 113 function MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): TCustomLayer; 114 113 115 property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; 114 116 property OnChange: TNotifyEvent read FOnChange write FOnChange; … … 122 124 constructor Create(AOwner: TPersistent); 123 125 destructor Destroy; override; 126 124 127 function Add(ItemClass: TLayerClass): TCustomLayer; 125 128 procedure Assign(Source: TPersistent); override; … … 131 134 procedure GetViewportScale(out ScaleX, ScaleY: TFloat); virtual; 132 135 procedure GetViewportShift(out ShiftX, ShiftY: TFloat); virtual; 136 133 137 property Count: Integer read GetCount; 134 138 property Owner: TPersistent read FOwner; … … 137 141 property MouseEvents: Boolean read FMouseEvents write SetMouseEvents; 138 142 end; 143 144 {$IFDEF COMPILER2009_UP} 145 TLayerEnum = class 146 private 147 FIndex: Integer; 148 FLayerCollection: TLayerCollection; 149 public 150 constructor Create(ALayerCollection: TLayerCollection); 151 152 function GetCurrent: TCustomLayer; 153 function MoveNext: Boolean; 154 155 property Current: TCustomLayer read GetCurrent; 156 end; 157 158 TLayerCollectionHelper = class Helper for TLayerCollection 159 public 160 function GetEnumerator: TLayerEnum; 161 end; 162 {$ENDIF} 139 163 140 164 TLayerState = (lsMouseLeft, lsMouseRight, lsMouseMiddle); … … 151 175 FLayerStates: TLayerStates; 152 176 FLayerOptions: Cardinal; 177 FTag: Integer; 178 FClicked: Boolean; 153 179 FOnHitTest: THitTestEvent; 154 180 FOnMouseDown: TMouseEvent; … … 156 182 FOnMouseUp: TMouseEvent; 157 183 FOnPaint: TPaintLayerEvent; 158 FTag: Integer;159 184 FOnDestroy: TNotifyEvent; 185 FOnDblClick: TNotifyEvent; 186 FOnClick: TNotifyEvent; 160 187 function GetIndex: Integer; 161 188 function GetMouseEvents: Boolean; … … 170 197 procedure AddNotification(ALayer: TCustomLayer); 171 198 procedure Changing; 199 procedure Click; 200 procedure DblClick; 172 201 function DoHitTest(X, Y: Integer): Boolean; virtual; 173 202 procedure DoPaint(Buffer: TBitmap32); … … 184 213 procedure SetLayerCollection(Value: TLayerCollection); virtual; 185 214 procedure SetLayerOptions(Value: Cardinal); virtual; 215 186 216 property Invalid: Boolean read GetInvalid write SetInvalid; 187 217 property ForceUpdate: Boolean read GetForceUpdate write SetForceUpdate; … … 189 219 constructor Create(ALayerCollection: TLayerCollection); virtual; 190 220 destructor Destroy; override; 221 191 222 procedure BeforeDestruction; override; 192 223 procedure BringToFront; … … 198 229 procedure SendToBack; 199 230 procedure SetAsMouseListener; 231 200 232 property Cursor: TCursor read FCursor write SetCursor; 201 233 property Index: Integer read GetIndex write SetIndex; … … 206 238 property Tag: Integer read FTag write FTag; 207 239 property Visible: Boolean read GetVisible write SetVisible; 240 208 241 property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; 209 242 property OnHitTest: THitTestEvent read FOnHitTest write FOnHitTest; 210 243 property OnPaint: TPaintLayerEvent read FOnPaint write FOnPaint; 244 property OnClick: TNotifyEvent read FOnClick write FOnClick; 245 property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick; 211 246 property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown; 212 247 property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove; … … 225 260 public 226 261 constructor Create(ALayerCollection: TLayerCollection); override; 262 227 263 function GetAdjustedRect(const R: TFloatRect): TFloatRect; virtual; 228 264 function GetAdjustedLocation: TFloatRect; 265 229 266 property Location: TFloatRect read FLocation write SetLocation; 230 267 property Scaled: Boolean read FScaled write SetScaled; … … 245 282 constructor Create(ALayerCollection: TLayerCollection); override; 246 283 destructor Destroy; override; 284 247 285 property AlphaHit: Boolean read FAlphaHit write FAlphaHit; 248 286 property Bitmap: TBitmap32 read FBitmap write SetBitmap; … … 250 288 end; 251 289 252 T DragState = (dsNone, dsMove, dsSizeL, dsSizeT, dsSizeR, dsSizeB,290 TRBDragState = (dsNone, dsMove, dsSizeL, dsSizeT, dsSizeR, dsSizeB, 253 291 dsSizeTL, dsSizeTR, dsSizeBL, dsSizeBR); 254 292 TRBHandles = set of (rhCenter, rhSides, rhCorners, rhFrame, 255 293 rhNotLeftSide, rhNotRightSide, rhNotTopSide, rhNotBottomSide, 256 294 rhNotTLCorner, rhNotTRCorner, rhNotBLCorner, rhNotBRCorner); 257 TRBOptions = set of (roProportional, roConstrained );295 TRBOptions = set of (roProportional, roConstrained, roQuantized); 258 296 TRBResizingEvent = procedure( 259 297 Sender: TObject; 260 298 const OldLocation: TFloatRect; 261 299 var NewLocation: TFloatRect; 262 DragState: T DragState;300 DragState: TRBDragState; 263 301 Shift: TShiftState) of object; 264 302 TRBConstrainEvent = TRBResizingEvent; 303 304 TRubberbandPassMouse = class(TPersistent) 305 private 306 FOwner: TRubberbandLayer; 307 FEnabled: Boolean; 308 FToChild: Boolean; 309 FLayerUnderCursor: Boolean; 310 FCancelIfPassed: Boolean; 311 protected 312 function GetChildUnderCursor(X, Y: Integer): TPositionedLayer; 313 public 314 constructor Create(AOwner: TRubberbandLayer); 315 316 property Enabled: Boolean read FEnabled write FEnabled default False; 317 property ToChild: Boolean read FToChild write FToChild default False; 318 property ToLayerUnderCursor: Boolean read FLayerUnderCursor write FLayerUnderCursor default False; 319 property CancelIfPassed: Boolean read FCancelIfPassed write FCancelIfPassed default False; 320 end; 265 321 266 322 TRubberbandLayer = class(TPositionedLayer) … … 273 329 FHandleFill: TColor32; 274 330 FHandles: TRBHandles; 275 FHandleSize: Integer;331 FHandleSize: TFloat; 276 332 FMinWidth: TFloat; 277 333 FMaxHeight: TFloat; … … 282 338 FOnConstrain: TRBConstrainEvent; 283 339 FOptions: TRBOptions; 340 FQuantized: Integer; 341 FPassMouse: TRubberbandPassMouse; 284 342 procedure SetFrameStippleStep(const Value: TFloat); 285 343 procedure SetFrameStippleCounter(const Value: TFloat); … … 288 346 procedure SetHandleFrame(Value: TColor32); 289 347 procedure SetHandles(Value: TRBHandles); 290 procedure SetHandleSize(Value: Integer);348 procedure SetHandleSize(Value: TFloat); 291 349 procedure SetOptions(const Value: TRBOptions); 350 procedure SetQuantized(const Value: Integer); 292 351 protected 293 IsDragging: Boolean;294 DragState: TDragState;295 OldLocation: TFloatRect;296 MouseShift: TFloatPoint;352 FIsDragging: Boolean; 353 FDragState: TRBDragState; 354 FOldLocation: TFloatRect; 355 FMouseShift: TFloatPoint; 297 356 function DoHitTest(X, Y: Integer): Boolean; override; 298 procedure DoResizing(var OldLocation, NewLocation: TFloatRect; DragState: T DragState; Shift: TShiftState); virtual;299 procedure DoConstrain(var OldLocation, NewLocation: TFloatRect; DragState: T DragState; Shift: TShiftState); virtual;357 procedure DoResizing(var OldLocation, NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState); virtual; 358 procedure DoConstrain(var OldLocation, NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState); virtual; 300 359 procedure DoSetLocation(const NewLocation: TFloatRect); override; 301 function GetDragState(X, Y: Integer): T DragState; virtual;360 function GetDragState(X, Y: Integer): TRBDragState; virtual; 302 361 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; 303 362 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; … … 306 365 procedure Paint(Buffer: TBitmap32); override; 307 366 procedure SetLayerOptions(Value: Cardinal); override; 367 procedure SetDragState(const Value: TRBDragState); overload; 368 procedure SetDragState(const Value: TRBDragState; const X, Y: Integer); overload; 308 369 procedure UpdateChildLayer; 370 procedure DrawHandle(Buffer: TBitmap32; X, Y: TFloat); virtual; 309 371 public 310 372 constructor Create(ALayerCollection: TLayerCollection); override; 373 destructor Destroy; override; 374 311 375 procedure SetFrameStipple(const Value: Array of TColor32); 376 procedure Quantize; 377 312 378 property ChildLayer: TPositionedLayer read FChildLayer write SetChildLayer; 313 379 property Options: TRBOptions read FOptions write SetOptions; 314 380 property Handles: TRBHandles read FHandles write SetHandles; 315 property HandleSize: Integerread FHandleSize write SetHandleSize;381 property HandleSize: TFloat read FHandleSize write SetHandleSize; 316 382 property HandleFill: TColor32 read FHandleFill write SetHandleFill; 317 383 property HandleFrame: TColor32 read FHandleFrame write SetHandleFrame; … … 322 388 property MinHeight: TFloat read FMinHeight write FMinHeight; 323 389 property MinWidth: TFloat read FMinWidth write FMinWidth; 390 property Quantized: Integer read FQuantized write SetQuantized default 8; 391 property PassMouseToChild: TRubberbandPassMouse read FPassMouse; 392 324 393 property OnUserChange: TNotifyEvent read FOnUserChange write FOnUserChange; 325 394 property OnConstrain: TRBConstrainEvent read FOnConstrain write FOnConstrain; … … 330 399 331 400 uses 332 TypInfo, GR32_Image, GR32_LowLevel, GR32_Resamplers, GR32_RepaintOpt ;401 TypInfo, GR32_Image, GR32_LowLevel, GR32_Resamplers, GR32_RepaintOpt, Types; 333 402 334 403 { mouse state mapping } … … 375 444 procedure TLayerCollection.BeginUpdate; 376 445 begin 377 if FUpdateCount = 0 then Changing; 446 if FUpdateCount = 0 then 447 Changing; 378 448 Inc(FUpdateCount); 379 449 end; … … 381 451 procedure TLayerCollection.Changed; 382 452 begin 383 if Assigned(FOnChange) then FOnChange(Self); 453 if Assigned(FOnChange) then 454 FOnChange(Self); 384 455 end; 385 456 386 457 procedure TLayerCollection.Changing; 387 458 begin 388 if Assigned(FOnChanging) then FOnChanging(Self); 459 if Assigned(FOnChanging) then 460 FOnChanging(Self); 389 461 end; 390 462 … … 415 487 begin 416 488 FUpdateCount := 1; // disable update notification 417 if Assigned(FItems) then Clear; 489 if Assigned(FItems) then 490 Clear; 418 491 FItems.Free; 419 492 inherited; … … 423 496 begin 424 497 Dec(FUpdateCount); 425 if FUpdateCount = 0 then Changed; 498 if FUpdateCount = 0 then 499 Changed; 426 500 Assert(FUpdateCount >= 0, 'Unpaired EndUpdate'); 427 501 end; … … 434 508 begin 435 509 Result := Items[I]; 436 if (Result.LayerOptions and OptionsMask) = 0 then Continue; // skip to the next one 510 if (Result.LayerOptions and OptionsMask) = 0 then 511 Continue; // skip to the next one 437 512 if Result.HitTest(X, Y) then Exit; 438 513 end; … … 442 517 procedure TLayerCollection.GDIUpdate; 443 518 begin 444 if (FUpdateCount = 0) and Assigned(FOnGDIUpdate) then FOnGDIUpdate(Self); 519 if (FUpdateCount = 0) and Assigned(FOnGDIUpdate) then 520 FOnGDIUpdate(Self); 445 521 end; 446 522 … … 538 614 begin 539 615 Result := MouseListener; 540 if Result = nil then Result := FindLayerAtPos(X, Y, LOB_MOUSE_EVENTS); 541 if Assigned(Result) then Result.MouseMove(Shift, X, Y) 542 else if FOwner is TControl then Screen.Cursor := TControl(FOwner).Cursor; 616 if Result = nil then 617 Result := FindLayerAtPos(X, Y, LOB_MOUSE_EVENTS); 618 619 if Assigned(Result) then 620 Result.MouseMove(Shift, X, Y) 621 else if FOwner is TControl then 622 Screen.Cursor := TControl(FOwner).Cursor; 543 623 end; 544 624 … … 546 626 begin 547 627 Result := MouseListener; 548 if Result = nil then Result := FindLayerAtPos(X, Y, LOB_MOUSE_EVENTS); 628 if Result = nil then 629 Result := FindLayerAtPos(X, Y, LOB_MOUSE_EVENTS); 549 630 550 631 if Assigned(Result) then … … 562 643 procedure TLayerCollection.Notify(Action: TLayerListNotification; Layer: TCustomLayer; Index: Integer); 563 644 begin 564 if Assigned(FOnListNotify) then FOnListNotify(Self, Action, Layer, Index); 645 if Assigned(FOnListNotify) then 646 FOnListNotify(Self, Action, Layer, Index); 565 647 end; 566 648 … … 607 689 procedure TLayerCollection.DoUpdateArea(const Rect: TRect); 608 690 begin 609 if Assigned(FOnAreaUpdated) then FOnAreaUpdated(Self, Rect, AREAINFO_RECT); 610 Changed; 691 if Assigned(FOnAreaUpdated) then 692 FOnAreaUpdated(Self, Rect, AREAINFO_RECT); 693 Changed; 611 694 end; 612 695 613 696 procedure TLayerCollection.DoUpdateLayer(Layer: TCustomLayer); 614 697 begin 615 if Assigned(FOnLayerUpdated) then FOnLayerUpdated(Self, Layer); 698 if Assigned(FOnLayerUpdated) then 699 FOnLayerUpdated(Self, Layer); 616 700 Changed; 617 701 end; … … 639 723 end; 640 724 725 726 {$IFDEF COMPILER2009_UP} 727 { TLayerEnum } 728 729 constructor TLayerEnum.Create(ALayerCollection: TLayerCollection); 730 begin 731 inherited Create; 732 FLayerCollection := ALayerCollection; 733 FIndex := -1; 734 end; 735 736 function TLayerEnum.GetCurrent: TCustomLayer; 737 begin 738 Result := FLayerCollection.Items[FIndex]; 739 end; 740 741 function TLayerEnum.MoveNext: Boolean; 742 begin 743 Result := FIndex < Pred(FLayerCollection.Count); 744 if Result then 745 Inc(FIndex); 746 end; 747 748 749 { TLayerCollectionHelper } 750 751 function TLayerCollectionHelper.GetEnumerator: TLayerEnum; 752 begin 753 Result := TLayerEnum.Create(Self); 754 end; 755 {$ENDIF} 756 757 641 758 { TCustomLayer } 642 759 760 constructor TCustomLayer.Create(ALayerCollection: TLayerCollection); 761 begin 762 LayerCollection := ALayerCollection; 763 FLayerOptions := LOB_VISIBLE; 764 end; 765 766 destructor TCustomLayer.Destroy; 767 var 768 I: Integer; 769 begin 770 if Assigned(FFreeNotifies) then 771 begin 772 for I := FFreeNotifies.Count - 1 downto 0 do 773 begin 774 TCustomLayer(FFreeNotifies[I]).Notification(Self); 775 if FFreeNotifies = nil then Break; 776 end; 777 FFreeNotifies.Free; 778 FFreeNotifies := nil; 779 end; 780 SetLayerCollection(nil); 781 inherited; 782 end; 783 643 784 procedure TCustomLayer.AddNotification(ALayer: TCustomLayer); 644 785 begin 645 if not Assigned(FFreeNotifies) then FFreeNotifies := TList.Create; 646 if FFreeNotifies.IndexOf(ALayer) < 0 then FFreeNotifies.Add(ALayer); 786 if not Assigned(FFreeNotifies) then 787 FFreeNotifies := TList.Create; 788 if FFreeNotifies.IndexOf(ALayer) < 0 then 789 FFreeNotifies.Add(ALayer); 647 790 end; 648 791 649 792 procedure TCustomLayer.BeforeDestruction; 650 793 begin 651 if Assigned(FOnDestroy) then FOnDestroy(Self); 794 if Assigned(FOnDestroy) then 795 FOnDestroy(Self); 652 796 inherited; 653 797 end; … … 664 808 begin 665 809 Update; 666 if Visible then FLayerCollection.Changed 810 if Visible then 811 FLayerCollection.Changed 667 812 else if (FLayerOptions and LOB_GDI_OVERLAY) <> 0 then 668 813 FLayerCollection.GDIUpdate; … … 678 823 begin 679 824 Update(Rect); 680 if Visible then FLayerCollection.Changed 825 if Visible then 826 FLayerCollection.Changed 681 827 else if (FLayerOptions and LOB_GDI_OVERLAY) <> 0 then 682 828 FLayerCollection.GDIUpdate; … … 694 840 end; 695 841 696 constructor TCustomLayer.Create(ALayerCollection: TLayerCollection); 697 begin 698 LayerCollection := ALayerCollection; 699 FLayerOptions := LOB_VISIBLE; 700 end; 701 702 destructor TCustomLayer.Destroy; 703 var 704 I: Integer; 705 begin 706 if Assigned(FFreeNotifies) then 707 begin 708 for I := FFreeNotifies.Count - 1 downto 0 do 709 begin 710 TCustomLayer(FFreeNotifies[I]).Notification(Self); 711 if FFreeNotifies = nil then Break; 712 end; 713 FFreeNotifies.Free; 714 FFreeNotifies := nil; 715 end; 716 SetLayerCollection(nil); 717 inherited; 842 procedure TCustomLayer.Click; 843 begin 844 FClicked := False; 845 if Assigned(FOnClick) then 846 FOnClick(Self); 847 end; 848 849 procedure TCustomLayer.DblClick; 850 begin 851 FClicked := False; 852 if Assigned(FOnDblClick) then 853 FOnDblClick(Self); 718 854 end; 719 855 720 856 function TCustomLayer.DoHitTest(X, Y: Integer): Boolean; 721 857 begin 722 Result := True;858 Result := Visible; 723 859 end; 724 860 … … 726 862 begin 727 863 Paint(Buffer); 728 if Assigned(FOnPaint) then FOnPaint(Self, Buffer); 864 if Assigned(FOnPaint) then 865 FOnPaint(Self, Buffer); 729 866 end; 730 867 … … 755 892 begin 756 893 Result := DoHitTest(X, Y); 757 if Assigned(FOnHitTest) then FOnHitTest(Self, X, Y, Result); 894 if Assigned(FOnHitTest) then 895 FOnHitTest(Self, X, Y, Result); 758 896 end; 759 897 760 898 procedure TCustomLayer.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 761 899 begin 762 if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y); 900 if (Button = mbLeft) then 901 begin 902 if (ssDouble in Shift) then 903 DblClick 904 else 905 FClicked := True; 906 end; 907 if Assigned(FOnMouseDown) then 908 FOnMouseDown(Self, Button, Shift, X, Y); 763 909 end; 764 910 … … 766 912 begin 767 913 Screen.Cursor := Cursor; 768 if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y); 914 if Assigned(FOnMouseMove) then 915 FOnMouseMove(Self, Shift, X, Y); 769 916 end; 770 917 … … 772 919 begin 773 920 Screen.Cursor := crDefault; 774 if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X, Y); 921 if (Button = mbLeft) and FClicked then 922 Click; 923 if Assigned(FOnMouseUp) then 924 FOnMouseUp(Self, Button, Shift, X, Y); 775 925 end; 776 926 … … 819 969 begin 820 970 FCursor := Value; 821 if FLayerCollection.MouseListener = Self then Screen.Cursor := Value; 971 if FLayerCollection.MouseListener = Self then 972 Screen.Cursor := Value; 822 973 end; 823 974 end; … … 857 1008 if Assigned(Value) then 858 1009 Value.InsertItem(Self); 1010 FLayerCollection := Value; 859 1011 end; 860 1012 end; … … 948 1100 begin 949 1101 with GetAdjustedRect(FLocation) do 950 Result := (X >= Left) and (X < Right) and (Y >= Top) and (Y < Bottom); 1102 Result := (X >= Left) and (X < Right) and (Y >= Top) and (Y < Bottom) and 1103 inherited DoHitTest(X, Y); 951 1104 end; 952 1105 … … 1076 1229 DstRect := MakeRect(GetAdjustedRect(FLocation)); 1077 1230 ClipRect := Buffer.ClipRect; 1078 IntersectRect(TempRect, ClipRect, DstRect);1079 if IsRectEmpty(TempRect) then Exit;1231 GR32.IntersectRect(TempRect, ClipRect, DstRect); 1232 if GR32.IsRectEmpty(TempRect) then Exit; 1080 1233 1081 1234 SrcRect := MakeRect(0, 0, Bitmap.Width, Bitmap.Height); … … 1090 1243 if (LayerWidth < 0.5) or (LayerHeight < 0.5) then Exit; 1091 1244 ImageRect := TCustomImage32(LayerCollection.FOwner).GetBitmapRect; 1092 IntersectRect(ClipRect, ClipRect, ImageRect);1245 GR32.IntersectRect(ClipRect, ClipRect, ImageRect); 1093 1246 end; 1094 1247 StretchTransfer(Buffer, DstRect, ClipRect, FBitmap, SrcRect, … … 1109 1262 end; 1110 1263 end; 1264 1265 1266 { TRubberbandPassMouse } 1267 1268 constructor TRubberbandPassMouse.Create(AOwner: TRubberbandLayer); 1269 begin 1270 FOwner := AOwner; 1271 FEnabled := False; 1272 FToChild := False; 1273 FLayerUnderCursor := False; 1274 FCancelIfPassed := False; 1275 end; 1276 1277 function TRubberbandPassMouse.GetChildUnderCursor(X, Y: Integer): TPositionedLayer; 1278 var 1279 Layer: TCustomLayer; 1280 Index: Integer; 1281 begin 1282 Result := nil; 1283 for Index := FOwner.LayerCollection.Count - 1 downto 0 do 1284 begin 1285 Layer := FOwner.LayerCollection.Items[Index]; 1286 if ((Layer.LayerOptions and LOB_MOUSE_EVENTS) > 0) and 1287 (Layer is TPositionedLayer) and Layer.HitTest(X, Y) then 1288 begin 1289 Result := TPositionedLayer(Layer); 1290 Exit; 1291 end; 1292 end; 1293 end; 1294 1111 1295 1112 1296 { TRubberbandLayer } … … 1121 1305 FMinWidth := 10; 1122 1306 FMinHeight := 10; 1307 FQuantized := 8; 1123 1308 FLayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS; 1124 1309 SetFrameStipple([clWhite32, clWhite32, clBlack32, clBlack32]); 1310 FPassMouse := TRubberbandPassMouse.Create(Self); 1125 1311 FFrameStippleStep := 1; 1126 1312 FFrameStippleCounter := 0; 1127 1313 end; 1128 1314 1315 destructor TRubberbandLayer.Destroy; 1316 begin 1317 FPassMouse.Free; 1318 inherited; 1319 end; 1320 1129 1321 function TRubberbandLayer.DoHitTest(X, Y: Integer): Boolean; 1130 1322 begin 1131 Result := GetDragState(X, Y) <> dsNone; 1323 if (Visible) then 1324 Result := (GetDragState(X, Y) <> dsNone) 1325 else 1326 Result := False; 1132 1327 end; 1133 1328 1134 1329 procedure TRubberbandLayer.DoResizing(var OldLocation, 1135 NewLocation: TFloatRect; DragState: T DragState; Shift: TShiftState);1330 NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState); 1136 1331 begin 1137 1332 if Assigned(FOnResizing) then … … 1140 1335 1141 1336 procedure TRubberbandLayer.DoConstrain(var OldLocation, 1142 NewLocation: TFloatRect; DragState: T DragState; Shift: TShiftState);1337 NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState); 1143 1338 begin 1144 1339 if Assigned(FOnConstrain) then … … 1152 1347 end; 1153 1348 1154 function TRubberbandLayer.GetDragState(X, Y: Integer): T DragState;1349 function TRubberbandLayer.GetDragState(X, Y: Integer): TRBDragState; 1155 1350 var 1156 1351 R: TRect; … … 1158 1353 dl, dt, dr, db, dx, dy: Boolean; 1159 1354 Sz: Integer; 1355 const 1356 DragZone = 1; 1160 1357 begin 1161 1358 Result := dsNone; 1162 Sz := FHandleSize + 1;1359 Sz := Ceil(FHandleSize + DragZone); 1163 1360 dh_center := rhCenter in FHandles; 1164 1361 dh_sides := rhSides in FHandles; … … 1186 1383 else if dl and dy and dh_sides and not(rhNotLeftSide in FHandles) then Result := dsSizeL 1187 1384 else if dt and dx and dh_sides and not(rhNotTopSide in FHandles) then Result := dsSizeT 1188 else if dh_center and PtInRect(R,Point(X, Y)) then Result := dsMove;1385 else if dh_center and GR32.PtInRect(R, GR32.Point(X, Y)) then Result := dsMove; 1189 1386 end; 1190 1387 1191 1388 procedure TRubberbandLayer.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 1192 1389 var 1193 ALoc: TFloatRect; 1194 begin 1195 if IsDragging then Exit; 1196 DragState := GetDragState(X, Y); 1197 IsDragging := DragState <> dsNone; 1198 if IsDragging then 1199 begin 1200 OldLocation := Location; 1201 1202 ALoc := GetAdjustedRect(FLocation); 1203 case DragState of 1204 dsMove: MouseShift := FloatPoint(X - ALoc.Left, Y - ALoc.Top); 1390 PositionedLayer: TPositionedLayer; 1391 begin 1392 if FPassMouse.Enabled then 1393 begin 1394 if FPassMouse.ToLayerUnderCursor then 1395 PositionedLayer := FPassMouse.GetChildUnderCursor(X, Y) 1205 1396 else 1206 MouseShift := FloatPoint(0, 0); 1207 end; 1208 end; 1397 PositionedLayer := ChildLayer; 1398 1399 if FPassMouse.ToChild and Assigned(ChildLayer) then 1400 begin 1401 ChildLayer.MouseDown(Button, Shift, X, Y); 1402 if FPassMouse.CancelIfPassed then 1403 Exit; 1404 end; 1405 1406 if (PositionedLayer <> ChildLayer) and Assigned(PositionedLayer) then 1407 begin 1408 PositionedLayer.MouseDown(Button, Shift, X, Y); 1409 if FPassMouse.CancelIfPassed then 1410 Exit; 1411 end; 1412 end; 1413 1414 if FIsDragging then Exit; 1415 SetDragState(GetDragState(X, Y), X, Y); 1209 1416 inherited; 1210 1417 end; … … 1212 1419 procedure TRubberbandLayer.MouseMove(Shift: TShiftState; X, Y: Integer); 1213 1420 const 1214 CURSOR_ID: array [T DragState] of TCursor = (crDefault, crDefault, crSizeWE,1421 CURSOR_ID: array [TRBDragState] of TCursor = (crDefault, crDefault, crSizeWE, 1215 1422 crSizeNS, crSizeWE, crSizeNS, crSizeNWSE, crSizeNESW, crSizeNESW, crSizeNWSE); 1216 1423 var 1217 1424 Mx, My: TFloat; 1218 1425 L, T, R, B, W, H: TFloat; 1426 Quantize: Boolean; 1219 1427 ALoc, NewLocation: TFloatRect; 1220 1428 … … 1234 1442 1235 1443 begin 1236 if not IsDragging then 1237 begin 1238 DragState := GetDragState(X, Y); 1239 if DragState = dsMove then Screen.Cursor := Cursor 1240 else Screen.Cursor := CURSOR_ID[DragState]; 1444 if not FIsDragging then 1445 begin 1446 FDragState := GetDragState(X, Y); 1447 if FDragState = dsMove then 1448 Screen.Cursor := Cursor 1449 else 1450 Screen.Cursor := CURSOR_ID[FDragState]; 1241 1451 end 1242 1452 else 1243 1453 begin 1244 Mx := X - MouseShift.X;1245 My := Y - MouseShift.Y;1454 Mx := X - FMouseShift.X; 1455 My := Y - FMouseShift.Y; 1246 1456 if Scaled then 1247 1457 with Location do 1248 1458 begin 1249 1459 ALoc := GetAdjustedRect(FLocation); 1250 if IsRectEmpty(ALoc) then Exit;1460 if GR32.IsRectEmpty(ALoc) then Exit; 1251 1461 Mx := (Mx - ALoc.Left) / (ALoc.Right - ALoc.Left) * (Right - Left) + Left; 1252 1462 My := (My - ALoc.Top) / (ALoc.Bottom - ALoc.Top) * (Bottom - Top) + Top; 1253 1463 end; 1254 1464 1255 with OldLocation do1465 with FOldLocation do 1256 1466 begin 1257 1467 L := Left; … … 1263 1473 end; 1264 1474 1265 if DragState = dsMove then 1475 Quantize := (roQuantized in Options) and not (ssAlt in Shift); 1476 1477 if FDragState = dsMove then 1266 1478 begin 1267 1479 L := Mx; 1268 1480 T := My; 1481 if Quantize then 1482 begin 1483 L := Round(L / FQuantized) * FQuantized; 1484 T := Round(T / FQuantized) * FQuantized; 1485 end; 1269 1486 R := L + W; 1270 1487 B := T + H; … … 1272 1489 else 1273 1490 begin 1274 if DragState in [dsSizeL, dsSizeTL, dsSizeBL] then 1491 if FDragState in [dsSizeL, dsSizeTL, dsSizeBL] then 1492 begin 1275 1493 IncLT(L, R, Mx - L, MinWidth, MaxWidth); 1276 1277 if DragState in [dsSizeR, dsSizeTR, dsSizeBR] then 1494 if Quantize then 1495 L := Round(L / FQuantized) * FQuantized; 1496 end; 1497 1498 if FDragState in [dsSizeR, dsSizeTR, dsSizeBR] then 1499 begin 1278 1500 IncRB(L, R, Mx - R, MinWidth, MaxWidth); 1279 1280 if DragState in [dsSizeT, dsSizeTL, dsSizeTR] then 1501 if Quantize then 1502 R := Round(R / FQuantized) * FQuantized; 1503 end; 1504 1505 if FDragState in [dsSizeT, dsSizeTL, dsSizeTR] then 1506 begin 1281 1507 IncLT(T, B, My - T, MinHeight, MaxHeight); 1282 1283 if DragState in [dsSizeB, dsSizeBL, dsSizeBR] then 1508 if Quantize then 1509 T := Round(T / FQuantized) * FQuantized; 1510 end; 1511 1512 if FDragState in [dsSizeB, dsSizeBL, dsSizeBR] then 1513 begin 1284 1514 IncRB(T, B, My - B, MinHeight, MaxHeight); 1515 if Quantize then 1516 B := Round(B / FQuantized) * FQuantized; 1517 end; 1285 1518 end; 1286 1519 … … 1288 1521 1289 1522 if roConstrained in FOptions then 1290 DoConstrain( OldLocation, NewLocation,DragState, Shift);1523 DoConstrain(FOldLocation, NewLocation, FDragState, Shift); 1291 1524 1292 1525 if roProportional in FOptions then 1293 1526 begin 1294 case DragState of1527 case FDragState of 1295 1528 dsSizeB, dsSizeBR: 1296 NewLocation.Right := OldLocation.Left + (OldLocation.Right - OldLocation.Left) * (NewLocation.Bottom - NewLocation.Top) / (OldLocation.Bottom -OldLocation.Top);1529 NewLocation.Right := FOldLocation.Left + (FOldLocation.Right - FOldLocation.Left) * (NewLocation.Bottom - NewLocation.Top) / (FOldLocation.Bottom - FOldLocation.Top); 1297 1530 dsSizeT, dsSizeTL: 1298 NewLocation.Left := OldLocation.Right - (OldLocation.Right - OldLocation.Left) * (NewLocation.Bottom - NewLocation.Top) / (OldLocation.Bottom -OldLocation.Top);1531 NewLocation.Left := FOldLocation.Right - (FOldLocation.Right - FOldLocation.Left) * (NewLocation.Bottom - NewLocation.Top) / (FOldLocation.Bottom - FOldLocation.Top); 1299 1532 dsSizeR, dsSizeBL: 1300 NewLocation.Bottom := OldLocation.Top + (OldLocation.Bottom - OldLocation.Top) * (NewLocation.Right - NewLocation.Left) / (OldLocation.Right -OldLocation.Left);1533 NewLocation.Bottom := FOldLocation.Top + (FOldLocation.Bottom - FOldLocation.Top) * (NewLocation.Right - NewLocation.Left) / (FOldLocation.Right - FOldLocation.Left); 1301 1534 dsSizeL, dsSizeTR: 1302 NewLocation.Top := OldLocation.Bottom - (OldLocation.Bottom - OldLocation.Top) * (NewLocation.Right - NewLocation.Left) / (OldLocation.Right -OldLocation.Left);1535 NewLocation.Top := FOldLocation.Bottom - (FOldLocation.Bottom - FOldLocation.Top) * (NewLocation.Right - NewLocation.Left) / (FOldLocation.Right - FOldLocation.Left); 1303 1536 end; 1304 1537 end; 1305 1538 1306 DoResizing( OldLocation, NewLocation,DragState, Shift);1539 DoResizing(FOldLocation, NewLocation, FDragState, Shift); 1307 1540 1308 1541 if (NewLocation.Left <> Location.Left) or … … 1312 1545 begin 1313 1546 Location := NewLocation; 1314 if Assigned(FOnUserChange) then FOnUserChange(Self); 1547 if Assigned(FOnUserChange) then 1548 FOnUserChange(Self); 1315 1549 end; 1316 1550 end; … … 1318 1552 1319 1553 procedure TRubberbandLayer.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 1320 begin 1321 IsDragging := False; 1554 var 1555 PositionedLayer: TPositionedLayer; 1556 begin 1557 if FPassMouse.Enabled then 1558 begin 1559 if FPassMouse.ToLayerUnderCursor then 1560 PositionedLayer := FPassMouse.GetChildUnderCursor(X, Y) 1561 else 1562 PositionedLayer := ChildLayer; 1563 1564 if FPassMouse.ToChild and Assigned(ChildLayer) then 1565 begin 1566 ChildLayer.MouseUp(Button, Shift, X, Y); 1567 if FPassMouse.CancelIfPassed then 1568 Exit; 1569 end; 1570 1571 if (PositionedLayer <> ChildLayer) and Assigned(PositionedLayer) then 1572 begin 1573 PositionedLayer.MouseUp(Button, Shift, X, Y); 1574 if FPassMouse.CancelIfPassed then 1575 Exit; 1576 end; 1577 end; 1578 1579 FIsDragging := False; 1322 1580 inherited; 1323 1581 end; … … 1329 1587 end; 1330 1588 1589 procedure TRubberbandLayer.DrawHandle(Buffer: TBitmap32; X, Y: TFloat); 1590 var 1591 HandleRect: TRect; 1592 begin 1593 // Coordinate specifies exact center of handle. I.e. center of 1594 // pixel if handle is odd number of pixels wide. 1595 1596 HandleRect.Left := Floor(X - FHandleSize); 1597 HandleRect.Right := HandleRect.Left + Ceil(FHandleSize*2); 1598 HandleRect.Top := Floor(Y - FHandleSize); 1599 HandleRect.Bottom := HandleRect.Top + Ceil(FHandleSize*2); 1600 1601 Buffer.FrameRectTS(HandleRect, FHandleFrame); 1602 1603 GR32.InflateRect(HandleRect, -1, -1); 1604 Buffer.FillRectTS(HandleRect, FHandleFill); 1605 end; 1606 1331 1607 procedure TRubberbandLayer.Paint(Buffer: TBitmap32); 1332 var 1333 Cx, Cy: Integer; 1608 1609 var 1610 CenterX, CenterY: TFloat; 1334 1611 R: TRect; 1335 1336 procedure DrawHandle(X, Y: Integer);1337 begin1338 Buffer.FillRectTS(X - FHandleSize, Y - FHandleSize, X + FHandleSize, Y + FHandleSize, FHandleFill);1339 Buffer.FrameRectTS(X - FHandleSize, Y - FHandleSize, X + FHandleSize, Y + FHandleSize, FHandleFrame);1340 end;1341 1342 1612 begin 1343 1613 R := MakeRect(GetAdjustedRect(FLocation)); … … 1354 1624 if rhCorners in FHandles then 1355 1625 begin 1356 if not(rhNotTLCorner in FHandles) then DrawHandle( Left, Top);1357 if not(rhNotTRCorner in FHandles) then DrawHandle( Right, Top);1358 if not(rhNotBLCorner in FHandles) then DrawHandle( Left, Bottom);1359 if not(rhNotBRCorner in FHandles) then DrawHandle( Right, Bottom);1626 if not(rhNotTLCorner in FHandles) then DrawHandle(Buffer, Left+0.5, Top+0.5); 1627 if not(rhNotTRCorner in FHandles) then DrawHandle(Buffer, Right-0.5, Top+0.5); 1628 if not(rhNotBLCorner in FHandles) then DrawHandle(Buffer, Left+0.5, Bottom-0.5); 1629 if not(rhNotBRCorner in FHandles) then DrawHandle(Buffer, Right-0.5, Bottom-0.5); 1360 1630 end; 1361 1631 if rhSides in FHandles then 1362 1632 begin 1363 Cx := (Left + Right) div 2; 1364 Cy := (Top + Bottom) div 2; 1365 if not(rhNotTopSide in FHandles) then DrawHandle(Cx, Top); 1366 if not(rhNotLeftSide in FHandles) then DrawHandle(Left, Cy); 1367 if not(rhNotRightSide in FHandles) then DrawHandle(Right, Cy); 1368 if not(rhNotBottomSide in FHandles) then DrawHandle(Cx, Bottom); 1369 end; 1370 end; 1633 CenterX := (Left + Right) / 2; 1634 CenterY := (Top + Bottom) / 2; 1635 if not(rhNotTopSide in FHandles) then DrawHandle(Buffer, CenterX, Top+0.5); 1636 if not(rhNotLeftSide in FHandles) then DrawHandle(Buffer, Left+0.5, CenterY); 1637 if not(rhNotRightSide in FHandles) then DrawHandle(Buffer, Right-0.5, CenterY); 1638 if not(rhNotBottomSide in FHandles) then DrawHandle(Buffer, CenterX, Bottom-0.5); 1639 end; 1640 end; 1641 end; 1642 1643 procedure TRubberbandLayer.Quantize; 1644 begin 1645 Location := FloatRect( 1646 Round(Location.Left / Quantized) * Quantized, 1647 Round(Location.Top / Quantized) * Quantized, 1648 Round(Location.Right / Quantized) * Quantized, 1649 Round(Location.Bottom / Quantized) * Quantized); 1371 1650 end; 1372 1651 … … 1385 1664 end; 1386 1665 1666 procedure TRubberbandLayer.SetDragState(const Value: TRBDragState); 1667 begin 1668 SetDragState(Value, 0, 0); 1669 end; 1670 1671 procedure TRubberbandLayer.SetDragState(const Value: TRBDragState; const X, Y: Integer); 1672 var 1673 ALoc: TFloatRect; 1674 begin 1675 FDragState := Value; 1676 FIsDragging := FDragState <> dsNone; 1677 1678 if FIsDragging then 1679 begin 1680 FOldLocation := Location; 1681 1682 ALoc := GetAdjustedRect(FLocation); 1683 1684 case FDragState of 1685 dsMove: FMouseShift := FloatPoint(X - ALoc.Left, Y - ALoc.Top); 1686 else 1687 FMouseShift := FloatPoint(0, 0); 1688 end; 1689 end; 1690 end; 1691 1387 1692 procedure TRubberbandLayer.SetHandleFill(Value: TColor32); 1388 1693 begin … … 1412 1717 end; 1413 1718 1414 procedure TRubberbandLayer.SetHandleSize(Value: Integer); 1415 begin 1416 if Value < 1 then Value := 1; 1719 procedure TRubberbandLayer.SetHandleSize(Value: TFloat); 1720 begin 1721 if Value < 1 then 1722 Value := 1; 1417 1723 if Value <> FHandleSize then 1418 1724 begin … … 1466 1772 end; 1467 1773 1774 procedure TRubberbandLayer.SetQuantized(const Value: Integer); 1775 begin 1776 if Value < 1 then 1777 raise Exception.Create('Value must be larger than zero!'); 1778 1779 FQuantized := Value; 1780 end; 1781 1468 1782 end. -
GraphicTest/Packages/Graphics32/GR32_LowLevel.pas
r450 r522 49 49 50 50 uses 51 Graphics, GR32, GR32_Math , GR32_System, GR32_Bindings;51 Graphics, GR32, GR32_Math; 52 52 53 53 { Clamp function restricts value to [0..255] range } … … 68 68 procedure MoveWord(const Source; var Dest; Count: Integer); 69 69 70 {$IFDEF USESTACKALLOC} 70 71 { Allocates a 'small' block of memory on the stack } 71 72 function StackAlloc(Size: Integer): Pointer; register; … … 73 74 { Pops memory allocated by StackAlloc } 74 75 procedure StackFree(P: Pointer); register; 76 {$ENDIF} 75 77 76 78 { Exchange two 32-bit values } … … 79 81 procedure Swap(var A, B: TFixed); overload;{$IFDEF USEINLINING} inline; {$ENDIF} 80 82 procedure Swap(var A, B: TColor32); overload;{$IFDEF USEINLINING} inline; {$ENDIF} 83 procedure Swap32(var A, B); overload;{$IFDEF USEINLINING} inline; {$ENDIF} 81 84 82 85 { Exchange A <-> B only if B < A } … … 147 150 148 151 { shift right with sign conservation } 152 function SAR_3(Value: Integer): Integer; 149 153 function SAR_4(Value: Integer): Integer; 154 function SAR_6(Value: Integer): Integer; 150 155 function SAR_8(Value: Integer): Integer; 151 156 function SAR_9(Value: Integer): Integer; … … 162 167 implementation 163 168 169 uses 164 170 {$IFDEF FPC} 165 uses 166 SysUtils; 167 {$ENDIF} 171 SysUtils, 172 {$ENDIF} 173 GR32_System, GR32_Bindings; 168 174 169 175 {$R-}{$Q-} // switch off overflow and range checking … … 172 178 {$IFDEF USENATIVECODE} 173 179 begin 174 if Value > 255 then Result := 255 175 else if Value < 0 then Result := 0 176 else Result := Value; 177 {$ELSE} 180 if Value > 255 then 181 Result := 255 182 else 183 if Value < 0 then 184 Result := 0 185 else 186 Result := Value; 187 {$ELSE} 188 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 178 189 asm 179 190 {$IFDEF TARGET_x64} … … 202 213 203 214 {$IFNDEF PUREPASCAL} 204 procedure FillLongword_ASM(var X; Count: Cardinal; Value: Longword); 215 procedure FillLongword_ASM(var X; Count: Cardinal; Value: Longword); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 205 216 asm 206 217 {$IFDEF TARGET_x86} … … 232 243 end; 233 244 234 procedure FillLongword_MMX(var X; Count: Cardinal; Value: Longword); 245 procedure FillLongword_MMX(var X; Count: Cardinal; Value: Longword); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 235 246 asm 236 247 {$IFDEF TARGET_x86} … … 301 312 end; 302 313 303 procedure FillLongword_SSE2(var X; Count: Integer; Value: Longword); 314 procedure FillLongword_SSE2(var X; Count: Integer; Value: Longword); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 304 315 asm 305 316 {$IFDEF TARGET_x86} … … 363 374 {$IFDEF TARGET_x64} 364 375 // RCX = X; RDX = Count; R8 = Value 365 TEST EDX,EDX // if Count = 0 then 366 JZ @Exit // Exit 367 MOV RAX, RCX // RAX = X 368 369 PUSH RDI // store RDI on stack 370 MOV R9, RDX // R9 = Count 371 MOV RDI, RDX // RDI = Count 372 373 SHR RDI, 1 // RDI = RDI SHR 1 374 SHL RDI, 1 // RDI = RDI SHL 1 375 SUB R9, RDI // check if extra fill is necessary 376 JE @QLoopIni 377 378 MOV [RAX], R8D // eventually perform extra fill 379 ADD RAX, 4 // Inc(X, 4) 380 DEC RDX // Dec(Count) 381 JZ @ExitPOP // if (Count = 0) then Exit 382 @QLoopIni: 383 MOVD XMM0, R8D // XMM0 = R8D 384 PUNPCKLDQ XMM0, XMM0 // unpack XMM0 register 385 SHR RDX, 1 // RDX = RDX div 2 386 @QLoop: 387 MOVQ QWORD PTR [RAX], XMM0 // perform fill 388 ADD RAX, 8 // Inc(X, 8) 389 DEC RDX // Dec(X); 390 JNZ @QLoop 391 EMMS 392 @ExitPOP: 393 POP RDI 376 377 TEST RDX, RDX // if Count = 0 then 378 JZ @Exit // Exit 379 380 MOV R9, RCX // Point R9 to destination 381 382 CMP RDX, 32 383 JL @SmallLoop 384 385 AND RCX, 3 // get aligned count 386 TEST RCX, RCX // check if X is not dividable by 4 387 JNZ @SmallLoop // otherwise perform slow small loop 388 389 MOV RCX, R9 390 SHR RCX, 2 // bytes to count 391 AND RCX, 3 // get aligned count 392 ADD RCX,-4 393 NEG RCX // get count to advance 394 JZ @SetupMain 395 SUB RDX, RCX // subtract aligning start from total count 396 397 @AligningLoop: 398 MOV [R9], R8D 399 ADD R9, 4 400 DEC RCX 401 JNZ @AligningLoop 402 403 @SetupMain: 404 MOV RCX, RDX // RCX = remaining count 405 SHR RCX, 2 406 SHL RCX, 2 407 SUB RDX, RCX // RDX = remaining count 408 SHR RCX, 2 409 410 MOVD XMM0, R8D 411 PUNPCKLDQ XMM0, XMM0 412 PUNPCKLDQ XMM0, XMM0 413 @SSE2Loop: 414 MOVDQA [R9], XMM0 415 ADD R9, 16 416 DEC RCX 417 JNZ @SSE2Loop 418 419 TEST RDX, RDX 420 JZ @Exit 421 @SmallLoop: 422 MOV [R9], R8D 423 ADD R9, 4 424 DEC RDX 425 JNZ @SmallLoop 394 426 @Exit: 395 427 {$ENDIF} … … 407 439 P[I] := Value; 408 440 {$ELSE} 441 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 409 442 asm 410 443 {$IFDEF TARGET_x86} … … 445 478 Move(Source, Dest, Count shl 2); 446 479 {$ELSE} 480 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 447 481 asm 448 482 {$IFDEF TARGET_x86} … … 486 520 Move(Source, Dest, Count shl 1); 487 521 {$ELSE} 522 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 488 523 asm 489 524 {$IFDEF TARGET_x86} … … 557 592 A := B; 558 593 B := T; 594 end; 595 596 procedure Swap32(var A, B); 597 var 598 T: Integer; 599 begin 600 T := Integer(A); 601 Integer(A) := Integer(B); 602 Integer(B) := T; 559 603 end; 560 604 … … 613 657 Result := Value; 614 658 {$ELSE} 659 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 615 660 asm 616 661 {$IFDEF TARGET_x64} … … 651 696 Result := C; 652 697 {$ELSE} 698 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 653 699 asm 654 700 {$IFDEF TARGET_x64} … … 674 720 Result := C; 675 721 {$ELSE} 722 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 676 723 asm 677 724 {$IFDEF TARGET_x64} … … 696 743 Result := Value; 697 744 {$ELSE} 745 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 698 746 asm 699 747 {$IFDEF TARGET_x64} … … 725 773 Result := Value; 726 774 {$ELSE} 775 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 727 776 asm 728 777 {$IFDEF TARGET_x64} … … 743 792 Result := Max + (Value - Max) mod (Max + 1) 744 793 else 745 Result := (Value) mod (Max + 1); 746 {$ELSE} 794 Result := Value mod (Max + 1); 795 {$ELSE} 796 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 747 797 asm 748 798 {$IFDEF TARGET_x64} … … 776 826 Result := FloatMod(Value, Max); 777 827 {$ELSE} 828 if Max = 0 then 829 begin 830 Result := 0; 831 Exit; 832 end; 833 778 834 Result := Value; 779 835 while Result >= Max do Result := Result - Max; … … 788 844 Result := Dividend div Divisor; 789 845 {$ELSE} 846 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 790 847 asm 791 848 {$IFDEF TARGET_x86} … … 826 883 Result := Max - Result; 827 884 {$ELSE} 885 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 828 886 asm 829 887 {$IFDEF TARGET_x64} … … 861 919 Inc(Result, Min); 862 920 end; 863 if Odd(DivResult) then Result := Max +Min-Result;921 if Odd(DivResult) then Result := Max + Min - Result; 864 922 end; 865 923 … … 979 1037 980 1038 { shift right with sign conservation } 1039 function SAR_3(Value: Integer): Integer; 1040 {$IFDEF PUREPASCAL} 1041 begin 1042 Result := Value div 8; 1043 {$ELSE} 1044 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1045 asm 1046 {$IFDEF TARGET_x64} 1047 MOV EAX,ECX 1048 {$ENDIF} 1049 SAR EAX,3 1050 {$ENDIF} 1051 end; 1052 981 1053 function SAR_4(Value: Integer): Integer; 982 {$IFDEF USENATIVECODE}1054 {$IFDEF PUREPASCAL} 983 1055 begin 984 1056 Result := Value div 16; 985 1057 {$ELSE} 1058 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 986 1059 asm 987 1060 {$IFDEF TARGET_x64} … … 992 1065 end; 993 1066 1067 function SAR_6(Value: Integer): Integer; 1068 {$IFDEF PUREPASCAL} 1069 begin 1070 Result := Value div 64; 1071 {$ELSE} 1072 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1073 asm 1074 {$IFDEF TARGET_x64} 1075 MOV EAX,ECX 1076 {$ENDIF} 1077 SAR EAX,6 1078 {$ENDIF} 1079 end; 1080 994 1081 function SAR_8(Value: Integer): Integer; 995 {$IFDEF USENATIVECODE}1082 {$IFDEF PUREPASCAL} 996 1083 begin 997 1084 Result := Value div 256; 998 1085 {$ELSE} 1086 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 999 1087 asm 1000 1088 {$IFDEF TARGET_x64} … … 1006 1094 1007 1095 function SAR_9(Value: Integer): Integer; 1008 {$IFDEF USENATIVECODE}1096 {$IFDEF PUREPASCAL} 1009 1097 begin 1010 1098 Result := Value div 512; 1011 1099 {$ELSE} 1100 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1012 1101 asm 1013 1102 {$IFDEF TARGET_x64} … … 1019 1108 1020 1109 function SAR_11(Value: Integer): Integer; 1021 {$IFDEF USENATIVECODE}1110 {$IFDEF PUREPASCAL} 1022 1111 begin 1023 1112 Result := Value div 2048; 1024 1113 {$ELSE} 1114 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1025 1115 asm 1026 1116 {$IFDEF TARGET_x64} … … 1032 1122 1033 1123 function SAR_12(Value: Integer): Integer; 1034 {$IFDEF USENATIVECODE}1124 {$IFDEF PUREPASCAL} 1035 1125 begin 1036 1126 Result := Value div 4096; 1037 1127 {$ELSE} 1128 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1038 1129 asm 1039 1130 {$IFDEF TARGET_x64} … … 1045 1136 1046 1137 function SAR_13(Value: Integer): Integer; 1047 {$IFDEF USENATIVECODE}1138 {$IFDEF PUREPASCAL} 1048 1139 begin 1049 1140 Result := Value div 8192; 1050 1141 {$ELSE} 1142 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1051 1143 asm 1052 1144 {$IFDEF TARGET_x64} … … 1058 1150 1059 1151 function SAR_14(Value: Integer): Integer; 1060 {$IFDEF USENATIVECODE}1152 {$IFDEF PUREPASCAL} 1061 1153 begin 1062 1154 Result := Value div 16384; 1063 1155 {$ELSE} 1156 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1064 1157 asm 1065 1158 {$IFDEF TARGET_x64} … … 1071 1164 1072 1165 function SAR_15(Value: Integer): Integer; 1073 {$IFDEF USENATIVECODE}1166 {$IFDEF PUREPASCAL} 1074 1167 begin 1075 1168 Result := Value div 32768; 1076 1169 {$ELSE} 1170 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1077 1171 asm 1078 1172 {$IFDEF TARGET_x64} … … 1084 1178 1085 1179 function SAR_16(Value: Integer): Integer; 1086 {$IFDEF USENATIVECODE}1180 {$IFDEF PUREPASCAL} 1087 1181 begin 1088 1182 Result := Value div 65536; 1089 1183 {$ELSE} 1184 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1090 1185 asm 1091 1186 {$IFDEF TARGET_x64} … … 1108 1203 REn.B := WCEn.R; 1109 1204 {$ELSE} 1205 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1110 1206 asm 1111 1207 // EAX = WinColor … … 1121 1217 end; 1122 1218 1219 {$IFDEF USESTACKALLOC} 1123 1220 {$IFDEF PUREPASCAL} 1124 1221 function StackAlloc(Size: Integer): Pointer; … … 1138 1235 x64 implementation by Jameel Halabi 1139 1236 } 1140 function StackAlloc(Size: Integer): Pointer; register; 1237 function StackAlloc(Size: Integer): Pointer; register; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1141 1238 asm 1142 1239 {$IFDEF TARGET_x86} … … 1163 1260 {$ENDIF} 1164 1261 {$IFDEF TARGET_x64} 1165 MOV RAX, RCX 1262 {$IFNDEF FPC} 1263 .NOFRAME 1264 {$ENDIF} 1166 1265 POP R8 // return address 1167 1266 MOV RDX, RSP // original SP 1168 1267 ADD ECX, 15 1169 1268 AND ECX, NOT 15 // round up to keep SP dqword aligned 1170 CMP ECX, 40 921269 CMP ECX, 4088 1171 1270 JLE @@2 1172 1271 @@1: 1173 SUB RSP, 40 921272 SUB RSP, 4088 1174 1273 PUSH RCX // make sure we touch guard page, to grow stack 1175 1274 SUB ECX, 4096 … … 1183 1282 SUB RDX, 8 1184 1283 PUSH RDX // save current SP, for sanity check (sp = [sp]) 1284 PUSH R8 // return to caller 1185 1285 {$ENDIF} 1186 1286 end; … … 1196 1296 corrupt the stack. Worst case is that the stack block is not released until 1197 1297 the calling routine exits. } 1198 procedure StackFree(P: Pointer); register; 1298 procedure StackFree(P: Pointer); register; {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1199 1299 asm 1200 1300 {$IFDEF TARGET_x86} 1201 POP ECX { return address }1301 POP ECX // return address 1202 1302 MOV EDX, DWORD PTR [ESP] 1203 1303 SUB EAX, 8 1204 CMP EDX, ESP { sanity check #1 (SP = [SP]) }1304 CMP EDX, ESP // sanity check #1 (SP = [SP]) 1205 1305 JNE @Exit 1206 CMP EDX, EAX { sanity check #2 (P = this stack block) }1306 CMP EDX, EAX // sanity check #2 (P = this stack block) 1207 1307 JNE @Exit 1208 MOV ESP, DWORD PTR [ESP+4] { restore previous SP }1308 MOV ESP, DWORD PTR [ESP+4] // restore previous SP 1209 1309 @Exit: 1210 PUSH ECX { return to caller } 1211 {$ENDIF} 1212 {$IFDEF TARGET_x64} 1213 POP R8 { return address } 1310 PUSH ECX // return to caller 1311 {$ENDIF} 1312 {$IFDEF TARGET_x64} 1313 {$IFNDEF FPC} 1314 .NOFRAME 1315 {$ENDIF} 1316 POP R8 // return address 1214 1317 MOV RDX, QWORD PTR [RSP] 1215 1318 SUB RCX, 16 1216 CMP RDX, RSP { sanity check #1 (SP = [SP]) }1319 CMP RDX, RSP // sanity check #1 (SP = [SP]) 1217 1320 JNE @Exit 1218 CMP RDX, RCX { sanity check #2 (P = this stack block) }1321 CMP RDX, RCX // sanity check #2 (P = this stack block) 1219 1322 JNE @Exit 1220 MOV RSP, QWORD PTR [RSP + 8] { restore previous SP }1323 MOV RSP, QWORD PTR [RSP + 8] // restore previous SP 1221 1324 @Exit: 1222 PUSH R8 { return to caller } 1223 {$ENDIF} 1224 end; 1325 PUSH R8 // return to caller 1326 {$ENDIF} 1327 end; 1328 {$ENDIF} 1225 1329 {$ENDIF} 1226 1330 -
GraphicTest/Packages/Graphics32/GR32_Math.pas
r450 r522 59 59 procedure SinCos(const Theta: TFloat; out Sin, Cos: TFloat); overload; 60 60 procedure SinCos(const Theta, Radius: Single; out Sin, Cos: Single); overload; 61 procedure SinCos(const Theta, ScaleX, ScaleY: TFloat; out Sin, Cos: Single); overload; 61 62 function Hypot(const X, Y: TFloat): TFloat; overload; 62 63 function Hypot(const X, Y: Integer): Integer; overload; … … 86 87 function FloatMod(x, y: Double): Double; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 87 88 89 function DivMod(Dividend, Divisor: Integer; var Remainder: Integer): Integer; 90 91 92 {$IFDEF FPC} 93 {$IFDEF TARGET_X64} 94 (* 95 FPC has no similar {$EXCESSPRECISION OFF} directive, 96 but we can easily emulate that by overriding some internal math functions 97 *) 98 function PI: Single; [internproc: fpc_in_pi_real]; 99 //function Abs(D: Single): Single; [internproc: fpc_in_abs_real]; 100 //function Sqr(D: Single): Single; [internproc: fpc_in_sqr_real]; 101 function Sqrt(D: Single): Single; [internproc: fpc_in_sqrt_real]; 102 function ArcTan(D: Single): Single; [internproc: fpc_in_arctan_real]; 103 function Ln(D: Single): Single; [internproc: fpc_in_ln_real]; 104 function Sin(D: Single): Single; [internproc: fpc_in_sin_real]; 105 function Cos(D: Single): Single; [internproc: fpc_in_cos_real]; 106 function Exp(D: Single): Single; [internproc: fpc_in_exp_real]; 107 function Round(D: Single): Int64; [internproc: fpc_in_round_real]; 108 function Frac(D: Single): Single; [internproc: fpc_in_frac_real]; 109 function Int(D: Single): Single; [internproc: fpc_in_int_real]; 110 function Trunc(D: Single): Int64; [internproc: fpc_in_trunc_real]; 111 112 function Ceil(X: Single): Integer; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 113 function Floor(X: Single): Integer; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 114 {$ENDIF} 115 {$ENDIF} 116 117 type 118 TCumSumProc = procedure(Values: PSingleArray; Count: Integer); 119 120 var 121 CumSum: TCumSumProc; 122 88 123 implementation 89 124 90 125 uses 91 Math ;126 Math, GR32_System; 92 127 93 128 {$IFDEF PUREPASCAL} … … 96 131 {$ENDIF} 97 132 133 134 {$IFDEF FPC} 135 {$IFDEF TARGET_X64} 136 function Ceil(X: Single): Integer; 137 begin 138 Result := Trunc(X); 139 if (X - Result) > 0 then 140 Inc(Result); 141 end; 142 143 function Floor(X: Single): Integer; 144 begin 145 Result := Trunc(X); 146 if (X - Result) < 0 then 147 Dec(Result); 148 end; 149 {$ENDIF} 150 {$ENDIF} 151 152 98 153 { Fixed-point math } 99 154 … … 103 158 Result := A div FIXEDONE; 104 159 {$ELSE} 160 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 105 161 asm 106 162 {$IFDEF TARGET_x86} … … 119 175 Result := (A + $FFFF) div FIXEDONE; 120 176 {$ELSE} 177 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 121 178 asm 122 179 {$IFDEF TARGET_x86} … … 137 194 Result := (A + $7FFF) div FIXEDONE; 138 195 {$ELSE} 196 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 139 197 asm 140 198 {$IFDEF TARGET_x86} … … 155 213 Result := Round(A * FixedToFloat * B); 156 214 {$ELSE} 215 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 157 216 asm 158 217 {$IFDEF TARGET_x86} … … 173 232 Result := Round(A / B * FixedOne); 174 233 {$ELSE} 234 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 175 235 asm 176 236 {$IFDEF TARGET_x86} … … 199 259 Result := Round(Dividend / Value); 200 260 {$ELSE} 261 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 201 262 asm 202 263 {$IFDEF TARGET_x86} … … 219 280 Result := Round(Value * FixedToFloat * Value); 220 281 {$ELSE} 282 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 221 283 asm 222 284 {$IFDEF TARGET_x86} … … 237 299 Result := Round(Sqrt(Value * FixedOneS)); 238 300 {$ELSE} 301 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 239 302 asm 240 303 {$IFDEF TARGET_x86} … … 297 360 Result := Round(Sqrt(Value * FixedOneS)); 298 361 {$ELSE} 362 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 299 363 asm 300 364 {$IFDEF TARGET_x86} … … 397 461 Result := Round(Y + (X - Y) * FixedToFloat * W); 398 462 {$ELSE} 463 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 399 464 asm 400 465 {$IFDEF TARGET_x86} … … 427 492 {$IFDEF TARGET_x64} 428 493 var 429 Temp: DWord = 0;494 Temp: TFloat; 430 495 {$ENDIF} 431 496 asm … … 455 520 Cos := C * Radius; 456 521 {$ELSE} 522 {$IFDEF TARGET_x64} 523 var 524 Temp: TFloat; 525 {$ENDIF} 457 526 asm 458 527 {$IFDEF TARGET_x86} … … 477 546 end; 478 547 548 procedure SinCos(const Theta, ScaleX, ScaleY: TFloat; out Sin, Cos: Single); overload; 549 {$IFDEF NATIVE_SINCOS} 550 var 551 S, C: Extended; 552 begin 553 Math.SinCos(Theta, S, C); 554 Sin := S * ScaleX; 555 Cos := C * ScaleY; 556 {$ELSE} 557 {$IFDEF TARGET_x64} 558 var 559 Temp: TFloat; 560 {$ENDIF} 561 asm 562 {$IFDEF TARGET_x86} 563 FLD Theta 564 FSINCOS 565 FMUL ScaleX 566 FSTP DWORD PTR [EDX] // cosine 567 FMUL ScaleY 568 FSTP DWORD PTR [EAX] // sine 569 {$ENDIF} 570 {$IFDEF TARGET_x64} 571 MOVD Temp, Theta 572 FLD Temp 573 FSINCOS 574 MOVD Temp, ScaleX 575 FMUL Temp 576 FSTP [Cos] 577 MOVD Temp, ScaleY 578 FMUL Temp 579 FSTP [Sin] 580 {$ENDIF} 581 {$ENDIF} 582 end; 583 479 584 function Hypot(const X, Y: TFloat): TFloat; 480 585 {$IFDEF PUREPASCAL} … … 482 587 Result := Sqrt(Sqr(X) + Sqr(Y)); 483 588 {$ELSE} 589 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 484 590 asm 485 591 {$IFDEF TARGET_x86} … … 534 640 J := (I - $3F800000) div 2 + $3F800000; 535 641 {$ELSE} 642 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 536 643 asm 537 644 {$IFDEF TARGET_x86} … … 552 659 // see http://en.wikipedia.org/wiki/Methods_of_computing_square_roots#Approximations_that_depend_on_IEEE_representation 553 660 // additionally one babylonian step added 661 {$IFNDEF PUREPASCAL} 662 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 663 {$ENDIF} 554 664 const 555 665 CHalf : TFloat = 0.5; … … 594 704 Result := CQuarter * Result + Value / Result; 595 705 {$ELSE} 706 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 596 707 const 597 708 CHalf : TFloat = 0.5; … … 616 727 DIVSS XMM0, XMM1 617 728 ADDSS XMM0, XMM1 618 MOVD XMM1, CHalf729 MOVD XMM1, [RIP + CHalf] 619 730 MULSS XMM0, XMM1 620 731 {$ENDIF} … … 638 749 Result := Int64(Multiplicand) * Int64(Multiplier) div Divisor; 639 750 {$ELSE} 751 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 640 752 asm 641 753 {$IFDEF TARGET_x86} … … 741 853 Result := Result shl 1; 742 854 {$ELSE} 855 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 743 856 asm 744 857 {$IFDEF TARGET_x86} … … 764 877 Result := Result shl 1; 765 878 {$ELSE} 879 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 766 880 asm 767 881 {$IFDEF TARGET_x86} … … 796 910 Result := (A and B) + (A xor B) div 2; 797 911 {$ELSE} 912 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 798 913 asm 799 914 {$IFDEF TARGET_x86} … … 821 936 Result := (- Value) shr 31 - (Value shr 31); 822 937 {$ELSE} 938 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 823 939 asm 824 940 {$IFDEF TARGET_x64} … … 840 956 end; 841 957 958 function DivMod(Dividend, Divisor: Integer; var Remainder: Integer): Integer; 959 {$IFDEF PUREPASCAL} 960 begin 961 Result := Dividend div Divisor; 962 Remainder := Dividend mod Divisor; 963 {$ELSE} 964 {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 965 asm 966 {$IFDEF TARGET_x86} 967 PUSH EDX 968 CDQ 969 IDIV DWORD PTR [ESP] 970 ADD ESP, $04 971 MOV DWORD PTR [ECX], edx 972 {$ENDIF} 973 {$IFDEF TARGET_x64} 974 MOV RAX, RCX 975 MOV R9, RDX 976 CDQ 977 IDIV R9 978 MOV DWORD PTR [R8], EDX 979 {$ENDIF} 980 {$ENDIF} 981 end; 982 983 procedure CumSum_Pas(Values: PSingleArray; Count: Integer); 984 var 985 I: Integer; 986 V: TFloat; 987 begin 988 V := Values[0]; 989 for I := 1 to Count - 1 do 990 begin 991 if PInteger(@Values[I])^ <> 0 then 992 V := V + Values[I]; 993 Values[I] := V; 994 end; 995 end; 996 997 {$IFNDEF PUREPASCAL} 998 // Aligned SSE2 version -- Credits: Sanyin <prevodilac@hotmail.com> 999 procedure CumSum_SSE2(Values: PSingleArray; Count: Integer); {$IFDEF FPC} assembler; nostackframe; {$ENDIF} 1000 asm 1001 {$IFDEF TARGET_x86} 1002 MOV ECX,EDX 1003 CMP ECX,2 // if count < 2, exit 1004 JL @END 1005 CMP ECX,32 // if count < 32, avoid SSE2 overhead 1006 JL @SMALL 1007 1008 {--- align memory ---} 1009 PUSH EBX 1010 PXOR XMM4,XMM4 1011 MOV EBX,EAX 1012 AND EBX,15 // get aligned count 1013 JZ @ENDALIGNING // already aligned 1014 ADD EBX,-16 1015 NEG EBX // get bytes to advance 1016 JZ @ENDALIGNING // already aligned 1017 1018 MOV ECX,EBX 1019 SAR ECX,2 // div with 4 to get cnt 1020 SUB EDX,ECX 1021 1022 ADD EAX,4 1023 DEC ECX 1024 JZ @SETUPLAST // one element 1025 1026 @ALIGNINGLOOP: 1027 FLD DWORD PTR [EAX-4] 1028 FADD DWORD PTR [EAX] 1029 FSTP DWORD PTR [EAX] 1030 ADD EAX,4 1031 DEC ECX 1032 JNZ @ALIGNINGLOOP 1033 1034 @SETUPLAST: 1035 MOVUPS XMM4,[EAX-4] 1036 PSLLDQ XMM4,12 1037 PSRLDQ XMM4,12 1038 1039 @ENDALIGNING: 1040 POP EBX 1041 PUSH EBX 1042 MOV ECX,EDX 1043 SAR ECX,2 1044 @LOOP: 1045 MOVAPS XMM0,[EAX] 1046 PXOR XMM5,XMM5 1047 PCMPEQD XMM5,XMM0 1048 PMOVMSKB EBX,XMM5 1049 CMP EBX,$0000FFFF 1050 JNE @NORMAL 1051 PSHUFD XMM0,XMM4,0 1052 JMP @SKIP 1053 1054 @NORMAL: 1055 ADDPS XMM0,XMM4 1056 PSHUFD XMM1,XMM0,$e4 1057 PSLLDQ XMM1,4 1058 PSHUFD XMM2,XMM1,$90 1059 PSHUFD XMM3,XMM1,$40 1060 ADDPS XMM2,XMM3 1061 ADDPS XMM1,XMM2 1062 ADDPS XMM0,XMM1 1063 1064 PSHUFLW XMM4,XMM0,$E4 1065 PSRLDQ XMM4,12 1066 1067 @SKIP: 1068 PREFETCHNTA [eax+16*16*2] 1069 MOVAPS [EAX],XMM0 1070 ADD EAX,16 1071 SUB ECX,1 1072 JNZ @LOOP 1073 POP EBX 1074 MOV ECX,EDX 1075 SAR ECX,2 1076 SHL ECX,2 1077 SUB EDX,ECX 1078 MOV ECX,EDX 1079 JZ @END 1080 1081 @LOOP2: 1082 FLD DWORD PTR [EAX-4] 1083 FADD DWORD PTR [EAX] 1084 FSTP DWORD PTR [EAX] 1085 ADD EAX,4 1086 DEC ECX 1087 JNZ @LOOP2 1088 JMP @END 1089 1090 @SMALL: 1091 MOV ECX,EDX 1092 ADD EAX,4 1093 DEC ECX 1094 @LOOP3: 1095 FLD DWORD PTR [EAX-4] 1096 FADD DWORD PTR [EAX] 1097 FSTP DWORD PTR [EAX] 1098 ADD EAX,4 1099 DEC ECX 1100 JNZ @LOOP3 1101 {$ENDIF} 1102 {$IFDEF TARGET_x64} 1103 CMP EDX,2 // if count < 2, exit 1104 JL @END 1105 1106 MOV RAX,RCX 1107 MOV ECX,EDX 1108 1109 CMP ECX,32 // if count < 32, avoid SSE2 overhead 1110 JL @SMALL 1111 1112 {--- align memory ---} 1113 PXOR XMM4,XMM4 1114 MOV R8D,EAX 1115 AND R8D,15 // get aligned count 1116 JZ @ENDALIGNING // already aligned 1117 ADD R8D,-16 1118 NEG R8D // get bytes to advance 1119 JZ @ENDALIGNING // already aligned 1120 1121 MOV ECX,R8D 1122 SAR ECX,2 // div with 4 to get cnt 1123 SUB EDX,ECX 1124 1125 ADD RAX,4 1126 DEC ECX 1127 JZ @SETUPLAST // one element 1128 1129 @ALIGNINGLOOP: 1130 FLD DWORD PTR [RAX - 4] 1131 FADD DWORD PTR [RAX] 1132 FSTP DWORD PTR [RAX] 1133 ADD RAX,4 1134 DEC ECX 1135 JNZ @ALIGNINGLOOP 1136 1137 @SETUPLAST: 1138 MOVUPS XMM4,[RAX - 4] 1139 PSLLDQ XMM4,12 1140 PSRLDQ XMM4,12 1141 1142 @ENDALIGNING: 1143 MOV ECX,EDX 1144 SAR ECX,2 1145 @LOOP: 1146 MOVAPS XMM0,[RAX] 1147 PXOR XMM5,XMM5 1148 PCMPEQD XMM5,XMM0 1149 PMOVMSKB R8D,XMM5 1150 CMP R8D,$0000FFFF 1151 JNE @NORMAL 1152 PSHUFD XMM0,XMM4,0 1153 JMP @SKIP 1154 1155 @NORMAL: 1156 ADDPS XMM0,XMM4 1157 PSHUFD XMM1,XMM0,$e4 1158 PSLLDQ XMM1,4 1159 PSHUFD XMM2,XMM1,$90 1160 PSHUFD XMM3,XMM1,$40 1161 ADDPS XMM2,XMM3 1162 ADDPS XMM1,XMM2 1163 ADDPS XMM0,XMM1 1164 1165 PSHUFLW XMM4,XMM0,$E4 1166 PSRLDQ XMM4,12 1167 1168 @SKIP: 1169 PREFETCHNTA [RAX + 32 * 2] 1170 MOVAPS [RAX],XMM0 1171 ADD RAX,16 1172 SUB ECX,1 1173 JNZ @LOOP 1174 MOV ECX,EDX 1175 SAR ECX,2 1176 SHL ECX,2 1177 SUB EDX,ECX 1178 MOV ECX,EDX 1179 JZ @END 1180 1181 @LOOP2: 1182 FLD DWORD PTR [RAX - 4] 1183 FADD DWORD PTR [RAX] 1184 FSTP DWORD PTR [RAX] 1185 ADD RAX,4 1186 DEC ECX 1187 JNZ @LOOP2 1188 JMP @END 1189 1190 @SMALL: 1191 ADD RAX,4 1192 DEC ECX 1193 @LOOP3: 1194 FLD DWORD PTR [RAX - 4] 1195 FADD DWORD PTR [RAX] 1196 FSTP DWORD PTR [RAX] 1197 ADD RAX,4 1198 DEC ECX 1199 JNZ @LOOP3 1200 {$ENDIF} 1201 @END: 1202 end; 1203 {$ENDIF} 1204 1205 1206 initialization 1207 {$IFNDEF PUREPASCAL} 1208 if HasInstructionSet(ciSSE2) then 1209 CumSum := CumSum_SSE2 1210 else 1211 {$ENDIF} 1212 CumSum := CumSum_Pas; 1213 842 1214 end. -
GraphicTest/Packages/Graphics32/GR32_MicroTiles.pas
r450 r522 62 62 {$ENDIF} 63 63 SysUtils, Classes, 64 GR32, GR32_System, GR32_Containers, GR32_Layers, GR32_RepaintOpt , GR32_Bindings;64 GR32, GR32_System, GR32_Containers, GR32_Layers, GR32_RepaintOpt; 65 65 66 66 const … … 242 242 243 243 uses 244 GR32_ LowLevel, GR32_Math, Math;244 GR32_Bindings, GR32_LowLevel, GR32_Math, Math; 245 245 246 246 var -
GraphicTest/Packages/Graphics32/GR32_OrdinalMaps.pas
r450 r522 54 54 ctWeightedRGB); 55 55 56 {$IFDEF FPC} 57 PInteger = ^Integer; 58 {$ENDIF} 59 56 60 TBooleanMap = class(TCustomMap) 57 61 private 58 FBits: TArrayOfByte;59 62 function GetValue(X, Y: Integer): Boolean; 60 63 procedure SetValue(X, Y: Integer; const Value: Boolean); 61 function GetBits: PByteArray;62 64 protected 65 FBits: PByteArray; 63 66 procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; 64 67 public 68 constructor Create; overload; override; 65 69 destructor Destroy; override; 70 66 71 function Empty: Boolean; override; 67 72 procedure Clear(FillValue: Byte); 68 73 procedure ToggleBit(X, Y: Integer); 74 69 75 property Value[X, Y: Integer]: Boolean read GetValue write SetValue; default; 70 property Bits: PByteArray read GetBits;76 property Bits: PByteArray read FBits; 71 77 end; 72 78 73 79 TByteMap = class(TCustomMap) 74 80 private 75 FBits: TArrayOfByte;76 81 function GetValue(X, Y: Integer): Byte; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 77 82 function GetValPtr(X, Y: Integer): PByte; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 78 83 procedure SetValue(X, Y: Integer; Value: Byte); {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 79 function Get Bits: PByteArray;84 function GetScanline(Y: Integer): PByteArray; 80 85 protected 86 FBits: PByteArray; 81 87 procedure AssignTo(Dst: TPersistent); override; 82 88 procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; 83 89 public 90 constructor Create; overload; override; 84 91 destructor Destroy; override; 92 85 93 procedure Assign(Source: TPersistent); override; 86 function 94 function Empty: Boolean; override; 87 95 procedure Clear(FillValue: Byte); 96 97 procedure Multiply(Value: Byte); 98 procedure Add(Value: Byte); 99 procedure Sub(Value: Byte); 100 88 101 procedure ReadFrom(Source: TCustomBitmap32; Conversion: TConversionType); 89 102 procedure WriteTo(Dest: TCustomBitmap32; Conversion: TConversionType); overload; 90 103 procedure WriteTo(Dest: TCustomBitmap32; const Palette: TPalette32); overload; 91 property Bits: PByteArray read GetBits; 104 105 procedure DrawTo(Dest: TCustomBitmap32; X, Y: Integer; Color: TColor32); overload; 106 procedure DrawTo(Dest: TCustomBitmap32; Rect: TRect; Color: TColor32); overload; 107 108 procedure Downsample(Factor: Byte); overload; 109 procedure Downsample(Dest: TByteMap; Factor: Byte); overload; 110 111 procedure FlipHorz(Dst: TByteMap = nil); 112 procedure FlipVert(Dst: TByteMap = nil); 113 procedure Rotate90(Dst: TByteMap = nil); 114 procedure Rotate180(Dst: TByteMap = nil); 115 procedure Rotate270(Dst: TByteMap = nil); 116 117 property Bits: PByteArray read FBits; 118 property Scanline[Y: Integer]: PByteArray read GetScanline; 92 119 property ValPtr[X, Y: Integer]: PByte read GetValPtr; 93 120 property Value[X, Y: Integer]: Byte read GetValue write SetValue; default; 94 121 end; 95 122 123 { TWordMap } 124 96 125 TWordMap = class(TCustomMap) 97 126 private 98 FBits: TArrayOfWord;99 127 function GetValPtr(X, Y: Integer): PWord; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 100 128 function GetValue(X, Y: Integer): Word; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 101 129 procedure SetValue(X, Y: Integer; const Value: Word); {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 102 function Get Bits: PWordArray;130 function GetScanline(Y: Integer): PWordArray; 103 131 protected 132 FBits: PWordArray; 104 133 procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; 105 134 public 135 constructor Create; overload; override; 106 136 destructor Destroy; override; 137 138 procedure Assign(Source: TPersistent); override; 107 139 function Empty: Boolean; override; 108 140 procedure Clear(FillValue: Word); 141 109 142 property ValPtr[X, Y: Integer]: PWord read GetValPtr; 110 143 property Value[X, Y: Integer]: Word read GetValue write SetValue; default; 111 property Bits: PWordArray read GetBits; 112 end; 144 property Bits: PWordArray read FBits; 145 property Scanline[Y: Integer]: PWordArray read GetScanline; 146 end; 147 148 { TIntegerMap } 113 149 114 150 TIntegerMap = class(TCustomMap) 115 151 private 116 FBits: TArrayOfInteger;117 152 function GetValPtr(X, Y: Integer): PInteger; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 118 153 function GetValue(X, Y: Integer): Integer; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 119 154 procedure SetValue(X, Y: Integer; const Value: Integer); {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 120 function Get Bits: PIntegerArray;155 function GetScanline(Y: Integer): PIntegerArray; 121 156 protected 157 FBits: PIntegerArray; 122 158 procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; 123 159 public 160 constructor Create; overload; override; 124 161 destructor Destroy; override; 162 163 procedure Assign(Source: TPersistent); override; 125 164 function Empty: Boolean; override; 126 procedure Clear(FillValue: Integer); 165 procedure Clear(FillValue: Integer = 0); 166 127 167 property ValPtr[X, Y: Integer]: PInteger read GetValPtr; 128 168 property Value[X, Y: Integer]: Integer read GetValue write SetValue; default; 129 property Bits: PIntegerArray read GetBits; 130 end; 169 property Bits: PIntegerArray read FBits; 170 property Scanline[Y: Integer]: PIntegerArray read GetScanline; 171 end; 172 173 { TCardinalMap } 174 175 TCardinalMap = class(TCustomMap) 176 private 177 function GetValPtr(X, Y: Cardinal): PCardinal; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 178 function GetValue(X, Y: Cardinal): Cardinal; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 179 procedure SetValue(X, Y: Cardinal; const Value: Cardinal); {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 180 function GetScanline(Y: Integer): PCardinalArray; 181 protected 182 FBits: PCardinalArray; 183 procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; 184 public 185 constructor Create; overload; override; 186 destructor Destroy; override; 187 188 procedure Assign(Source: TPersistent); override; 189 function Empty: Boolean; override; 190 procedure Clear(FillValue: Cardinal = 0); 191 192 property ValPtr[X, Y: Cardinal]: PCardinal read GetValPtr; 193 property Value[X, Y: Cardinal]: Cardinal read GetValue write SetValue; default; 194 property Bits: PCardinalArray read FBits; 195 property Scanline[Y: Integer]: PCardinalArray read GetScanline; 196 end; 197 198 { TFloatMap } 131 199 132 200 TFloatMap = class(TCustomMap) 133 201 private 134 FBits: TArrayOfFloat; 135 function GetValPtr(X, Y: Integer): PFloat; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 202 function GetValPtr(X, Y: Integer): GR32.PFloat; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 136 203 function GetValue(X, Y: Integer): TFloat; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 137 204 procedure SetValue(X, Y: Integer; const Value: TFloat); {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 138 function Get Bits: PFloatArray;205 function GetScanline(Y: Integer): PFloatArray; 139 206 protected 207 FBits: PFloatArray; 140 208 procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; 141 209 public 210 constructor Create; overload; override; 142 211 destructor Destroy; override; 212 213 procedure Assign(Source: TPersistent); override; 143 214 function Empty: Boolean; override; 144 215 procedure Clear; overload; 145 216 procedure Clear(FillValue: TFloat); overload; 217 146 218 property ValPtr[X, Y: Integer]: PFloat read GetValPtr; 147 219 property Value[X, Y: Integer]: TFloat read GetValue write SetValue; default; 148 property Bits: PFloatArray read GetBits; 149 end; 220 property Bits: PFloatArray read FBits; 221 property Scanline[Y: Integer]: PFloatArray read GetScanline; 222 end; 223 224 {$IFDEF COMPILER2010} 225 226 { TGenericMap<T> } 227 228 TGenericMap<T> = class(TCustomMap) 229 private 230 function GetValue(X, Y: Integer): T; {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 231 procedure SetValue(X, Y: Integer; const Value: T); {$IFDEF INLININGSUPPORTED} inline; {$ENDIF} 232 protected 233 FBits: Pointer; 234 procedure ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); override; 235 public 236 constructor Create; overload; override; 237 destructor Destroy; override; 238 239 procedure Assign(Source: TPersistent); override; 240 function Empty: Boolean; override; 241 procedure Clear; overload; 242 procedure Clear(FillValue: T); overload; 243 244 property Value[X, Y: Integer]: T read GetValue write SetValue; default; 245 property Bits: Pointer read FBits; 246 end; 247 248 {$ENDIF} 150 249 151 250 implementation 152 251 153 252 uses 154 GR32_LowLevel; 253 Math, GR32_LowLevel, GR32_Blend, GR32_Resamplers; 254 255 function Bytes(Bits: Integer): Integer; 256 begin 257 Result := (Bits - 1) shr 3 + 1; 258 end; 155 259 156 260 { TBooleanMap } 157 261 158 function Bytes(Bits: Integer): Integer; 159 begin 160 Result := (Bits - 1) shr 3 + 1; 262 constructor TBooleanMap.Create; 263 begin 264 FreeMem(FBits); 265 inherited Create; 161 266 end; 162 267 … … 164 269 NewHeight: Integer); 165 270 begin 166 SetLength(FBits, Bytes(NewWidth * NewHeight));271 ReallocMem(FBits, Bytes(NewWidth * NewHeight)); 167 272 Width := NewWidth; 168 273 Height := NewHeight; … … 171 276 procedure TBooleanMap.Clear(FillValue: Byte); 172 277 begin 173 FillChar(FBits [0], Bytes(Width * Height), FillValue);278 FillChar(FBits^, Bytes(Width * Height), FillValue); 174 279 end; 175 280 … … 185 290 end; 186 291 187 function TBooleanMap.GetBits: PByteArray;188 begin189 Result := @FBits[0];190 end;191 192 292 function TBooleanMap.GetValue(X, Y: Integer): Boolean; 193 293 begin 194 294 X := X + Y * Width; 195 Result := FBits [X shr 3] and (1 shl (X and 7)) <> 0; //Boolean(FBits[X shr 3] and (1 shl (X and 7)));295 Result := FBits^[X shr 3] and (1 shl (X and 7)) <> 0; //Boolean(FBits^[X shr 3] and (1 shl (X and 7))); 196 296 end; 197 297 … … 200 300 X := Y * Width + X; 201 301 if Value then 202 FBits [X shr 3] := FBits[X shr 3] or (1 shl (X and 7))302 FBits^[X shr 3] := FBits^[X shr 3] or (1 shl (X and 7)) 203 303 else 204 FBits [X shr 3] := FBits[X shr 3] and ((1 shl (X and 7)) xor $FF);304 FBits^[X shr 3] := FBits^[X shr 3] and ((1 shl (X and 7)) xor $FF); 205 305 end; 206 306 … … 208 308 begin 209 309 X := Y * Width + X; 210 FBits [X shr 3] := FBits[X shr 3] xor (1 shl (X and 7));310 FBits^[X shr 3] := FBits^[X shr 3] xor (1 shl (X and 7)); 211 311 end; 212 312 213 313 { TByteMap } 314 315 constructor TByteMap.Create; 316 begin 317 FBits := nil; 318 inherited Create; 319 end; 320 321 destructor TByteMap.Destroy; 322 begin 323 FreeMem(FBits); 324 inherited; 325 end; 326 327 procedure TByteMap.Downsample(Factor: Byte); 328 begin 329 // downsample inplace 330 case Factor of 331 2: 332 DownsampleByteMap2x(Self, Self); 333 3: 334 DownsampleByteMap3x(Self, Self); 335 4: 336 DownsampleByteMap4x(Self, Self); 337 6: 338 begin 339 DownsampleByteMap3x(Self, Self); 340 DownsampleByteMap2x(Self, Self); 341 end; 342 8: 343 begin 344 DownsampleByteMap4x(Self, Self); 345 DownsampleByteMap2x(Self, Self); 346 end; 347 9: 348 begin 349 DownsampleByteMap3x(Self, Self); 350 DownsampleByteMap3x(Self, Self); 351 end; 352 12: 353 begin 354 DownsampleByteMap4x(Self, Self); 355 DownsampleByteMap3x(Self, Self); 356 end; 357 16: 358 begin 359 DownsampleByteMap4x(Self, Self); 360 DownsampleByteMap4x(Self, Self); 361 end; 362 18: 363 begin 364 DownsampleByteMap3x(Self, Self); 365 DownsampleByteMap3x(Self, Self); 366 DownsampleByteMap2x(Self, Self); 367 end; 368 24: 369 begin 370 DownsampleByteMap4x(Self, Self); 371 DownsampleByteMap3x(Self, Self); 372 DownsampleByteMap2x(Self, Self); 373 end; 374 27: 375 begin 376 DownsampleByteMap3x(Self, Self); 377 DownsampleByteMap3x(Self, Self); 378 DownsampleByteMap3x(Self, Self); 379 end; 380 32: 381 begin 382 DownsampleByteMap4x(Self, Self); 383 DownsampleByteMap4x(Self, Self); 384 DownsampleByteMap2x(Self, Self); 385 end; 386 end; 387 end; 388 389 procedure TByteMap.Downsample(Dest: TByteMap; Factor: Byte); 390 391 procedure DownsampleAndMove; 392 var 393 Temp: TByteMap; 394 Y: Integer; 395 begin 396 // clone destination and downsample inplace 397 Temp := TByteMap.Create; 398 Temp.Assign(Self); 399 Temp.Downsample(Factor); 400 401 // copy downsampled result 402 Dest.SetSize(Width div Factor, Height div Factor); 403 for Y := 0 to Dest.Height - 1 do 404 Move(Temp.Scanline[Y]^, Dest.Scanline[Y]^, Dest.Width); 405 end; 406 407 begin 408 // downsample directly 409 if (Dest = Self) or not (Factor in [2, 3, 4]) then 410 begin 411 DownsampleAndMove; 412 Exit; 413 end; 414 415 case Factor of 416 2: 417 begin 418 Dest.SetSize(Width div 2, Height div 2); 419 DownsampleByteMap2x(Self, Dest); 420 end; 421 3: 422 begin 423 // downsample directly 424 Dest.SetSize(Width div 3, Height div 3); 425 DownsampleByteMap3x(Self, Dest); 426 end; 427 4: 428 begin 429 // downsample directly 430 Dest.SetSize(Width div 4, Height div 4); 431 DownsampleByteMap4x(Self, Dest); 432 end; 433 end; 434 end; 214 435 215 436 procedure TByteMap.Assign(Source: TPersistent); … … 240 461 procedure TByteMap.ChangeSize(var Width, Height: Integer; NewWidth, NewHeight: Integer); 241 462 begin 242 SetLength(FBits, NewWidth * NewHeight);463 ReallocMem(FBits, NewWidth * NewHeight); 243 464 Width := NewWidth; 244 465 Height := NewHeight; … … 247 468 procedure TByteMap.Clear(FillValue: Byte); 248 469 begin 249 FillChar(Bits [0], Width * Height, FillValue);470 FillChar(Bits^, Width * Height, FillValue); 250 471 Changed; 251 end;252 253 destructor TByteMap.Destroy;254 begin255 FBits := nil;256 inherited;257 472 end; 258 473 … … 263 478 end; 264 479 265 function TByteMap.GetBits: PByteArray; 266 begin 267 Result := @FBits[0]; 480 procedure TByteMap.FlipHorz(Dst: TByteMap); 481 var 482 i, j: Integer; 483 P1, P2: PByte; 484 tmp: Byte; 485 W, W2: Integer; 486 begin 487 W := Width; 488 if (Dst = nil) or (Dst = Self) then 489 begin 490 { In-place flipping } 491 P1 := PByte(Bits); 492 P2 := P1; 493 Inc(P2, Width - 1); 494 W2 := Width shr 1; 495 for J := 0 to Height - 1 do 496 begin 497 for I := 0 to W2 - 1 do 498 begin 499 tmp := P1^; 500 P1^ := P2^; 501 P2^ := tmp; 502 Inc(P1); 503 Dec(P2); 504 end; 505 Inc(P1, W - W2); 506 Inc(P2, W + W2); 507 end; 508 Changed; 509 end 510 else 511 begin 512 { Flip to Dst } 513 Dst.BeginUpdate; 514 Dst.SetSize(W, Height); 515 P1 := PByte(Bits); 516 P2 := PByte(Dst.Bits); 517 Inc(P2, W - 1); 518 for J := 0 to Height - 1 do 519 begin 520 for I := 0 to W - 1 do 521 begin 522 P2^ := P1^; 523 Inc(P1); 524 Dec(P2); 525 end; 526 Inc(P2, W shl 1); 527 end; 528 Dst.EndUpdate; 529 Dst.Changed; 530 end; 531 end; 532 533 procedure TByteMap.FlipVert(Dst: TByteMap); 534 var 535 J, J2: Integer; 536 Buffer: PByteArray; 537 P1, P2: PByte; 538 begin 539 if (Dst = nil) or (Dst = Self) then 540 begin 541 { in-place } 542 J2 := Height - 1; 543 GetMem(Buffer, Width); 544 for J := 0 to Height div 2 - 1 do 545 begin 546 P1 := PByte(ScanLine[J]); 547 P2 := PByte(ScanLine[J2]); 548 Move(P1^, Buffer^, Width); 549 Move(P2^, P1^, Width); 550 Move(Buffer^, P2^, Width); 551 Dec(J2); 552 end; 553 FreeMem(Buffer); 554 Changed; 555 end 556 else 557 begin 558 Dst.SetSize(Width, Height); 559 J2 := Height - 1; 560 for J := 0 to Height - 1 do 561 begin 562 Move(ScanLine[J]^, Dst.ScanLine[J2]^, Width); 563 Dec(J2); 564 end; 565 Dst.Changed; 566 end; 567 end; 568 569 function TByteMap.GetScanline(Y: Integer): PByteArray; 570 begin 571 Result := @FBits^[Y * Width]; 268 572 end; 269 573 270 574 function TByteMap.GetValPtr(X, Y: Integer): PByte; 271 575 begin 272 Result := @FBits [X + Y * Width];576 Result := @FBits^[X + Y * Width]; 273 577 end; 274 578 275 579 function TByteMap.GetValue(X, Y: Integer): Byte; 276 580 begin 277 Result := FBits[X + Y * Width]; 581 Result := FBits^[X + Y * Width]; 582 end; 583 584 procedure TByteMap.Multiply(Value: Byte); 585 var 586 Index: Integer; 587 begin 588 for Index := 0 to FWidth * FHeight - 1 do 589 FBits^[Index] := ((FBits^[Index] * Value + $80) shr 8); 590 end; 591 592 procedure TByteMap.Add(Value: Byte); 593 var 594 Index: Integer; 595 begin 596 for Index := 0 to FWidth * FHeight - 1 do 597 FBits^[Index] := Min(FBits^[Index] + Value, 255); 598 end; 599 600 procedure TByteMap.Sub(Value: Byte); 601 var 602 Index: Integer; 603 begin 604 for Index := 0 to FWidth * FHeight - 1 do 605 FBits^[Index] := Max(FBits^[Index] + Value, 0); 278 606 end; 279 607 … … 295 623 SrcC := Source.PixelPtr[0, 0]; 296 624 SrcB := Pointer(SrcC); 297 DstB := @FBits [0];625 DstB := @FBits^; 298 626 case Conversion of 299 627 … … 371 699 end; 372 700 701 procedure TByteMap.Rotate180(Dst: TByteMap); 702 var 703 Src: PByteArray; 704 S, D: PByte; 705 X, Y: Integer; 706 T: Byte; 707 begin 708 if (Dst = nil) or (Dst = Self) then 709 begin 710 for Y := 0 to FHeight - 1 do 711 begin 712 Src := Scanline[Y]; 713 for X := 0 to (FWidth div 2) - 1 do 714 begin 715 T := Src^[X]; 716 Src^[X] := Src^[Width - 1 - X]; 717 Src^[Width - 1 - X] := T; 718 end; 719 end; 720 end 721 else 722 begin 723 S := PByte(FBits); 724 D := PByte(@Dst.Bits[FHeight * FWidth - 1]); 725 for X := 0 to FHeight * FWidth - 1 do 726 begin 727 D^ := S^; 728 Dec(D); 729 Inc(S); 730 end; 731 end; 732 end; 733 734 procedure TByteMap.Rotate270(Dst: TByteMap); 735 var 736 Src: PByteArray; 737 Current: PByte; 738 X, Y, W, H: Integer; 739 begin 740 if (Dst = nil) or (Dst = Self) then 741 begin 742 W := FWidth; 743 H := FHeight; 744 745 // inplace replace 746 GetMem(Src, W * H); 747 748 // copy bits 749 Move(Bits^, Src^, W * H); 750 751 SetSize(H, W); 752 753 Current := PByte(Src); 754 for Y := 0 to H - 1 do 755 for X := 0 to W - 1 do 756 begin 757 Bits^[(W - 1 - X) * H + Y] := Current^; 758 Inc(Current); 759 end; 760 761 // dispose old data pointer 762 FreeMem(Src); 763 end 764 else 765 begin 766 // exchange dimensions 767 Dst.SetSize(Height, Width); 768 769 for Y := 0 to FHeight - 1 do 770 begin 771 Src := Scanline[Y]; 772 for X := 0 to FWidth - 1 do 773 Dst.Bits^[X * FHeight + FHeight - 1 - Y] := Src^[X]; 774 end; 775 end; 776 end; 777 778 procedure TByteMap.Rotate90(Dst: TByteMap); 779 var 780 Src: PByteArray; 781 Current: PByte; 782 X, Y, W, H: Integer; 783 begin 784 if (Dst = nil) or (Dst = Self) then 785 begin 786 W := FWidth; 787 H := FHeight; 788 789 // inplace replace 790 GetMem(Src, W * H); 791 792 // copy bits 793 Move(Bits^, Src^, W * H); 794 795 SetSize(H, W); 796 797 Current := PByte(Src); 798 for Y := 0 to H - 1 do 799 for X := 0 to W - 1 do 800 begin 801 Bits^[X * H + (H - 1 - Y)] := Current^; 802 Inc(Current); 803 end; 804 805 // dispose old data pointer 806 FreeMem(Src); 807 end 808 else 809 begin 810 // exchange dimensions 811 Dst.SetSize(Height, Width); 812 813 for Y := 0 to FHeight - 1 do 814 begin 815 Src := Scanline[Y]; 816 for X := 0 to FWidth - 1 do 817 Dst.Bits^[(FWidth - 1 - X) * FHeight + Y] := Src^[X]; 818 end; 819 end; 820 end; 821 373 822 procedure TByteMap.SetValue(X, Y: Integer; Value: Byte); 374 823 begin 375 FBits [X + Y * Width] := Value;824 FBits^[X + Y * Width] := Value; 376 825 end; 377 826 … … 394 843 DstC := Dest.PixelPtr[0, 0]; 395 844 DstB := Pointer(DstC); 396 SrcB := @FBits [0];845 SrcB := @FBits^; 397 846 case Conversion of 398 847 … … 472 921 N := W * H - 1; 473 922 DstC := Dest.PixelPtr[0, 0]; 474 SrcB := @FBits [0];923 SrcB := @FBits^; 475 924 476 925 for I := 0 to N do … … 485 934 end; 486 935 end; 487 936 937 procedure TByteMap.DrawTo(Dest: TCustomBitmap32; X, Y: Integer; Color: TColor32); 938 var 939 ClipRect: TRect; 940 IX, IY: Integer; 941 RGB: Cardinal; 942 NewColor: TColor32; 943 ScnLn: PColor32Array; 944 ByteLine: PByteArray; 945 Alpha: Byte; 946 begin 947 with ClipRect do 948 begin 949 Left := X; 950 if Left < 0 then 951 Left := 0; 952 Top := Y; 953 if Top < 0 then 954 Top := 0; 955 Right := X + Self.Width; 956 if Right > Self.Width then 957 Right := Self.Width; 958 Bottom := Y + Self.Height; 959 if Bottom > Self.Height then 960 Bottom := Self.Height; 961 962 // split RGB and alpha 963 RGB := Color and $FFFFFF; 964 Alpha := Color shr 24; 965 966 // blend scanlines 967 for IY := Top to Bottom - 1 do 968 begin 969 ScnLn := Dest.ScanLine[IY]; 970 ByteLine := Self.ScanLine[IY - Y]; 971 for IX := Left to Right - 1 do 972 begin 973 NewColor := (((ByteLine^[IX - X] * Alpha) shl 16) and $FF000000) or RGB; 974 MergeMem(NewColor, ScnLn^[IX]); 975 end; 976 end; 977 EMMS; 978 end; 979 end; 980 981 procedure TByteMap.DrawTo(Dest: TCustomBitmap32; Rect: TRect; Color: TColor32); 982 var 983 ClipRect: TRect; 984 IX, IY: Integer; 985 RGB: Cardinal; 986 NewColor: TColor32; 987 ScnLn: PColor32Array; 988 ByteLine: PByteArray; 989 Alpha: Byte; 990 begin 991 with ClipRect do 992 begin 993 Left := Rect.Left; 994 if Left < 0 then 995 Left := 0; 996 Top := Rect.Top; 997 if Top < 0 then 998 Top := 0; 999 Right := Math.Min(Rect.Left + Self.Width, Rect.Right); 1000 Bottom := Math.Min(Rect.Top + Self.Height, Rect.Bottom); 1001 1002 // split RGB and alpha 1003 RGB := Color and $FFFFFF; 1004 Alpha := Color shr 24; 1005 1006 // blend scanlines 1007 for IY := Top to Bottom - 1 do 1008 begin 1009 ScnLn := Dest.ScanLine[IY]; 1010 ByteLine := Self.ScanLine[IY - Rect.Top]; 1011 for IX := Left to Right - 1 do 1012 begin 1013 NewColor := (((ByteLine^[IX - Rect.Left] * Alpha) shl 16) and $FF000000) or RGB; 1014 MergeMem(NewColor, ScnLn^[IX]); 1015 end; 1016 end; 1017 EMMS; 1018 end; 1019 end; 1020 1021 488 1022 { TWordMap } 1023 1024 constructor TWordMap.Create; 1025 begin 1026 FBits := nil; 1027 inherited Create; 1028 end; 1029 1030 destructor TWordMap.Destroy; 1031 begin 1032 FreeMem(FBits); 1033 inherited; 1034 end; 489 1035 490 1036 procedure TWordMap.ChangeSize(var Width, Height: Integer; NewWidth, 491 1037 NewHeight: Integer); 492 1038 begin 493 SetLength(FBits, NewWidth * NewHeight);1039 ReallocMem(FBits, NewWidth * NewHeight * SizeOf(Word)); 494 1040 Width := NewWidth; 495 1041 Height := NewHeight; … … 498 1044 procedure TWordMap.Clear(FillValue: Word); 499 1045 begin 500 FillWord(FBits [0], Width * Height, FillValue);1046 FillWord(FBits^, Width * Height, FillValue); 501 1047 Changed; 502 1048 end; 503 1049 504 destructor TWordMap.Destroy; 1050 procedure TWordMap.Assign(Source: TPersistent); 1051 begin 1052 BeginUpdate; 1053 try 1054 if Source is TWordMap then 1055 begin 1056 inherited SetSize(TWordMap(Source).Width, TWordMap(Source).Height); 1057 Move(TWordMap(Source).Bits[0], Bits[0], Width * Height * SizeOf(Word)); 1058 end 1059 //else if Source is TBitmap32 then 1060 // ReadFrom(TBitmap32(Source), ctWeightedRGB) 1061 else 1062 inherited; 1063 finally 1064 EndUpdate; 1065 Changed; 1066 end; 1067 end; 1068 1069 function TWordMap.Empty: Boolean; 1070 begin 1071 Result := not Assigned(FBits); 1072 end; 1073 1074 function TWordMap.GetScanline(Y: Integer): PWordArray; 1075 begin 1076 Result := @FBits^[Y * Width]; 1077 end; 1078 1079 function TWordMap.GetValPtr(X, Y: Integer): PWord; 1080 begin 1081 Result := @FBits^[X + Y * Width]; 1082 end; 1083 1084 function TWordMap.GetValue(X, Y: Integer): Word; 1085 begin 1086 Result := FBits^[X + Y * Width]; 1087 end; 1088 1089 procedure TWordMap.SetValue(X, Y: Integer; const Value: Word); 1090 begin 1091 FBits^[X + Y * Width] := Value; 1092 end; 1093 1094 1095 { TIntegerMap } 1096 1097 constructor TIntegerMap.Create; 505 1098 begin 506 1099 FBits := nil; 1100 inherited Create; 1101 end; 1102 1103 destructor TIntegerMap.Destroy; 1104 begin 1105 FreeMem(FBits); 507 1106 inherited; 508 1107 end; 509 510 function TWordMap.Empty: Boolean;511 begin512 Result := not Assigned(FBits);513 end;514 515 function TWordMap.GetBits: PWordArray;516 begin517 Result := @FBits[0];518 end;519 520 function TWordMap.GetValPtr(X, Y: Integer): PWord;521 begin522 Result := @FBits[X + Y * Width];523 end;524 525 function TWordMap.GetValue(X, Y: Integer): Word;526 begin527 Result := FBits[X + Y * Width];528 end;529 530 procedure TWordMap.SetValue(X, Y: Integer; const Value: Word);531 begin532 FBits[X + Y * Width] := Value;533 end;534 535 { TIntegerMap }536 1108 537 1109 procedure TIntegerMap.ChangeSize(var Width, Height: Integer; NewWidth, 538 1110 NewHeight: Integer); 539 1111 begin 540 SetLength(FBits, NewWidth * NewHeight);1112 ReallocMem(FBits, NewWidth * NewHeight * SizeOf(Integer)); 541 1113 Width := NewWidth; 542 1114 Height := NewHeight; … … 545 1117 procedure TIntegerMap.Clear(FillValue: Integer); 546 1118 begin 547 FillLongword(FBits [0], Width * Height, FillValue);1119 FillLongword(FBits^, Width * Height, FillValue); 548 1120 Changed; 549 1121 end; 550 1122 551 destructor TIntegerMap.Destroy; 1123 procedure TIntegerMap.Assign(Source: TPersistent); 1124 begin 1125 BeginUpdate; 1126 try 1127 if Source is TIntegerMap then 1128 begin 1129 inherited SetSize(TIntegerMap(Source).Width, TIntegerMap(Source).Height); 1130 Move(TIntegerMap(Source).Bits[0], Bits[0], Width * Height * SizeOf(Integer)); 1131 end 1132 //else if Source is TBitmap32 then 1133 // ReadFrom(TBitmap32(Source), ctWeightedRGB) 1134 else 1135 inherited; 1136 finally 1137 EndUpdate; 1138 Changed; 1139 end; 1140 end; 1141 1142 function TIntegerMap.Empty: Boolean; 1143 begin 1144 Result := not Assigned(FBits); 1145 end; 1146 1147 function TIntegerMap.GetScanline(Y: Integer): PIntegerArray; 1148 begin 1149 Result := @FBits^[Y * Width]; 1150 end; 1151 1152 function TIntegerMap.GetValPtr(X, Y: Integer): PInteger; 1153 begin 1154 Result := @FBits^[X + Y * Width]; 1155 end; 1156 1157 function TIntegerMap.GetValue(X, Y: Integer): Integer; 1158 begin 1159 Result := FBits^[X + Y * Width]; 1160 end; 1161 1162 procedure TIntegerMap.SetValue(X, Y: Integer; const Value: Integer); 1163 begin 1164 FBits^[X + Y * Width] := Value; 1165 end; 1166 1167 1168 { TCardinalMap } 1169 1170 constructor TCardinalMap.Create; 552 1171 begin 553 1172 FBits := nil; 1173 inherited Create; 1174 end; 1175 1176 destructor TCardinalMap.Destroy; 1177 begin 1178 FreeMem(FBits); 554 1179 inherited; 555 1180 end; 556 1181 557 function TIntegerMap.Empty: Boolean; 1182 procedure TCardinalMap.Assign(Source: TPersistent); 1183 begin 1184 BeginUpdate; 1185 try 1186 if Source is TCardinalMap then 1187 begin 1188 inherited SetSize(TCardinalMap(Source).Width, TCardinalMap(Source).Height); 1189 Move(TCardinalMap(Source).Bits[0], Bits[0], Width * Height * SizeOf(Cardinal)); 1190 end 1191 //else if Source is TBitmap32 then 1192 // ReadFrom(TBitmap32(Source), ctWeightedRGB) 1193 else 1194 inherited; 1195 finally 1196 EndUpdate; 1197 Changed; 1198 end; 1199 end; 1200 1201 procedure TCardinalMap.ChangeSize(var Width, Height: Integer; NewWidth, 1202 NewHeight: Integer); 1203 begin 1204 ReallocMem(FBits, NewWidth * NewHeight * SizeOf(Cardinal)); 1205 Width := NewWidth; 1206 Height := NewHeight; 1207 end; 1208 1209 procedure TCardinalMap.Clear(FillValue: Cardinal); 1210 begin 1211 FillLongword(FBits^, Width * Height, FillValue); 1212 Changed; 1213 end; 1214 1215 function TCardinalMap.Empty: Boolean; 558 1216 begin 559 1217 Result := not Assigned(FBits); 560 1218 end; 561 1219 562 function TIntegerMap.GetBits: PIntegerArray; 563 begin 564 Result := @FBits[0]; 565 end; 566 567 function TIntegerMap.GetValPtr(X, Y: Integer): PInteger; 568 begin 569 Result := @FBits[X + Y * Width]; 570 end; 571 572 function TIntegerMap.GetValue(X, Y: Integer): Integer; 573 begin 574 Result := FBits[X + Y * Width]; 575 end; 576 577 procedure TIntegerMap.SetValue(X, Y: Integer; const Value: Integer); 578 begin 579 FBits[X + Y * Width] := Value; 580 end; 1220 function TCardinalMap.GetScanline(Y: Integer): PCardinalArray; 1221 begin 1222 Result := @FBits^[Y * Width]; 1223 end; 1224 1225 function TCardinalMap.GetValPtr(X, Y: Cardinal): PCardinal; 1226 begin 1227 Result := @FBits^[X + Y * Cardinal(Width)]; 1228 end; 1229 1230 function TCardinalMap.GetValue(X, Y: Cardinal): Cardinal; 1231 begin 1232 Result := FBits^[X + Y * Cardinal(Width)]; 1233 end; 1234 1235 procedure TCardinalMap.SetValue(X, Y: Cardinal; const Value: Cardinal); 1236 begin 1237 FBits^[X + Y * Cardinal(Width)] := Value; 1238 end; 1239 581 1240 582 1241 { TFloatMap } 1242 1243 constructor TFloatMap.Create; 1244 begin 1245 FBits := nil; 1246 inherited Create; 1247 end; 1248 1249 destructor TFloatMap.Destroy; 1250 begin 1251 FreeMem(FBits); 1252 inherited; 1253 end; 1254 1255 procedure TFloatMap.Assign(Source: TPersistent); 1256 begin 1257 BeginUpdate; 1258 try 1259 if Source is TFloatMap then 1260 begin 1261 inherited SetSize(TFloatMap(Source).Width, TFloatMap(Source).Height); 1262 Move(TFloatMap(Source).Bits[0], Bits[0], Width * Height * SizeOf(TFloat)); 1263 end 1264 //else if Source is TBitmap32 then 1265 // ReadFrom(TBitmap32(Source), ctWeightedRGB) 1266 else 1267 inherited; 1268 finally 1269 EndUpdate; 1270 Changed; 1271 end; 1272 end; 583 1273 584 1274 procedure TFloatMap.ChangeSize(var Width, Height: Integer; NewWidth, 585 1275 NewHeight: Integer); 586 1276 begin 587 SetLength(FBits, NewWidth * NewHeight);1277 ReallocMem(FBits, NewWidth * NewHeight * SizeOf(TFloat)); 588 1278 Width := NewWidth; 589 1279 Height := NewHeight; … … 592 1282 procedure TFloatMap.Clear; 593 1283 begin 594 FillChar(FBits [0], Width * Height * SizeOf(TFloat), 0);1284 FillChar(FBits^, Width * Height * SizeOf(TFloat), 0); 595 1285 Changed; 596 1286 end; … … 601 1291 begin 602 1292 for Index := 0 to Width * Height - 1 do 603 FBits [Index] := FillValue;1293 FBits^[Index] := FillValue; 604 1294 Changed; 605 1295 end; 606 1296 607 destructor TFloatMap.Destroy; 1297 function TFloatMap.Empty: Boolean; 1298 begin 1299 Result := not Assigned(FBits); 1300 end; 1301 1302 function TFloatMap.GetScanline(Y: Integer): PFloatArray; 1303 begin 1304 Result := @FBits^[Y * Width]; 1305 end; 1306 1307 function TFloatMap.GetValPtr(X, Y: Integer): GR32.PFloat; 1308 begin 1309 Result := @FBits^[X + Y * Width]; 1310 end; 1311 1312 function TFloatMap.GetValue(X, Y: Integer): TFloat; 1313 begin 1314 Result := FBits^[X + Y * Width]; 1315 end; 1316 1317 procedure TFloatMap.SetValue(X, Y: Integer; const Value: TFloat); 1318 begin 1319 FBits^[X + Y * Width] := Value; 1320 end; 1321 1322 1323 {$IFDEF COMPILER2010} 1324 1325 { TGenericMap<T> } 1326 1327 constructor TGenericMap<T>.Create; 608 1328 begin 609 1329 FBits := nil; 1330 inherited Create; 1331 end; 1332 1333 destructor TGenericMap<T>.Destroy; 1334 begin 1335 FreeMem(FBits); 610 1336 inherited; 611 1337 end; 612 1338 613 function TFloatMap.Empty: Boolean; 1339 procedure TGenericMap<T>.Assign(Source: TPersistent); 1340 begin 1341 BeginUpdate; 1342 try 1343 (* 1344 if Source is TFloatMap then 1345 begin 1346 inherited SetSize(TFloatMap(Source).Width, TFloatMap(Source).Height); 1347 Move(TFloatMap(Source).Bits[0], Bits[0], Width * Height * SizeOf(TFloat)); 1348 end 1349 //else if Source is TBitmap32 then 1350 // ReadFrom(TBitmap32(Source), ctWeightedRGB) 1351 else 1352 inherited; 1353 *) 1354 finally 1355 EndUpdate; 1356 Changed; 1357 end; 1358 end; 1359 1360 procedure TGenericMap<T>.ChangeSize(var Width, Height: Integer; NewWidth, 1361 NewHeight: Integer); 1362 begin 1363 ReallocMem(FBits, NewWidth * NewHeight * SizeOf(T)); 1364 Width := NewWidth; 1365 Height := NewHeight; 1366 end; 1367 1368 procedure TGenericMap<T>.Clear(FillValue: T); 1369 var 1370 Index: Integer; 1371 begin 1372 for Index := 0 to Width * Height - 1 do 1373 Move(FillValue, PByte(FBits)[Index], SizeOf(T)); 1374 Changed; 1375 end; 1376 1377 procedure TGenericMap<T>.Clear; 1378 begin 1379 FillChar(FBits^, Width * Height * SizeOf(T), 0); 1380 Changed; 1381 end; 1382 1383 function TGenericMap<T>.Empty: Boolean; 614 1384 begin 615 1385 Result := not Assigned(FBits); 616 1386 end; 617 1387 618 function TFloatMap.GetBits: PFloatArray; 619 begin 620 Result := @FBits[0]; 621 end; 622 623 function TFloatMap.GetValPtr(X, Y: Integer): PFloat; 624 begin 625 Result := @FBits[X + Y * Width]; 626 end; 627 628 function TFloatMap.GetValue(X, Y: Integer): TFloat; 629 begin 630 Result := FBits[X + Y * Width]; 631 end; 632 633 procedure TFloatMap.SetValue(X, Y: Integer; const Value: TFloat); 634 begin 635 FBits[X + Y * Width] := Value; 636 end; 1388 function TGenericMap<T>.GetValue(X, Y: Integer): T; 1389 begin 1390 Move(PByte(FBits)[(X + Y * Width) * SizeOf(T)], Result, SizeOf(T)); 1391 end; 1392 1393 procedure TGenericMap<T>.SetValue(X, Y: Integer; const Value: T); 1394 begin 1395 Move(Value, PByte(FBits)[(X + Y * Width) * SizeOf(T)], SizeOf(T)); 1396 end; 1397 1398 {$ENDIF} 637 1399 638 1400 end. -
GraphicTest/Packages/Graphics32/GR32_Polygons.pas
r450 r522 21 21 * license. 22 22 * 23 * The Original Code is Graphics3223 * The Original Code is Vectorial Polygon Rasterizer for Graphics32 24 24 * 25 25 * The Initial Developer of the Original Code is 26 * Alex A. Denisov26 * Mattias Andersson <mattias@centaurix.com> 27 27 * 28 * Portions created by the Initial Developer are Copyright (C) 200 0-200928 * Portions created by the Initial Developer are Copyright (C) 2008-2012 29 29 * the Initial Developer. All Rights Reserved. 30 30 * 31 31 * Contributor(s): 32 * Andre Beckedorf <Andre@metaException.de>33 * Mattias Andersson <mattias@centaurix.com>34 * Peter Larson <peter@larson.net>35 32 * 36 33 * ***** END LICENSE BLOCK ***** *) … … 40 37 {$I GR32.inc} 41 38 42 {$IFDEF PUREPASCAL}43 {$DEFINE USENATIVECODE}44 {$ENDIF}45 {$IFDEF USEINLINING}46 {$DEFINE USENATIVECODE}47 {$ENDIF}48 49 39 uses 50 {$IFDEF FPC} 51 {$ELSE} 52 Windows, 53 {$ENDIF} 54 Classes, SysUtils, GR32, GR32_LowLevel, GR32_Blend, GR32_Transforms, 55 GR32_Resamplers, GR32_Math; 56 57 { Polylines } 58 59 procedure PolylineTS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 60 Color: TColor32; Closed: Boolean = False; Transformation: TTransformation = nil); 61 procedure PolylineAS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 62 Color: TColor32; Closed: Boolean = False; Transformation: TTransformation = nil); 63 procedure PolylineXS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 64 Color: TColor32; Closed: Boolean = False; Transformation: TTransformation = nil); 65 procedure PolylineXSP(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 66 Closed: Boolean = False; Transformation: TTransformation = nil); 67 68 procedure PolyPolylineTS(Bitmap: TCustomBitmap32; const Points: TArrayOfArrayOfFixedPoint; 69 Color: TColor32; Closed: Boolean = False; Transformation: TTransformation = nil); 70 procedure PolyPolylineAS(Bitmap: TCustomBitmap32; const Points: TArrayOfArrayOfFixedPoint; 71 Color: TColor32; Closed: Boolean = False; Transformation: TTransformation = nil); 72 procedure PolyPolylineXS(Bitmap: TCustomBitmap32; const Points: TArrayOfArrayOfFixedPoint; 73 Color: TColor32; Closed: Boolean = False; Transformation: TTransformation = nil); 74 procedure PolyPolylineXSP(Bitmap: TCustomBitmap32; const Points: TArrayOfArrayOfFixedPoint; 75 Closed: Boolean = False; Transformation: TTransformation = nil); 76 77 { Polygons } 40 Types, GR32, GR32_Containers, GR32_VPR, GR32_Transforms, GR32_Resamplers; 78 41 79 42 type 80 TPolyFillMode = (pfAlternate, pfWinding); 81 TAntialiasMode = (am32times, am16times, am8times, am4times, am2times, amNone); 82 83 TFillLineEvent = procedure(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32) of object; 43 { Polygon join style - used by GR32_VectorUtils.Grow(). } 44 { nb: jsRoundEx rounds both convex and concave joins unlike jsRound which 45 only rounds convex joins. The depth of convex join rounding is controlled 46 by Grow's MiterLimit parameter } 47 TJoinStyle = (jsMiter, jsBevel, jsRound, jsRoundEx); 48 49 { Polygon end style } 50 TEndStyle = (esButt, esSquare, esRound); 51 52 { Polygon fill mode } 53 TPolyFillMode = (pfAlternate, pfWinding, pfEvenOdd = 0, pfNonZero); 54 55 { TCustomPolygonRenderer } 56 TCustomPolygonRenderer = class(TThreadPersistent) 57 public 58 procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint; 59 const ClipRect: TFloatRect; Transformation: TTransformation); overload; virtual; 60 procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint; 61 const ClipRect: TFloatRect); overload; virtual; 62 procedure PolygonFS(const Points: TArrayOfFloatPoint; 63 const ClipRect: TFloatRect; Transformation: TTransformation); overload; virtual; 64 procedure PolygonFS(const Points: TArrayOfFloatPoint; 65 const ClipRect: TFloatRect); overload; virtual; 66 67 // procedure PolyPolygonXS(const Points: TArrayOfArrayOfFixedPoint; const ClipRect: TFixedRect; Transformation: TTransformation); virtual; overload; 68 // procedure PolyPolygonXS(const Points: TArrayOfArrayOfFixedPoint; const ClipRect: TFixedRect); virtual; overload; 69 end; 70 TCustomPolygonRendererClass = class of TCustomPolygonRenderer; 71 72 TCustomPolygonFiller = class; 73 74 { TPolygonRenderer32 } 75 TPolygonRenderer32 = class(TCustomPolygonRenderer) 76 private 77 FBitmap: TBitmap32; 78 FFillMode: TPolyFillMode; 79 FColor: TColor32; 80 FFiller: TCustomPolygonFiller; 81 procedure SetColor(const Value: TColor32); 82 procedure SetFillMode(const Value: TPolyFillMode); 83 procedure SetFiller(const Value: TCustomPolygonFiller); 84 protected 85 procedure SetBitmap(const Value: TBitmap32); virtual; 86 public 87 constructor Create(Bitmap: TBitmap32; Fillmode: TPolyFillMode = pfWinding); reintroduce; overload; 88 procedure PolygonFS(const Points: TArrayOfFloatPoint); overload; virtual; 89 procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint); overload; virtual; 90 91 property Bitmap: TBitmap32 read FBitmap write SetBitmap; 92 property FillMode: TPolyFillMode read FFillMode write SetFillMode; 93 property Color: TColor32 read FColor write SetColor; 94 property Filler: TCustomPolygonFiller read FFiller write SetFiller; 95 end; 96 TPolygonRenderer32Class = class of TPolygonRenderer32; 97 98 { TPolygonRenderer32VPR } 99 { Polygon renderer based on VPR. Computes exact coverages for optimal anti-aliasing. } 100 TFillProc = procedure(Coverage: PSingleArray; AlphaValues: PColor32Array; Count: Integer; Color: TColor32); 101 102 TPolygonRenderer32VPR = class(TPolygonRenderer32) 103 private 104 FFillProc: TFillProc; 105 procedure UpdateFillProcs; 106 protected 107 procedure RenderSpan(const Span: TValueSpan; DstY: Integer); virtual; 108 procedure FillSpan(const Span: TValueSpan; DstY: Integer); virtual; 109 function GetRenderSpan: TRenderSpanEvent; virtual; 110 public 111 procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint; 112 const ClipRect: TFloatRect); override; 113 end; 114 115 { TPolygonRenderer32LCD } 116 TPolygonRenderer32LCD = class(TPolygonRenderer32VPR) 117 protected 118 procedure RenderSpan(const Span: TValueSpan; DstY: Integer); override; 119 public 120 procedure PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint; 121 const ClipRect: TFloatRect); override; 122 end; 123 124 { TPolygonRenderer32LCD2 } 125 TPolygonRenderer32LCD2 = class(TPolygonRenderer32LCD) 126 public 127 procedure RenderSpan(const Span: TValueSpan; DstY: Integer); override; 128 end; 129 130 { TCustomPolygonFiller } 131 132 TFillLineEvent = procedure(Dst: PColor32; DstX, DstY, Length: Integer; 133 AlphaValues: PColor32; CombineMode: TCombineMode) of object; 84 134 85 135 TCustomPolygonFiller = class … … 87 137 function GetFillLine: TFillLineEvent; virtual; abstract; 88 138 public 139 procedure BeginRendering; virtual; 140 procedure EndRendering; virtual; 141 89 142 property FillLine: TFillLineEvent read GetFillLine; 90 143 end; 91 144 92 const 93 DefaultAAMode = am8times; // Use 54 levels of transparency for antialiasing. 94 95 procedure PolygonTS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 96 Color: TColor32; Mode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; 97 procedure PolygonTS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 98 FillLineCallback: TFillLineEvent; Mode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; 99 procedure PolygonTS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 100 Filler: TCustomPolygonFiller; Mode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; 101 102 procedure PolygonXS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 103 Color: TColor32; Mode: TPolyFillMode = pfAlternate; 104 const AAMode: TAntialiasMode = DefaultAAMode; Transformation: TTransformation = nil); overload; 105 procedure PolygonXS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 106 FillLineCallback: TFillLineEvent; Mode: TPolyFillMode = pfAlternate; 107 const AAMode: TAntialiasMode = DefaultAAMode; Transformation: TTransformation = nil); overload; 108 procedure PolygonXS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 109 Filler: TCustomPolygonFiller; Mode: TPolyFillMode = pfAlternate; 110 const AAMode: TAntialiasMode = DefaultAAMode; Transformation: TTransformation = nil); overload; 111 112 procedure PolyPolygonTS(Bitmap: TCustomBitmap32; const Points: TArrayOfArrayOfFixedPoint; 113 Color: TColor32; Mode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; 114 procedure PolyPolygonTS(Bitmap: TCustomBitmap32; const Points: TArrayOfArrayOfFixedPoint; 115 FillLineCallback: TFillLineEvent; Mode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; 116 procedure PolyPolygonTS(Bitmap: TCustomBitmap32; const Points: TArrayOfArrayOfFixedPoint; 117 Filler: TCustomPolygonFiller; Mode: TPolyFillMode = pfAlternate; Transformation: TTransformation = nil); overload; 118 119 procedure PolyPolygonXS(Bitmap: TCustomBitmap32; const Points: TArrayOfArrayOfFixedPoint; 120 FillLineCallback: TFillLineEvent; Mode: TPolyFillMode = pfAlternate; 121 const AAMode: TAntialiasMode = DefaultAAMode; Transformation: TTransformation = nil); overload; 122 procedure PolyPolygonXS(Bitmap: TCustomBitmap32; const Points: TArrayOfArrayOfFixedPoint; 123 Color: TColor32; Mode: TPolyFillMode = pfAlternate; 124 const AAMode: TAntialiasMode = DefaultAAMode; Transformation: TTransformation = nil); overload; 125 procedure PolyPolygonXS(Bitmap: TCustomBitmap32; const Points: TArrayOfArrayOfFixedPoint; 126 Filler: TCustomPolygonFiller; Mode: TPolyFillMode = pfAlternate; 127 const AAMode: TAntialiasMode = DefaultAAMode; Transformation: TTransformation = nil); overload; 128 129 function PolygonBounds(const Points: TArrayOfFixedPoint; Transformation: TTransformation = nil): TFixedRect; 130 function PolyPolygonBounds(const Points: TArrayOfArrayOfFixedPoint; Transformation: TTransformation = nil): TFixedRect; 131 132 function PtInPolygon(const Pt: TFixedPoint; const Points: TArrayOfFixedPoint): Boolean; 133 134 { TPolygon32 } 135 { TODO : Bezier Curves, and QSpline curves for TrueType font rendering } 136 { TODO : Check if QSpline is compatible with Type1 fonts } 137 type 138 TPolygon32 = class(TThreadPersistent) 145 { TCallbackPolygonFiller } 146 TCallbackPolygonFiller = class(TCustomPolygonFiller) 139 147 private 140 FAntialiased: Boolean; 141 FClosed: Boolean; 142 FFillMode: TPolyFillMode; 143 FNormals: TArrayOfArrayOfFixedPoint; 144 FPoints: TArrayOfArrayOfFixedPoint; 145 FAntialiasMode: TAntialiasMode; 148 FFillLineEvent: TFillLineEvent; 146 149 protected 147 procedure BuildNormals; 148 procedure CopyPropertiesTo(Dst: TPolygon32); virtual; 149 procedure AssignTo(Dst: TPersistent); override; 150 function GetFillLine: TFillLineEvent; override; 150 151 public 151 constructor Create; override; 152 destructor Destroy; override; 153 procedure Add(const P: TFixedPoint); 154 procedure AddPoints(var First: TFixedPoint; Count: Integer); 155 function ContainsPoint(const P: TFixedPoint): Boolean; 156 procedure Clear; 157 function Grow(const Delta: TFixed; EdgeSharpness: Single = 0): TPolygon32; 158 159 procedure Draw(Bitmap: TCustomBitmap32; OutlineColor, FillColor: TColor32; Transformation: TTransformation = nil); overload; 160 procedure Draw(Bitmap: TCustomBitmap32; OutlineColor: TColor32; FillCallback: TFillLineEvent; Transformation: TTransformation = nil); overload; 161 procedure Draw(Bitmap: TCustomBitmap32; OutlineColor: TColor32; Filler: TCustomPolygonFiller; Transformation: TTransformation = nil); overload; 162 163 procedure DrawEdge(Bitmap: TCustomBitmap32; Color: TColor32; Transformation: TTransformation = nil); 164 165 procedure DrawFill(Bitmap: TCustomBitmap32; Color: TColor32; Transformation: TTransformation = nil); overload; 166 procedure DrawFill(Bitmap: TCustomBitmap32; FillCallback: TFillLineEvent; Transformation: TTransformation = nil); overload; 167 procedure DrawFill(Bitmap: TCustomBitmap32; Filler: TCustomPolygonFiller; Transformation: TTransformation = nil); overload; 168 169 procedure NewLine; 170 procedure Offset(const Dx, Dy: TFixed); 171 function Outline: TPolygon32; 172 procedure Transform(Transformation: TTransformation); 173 function GetBoundingRect: TFixedRect; 174 175 property Antialiased: Boolean read FAntialiased write FAntialiased; 176 property AntialiasMode: TAntialiasMode read FAntialiasMode write FAntialiasMode; 177 property Closed: Boolean read FClosed write FClosed; 178 property FillMode: TPolyFillMode read FFillMode write FFillMode; 179 180 property Normals: TArrayOfArrayOfFixedPoint read FNormals write FNormals; 181 property Points: TArrayOfArrayOfFixedPoint read FPoints write FPoints; 152 property FillLineEvent: TFillLineEvent read FFillLineEvent write FFillLineEvent; 153 end; 154 155 { TInvertPolygonFiller } 156 TInvertPolygonFiller = class(TCustomPolygonFiller) 157 protected 158 function GetFillLine: TFillLineEvent; override; 159 procedure FillLineBlend(Dst: PColor32; DstX, DstY, Length: Integer; 160 AlphaValues: PColor32; CombineMode: TCombineMode); 161 end; 162 163 { TClearPolygonFiller } 164 TClearPolygonFiller = class(TCustomPolygonFiller) 165 private 166 FColor: TColor32; 167 protected 168 function GetFillLine: TFillLineEvent; override; 169 procedure FillLineClear(Dst: PColor32; DstX, DstY, 170 Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); 171 public 172 constructor Create(Color: TColor32 = $00808080); reintroduce; virtual; 173 174 property Color: TColor32 read FColor write FColor; 182 175 end; 183 176 … … 190 183 protected 191 184 function GetFillLine: TFillLineEvent; override; 192 procedure FillLineOpaque(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); 193 procedure FillLineBlend(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); 194 procedure FillLineBlendMasterAlpha(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); 195 procedure FillLineCustomCombine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); 185 procedure FillLineOpaque(Dst: PColor32; DstX, DstY, 186 Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); 187 procedure FillLineBlend(Dst: PColor32; DstX, DstY, 188 Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); 189 procedure FillLineBlendMasterAlpha(Dst: PColor32; DstX, DstY, 190 Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); 191 procedure FillLineCustomCombine(Dst: PColor32; DstX, DstY, 192 Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); 196 193 public 197 194 property Pattern: TCustomBitmap32 read FPattern write FPattern; … … 207 204 procedure SetSampler(const Value: TCustomSampler); 208 205 protected 206 procedure SamplerChanged; virtual; 209 207 function GetFillLine: TFillLineEvent; override; 210 procedure SampleLineOpaque(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); 211 208 procedure SampleLineOpaque(Dst: PColor32; DstX, DstY, Length: Integer; 209 AlphaValues: PColor32; CombineMode: TCombineMode); 210 public 211 constructor Create(Sampler: TCustomSampler = nil); reintroduce; virtual; 212 procedure BeginRendering; override; 213 procedure EndRendering; override; 212 214 property Sampler: TCustomSampler read FSampler write SetSampler; 213 215 end; 214 216 217 procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 218 Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 219 Transformation: TTransformation = nil); overload; 220 procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 221 Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 222 Transformation: TTransformation = nil); overload; 223 procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 224 Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; 225 Transformation: TTransformation = nil); overload; 226 procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 227 Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; 228 Transformation: TTransformation = nil); overload; 229 procedure PolyPolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 230 Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 231 Transformation: TTransformation = nil); overload; 232 procedure PolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 233 Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 234 Transformation: TTransformation = nil); overload; 235 procedure PolyPolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 236 Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 237 Transformation: TTransformation = nil); overload; 238 procedure PolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 239 Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 240 Transformation: TTransformation = nil); overload; 241 242 procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 243 ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 244 Transformation: TTransformation = nil); overload; 245 procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 246 ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 247 Transformation: TTransformation = nil); overload; 248 procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 249 ClipRect: TRect; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; 250 Transformation: TTransformation = nil); overload; 251 procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 252 ClipRect: TRect; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; 253 Transformation: TTransformation = nil); overload; 254 procedure PolyPolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 255 ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 256 Transformation: TTransformation = nil); overload; 257 procedure PolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 258 ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 259 Transformation: TTransformation = nil); overload; 260 procedure PolyPolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 261 ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 262 Transformation: TTransformation = nil); overload; 263 procedure PolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 264 ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 265 Transformation: TTransformation = nil); overload; 266 267 268 procedure PolyPolylineFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 269 Color: TColor32; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; 270 JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; 271 MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); overload; 272 procedure PolyPolylineFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 273 Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; 274 JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; 275 MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); overload; 276 277 procedure PolylineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 278 Color: TColor32; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; 279 JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; 280 MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); overload; 281 procedure PolylineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 282 Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; 283 JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; 284 MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); overload; 285 286 //Filled only Dashes ... 287 procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 288 const Dashes: TArrayOfFloat; Color: TColor32; 289 Closed: Boolean = False; Width: TFloat = 1.0); overload; 290 procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 291 const Dashes: TArrayOfFloat; FillColor, StrokeColor: TColor32; 292 Closed: Boolean; Width: TFloat; StrokeWidth: TFloat = 2.0); overload; 293 //Filled and stroked Dashes ... 294 procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 295 const Dashes: TArrayOfFloat; Filler: TCustomPolygonFiller; 296 Closed: Boolean = False; Width: TFloat = 1.0); overload; 297 procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 298 const Dashes: TArrayOfFloat; Filler: TCustomPolygonFiller; StrokeColor: TColor32; 299 Closed: Boolean; Width: TFloat; StrokeWidth: TFloat = 2.0); overload; 300 301 procedure PolyPolygonXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; 302 Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 303 Transformation: TTransformation = nil); overload; 304 procedure PolygonXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 305 Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 306 Transformation: TTransformation = nil); overload; 307 procedure PolyPolygonXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; 308 Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; 309 Transformation: TTransformation = nil); overload; 310 procedure PolygonXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 311 Filler: TCustomPolygonFiller; FillMode: TPolyFillMode = pfAlternate; 312 Transformation: TTransformation = nil); overload; 313 procedure PolyPolygonXS_LCD(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; 314 Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 315 Transformation: TTransformation = nil); overload; 316 procedure PolygonXS_LCD(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 317 Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 318 Transformation: TTransformation = nil); 319 procedure PolyPolygonXS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; 320 Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 321 Transformation: TTransformation = nil); overload; 322 procedure PolygonXS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 323 Color: TColor32; FillMode: TPolyFillMode = pfAlternate; 324 Transformation: TTransformation = nil); 325 326 procedure PolyPolylineXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; 327 Color: TColor32; Closed: Boolean = False; StrokeWidth: TFixed = $10000; 328 JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; 329 MiterLimit: TFixed = $40000; Transformation: TTransformation = nil); overload; 330 procedure PolyPolylineXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; 331 Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFixed = $10000; 332 JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; 333 MiterLimit: TFixed = $40000; Transformation: TTransformation = nil); overload; 334 335 procedure PolylineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 336 Color: TColor32; Closed: Boolean = False; StrokeWidth: TFixed = $10000; 337 JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; 338 MiterLimit: TFixed = $40000; Transformation: TTransformation = nil); overload; 339 procedure PolylineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 340 Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFixed = $10000; 341 JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; 342 MiterLimit: TFixed = $40000; Transformation: TTransformation = nil); overload; 343 344 //Filled only Dashes ... 345 procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 346 const Dashes: TArrayOfFixed; Color: TColor32; 347 Closed: Boolean = False; Width: TFixed = $10000); overload; 348 procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 349 const Dashes: TArrayOfFixed; FillColor, StrokeColor: TColor32; 350 Closed: Boolean; Width: TFixed; StrokeWidth: TFixed = $20000); overload; 351 //Filled and stroked Dashes ... 352 procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 353 const Dashes: TArrayOfFixed; Filler: TCustomPolygonFiller; 354 Closed: Boolean = False; Width: TFixed = $10000); overload; 355 procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 356 const Dashes: TArrayOfFixed; Filler: TCustomPolygonFiller; StrokeColor: TColor32; 357 Closed: Boolean; Width: TFixed; StrokeWidth: TFixed = $20000); overload; 358 359 // fill entire bitmap with a given polygon filler 360 procedure FillBitmap(Bitmap: TBitmap32; Filler: TCustomPolygonFiller); 361 362 { Registration routines } 363 procedure RegisterPolygonRenderer(PolygonRendererClass: TCustomPolygonRendererClass); 364 365 var 366 PolygonRendererList: TClassList; 367 DefaultPolygonRendererClass: TPolygonRenderer32Class = TPolygonRenderer32VPR; 368 215 369 implementation 216 370 217 uses Math; 371 uses 372 Math, SysUtils, GR32_Math, GR32_LowLevel, GR32_Blend, GR32_Gamma, 373 GR32_VectorUtils; 374 375 resourcestring 376 RCStrNoSamplerSpecified = 'No sampler specified!'; 218 377 219 378 type 220 TCustomBitmap32Access = class(TCustomBitmap32); 221 TShiftFunc = function(Value: Integer): Integer; // needed for antialiasing to speed things up 222 // These are for edge scan info. Note, that the most significant bit of the 223 // edge in a scan line is used for winding (edge direction) info. 224 225 TEdgePoint = Integer; 226 227 PEdgePoints = ^TEdgePoints; 228 TEdgePoints = array [0..MaxListSize-1] of TEdgePoint; 229 230 PScanLine = ^TScanLine; 231 TScanLine = record 232 Count: Integer; 233 EdgePoints: PEdgePoints; 234 EdgePointsLength: Integer; 235 end; 236 237 TScanLines = array of TScanLine; 238 239 const 240 AA_LINES: Array[TAntialiasMode] of Integer = (32, 16, 8, 4, 2, 1); 241 AA_SHIFT: Array[TAntialiasMode] of Integer = (5, 4, 3, 2, 1, 0); 242 AA_MULTI: Array[TAntialiasMode] of Integer = (65, 273, 1167, 5460, 32662, 0); 243 244 { POLYLINES } 245 246 procedure PolylineTS( 247 Bitmap: TCustomBitmap32; 248 const Points: TArrayOfFixedPoint; 249 Color: TColor32; 250 Closed: Boolean; 379 TBitmap32Access = class(TBitmap32); 380 381 procedure RegisterPolygonRenderer(PolygonRendererClass: TCustomPolygonRendererClass); 382 begin 383 if not Assigned(PolygonRendererList) then PolygonRendererList := TClassList.Create; 384 PolygonRendererList.Add(PolygonRendererClass); 385 end; 386 387 // routines for color filling: 388 389 procedure MakeAlphaNonZeroUP(Coverage: PSingleArray; AlphaValues: PColor32Array; 390 Count: Integer; Color: TColor32); 391 var 392 I: Integer; 393 M, V: Cardinal; 394 Last: TFloat; 395 C: TColor32Entry absolute Color; 396 begin 397 M := C.A * $101; 398 Last := Infinity; 399 for I := 0 to Count - 1 do 400 begin 401 if PInteger(@Last)^ <> PInteger(@Coverage[I])^ then 402 begin 403 Last := Coverage[I]; 404 V := Abs(Round(Last * $10000)); 405 if V > $10000 then V := $10000; 406 V := V * M shr 24; 407 {$IFDEF USEGR32GAMMA} 408 V := GAMMA_ENCODING_TABLE[V]; 409 {$ENDIF} 410 C.A := V; 411 end; 412 AlphaValues[I] := Color; 413 end; 414 end; 415 416 (* 417 procedure MakeAlphaNonZeroUP(Coverage: PSingleArray; AlphaValues: PColor32Array; 418 Count: Integer; Color: TColor32); 419 var 420 I: Integer; 421 M, V, C: Cardinal; 422 begin 423 M := Color shr 24 * $101; 424 C := Color and $00ffffff; 425 for I := 0 to Count - 1 do 426 begin 427 V := Abs(Round(Coverage[I] * $10000)); 428 if V > $10000 then V := $10000; 429 {$IFDEF USEGR32GAMMA} 430 V := GAMMA_ENCODING_TABLE[V * M shr 24]; 431 AlphaValues[I] := (V shl 24) or C; 432 {$ELSE} 433 AlphaValues[I] := (V * M and $ff000000) or C; 434 {$ENDIF} 435 end; 436 end; 437 *) 438 439 procedure MakeAlphaEvenOddUP(Coverage: PSingleArray; AlphaValues: PColor32Array; 440 Count: Integer; Color: TColor32); 441 var 442 I: Integer; 443 M, V: Cardinal; 444 Last: TFloat; 445 C: TColor32Entry absolute Color; 446 begin 447 M := C.A * $101; 448 Last := Infinity; 449 for I := 0 to Count - 1 do 450 begin 451 if PInteger(@Last)^ <> PInteger(@Coverage[I])^ then 452 begin 453 Last := Coverage[I]; 454 V := Abs(Round(Coverage[I] * $10000)); 455 V := V and $01ffff; 456 if V >= $10000 then 457 V := V xor $1ffff; 458 V := V * M shr 24; 459 {$IFDEF USEGR32GAMMA} 460 V := GAMMA_ENCODING_TABLE[V]; 461 {$ENDIF} 462 C.A := V; 463 end; 464 AlphaValues[I] := Color; 465 end; 466 end; 467 468 procedure MakeAlphaNonZeroP(Value: Single; AlphaValues: PColor32Array; 469 Count: Integer; Color: TColor32); 470 var 471 M, V: Cardinal; 472 C: TColor32Entry absolute Color; 473 begin 474 M := C.A * $101; 475 V := Abs(Round(Value * $10000)); 476 if V > $10000 then V := $10000; 477 V := V * M shr 24; 478 {$IFDEF USEGR32GAMMA} 479 V := GAMMA_ENCODING_TABLE[V]; 480 {$ENDIF} 481 C.A := V; 482 FillLongWord(AlphaValues[0], Count, Color); 483 end; 484 485 procedure MakeAlphaEvenOddP(Value: Single; AlphaValues: PColor32Array; 486 Count: Integer; Color: TColor32); 487 var 488 M, V: Cardinal; 489 C: TColor32Entry absolute Color; 490 begin 491 M := C.A * $101; 492 V := Abs(Round(Value * $10000)); 493 V := V and $01ffff; 494 if V > $10000 then V := V xor $1ffff; 495 V := V * M shr 24; 496 {$IFDEF USEGR32GAMMA} 497 V := GAMMA_ENCODING_TABLE[V]; 498 {$ENDIF} 499 C.A := V; 500 FillLongWord(AlphaValues[0], Count, Color); 501 end; 502 503 504 // polygon filler routines (extract alpha only): 505 506 procedure MakeAlphaNonZeroUPF(Coverage: PSingleArray; AlphaValues: PColor32Array; 507 Count: Integer; Color: TColor32); 508 var 509 I: Integer; 510 V: Integer; 511 begin 512 for I := 0 to Count - 1 do 513 begin 514 V := Clamp(Round(Abs(Coverage[I]) * 256)); 515 {$IFDEF USEGR32GAMMA} 516 V := GAMMA_ENCODING_TABLE[V]; 517 {$ENDIF} 518 AlphaValues[I] := V; 519 end; 520 end; 521 522 procedure MakeAlphaEvenOddUPF(Coverage: PSingleArray; AlphaValues: PColor32Array; 523 Count: Integer; Color: TColor32); 524 var 525 I: Integer; 526 V: Integer; 527 begin 528 for I := 0 to Count - 1 do 529 begin 530 V := Round(Abs(Coverage[I]) * 256); 531 V := V and $000001ff; 532 if V >= $100 then V := V xor $1ff; 533 {$IFDEF USEGR32GAMMA} 534 V := GAMMA_ENCODING_TABLE[V]; 535 {$ENDIF} 536 AlphaValues[I] := V; 537 end; 538 end; 539 540 procedure MakeAlphaNonZeroPF(Value: Single; AlphaValues: PColor32Array; 541 Count: Integer; Color: TColor32); 542 var 543 V: Integer; 544 begin 545 V := Clamp(Round(Abs(Value) * 256)); 546 {$IFDEF USEGR32GAMMA} 547 V := GAMMA_ENCODING_TABLE[V]; 548 {$ENDIF} 549 FillLongWord(AlphaValues[0], Count, V); 550 end; 551 552 procedure MakeAlphaEvenOddPF(Value: Single; AlphaValues: PColor32Array; 553 Count: Integer; Color: TColor32); 554 var 555 V: Integer; 556 begin 557 V := Round(Abs(Value) * 256); 558 V := V and $000001ff; 559 if V >= $100 then V := V xor $1ff; 560 {$IFDEF USEGR32GAMMA} 561 V := GAMMA_ENCODING_TABLE[V]; 562 {$ENDIF} 563 FillLongWord(AlphaValues[0], Count, V); 564 end; 565 566 procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 567 Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); 568 var 569 Renderer: TPolygonRenderer32VPR; 570 begin 571 Renderer := TPolygonRenderer32VPR.Create; 572 try 573 Renderer.Bitmap := Bitmap; 574 Renderer.Color := Color; 575 Renderer.FillMode := FillMode; 576 Renderer.PolyPolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); 577 finally 578 Renderer.Free; 579 end; 580 end; 581 582 procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 583 Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); 584 var 585 Renderer: TPolygonRenderer32VPR; 586 begin 587 Renderer := TPolygonRenderer32VPR.Create; 588 try 589 Renderer.Bitmap := Bitmap; 590 Renderer.Color := Color; 591 Renderer.FillMode := FillMode; 592 Renderer.PolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); 593 finally 594 Renderer.Free; 595 end; 596 end; 597 598 procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 599 Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); 600 var 601 Renderer: TPolygonRenderer32VPR; 602 begin 603 if not Assigned(Filler) then Exit; 604 Renderer := TPolygonRenderer32VPR.Create; 605 try 606 Renderer.Bitmap := Bitmap; 607 Renderer.Filler := Filler; 608 Renderer.FillMode := FillMode; 609 Renderer.PolyPolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); 610 finally 611 Renderer.Free; 612 end; 613 end; 614 615 procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 616 Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); 617 var 618 Renderer: TPolygonRenderer32VPR; 619 begin 620 if not Assigned(Filler) then Exit; 621 Renderer := TPolygonRenderer32VPR.Create; 622 try 623 Renderer.Bitmap := Bitmap; 624 Renderer.Filler := Filler; 625 Renderer.FillMode := FillMode; 626 Renderer.PolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); 627 finally 628 Renderer.Free; 629 end; 630 end; 631 632 procedure PolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 633 Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); 634 var 635 Renderer: TPolygonRenderer32LCD; 636 begin 637 Renderer := TPolygonRenderer32LCD.Create; 638 try 639 Renderer.Bitmap := Bitmap; 640 Renderer.FillMode := FillMode; 641 Renderer.Color := Color; 642 Renderer.PolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); 643 finally 644 Renderer.Free; 645 end; 646 end; 647 648 procedure PolyPolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 649 Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); 650 var 651 Renderer: TPolygonRenderer32LCD; 652 begin 653 Renderer := TPolygonRenderer32LCD.Create; 654 try 655 Renderer.Bitmap := Bitmap; 656 Renderer.FillMode := FillMode; 657 Renderer.Color := Color; 658 Renderer.PolyPolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); 659 finally 660 Renderer.Free; 661 end; 662 end; 663 664 procedure PolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 665 Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); 666 var 667 Renderer: TPolygonRenderer32LCD2; 668 begin 669 Renderer := TPolygonRenderer32LCD2.Create; 670 try 671 Renderer.Bitmap := Bitmap; 672 Renderer.FillMode := FillMode; 673 Renderer.Color := Color; 674 Renderer.PolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); 675 finally 676 Renderer.Free; 677 end; 678 end; 679 680 procedure PolyPolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 681 Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); 682 var 683 Renderer: TPolygonRenderer32LCD2; 684 begin 685 Renderer := TPolygonRenderer32LCD2.Create; 686 try 687 Renderer.Bitmap := Bitmap; 688 Renderer.FillMode := FillMode; 689 Renderer.Color := Color; 690 Renderer.PolyPolygonFS(Points, FloatRect(Bitmap.ClipRect), Transformation); 691 finally 692 Renderer.Free; 693 end; 694 end; 695 696 procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 697 ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode; 251 698 Transformation: TTransformation); 252 699 var 253 I, Count: Integer; 254 DoAlpha: Boolean; 255 begin 256 Count := Length(Points); 257 258 if (Count = 1) and Closed then 259 if Assigned(Transformation) then 260 with Transformation.Transform(Points[0]) do 261 Bitmap.SetPixelTS(FixedRound(X), FixedRound(Y), Color) 700 Renderer: TPolygonRenderer32VPR; 701 IntersectedClipRect: TRect; 702 begin 703 Renderer := TPolygonRenderer32VPR.Create; 704 try 705 Renderer.Bitmap := Bitmap; 706 Renderer.Color := Color; 707 Renderer.FillMode := FillMode; 708 GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); 709 Renderer.PolyPolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); 710 finally 711 Renderer.Free; 712 end; 713 end; 714 715 procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 716 ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode; 717 Transformation: TTransformation); 718 var 719 Renderer: TPolygonRenderer32VPR; 720 IntersectedClipRect: TRect; 721 begin 722 Renderer := TPolygonRenderer32VPR.Create; 723 try 724 Renderer.Bitmap := Bitmap; 725 Renderer.Color := Color; 726 Renderer.FillMode := FillMode; 727 GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); 728 Renderer.PolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); 729 finally 730 Renderer.Free; 731 end; 732 end; 733 734 procedure PolyPolygonFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 735 ClipRect: TRect; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; 736 Transformation: TTransformation); 737 var 738 Renderer: TPolygonRenderer32VPR; 739 IntersectedClipRect: TRect; 740 begin 741 if not Assigned(Filler) then Exit; 742 Renderer := TPolygonRenderer32VPR.Create; 743 try 744 Renderer.Bitmap := Bitmap; 745 Renderer.Filler := Filler; 746 Renderer.FillMode := FillMode; 747 GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); 748 Renderer.PolyPolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); 749 finally 750 Renderer.Free; 751 end; 752 end; 753 754 procedure PolygonFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 755 ClipRect: TRect; Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; 756 Transformation: TTransformation); 757 var 758 Renderer: TPolygonRenderer32VPR; 759 IntersectedClipRect: TRect; 760 begin 761 if not Assigned(Filler) then Exit; 762 Renderer := TPolygonRenderer32VPR.Create; 763 try 764 Renderer.Bitmap := Bitmap; 765 Renderer.Filler := Filler; 766 Renderer.FillMode := FillMode; 767 GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); 768 Renderer.PolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); 769 finally 770 Renderer.Free; 771 end; 772 end; 773 774 procedure PolygonFS_LCD(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 775 ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode; 776 Transformation: TTransformation); 777 var 778 Renderer: TPolygonRenderer32LCD; 779 IntersectedClipRect: TRect; 780 begin 781 Renderer := TPolygonRenderer32LCD.Create; 782 try 783 Renderer.Bitmap := Bitmap; 784 Renderer.FillMode := FillMode; 785 Renderer.Color := Color; 786 GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); 787 Renderer.PolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); 788 finally 789 Renderer.Free; 790 end; 791 end; 792 793 procedure PolyPolygonFS_LCD(Bitmap: TBitmap32; 794 const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; 795 FillMode: TPolyFillMode; Transformation: TTransformation); 796 var 797 Renderer: TPolygonRenderer32LCD; 798 IntersectedClipRect: TRect; 799 begin 800 Renderer := TPolygonRenderer32LCD.Create; 801 try 802 Renderer.Bitmap := Bitmap; 803 Renderer.FillMode := FillMode; 804 Renderer.Color := Color; 805 GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); 806 Renderer.PolyPolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); 807 finally 808 Renderer.Free; 809 end; 810 end; 811 812 procedure PolygonFS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 813 ClipRect: TRect; Color: TColor32; FillMode: TPolyFillMode; 814 Transformation: TTransformation); 815 var 816 Renderer: TPolygonRenderer32LCD2; 817 IntersectedClipRect: TRect; 818 begin 819 Renderer := TPolygonRenderer32LCD2.Create; 820 try 821 Renderer.Bitmap := Bitmap; 822 Renderer.FillMode := FillMode; 823 Renderer.Color := Color; 824 GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); 825 Renderer.PolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); 826 finally 827 Renderer.Free; 828 end; 829 end; 830 831 procedure PolyPolygonFS_LCD2(Bitmap: TBitmap32; 832 const Points: TArrayOfArrayOfFloatPoint; ClipRect: TRect; Color: TColor32; 833 FillMode: TPolyFillMode; Transformation: TTransformation); 834 var 835 Renderer: TPolygonRenderer32LCD2; 836 IntersectedClipRect: TRect; 837 begin 838 Renderer := TPolygonRenderer32LCD2.Create; 839 try 840 Renderer.Bitmap := Bitmap; 841 Renderer.FillMode := FillMode; 842 Renderer.Color := Color; 843 GR32.IntersectRect(IntersectedClipRect, Bitmap.ClipRect, ClipRect); 844 Renderer.PolyPolygonFS(Points, FloatRect(IntersectedClipRect), Transformation); 845 finally 846 Renderer.Free; 847 end; 848 end; 849 850 procedure PolyPolylineFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 851 Color: TColor32; Closed: Boolean; StrokeWidth: TFloat; 852 JoinStyle: TJoinStyle; EndStyle: TEndStyle; 853 MiterLimit: TFloat; Transformation: TTransformation); 854 var 855 Dst: TArrayOfArrayOfFloatPoint; 856 begin 857 Dst := BuildPolyPolyLine(Points, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit); 858 PolyPolygonFS(Bitmap, Dst, Color, pfWinding, Transformation); 859 end; 860 861 procedure PolyPolylineFS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFloatPoint; 862 Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; 863 JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; 864 MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); 865 var 866 Dst: TArrayOfArrayOfFloatPoint; 867 begin 868 Dst := BuildPolyPolyLine(Points, Closed, StrokeWidth, JoinStyle, EndStyle, MiterLimit); 869 PolyPolygonFS(Bitmap, Dst, Filler, pfWinding, Transformation); 870 end; 871 872 procedure PolylineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 873 Color: TColor32; Closed: Boolean; StrokeWidth: TFloat; 874 JoinStyle: TJoinStyle; EndStyle: TEndStyle; 875 MiterLimit: TFloat; Transformation: TTransformation); 876 begin 877 PolyPolylineFS(Bitmap, PolyPolygon(Points), Color, Closed, StrokeWidth, 878 JoinStyle, EndStyle, MiterLimit, Transformation); 879 end; 880 881 procedure PolylineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 882 Filler: TCustomPolygonFiller; Closed: Boolean = False; StrokeWidth: TFloat = 1.0; 883 JoinStyle: TJoinStyle = jsMiter; EndStyle: TEndStyle = esButt; 884 MiterLimit: TFloat = 4.0; Transformation: TTransformation = nil); 885 begin 886 PolyPolylineFS(Bitmap, PolyPolygon(Points), Filler, Closed, StrokeWidth, 887 JoinStyle, EndStyle, MiterLimit, Transformation); 888 end; 889 890 procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 891 const Dashes: TArrayOfFloat; Color: TColor32; 892 Closed: Boolean = False; Width: TFloat = 1.0); 893 var 894 MultiPoly: TArrayOfArrayOfFloatPoint; 895 begin 896 MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); 897 PolyPolylineFS(Bitmap, MultiPoly, Color, False, Width); 898 end; 899 900 procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 901 const Dashes: TArrayOfFloat; FillColor, StrokeColor: TColor32; 902 Closed: Boolean; Width: TFloat; StrokeWidth: TFloat = 2.0); 903 var 904 MultiPoly: TArrayOfArrayOfFloatPoint; 905 begin 906 MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); 907 MultiPoly := BuildPolyPolyLine(MultiPoly, False, Width); 908 PolyPolygonFS(Bitmap, MultiPoly, FillColor); 909 PolyPolylineFS(Bitmap, MultiPoly, StrokeColor, True, StrokeWidth); 910 end; 911 912 procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 913 const Dashes: TArrayOfFloat; Filler: TCustomPolygonFiller; 914 Closed: Boolean = False; Width: TFloat = 1.0); 915 var 916 MultiPoly: TArrayOfArrayOfFloatPoint; 917 begin 918 MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); 919 PolyPolylineFS(Bitmap, MultiPoly, Filler, False, Width); 920 end; 921 922 procedure DashLineFS(Bitmap: TBitmap32; const Points: TArrayOfFloatPoint; 923 const Dashes: TArrayOfFloat; Filler: TCustomPolygonFiller; StrokeColor: TColor32; 924 Closed: Boolean; Width: TFloat; StrokeWidth: TFloat = 2.0); 925 var 926 MultiPoly: TArrayOfArrayOfFloatPoint; 927 begin 928 MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); 929 MultiPoly := BuildPolyPolyLine(MultiPoly, False, Width); 930 PolyPolygonFS(Bitmap, MultiPoly, Filler); 931 PolyPolylineFS(Bitmap, MultiPoly, StrokeColor, True, StrokeWidth); 932 end; 933 934 935 procedure PolyPolygonXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; 936 Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); 937 var 938 Renderer: TPolygonRenderer32VPR; 939 begin 940 Renderer := TPolygonRenderer32VPR.Create; 941 try 942 Renderer.Bitmap := Bitmap; 943 Renderer.Color := Color; 944 Renderer.FillMode := FillMode; 945 Renderer.PolyPolygonFS(FixedPointToFloatPoint(Points), 946 FloatRect(Bitmap.ClipRect), Transformation); 947 finally 948 Renderer.Free; 949 end; 950 end; 951 952 procedure PolygonXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 953 Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); 954 var 955 Renderer: TPolygonRenderer32VPR; 956 begin 957 Renderer := TPolygonRenderer32VPR.Create; 958 try 959 Renderer.Bitmap := Bitmap; 960 Renderer.Color := Color; 961 Renderer.FillMode := FillMode; 962 Renderer.PolygonFS(FixedPointToFloatPoint(Points), 963 FloatRect(Bitmap.ClipRect), Transformation); 964 finally 965 Renderer.Free; 966 end; 967 end; 968 969 procedure PolyPolygonXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; 970 Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); 971 var 972 Renderer: TPolygonRenderer32VPR; 973 begin 974 Renderer := TPolygonRenderer32VPR.Create; 975 try 976 Renderer.Bitmap := Bitmap; 977 Renderer.Filler := Filler; 978 Renderer.FillMode := FillMode; 979 Renderer.PolyPolygonFS(FixedPointToFloatPoint(Points), 980 FloatRect(Bitmap.ClipRect), Transformation); 981 finally 982 Renderer.Free; 983 end; 984 end; 985 986 procedure PolygonXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 987 Filler: TCustomPolygonFiller; FillMode: TPolyFillMode; Transformation: TTransformation); 988 var 989 Renderer: TPolygonRenderer32VPR; 990 begin 991 Renderer := TPolygonRenderer32VPR.Create; 992 try 993 Renderer.Bitmap := Bitmap; 994 Renderer.Filler := Filler; 995 Renderer.FillMode := FillMode; 996 Renderer.PolygonFS(FixedPointToFloatPoint(Points), 997 FloatRect(Bitmap.ClipRect), Transformation); 998 finally 999 Renderer.Free; 1000 end; 1001 end; 1002 1003 procedure PolygonXS_LCD(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 1004 Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); 1005 var 1006 Renderer: TPolygonRenderer32LCD; 1007 begin 1008 Renderer := TPolygonRenderer32LCD.Create; 1009 try 1010 Renderer.Bitmap := Bitmap; 1011 Renderer.FillMode := FillMode; 1012 Renderer.Color := Color; 1013 Renderer.PolygonFS(FixedPointToFloatPoint(Points), 1014 FloatRect(Bitmap.ClipRect), Transformation); 1015 finally 1016 Renderer.Free; 1017 end; 1018 end; 1019 1020 procedure PolyPolygonXS_LCD(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; 1021 Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); 1022 var 1023 Renderer: TPolygonRenderer32LCD; 1024 begin 1025 Renderer := TPolygonRenderer32LCD.Create; 1026 try 1027 Renderer.Bitmap := Bitmap; 1028 Renderer.FillMode := FillMode; 1029 Renderer.Color := Color; 1030 Renderer.PolyPolygonFS(FixedPointToFloatPoint(Points), 1031 FloatRect(Bitmap.ClipRect), Transformation); 1032 finally 1033 Renderer.Free; 1034 end; 1035 end; 1036 1037 procedure PolygonXS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 1038 Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); 1039 var 1040 Renderer: TPolygonRenderer32LCD2; 1041 begin 1042 Renderer := TPolygonRenderer32LCD2.Create; 1043 try 1044 Renderer.Bitmap := Bitmap; 1045 Renderer.FillMode := FillMode; 1046 Renderer.Color := Color; 1047 Renderer.PolygonFS(FixedPointToFloatPoint(Points), 1048 FloatRect(Bitmap.ClipRect), Transformation); 1049 finally 1050 Renderer.Free; 1051 end; 1052 end; 1053 1054 procedure PolyPolygonXS_LCD2(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; 1055 Color: TColor32; FillMode: TPolyFillMode; Transformation: TTransformation); 1056 var 1057 Renderer: TPolygonRenderer32LCD2; 1058 begin 1059 Renderer := TPolygonRenderer32LCD2.Create; 1060 try 1061 Renderer.Bitmap := Bitmap; 1062 Renderer.FillMode := FillMode; 1063 Renderer.Color := Color; 1064 Renderer.PolyPolygonFS(FixedPointToFloatPoint(Points), 1065 FloatRect(Bitmap.ClipRect), Transformation); 1066 finally 1067 Renderer.Free; 1068 end; 1069 end; 1070 1071 procedure PolyPolylineXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; 1072 Color: TColor32; Closed: Boolean; StrokeWidth: TFixed; 1073 JoinStyle: TJoinStyle; EndStyle: TEndStyle; 1074 MiterLimit: TFixed; Transformation: TTransformation); 1075 var 1076 Dst: TArrayOfArrayOfFixedPoint; 1077 begin 1078 Dst := BuildPolyPolyLine(Points, Closed, StrokeWidth, JoinStyle, EndStyle, 1079 MiterLimit); 1080 PolyPolygonXS(Bitmap, Dst, Color, pfWinding, Transformation); 1081 end; 1082 1083 procedure PolyPolylineXS(Bitmap: TBitmap32; const Points: TArrayOfArrayOfFixedPoint; 1084 Filler: TCustomPolygonFiller; Closed: Boolean = False; 1085 StrokeWidth: TFixed = $10000; JoinStyle: TJoinStyle = jsMiter; 1086 EndStyle: TEndStyle = esButt; MiterLimit: TFixed = $40000; 1087 Transformation: TTransformation = nil); 1088 var 1089 Dst: TArrayOfArrayOfFixedPoint; 1090 begin 1091 Dst := BuildPolyPolyLine(Points, Closed, StrokeWidth, JoinStyle, EndStyle, 1092 MiterLimit); 1093 PolyPolygonXS(Bitmap, Dst, Filler, pfWinding, Transformation); 1094 end; 1095 1096 procedure PolylineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 1097 Color: TColor32; Closed: Boolean; StrokeWidth: TFixed; 1098 JoinStyle: TJoinStyle; EndStyle: TEndStyle; 1099 MiterLimit: TFixed; Transformation: TTransformation); 1100 begin 1101 PolyPolylineXS(Bitmap, PolyPolygon(Points), Color, 1102 Closed, StrokeWidth, JoinStyle, EndStyle, 1103 MiterLimit, Transformation); 1104 end; 1105 1106 procedure PolylineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 1107 Filler: TCustomPolygonFiller; Closed: Boolean = False; 1108 StrokeWidth: TFixed = $10000; JoinStyle: TJoinStyle = jsMiter; 1109 EndStyle: TEndStyle = esButt; MiterLimit: TFixed = $40000; 1110 Transformation: TTransformation = nil); 1111 begin 1112 PolyPolylineXS(Bitmap, PolyPolygon(Points), Filler, Closed, StrokeWidth, 1113 JoinStyle, EndStyle, MiterLimit, Transformation); 1114 end; 1115 1116 procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 1117 const Dashes: TArrayOfFixed; Color: TColor32; 1118 Closed: Boolean = False; Width: TFixed = $10000); 1119 var 1120 MultiPoly: TArrayOfArrayOfFixedPoint; 1121 begin 1122 MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); 1123 PolyPolylineXS(Bitmap, MultiPoly, Color, False, Width); 1124 end; 1125 1126 procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 1127 const Dashes: TArrayOfFixed; FillColor, StrokeColor: TColor32; 1128 Closed: Boolean; Width: TFixed; StrokeWidth: TFixed = $20000); 1129 var 1130 MultiPoly: TArrayOfArrayOfFixedPoint; 1131 begin 1132 MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); 1133 PolyPolylineXS(Bitmap, MultiPoly, FillColor, False, Width); 1134 MultiPoly := BuildPolyPolyLine(MultiPoly, False, Width); 1135 PolyPolylineXS(Bitmap, MultiPoly, StrokeColor, True, strokeWidth); 1136 end; 1137 1138 procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 1139 const Dashes: TArrayOfFixed; Filler: TCustomPolygonFiller; 1140 Closed: Boolean = False; Width: TFixed = $10000); 1141 var 1142 MultiPoly: TArrayOfArrayOfFixedPoint; 1143 begin 1144 MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); 1145 PolyPolylineXS(Bitmap, MultiPoly, Filler, False, Width); 1146 end; 1147 1148 procedure DashLineXS(Bitmap: TBitmap32; const Points: TArrayOfFixedPoint; 1149 const Dashes: TArrayOfFixed; Filler: TCustomPolygonFiller; StrokeColor: TColor32; 1150 Closed: Boolean; Width: TFixed; StrokeWidth: TFixed = $20000); 1151 var 1152 MultiPoly: TArrayOfArrayOfFixedPoint; 1153 begin 1154 MultiPoly := GR32_VectorUtils.BuildDashedLine(Points, Dashes, 0, Closed); 1155 PolyPolylineXS(Bitmap, MultiPoly, Filler, False, Width); 1156 MultiPoly := BuildPolyPolyLine(MultiPoly, False, Width); 1157 PolyPolylineXS(Bitmap, MultiPoly, StrokeColor, True, StrokeWidth); 1158 end; 1159 1160 procedure FillBitmap(Bitmap: TBitmap32; Filler: TCustomPolygonFiller); 1161 var 1162 AlphaValues: PColor32; 1163 Y: Integer; 1164 begin 1165 {$IFDEF USESTACKALLOC} 1166 AlphaValues := StackAlloc(Bitmap.Width * SizeOf(TColor32)); 1167 {$ELSE} 1168 GetMem(AlphaValues, Bitmap.Width * SizeOf(TColor32)); 1169 {$ENDIF} 1170 FillLongword(AlphaValues^, Bitmap.Width, $FF); 1171 Filler.BeginRendering; 1172 for Y := 0 to Bitmap.Height - 1 do 1173 Filler.FillLine(PColor32(Bitmap.ScanLine[y]), 0, y, Bitmap.Width, 1174 AlphaValues, Bitmap.CombineMode); 1175 Filler.EndRendering; 1176 {$IFDEF USESTACKALLOC} 1177 StackFree(AlphaValues); 1178 {$ELSE} 1179 FreeMem(AlphaValues); 1180 {$ENDIF} 1181 end; 1182 1183 1184 { LCD sub-pixel rendering (see http://www.grc.com/cttech.htm) } 1185 1186 type 1187 PRGBTriple = ^TRGBTriple; 1188 TRGBTriple = packed record 1189 B, G, R: Byte; 1190 end; 1191 1192 PRGBTripleArray = ^TRGBTripleArray; 1193 TRGBTripleArray = array [0..0] of TRGBTriple; 1194 1195 TMakeAlphaProcLCD = procedure(Coverage: PSingleArray; AlphaValues: SysUtils.PByteArray; 1196 Count: Integer; Color: TColor32); 1197 1198 procedure MakeAlphaNonZeroLCD(Coverage: PSingleArray; AlphaValues: SysUtils.PByteArray; 1199 Count: Integer; Color: TColor32); 1200 var 1201 I: Integer; 1202 M, V: Cardinal; 1203 Last: TFloat; 1204 C: TColor32Entry absolute Color; 1205 begin 1206 M := C.A * 86; // 86 = 258 / 3 1207 1208 Last := Infinity; 1209 V := 0; 1210 AlphaValues[0] := 0; 1211 AlphaValues[1] := 0; 1212 for I := 0 to Count - 1 do 1213 begin 1214 if PInteger(@Last)^ <> PInteger(@Coverage[I])^ then 1215 begin 1216 Last := Coverage[I]; 1217 V := Abs(Round(Last * $10000)); 1218 if V > $10000 then V := $10000; 1219 V := V * M shr 24; 1220 end; 1221 Inc(AlphaValues[I], V); 1222 {$IFDEF USEGR32GAMMA} 1223 AlphaValues[I] := GAMMA_ENCODING_TABLE[AlphaValues[I]]; 1224 {$ENDIF} 1225 Inc(AlphaValues[I + 1], V); 1226 AlphaValues[I + 2] := V; 1227 end; 1228 AlphaValues[Count + 2] := 0; 1229 AlphaValues[Count + 3] := 0; 1230 end; 1231 1232 procedure MakeAlphaEvenOddLCD(Coverage: PSingleArray; AlphaValues: SysUtils.PByteArray; 1233 Count: Integer; Color: TColor32); 1234 var 1235 I: Integer; 1236 M, V: Cardinal; 1237 Last: TFloat; 1238 begin 1239 M := Color shr 24 * 86; // 86 = 258 / 3 1240 1241 Last := Infinity; 1242 V := 0; 1243 AlphaValues[0] := 0; 1244 AlphaValues[1] := 0; 1245 for I := 0 to Count - 1 do 1246 begin 1247 if PInteger(@Last)^ <> PInteger(@Coverage[I])^ then 1248 begin 1249 Last := Coverage[I]; 1250 V := Abs(Round(Coverage[I] * $10000)); 1251 V := V and $01ffff; 1252 if V >= $10000 then V := V xor $1ffff; 1253 V := V * M shr 24; 1254 end; 1255 Inc(AlphaValues[I], V); 1256 {$IFDEF USEGR32GAMMA} 1257 AlphaValues[I] := GAMMA_ENCODING_TABLE[AlphaValues[I]]; 1258 {$ENDIF} 1259 Inc(AlphaValues[I + 1], V); 1260 AlphaValues[I + 2] := V; 1261 end; 1262 AlphaValues[Count + 2] := 0; 1263 AlphaValues[Count + 3] := 0; 1264 end; 1265 1266 procedure MakeAlphaNonZeroLCD2(Coverage: PSingleArray; AlphaValues: SysUtils.PByteArray; 1267 Count: Integer; Color: TColor32); 1268 var 1269 I: Integer; 1270 begin 1271 MakeAlphaNonZeroLCD(Coverage, AlphaValues, Count, Color); 1272 AlphaValues[Count + 2] := (AlphaValues[Count] + AlphaValues[Count + 1]) div 3; 1273 AlphaValues[Count + 3] := AlphaValues[Count + 1] div 3; 1274 for I := Count + 1 downto 2 do 1275 begin 1276 AlphaValues[I] := (AlphaValues[I] + AlphaValues[I - 1] + AlphaValues[I - 2]) div 3; 1277 end; 1278 AlphaValues[1] := (AlphaValues[0] + AlphaValues[1]) div 3; 1279 AlphaValues[0] := AlphaValues[0] div 3; 1280 end; 1281 1282 procedure MakeAlphaEvenOddLCD2(Coverage: PSingleArray; AlphaValues: SysUtils.PByteArray; 1283 Count: Integer; Color: TColor32); 1284 var 1285 I: Integer; 1286 begin 1287 MakeAlphaEvenOddLCD(Coverage, AlphaValues, Count, Color); 1288 AlphaValues[Count + 2] := (AlphaValues[Count] + AlphaValues[Count + 1]) div 3; 1289 AlphaValues[Count + 3] := AlphaValues[Count + 1] div 3; 1290 for I := Count + 1 downto 2 do 1291 begin 1292 AlphaValues[I] := (AlphaValues[I] + AlphaValues[I - 1] + AlphaValues[I - 2]) div 3; 1293 end; 1294 AlphaValues[1] := (AlphaValues[0] + AlphaValues[1]) div 3; 1295 AlphaValues[0] := AlphaValues[0] div 3; 1296 end; 1297 1298 procedure CombineLineLCD(Weights: PRGBTripleArray; Dst: PColor32Array; Color: TColor32; Count: Integer); 1299 var 1300 I: Integer; 1301 {$IFDEF TEST_BLENDMEMRGB128SSE4} 1302 Weights64: UInt64; 1303 {$ENDIF} 1304 begin 1305 I := 0; 1306 while Count <> 0 do 1307 {$IFDEF TEST_BLENDMEMRGB128SSE4} 1308 if (Count shr 1) = 0 then 1309 {$ENDIF} 1310 begin 1311 if PColor32(@Weights[I])^ = $FFFFFFFF then 1312 Dst[I] := Color 1313 else 1314 BlendMemRGB(Color, Dst[I], PColor32(@Weights[I])^); 1315 Dec(Count); 1316 Inc(I); 1317 end 1318 {$IFDEF TEST_BLENDMEMRGB128SSE4} 262 1319 else 263 with Points[0] do 264 Bitmap.SetPixelTS(FixedRound(X), FixedRound(Y), Color); 265 266 if Count < 2 then Exit; 267 DoAlpha := Color and $FF000000 <> $FF000000; 268 Bitmap.BeginUpdate; 269 Bitmap.PenColor := Color; 270 271 if Assigned(Transformation) then 272 begin 273 with Transformation.Transform(Points[0]) do Bitmap.MoveTo(FixedRound(X), FixedRound(Y)); 274 if DoAlpha then 275 for I := 1 to Count - 1 do 276 with Transformation.Transform(Points[I]) do 277 Bitmap.LineToTS(FixedRound(X), FixedRound(Y)) 278 else 279 for I := 1 to Count - 1 do 280 with Transformation.Transform(Points[I]) do 281 Bitmap.LineToS(FixedRound(X), FixedRound(Y)); 282 283 if Closed then with Transformation.Transform(Points[0]) do 284 if DoAlpha then 285 Bitmap.LineToTS(FixedRound(X), FixedRound(Y)) 286 else 287 Bitmap.LineToS(FixedRound(X), FixedRound(Y)); 288 end 289 else 290 begin 291 with Points[0] do Bitmap.MoveTo(FixedRound(X), FixedRound(Y)); 292 if DoAlpha then 293 for I := 1 to Count - 1 do 294 with Points[I] do 295 Bitmap.LineToTS(FixedRound(X), FixedRound(Y)) 296 else 297 for I := 1 to Count - 1 do 298 with Points[I] do 299 Bitmap.LineToS(FixedRound(X), FixedRound(Y)); 300 301 if Closed then with Points[0] do 302 if DoAlpha then 303 Bitmap.LineToTS(FixedRound(X), FixedRound(Y)) 304 else 305 Bitmap.LineToS(FixedRound(X), FixedRound(Y)); 306 end; 307 308 Bitmap.EndUpdate; 309 Bitmap.Changed; 310 end; 311 312 procedure PolylineAS( 313 Bitmap: TCustomBitmap32; 314 const Points: TArrayOfFixedPoint; 315 Color: TColor32; 316 Closed: Boolean; 317 Transformation: TTransformation); 318 var 319 I, Count: Integer; 320 begin 321 Count := Length(Points); 322 if (Count = 1) and Closed then 323 if Assigned(Transformation) then 324 with Transformation.Transform(Points[0]) do 325 Bitmap.SetPixelTS(FixedRound(X), FixedRound(Y), Color) 326 else 327 with Points[0] do 328 Bitmap.SetPixelTS(FixedRound(X), FixedRound(Y), Color); 329 330 if Count < 2 then Exit; 331 Bitmap.BeginUpdate; 332 Bitmap.PenColor := Color; 333 334 if Assigned(Transformation) then 335 begin 336 with Transformation.Transform(Points[0]) do Bitmap.MoveTo(FixedRound(X), FixedRound(Y)); 337 for I := 1 to Count - 1 do 338 with Transformation.Transform(Points[I]) do 339 Bitmap.LineToAS(FixedRound(X), FixedRound(Y)); 340 if Closed then with Transformation.Transform(Points[0]) do Bitmap.LineToAS(FixedRound(X), FixedRound(Y)); 341 end 342 else 343 begin 344 with Points[0] do Bitmap.MoveTo(FixedRound(X), FixedRound(Y)); 345 for I := 1 to Count - 1 do 346 with Points[I] do 347 Bitmap.LineToAS(FixedRound(X), FixedRound(Y)); 348 if Closed then with Points[0] do Bitmap.LineToAS(FixedRound(X), FixedRound(Y)); 349 end; 350 351 Bitmap.EndUpdate; 352 Bitmap.Changed; 353 end; 354 355 procedure PolylineXS( 356 Bitmap: TCustomBitmap32; 357 const Points: TArrayOfFixedPoint; 358 Color: TColor32; 359 Closed: Boolean; 360 Transformation: TTransformation); 361 var 362 I, Count: Integer; 363 begin 364 Count := Length(Points); 365 if (Count = 1) and Closed then 366 if Assigned(Transformation) then 367 with Transformation.Transform(Points[0]) do Bitmap.PixelXS[X, Y] := Color 368 else 369 with Points[0] do Bitmap.PixelXS[X, Y] := Color; 370 371 if Count < 2 then Exit; 372 Bitmap.BeginUpdate; 373 Bitmap.PenColor := Color; 374 375 if Assigned(Transformation) then 376 begin 377 with Transformation.Transform(Points[0]) do Bitmap.MoveToX(X, Y); 378 for I := 1 to Count - 1 do with Transformation.Transform(Points[I]) do Bitmap.LineToXS(X, Y); 379 if Closed then with Transformation.Transform(Points[0]) do Bitmap.LineToXS(X, Y); 380 end 381 else 382 begin 383 with Points[0] do Bitmap.MoveToX(X, Y); 384 for I := 1 to Count - 1 do with Points[I] do Bitmap.LineToXS(X, Y); 385 if Closed then with Points[0] do Bitmap.LineToXS(X, Y); 386 end; 387 388 Bitmap.EndUpdate; 389 Bitmap.Changed; 390 end; 391 392 procedure PolylineXSP( 393 Bitmap: TCustomBitmap32; 394 const Points: TArrayOfFixedPoint; 395 Closed: Boolean; 396 Transformation: TTransformation); 397 var 398 I, Count: Integer; 399 begin 400 Count := Length(Points); 401 if Count < 2 then Exit; 402 Bitmap.BeginUpdate; 403 if Assigned(Transformation) then 404 begin 405 with Transformation.Transform(Points[0]) do Bitmap.MoveToX(X, Y); 406 for I := 1 to Count - 1 do with Transformation.Transform(Points[I]) do Bitmap.LineToXSP(X, Y); 407 if Closed then with Transformation.Transform(Points[0]) do Bitmap.LineToXSP(X, Y); 408 end 409 else 410 begin 411 with Points[0] do Bitmap.MoveToX(X, Y); 412 for I := 1 to Count - 1 do with Points[I] do Bitmap.LineToXSP(X, Y); 413 if Closed then with Points[0] do Bitmap.LineToXSP(X, Y); 414 end; 415 416 Bitmap.EndUpdate; 417 Bitmap.Changed; 418 end; 419 420 procedure PolyPolylineTS( 421 Bitmap: TCustomBitmap32; 422 const Points: TArrayOfArrayOfFixedPoint; 423 Color: TColor32; 424 Closed: Boolean; 425 Transformation: TTransformation); 426 var 427 I: Integer; 428 begin 429 for I := 0 to High(Points) do PolylineTS(Bitmap, Points[I], Color, Closed, Transformation); 430 end; 431 432 procedure PolyPolylineAS( 433 Bitmap: TCustomBitmap32; 434 const Points: TArrayOfArrayOfFixedPoint; 435 Color: TColor32; 436 Closed: Boolean; 437 Transformation: TTransformation); 438 var 439 I: Integer; 440 begin 441 for I := 0 to High(Points) do PolylineAS(Bitmap, Points[I], Color, Closed, Transformation); 442 end; 443 444 procedure PolyPolylineXS( 445 Bitmap: TCustomBitmap32; 446 const Points: TArrayOfArrayOfFixedPoint; 447 Color: TColor32; 448 Closed: Boolean; 449 Transformation: TTransformation); 450 var 451 I: Integer; 452 begin 453 for I := 0 to High(Points) do PolylineXS(Bitmap, Points[I], Color, Closed, Transformation); 454 end; 455 456 procedure PolyPolylineXSP( 457 Bitmap: TCustomBitmap32; 458 const Points: TArrayOfArrayOfFixedPoint; 459 Closed: Boolean; 460 Transformation: TTransformation); 461 var 462 I: Integer; 463 begin 464 for I := 0 to High(Points) do PolylineXSP(Bitmap, Points[I], Closed, Transformation); 465 end; 466 467 468 { General routines for drawing polygons } 469 470 procedure ScanLinesCreate(var ScanLines: TScanLines; Length: Integer); 471 begin 472 SetLength(ScanLines, Length); 473 end; 474 475 procedure ScanLinesDestroy(var ScanLines: TScanLines); 476 var 477 I: Integer; 478 begin 479 for I := 0 to High(ScanLines) do 480 FreeMem(ScanLines[I].EdgePoints); 481 482 SetLength(ScanLines, 0); 483 end; 484 485 486 { Routines for sorting edge points in scanlines } 487 488 const 489 SortThreshold = 10; 490 ReallocationThreshold = 64; 491 492 procedure InsertionSort(LPtr, RPtr: PInteger); 493 var 494 IPtr, JPtr: PInteger; 495 Temp: PInteger; 496 P, C, T: Integer; 497 begin 498 IPtr := LPtr; 499 Inc(IPtr); 500 repeat 501 C := IPtr^; 502 P := C and $7FFFFFFF; 503 JPtr := IPtr; 504 505 {$IFDEF HAS_NATIVEINT} 506 if NativeUInt(JPtr) > NativeUInt(LPtr) then 507 {$ELSE} 508 if Cardinal(JPtr) > Cardinal(LPtr) then 509 {$ENDIF} 510 repeat 511 Temp := JPtr; 512 Dec(Temp); 513 T := Temp^; 514 if T and $7FFFFFFF > P then 1320 begin 1321 Weights64 := (UInt64(PColor32(@Weights[I + 1])^) shl 32) or 1322 PColor32(@Weights[I])^; 1323 if Weights64 = $FFFFFFFFFFFFFFFF then 515 1324 begin 516 JPtr^ := T;517 JPtr := Temp;1325 Dst[I] := Color; 1326 Dst[I + 1] := Color; 518 1327 end 519 1328 else 520 Break; 521 {$IFDEF HAS_NATIVEINT} 522 until NativeUInt(JPtr) <= NativeUInt(LPtr); 523 {$ELSE} 524 until Cardinal(JPtr) <= Cardinal(LPtr); 525 {$ENDIF} 526 527 JPtr^ := C; 528 Inc(IPtr); 529 {$IFDEF HAS_NATIVEINT} 530 until NativeUInt(IPtr) > NativeUInt(RPtr); 531 {$ELSE} 532 until Cardinal(IPtr) > Cardinal(RPtr); 533 {$ENDIF} 534 end; 535 536 procedure QuickSort(LPtr, RPtr: PInteger); 537 var 538 {$IFDEF HAS_NATIVEINT} 539 P: NativeUInt; 540 {$ELSE} 541 P: Cardinal; 542 {$ENDIF} 543 TempVal: Integer; 544 IPtr, JPtr: PInteger; 545 Temp: Integer; 546 const 547 OddMask = SizeOf(Integer) and not(SizeOf(Integer) - 1); 548 begin 549 {$IFDEF HAS_NATIVEINT} 550 if NativeUInt(RPtr) - NativeUInt(LPtr) > SortThreshold shl 2 then 551 {$ELSE} 552 if Cardinal(RPtr) - Cardinal(LPtr) > SortThreshold shl 2 then 553 {$ENDIF} 554 repeat 555 {$IFDEF HAS_NATIVEINT} 556 P := NativeUInt(RPtr) - NativeUInt(LPtr); 557 if (P and OddMask > 0) then Dec(P, SizeOf(Integer)); 558 TempVal := PInteger(NativeUInt(LPtr) + P shr 1)^ and $7FFFFFFF; 559 {$ELSE} 560 P := Cardinal(RPtr) - Cardinal(LPtr); 561 if (P and OddMask > 0) then Dec(P, SizeOf(Integer)); 562 TempVal := PInteger(Cardinal(LPtr) + P shr 1)^ and $7FFFFFFF; 563 {$ENDIF} 564 565 IPtr := LPtr; 566 JPtr := RPtr; 567 repeat 568 while (IPtr^ and $7FFFFFFF) < TempVal do Inc(IPtr); 569 while (JPtr^ and $7FFFFFFF) > TempVal do Dec(JPtr); 570 {$IFDEF HAS_NATIVEINT} 571 if NativeUInt(IPtr) <= NativeUInt(JPtr) then 572 {$ELSE} 573 if Cardinal(IPtr) <= Cardinal(JPtr) then 574 {$ENDIF} 575 begin 576 Temp := IPtr^; 577 IPtr^ := JPtr^; 578 JPtr^ := Temp; 579 // Swap(IPtr^, JPtr^); 580 Inc(IPtr); 581 Dec(JPtr); 582 end; 583 {$IFDEF HAS_NATIVEINT} 584 until NativeUInt(IPtr) > NativeUInt(JPtr); 585 if NativeUInt(LPtr) < NativeUInt(JPtr) then 586 {$ELSE} 587 until Integer(IPtr) > Integer(JPtr); 588 if Cardinal(LPtr) < Cardinal(JPtr) then 589 {$ENDIF} 590 QuickSort(LPtr, JPtr); 591 LPtr := IPtr; 592 {$IFDEF HAS_NATIVEINT} 593 until NativeUInt(IPtr) >= NativeUInt(RPtr) 594 {$ELSE} 595 until Cardinal(IPtr) >= Cardinal(RPtr) 596 {$ENDIF} 597 else 598 InsertionSort(LPtr, RPtr); 599 end; 600 601 procedure SortLine(const ALine: TScanLine); 602 var 603 L, T: Integer; 604 begin 605 L := ALine.Count; 606 Assert(not Odd(L)); 607 if L = 2 then 608 begin 609 if (ALine.EdgePoints[0] and $7FFFFFFF) > (ALine.EdgePoints[1] and $7FFFFFFF) then 610 begin 611 T := ALine.EdgePoints[0]; 612 ALine.EdgePoints[0] := ALine.EdgePoints[1]; 613 ALine.EdgePoints[1] := T; 614 end; 615 end 616 else if L > SortThreshold then 617 QuickSort(@ALine.EdgePoints[0], @ALine.EdgePoints[L - 1]) 618 else if L > 2 then 619 InsertionSort(@ALine.EdgePoints[0], @ALine.EdgePoints[L - 1]); 620 end; 621 622 procedure SortLines(const ScanLines: TScanLines); 623 var 624 I: Integer; 625 begin 626 for I := 0 to High(ScanLines) do SortLine(ScanLines[I]); 627 end; 628 629 630 { Routines for rendering polygon edges to scanlines } 631 632 procedure AddEdgePoint(X: Integer; const Y: Integer; const ClipRect: TFixedRect; const ScanLines: TScanLines; const Direction: Integer); 633 var 634 L: Integer; 635 ScanLine: PScanLine; 636 begin 637 if (Y < ClipRect.Top) or (Y > ClipRect.Bottom) then Exit; 638 639 if X < ClipRect.Left then 640 X := ClipRect.Left 641 else if X > ClipRect.Right then 642 X := ClipRect.Right; 643 644 // positive direction (+1) is down 645 if Direction < 0 then 646 X := Integer(Longword(X) or $80000000); // set the highest bit if the winding is up 647 648 ScanLine := @ScanLines[Y - ClipRect.Top]; 649 650 L := ScanLine.Count; 651 Inc(ScanLine.Count); 652 if ScanLine.Count > ScanLine.EdgePointsLength then 653 begin 654 ScanLine.EdgePointsLength := L + ReallocationThreshold; 655 ReallocMem(ScanLine.EdgePoints, ScanLine.EdgePointsLength * SizeOf(TEdgePoint)); 656 end; 657 ScanLine.EdgePoints[L] := X; 658 end; 659 660 function DrawEdge(const P1, P2: TFixedPoint; const ClipRect: TFixedRect; const ScanLines: TScanLines): Integer; 661 var 662 X, Y: Integer; 663 I, K: Integer; 664 Dx, Dy, Sx, Sy: Integer; 665 Delta: Integer; 666 begin 667 // this function 'renders' a line into the edge point (ScanLines) buffer 668 // and returns the line direction (1 - down, -1 - up, 0 - horizontal) 669 Result := 0; 670 if P2.Y = P1.Y then Exit; 671 Dx := P2.X - P1.X; 672 Dy := P2.Y - P1.Y; 673 674 if Dy > 0 then Sy := 1 675 else 676 begin 677 Sy := -1; 678 Dy := -Dy; 679 end; 680 681 Result := Sy; 682 683 if Dx > 0 then Sx := 1 684 else 685 begin 686 Sx := -1; 687 Dx := -Dx; 688 end; 689 690 Delta := (Dx mod Dy) shr 1; 691 X := P1.X; Y := P1.Y; 692 693 for I := 0 to Dy - 1 do 694 begin 695 AddEdgePoint(X, Y, ClipRect, ScanLines, Result); 696 Inc(Y, Sy); 697 Inc(Delta, Dx); 698 699 // try it two times and if anything else left, use div and mod 700 if Delta > Dy then 701 begin 702 Inc(X, Sx); 703 Dec(Delta, Dy); 704 705 if Delta > Dy then // segment is tilted more than 45 degrees? 706 begin 707 Inc(X, Sx); 708 Dec(Delta, Dy); 709 710 if Delta > Dy then // are we still here? 711 begin 712 K := (Delta + Dy - 1) div Dy; 713 Inc(X, Sx * K); 714 Dec(Delta, Dy * K); 715 end; 716 end; 717 end; 718 end; 719 end; 720 721 722 procedure RoundShift1(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); forward; {$IFDEF USEINLINING} inline; {$ENDIF} 723 procedure RoundShift2(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); forward; {$IFDEF USEINLINING} inline; {$ENDIF} 724 procedure RoundShift4(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); forward; {$IFDEF USEINLINING} inline; {$ENDIF} 725 procedure RoundShift8(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); forward; {$IFDEF USEINLINING} inline; {$ENDIF} 726 procedure RoundShift16(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); forward; {$IFDEF USEINLINING} inline; {$ENDIF} 727 procedure RoundShift32(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); forward; {$IFDEF USEINLINING} inline; {$ENDIF} 728 729 type 730 TTransformProc = procedure(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 731 TTransformationAccess = class(TTransformation); 732 733 procedure Transform1(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 734 begin 735 TTransformationAccess(T).TransformFixed(SrcPoint.X, SrcPoint.Y, DstPoint.X, DstPoint.Y); 736 RoundShift1(DstPoint, DstPoint, nil); 737 end; 738 739 procedure RoundShift1(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 740 {$IFDEF USENATIVECODE} 741 begin 742 DstPoint.X := (SrcPoint.X + $7F) div 256; 743 DstPoint.Y := (SrcPoint.Y + $7FFF) div 65536; 744 {$ELSE} 745 asm 746 {$IFDEF TARGET_x64} 747 MOV EAX, [SrcPoint] 748 ADD EAX, $0000007F 749 SAR EAX, 8 // sub-sampled 750 MOV [DstPoint], EAX 751 MOV EDX, [SrcPoint + $4] 752 ADD EDX, $00007FFF 753 SAR EDX, 16 754 MOV [DstPoint + $4], EDX 755 {$ENDIF} 756 {$IFDEF TARGET_x86} 757 MOV ECX, [SrcPoint.X] 758 ADD ECX, $0000007F 759 SAR ECX, 8 // sub-sampled 760 MOV [DstPoint.X], ECX 761 MOV EDX, [SrcPoint.Y] 762 ADD EDX, $00007FFF 763 SAR EDX, 16 764 MOV [DstPoint.Y], EDX 765 {$ENDIF} 766 {$ENDIF} 767 end; 768 769 procedure Transform2(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 770 begin 771 TTransformationAccess(T).TransformFixed(SrcPoint.X, SrcPoint.Y, DstPoint.X, DstPoint.Y); 772 RoundShift2(DstPoint, DstPoint, nil); 773 end; 774 775 procedure RoundShift2(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 776 {$IFDEF USENATIVECODE} 777 begin 778 DstPoint.X := (SrcPoint.X + $3FFF) div 32768; 779 DstPoint.Y := (SrcPoint.Y + $3FFF) div 32768; 780 {$ELSE} 781 asm 782 {$IFDEF TARGET_x64} 783 MOV EAX, [SrcPoint] 784 ADD EAX, $00003FFF 785 SAR EAX, 15 786 MOV [DstPoint], EAX 787 MOV EDX, [SrcPoint + $4] 788 ADD EDX, $00003FFF 789 SAR EDX, 15 790 MOV [DstPoint + $4], EDX 791 {$ENDIF} 792 {$IFDEF TARGET_x86} 793 MOV ECX, [SrcPoint.X] 794 ADD ECX, $00003FFF 795 SAR ECX, 15 796 MOV [DstPoint.X], ECX 797 MOV EDX, [SrcPoint.Y] 798 ADD EDX, $00003FFF 799 SAR EDX, 15 800 MOV [DstPoint.Y], EDX 801 {$ENDIF} 802 {$ENDIF} 803 end; 804 805 procedure Transform4(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 806 begin 807 TTransformationAccess(T).TransformFixed(SrcPoint.X, SrcPoint.Y, DstPoint.X, DstPoint.Y); 808 RoundShift4(DstPoint, DstPoint, nil); 809 end; 810 811 procedure RoundShift4(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 812 {$IFDEF USENATIVECODE} 813 begin 814 DstPoint.X := (SrcPoint.X + $1FFF) div 16384; 815 DstPoint.Y := (SrcPoint.Y + $1FFF) div 16384; 816 {$ELSE} 817 asm 818 {$IFDEF TARGET_x64} 819 MOV EAX, [SrcPoint] 820 ADD EAX, $00001FFF 821 SAR EAX, 14 822 MOV [DstPoint], EAX 823 MOV EDX, [SrcPoint + $4] 824 ADD EDX, $00001FFF 825 SAR EDX, 14 826 MOV [DstPoint + $4], EDX 827 {$ENDIF} 828 {$IFDEF TARGET_x86} 829 MOV ECX, [SrcPoint.X] 830 ADD ECX, $00001FFF 831 SAR ECX, 14 832 MOV [DstPoint.X], ECX 833 MOV EDX, [SrcPoint.Y] 834 ADD EDX, $00001FFF 835 SAR EDX, 14 836 MOV [DstPoint.Y], EDX 837 {$ENDIF} 838 {$ENDIF} 839 end; 840 841 procedure Transform8(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 842 begin 843 TTransformationAccess(T).TransformFixed(SrcPoint.X, SrcPoint.Y, DstPoint.X, DstPoint.Y); 844 RoundShift8(DstPoint, DstPoint, nil); 845 end; 846 847 procedure RoundShift8(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 848 {$IFDEF USENATIVECODE} 849 begin 850 DstPoint.X := (SrcPoint.X + $FFF) div 8192; 851 DstPoint.Y := (SrcPoint.Y + $FFF) div 8192; 852 {$ELSE} 853 asm 854 {$IFDEF TARGET_x64} 855 MOV EAX, [SrcPoint] 856 ADD EAX, $00000FFF 857 SAR EAX, 13 858 MOV [DstPoint], EAX 859 MOV EDX, [SrcPoint + $4] 860 ADD EDX, $00000FFF 861 SAR EDX, 13 862 MOV [DstPoint + $4], EDX 863 {$ENDIF} 864 {$IFDEF TARGET_x86} 865 MOV ECX, [SrcPoint.X] 866 ADD ECX, $00000FFF 867 SAR ECX, 13 868 MOV [DstPoint.X], ECX 869 MOV EDX, [SrcPoint.Y] 870 ADD EDX, $00000FFF 871 SAR EDX, 13 872 MOV [DstPoint.Y], EDX 873 {$ENDIF} 874 {$ENDIF} 875 end; 876 877 procedure Transform16(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 878 begin 879 TTransformationAccess(T).TransformFixed(SrcPoint.X, SrcPoint.Y, DstPoint.X, DstPoint.Y); 880 RoundShift16(DstPoint, DstPoint, nil); 881 end; 882 883 procedure RoundShift16(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 884 {$IFDEF USENATIVECODE} 885 begin 886 DstPoint.X := (SrcPoint.X + $7FF) div 4096; 887 DstPoint.Y := (SrcPoint.Y + $7FF) div 4096; 888 {$ELSE} 889 asm 890 {$IFDEF TARGET_x64} 891 MOV EAX, [SrcPoint] 892 ADD EAX, $000007FF 893 SAR EAX, 12 894 MOV [DstPoint], EAX 895 MOV EDX, [SrcPoint + $4] 896 ADD EDX, $000007FF 897 SAR EDX, 12 898 MOV [DstPoint + $4], EDX 899 {$ENDIF} 900 {$IFDEF TARGET_x86} 901 MOV ECX, [SrcPoint.X] 902 ADD ECX, $000007FF 903 SAR ECX, 12 904 MOV [DstPoint.X], ECX 905 MOV EDX, [SrcPoint.Y] 906 ADD EDX, $000007FF 907 SAR EDX, 12 908 MOV [DstPoint.Y], EDX 909 {$ENDIF} 910 {$ENDIF} 911 end; 912 913 procedure Transform32(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 914 begin 915 TTransformationAccess(T).TransformFixed(SrcPoint.X, SrcPoint.Y, DstPoint.X, DstPoint.Y); 916 RoundShift32(DstPoint, DstPoint, nil); 917 end; 918 919 procedure RoundShift32(var DstPoint: TFixedPoint; const SrcPoint: TFixedPoint; const T: TTransformation); 920 {$IFDEF USENATIVECODE} 921 begin 922 DstPoint.X := (SrcPoint.X + $3FF) div 2048; 923 DstPoint.Y := (SrcPoint.Y + $3FF) div 2048; 924 {$ELSE} 925 asm 926 {$IFDEF TARGET_x64} 927 MOV EAX, [SrcPoint] 928 ADD EAX, $000003FF 929 SAR EAX, 11 930 MOV [DstPoint], EAX 931 MOV EDX, [SrcPoint + $4] 932 ADD EDX, $000003FF 933 SAR EDX, 11 934 MOV [DstPoint + $4], EDX 935 {$ENDIF} 936 {$IFDEF TARGET_x86} 937 MOV ECX, [SrcPoint.X] 938 ADD ECX, $000003FF 939 SAR ECX, 11 940 MOV [DstPoint.X], ECX 941 MOV EDX, [SrcPoint.Y] 942 ADD EDX, $000003FF 943 SAR EDX, 11 944 MOV [DstPoint.Y], EDX 945 {$ENDIF} 946 {$ENDIF} 947 end; 948 949 const 950 RoundShiftProcs: array[TAntialiasMode] of TTransformProc = (RoundShift32, RoundShift16, RoundShift8, RoundShift4, RoundShift2, RoundShift1); 951 TransformProcs: array[TAntialiasMode] of TTransformProc = (Transform32, Transform16, Transform8, Transform4, Transform2, Transform1); 952 953 procedure AddPolygon(const Points: TArrayOfFixedPoint; const ClipRect: TFixedRect; 954 var ScanLines: TScanLines; AAMode: TAntialiasMode; Transformation: TTransformation); 955 var 956 P1, P2: TFixedPoint; 957 I: Integer; 958 PPtr: PFixedPoint; 959 Transform: TTransformProc; 960 Direction, PrevDirection: Integer; // up = 1 or down = -1 961 begin 962 if Length(Points) < 3 then Exit; 963 964 if Assigned(Transformation) then 965 Transform := TransformProcs[AAMode] 966 else 967 Transform := RoundShiftProcs[AAMode]; 968 969 Transform(P1, Points[0], Transformation); 970 971 // find the last Y different from Y1 and get direction 972 PrevDirection := 0; 973 I := High(Points); 974 PPtr := @Points[I]; 975 976 while (I > 0) and (PrevDirection = 0) do 977 begin 978 Dec(I); 979 Transform(P2, PPtr^, Transformation); { TODO : optimize minor inefficiency... } 980 PrevDirection := P1.Y - P2.Y; 981 Dec(PPtr); 982 end; 983 984 if PrevDirection > 0 then 985 PrevDirection := 1 986 else if PrevDirection < 0 then 987 PrevDirection := -1 988 else 989 PrevDirection := 0; 990 991 PPtr := @Points[1]; 992 for I := 1 to High(Points) do 993 begin 994 Transform(P2, PPtr^, Transformation); 995 996 if P1.Y <> P2.Y then 997 begin 998 Direction := DrawEdge(P1, P2, ClipRect, ScanLines); 999 if Direction <> PrevDirection then 1000 begin 1001 AddEdgePoint(P1.X, P1.Y, ClipRect, ScanLines, -Direction); 1002 PrevDirection := Direction; 1003 end; 1004 end; 1005 1006 P1 := P2; 1007 Inc(PPtr); 1008 end; 1009 1010 Transform(P2, Points[0], Transformation); 1011 1012 if P1.Y <> P2.Y then 1013 begin 1014 Direction := DrawEdge(P1, P2, ClipRect, ScanLines); 1015 if Direction <> PrevDirection then AddEdgePoint(P1.X, P1.Y, ClipRect, ScanLines, -Direction); 1016 end; 1017 end; 1018 1019 1020 { FillLines routines } 1021 { These routines rasterize the sorted edge points in the scanlines to 1022 the bitmap buffer } 1023 1024 procedure ColorFillLines(Bitmap: TCustomBitmap32; BaseY: Integer; 1025 const ScanLines: TScanLines; Color: TColor32; Mode: TPolyFillMode); 1026 var 1027 I, J, L: Integer; 1028 Top, Left, Right, OldRight, LP, RP, Cx: Integer; 1029 Winding, NextWinding: Integer; 1030 HorzLine: procedure(X1, Y, X2: Integer; Value: TColor32) of Object; 1031 begin 1032 if Color and $FF000000 <> $FF000000 then 1033 HorzLine := Bitmap.HorzLineT 1034 else 1035 HorzLine := Bitmap.HorzLine; 1036 1037 Cx := Bitmap.ClipRect.Right - 1; 1038 Top := BaseY - 1; 1039 1040 if Mode = pfAlternate then 1041 for J := 0 to High(ScanLines) do 1042 begin 1043 Inc(Top); 1044 L := ScanLines[J].Count; // assuming length is even 1045 if L = 0 then Continue; 1046 I := 0; 1047 OldRight := -1; 1048 1049 while I < L do 1050 begin 1051 Left := ScanLines[J].EdgePoints[I] and $7FFFFFFF; 1052 Inc(I); 1053 Right := ScanLines[J].EdgePoints[I] and $7FFFFFFF - 1; 1054 if Right > Left then 1055 begin 1056 if (Left and $FF) < $80 then Left := Left shr 8 1057 else Left := Left shr 8 + 1; 1058 1059 if (Right and $FF) < $80 then Right := Right shr 8 1060 else Right := Right shr 8 + 1; 1061 1062 if Right >= Cx then Right := Cx; 1063 1064 if Left <= OldRight then Left := OldRight + 1; 1065 OldRight := Right; 1066 if Right >= Left then HorzLine(Left, Top, Right, Color); 1067 end; 1068 Inc(I); 1069 end 1329 BlendMemRGB128(Color, Dst[I], Weights64); 1330 Dec(Count, 2); 1331 Inc(I, 2); 1070 1332 end 1071 else // Mode = pfWinding 1072 for J := 0 to High(ScanLines) do 1073 begin 1074 Inc(Top); 1075 L := ScanLines[J].Count; // assuming length is even 1076 if L = 0 then Continue; 1077 I := 0; 1078 1079 Winding := 0; 1080 Left := ScanLines[J].EdgePoints[0]; 1081 if (Left and $80000000) <> 0 then Inc(Winding) else Dec(Winding); 1082 Left := Left and $7FFFFFFF; 1083 Inc(I); 1084 1085 while I < L do 1086 begin 1087 Right := ScanLines[J].EdgePoints[I]; 1088 if (Right and $80000000) <> 0 then NextWinding := 1 else NextWinding := -1; 1089 Right := Right and $7FFFFFFF; 1090 Inc(I); 1091 1092 if Winding <> 0 then 1093 begin 1094 if (Left and $FF) < $80 then LP := Left shr 8 1095 else LP := Left shr 8 + 1; 1096 if (Right and $FF) < $80 then RP := Right shr 8 1097 else RP := Right shr 8 + 1; 1098 1099 if RP >= Cx then RP := Cx; 1100 1101 if RP >= LP then HorzLine(LP, Top, RP, Color); 1102 end; 1103 1104 Inc(Winding, NextWinding); 1105 Left := Right; 1106 end; 1107 end; 1108 end; 1109 1110 procedure ColorFillLines2(Bitmap: TCustomBitmap32; BaseY: Integer; 1111 const ScanLines: TScanLines; Color: TColor32; Mode: TPolyFillMode; 1112 const AAMode: TAntialiasMode = DefaultAAMode); 1113 var 1114 I, J, L, N: Integer; 1115 MinY, MaxY, Y, Top, Bottom: Integer; 1116 MinX, MaxX, X, Dx: Integer; 1117 Left, Right: Integer; 1118 Buffer: array of Integer; 1119 ColorBuffer: array of TColor32; 1120 BufferSize: Integer; 1121 C, A: TColor32; 1122 ScanLine: PIntegerArray; 1123 Winding, NextWinding: Integer; 1124 AAShift, AALines, AAMultiplier: Integer; 1125 BlendLineEx: TBlendLineEx; 1126 begin 1127 A := Color shr 24; 1128 1129 AAShift := AA_SHIFT[AAMode]; 1130 AALines := AA_LINES[AAMode] - 1; // we do the -1 here for optimization. 1131 AAMultiplier := AA_MULTI[AAMode]; 1132 1133 BlendLineEx := BLEND_LINE_EX[Bitmap.CombineMode]^; 1134 1135 // find the range of Y screen coordinates 1136 MinY := BaseY shr AAShift; 1137 MaxY := (BaseY + Length(ScanLines) + AALines) shr AAShift; 1138 1139 Y := MinY; 1140 while Y < MaxY do 1141 begin 1142 Top := Y shl AAShift - BaseY; 1143 Bottom := Top + AALines; 1144 if Top < 0 then Top := 0; 1145 if Bottom >= Length(ScanLines) then Bottom := High(ScanLines); 1146 1147 // find left and right edges of the screen scanline 1148 MinX := $7F000000; MaxX := -$7F000000; 1149 for J := Top to Bottom do 1150 begin 1151 L := ScanLines[J].Count - 1; 1152 if L > 0 then 1153 begin 1154 Left := (ScanLines[J].EdgePoints[0] and $7FFFFFFF); 1155 Right := (ScanLines[J].EdgePoints[L] and $7FFFFFFF + AALines); 1156 if Left < MinX then MinX := Left; 1157 if Right > MaxX then MaxX := Right; 1158 end 1159 end; 1160 1161 if MaxX >= MinX then 1162 begin 1163 MinX := MinX shr AAShift; 1164 MaxX := MaxX shr AAShift; 1165 // allocate buffer for a single scanline 1166 BufferSize := MaxX - MinX + 2; 1167 if Length(Buffer) < BufferSize then 1168 begin 1169 SetLength(Buffer, BufferSize + 64); 1170 SetLength(ColorBuffer, BufferSize + 64); 1171 end; 1172 FillLongword(Buffer[0], BufferSize, 0); 1173 1174 // ...and fill it 1175 if Mode = pfAlternate then 1176 for J := Top to Bottom do 1177 begin 1178 I := 0; 1179 L := ScanLines[J].Count; 1180 ScanLine := @ScanLines[J].EdgePoints[0]; 1181 while I < L do 1182 begin 1183 // Left edge 1184 X := ScanLine[I] and $7FFFFFFF; 1185 Dx := X and AALines; 1186 X := X shr AAShift - MinX; 1187 Inc(Buffer[X], Dx xor AALines); 1188 Inc(Buffer[X + 1], Dx); 1189 Inc(I); 1190 1191 // Right edge 1192 X := ScanLine[I] and $7FFFFFFF; 1193 Dx := X and AALines; 1194 X := X shr AAShift - MinX; 1195 Dec(Buffer[X], Dx xor AALines); 1196 Dec(Buffer[X + 1], Dx); 1197 Inc(I); 1198 end 1199 end 1200 else // mode = pfWinding 1201 for J := Top to Bottom do 1202 begin 1203 I := 0; 1204 L := ScanLines[J].Count; 1205 ScanLine := @ScanLines[J].EdgePoints[0]; 1206 Winding := 0; 1207 while I < L do 1208 begin 1209 X := ScanLine[I]; 1210 Inc(I); 1211 if (X and $80000000) <> 0 then NextWinding := 1 else NextWinding := -1; 1212 X := X and $7FFFFFFF; 1213 if Winding = 0 then 1214 begin 1215 Dx := X and AALines; 1216 X := X shr AAShift - MinX; 1217 Inc(Buffer[X], Dx xor AALines); 1218 Inc(Buffer[X + 1], Dx); 1219 end; 1220 Inc(Winding, NextWinding); 1221 if Winding = 0 then 1222 begin 1223 Dx := X and AALines; 1224 X := X shr AAShift - MinX; 1225 Dec(Buffer[X], Dx xor AALines); 1226 Dec(Buffer[X + 1], Dx); 1227 end; 1228 end; 1229 end; 1230 1231 // integrate the buffer 1232 N := 0; 1233 C := Color and $00FFFFFF; 1234 for I := 0 to BufferSize - 1 do 1235 begin 1236 Inc(N, Buffer[I]); 1237 ColorBuffer[I] := TColor32(N * AAMultiplier and $FF00) shl 16 or C; 1238 end; 1239 1240 // draw it to the screen 1241 BlendLineEx(@ColorBuffer[0], Pointer(Bitmap.PixelPtr[MinX, Y]), 1242 Min(BufferSize, Bitmap.Width - MinX), A); 1243 EMMS; 1244 end; 1245 1246 Inc(Y); 1247 end; 1248 end; 1249 1250 procedure CustomFillLines(Bitmap: TCustomBitmap32; BaseY: Integer; 1251 const ScanLines: TScanLines; FillLineCallback: TFillLineEvent; Mode: TPolyFillMode); 1252 var 1253 I, J, L: Integer; 1254 Top, Left, Right, OldRight, LP, RP, Cx: Integer; 1255 Winding, NextWinding: Integer; 1256 begin 1257 Top := BaseY - 1; 1258 Cx := Bitmap.ClipRect.Right - 1; 1259 1260 if Mode = pfAlternate then 1261 for J := 0 to High(ScanLines) do 1262 begin 1263 Inc(Top); 1264 L := ScanLines[J].Count; // assuming length is even 1265 if L = 0 then Continue; 1266 I := 0; 1267 OldRight := -1; 1268 1269 while I < L do 1270 begin 1271 Left := ScanLines[J].EdgePoints[I] and $7FFFFFFF; 1272 Inc(I); 1273 Right := ScanLines[J].EdgePoints[I] and $7FFFFFFF - 1; 1274 if Right > Left then 1275 begin 1276 if (Left and $FF) < $80 then Left := Left shr 8 1277 else Left := Left shr 8 + 1; 1278 if (Right and $FF) < $80 then Right := Right shr 8 1279 else Right := Right shr 8 + 1; 1280 1281 if Right >= Cx then Right := Cx; 1282 1283 if Left <= OldRight then Left := OldRight + 1; 1284 OldRight := Right; 1285 if Right >= Left then 1286 FillLineCallback(Bitmap.PixelPtr[Left, Top], Left, Top, Right - Left, nil); 1287 end; 1288 Inc(I); 1289 end 1290 end 1291 else // Mode = pfWinding 1292 for J := 0 to High(ScanLines) do 1293 begin 1294 Inc(Top); 1295 L := ScanLines[J].Count; // assuming length is even 1296 if L = 0 then Continue; 1297 I := 0; 1298 1299 Winding := 0; 1300 Left := ScanLines[J].EdgePoints[0]; 1301 if (Left and $80000000) <> 0 then Inc(Winding) else Dec(Winding); 1302 Left := Left and $7FFFFFFF; 1303 Inc(I); 1304 while I < L do 1305 begin 1306 Right := ScanLines[J].EdgePoints[I]; 1307 if (Right and $80000000) <> 0 then NextWinding := 1 else NextWinding := -1; 1308 Right := Right and $7FFFFFFF; 1309 Inc(I); 1310 1311 if Winding <> 0 then 1312 begin 1313 if (Left and $FF) < $80 then LP := Left shr 8 1314 else LP := Left shr 8 + 1; 1315 if (Right and $FF) < $80 then RP := Right shr 8 1316 else RP := Right shr 8 + 1; 1317 1318 if RP >= Cx then RP := Cx; 1319 1320 if RP >= LP then 1321 FillLineCallback(Bitmap.PixelPtr[LP, Top], LP, Top, RP - LP, nil); 1322 end; 1323 1324 Inc(Winding, NextWinding); 1325 Left := Right; 1326 end; 1327 end; 1333 {$ENDIF}; 1328 1334 EMMS; 1329 1335 end; 1330 1336 1331 procedure CustomFillLines2(Bitmap: TCustomBitmap32; BaseY: Integer; 1332 const ScanLines: TScanLines; FillLineCallback: TFillLineEvent; Mode: TPolyFillMode; 1333 const AAMode: TAntialiasMode = DefaultAAMode); 1334 var 1335 I, J, L, N: Integer; 1336 MinY, MaxY, Y, Top, Bottom: Integer; 1337 MinX, MaxX, X, Dx: Integer; 1338 Left, Right: Integer; 1339 Buffer: array of Integer; 1340 AlphaBuffer: array of TColor32; 1341 BufferSize: Integer; 1342 ScanLine: PIntegerArray; 1343 Winding, NextWinding: Integer; 1344 AAShift, AALines, AAMultiplier: Integer; 1345 begin 1346 AAShift := AA_SHIFT[AAMode]; 1347 AALines := AA_LINES[AAMode] - 1; // we do the -1 here for optimization. 1348 AAMultiplier := AA_MULTI[AAMode]; 1349 1350 // find the range of Y screen coordinates 1351 MinY := BaseY shr AAShift; 1352 MaxY := (BaseY + Length(ScanLines) + AALines) shr AAShift; 1353 1354 Y := MinY; 1355 while Y < MaxY do 1356 begin 1357 Top := Y shl AAShift - BaseY; 1358 Bottom := Top + AALines; 1359 if Top < 0 then Top := 0; 1360 if Bottom >= Length(ScanLines) then Bottom := High(ScanLines); 1361 1362 // find left and right edges of the screen scanline 1363 MinX := $7F000000; MaxX := -$7F000000; 1364 for J := Top to Bottom do 1365 begin 1366 L := ScanLines[J].Count - 1; 1367 if L > 0 then 1368 begin 1369 Left := (ScanLines[J].EdgePoints[0] and $7FFFFFFF); 1370 Right := (ScanLines[J].EdgePoints[L] and $7FFFFFFF + AALines); 1371 if Left < MinX then MinX := Left; 1372 if Right > MaxX then MaxX := Right; 1373 end 1374 end; 1375 1376 if MaxX >= MinX then 1377 begin 1378 MinX := MinX shr AAShift; 1379 MaxX := MaxX shr AAShift; 1380 // allocate buffer for a single scanline 1381 BufferSize := MaxX - MinX + 2; 1382 if Length(Buffer) < BufferSize then 1383 begin 1384 SetLength(Buffer, BufferSize + 64); 1385 SetLength(AlphaBuffer, BufferSize + 64); 1386 end; 1387 FillLongword(Buffer[0], BufferSize, 0); 1388 1389 // ...and fill it 1390 if Mode = pfAlternate then 1391 for J := Top to Bottom do 1392 begin 1393 I := 0; 1394 L := ScanLines[J].Count; 1395 ScanLine := @ScanLines[J].EdgePoints[0]; 1396 while I < L do 1397 begin 1398 // Left edge 1399 X := ScanLine[I] and $7FFFFFFF; 1400 Dx := X and AALines; 1401 X := X shr AAShift - MinX; 1402 Inc(Buffer[X], Dx xor AALines); 1403 Inc(Buffer[X + 1], Dx); 1404 Inc(I); 1405 1406 // Right edge 1407 X := ScanLine[I] and $7FFFFFFF; 1408 Dx := X and AALines; 1409 X := X shr AAShift - MinX; 1410 Dec(Buffer[X], Dx xor AALines); 1411 Dec(Buffer[X + 1], Dx); 1412 Inc(I); 1413 end 1414 end 1415 else // mode = pfWinding 1416 for J := Top to Bottom do 1417 begin 1418 I := 0; 1419 L := ScanLines[J].Count; 1420 ScanLine := @ScanLines[J].EdgePoints[0]; 1421 Winding := 0; 1422 while I < L do 1423 begin 1424 X := ScanLine[I]; 1425 Inc(I); 1426 if (X and $80000000) <> 0 then NextWinding := 1 else NextWinding := -1; 1427 X := X and $7FFFFFFF; 1428 if Winding = 0 then 1429 begin 1430 Dx := X and AALines; 1431 X := X shr AAShift - MinX; 1432 Inc(Buffer[X], Dx xor AALines); 1433 Inc(Buffer[X + 1], Dx); 1434 end; 1435 Inc(Winding, NextWinding); 1436 if Winding = 0 then 1437 begin 1438 Dx := X and AALines; 1439 X := X shr AAShift - MinX; 1440 Dec(Buffer[X], Dx xor AALines); 1441 Dec(Buffer[X + 1], Dx); 1442 end; 1443 end; 1444 end; 1445 1446 // integrate the buffer 1447 N := 0; 1448 for I := 0 to BufferSize - 1 do 1449 begin 1450 Inc(N, Buffer[I]); 1451 AlphaBuffer[I] := (N * AAMultiplier) shr 8; 1452 end; 1453 1454 // draw it to the screen 1455 FillLineCallback(Pointer(Bitmap.PixelPtr[MinX, Y]), MinX, Y, BufferSize, @AlphaBuffer[0]); 1456 EMMS; 1457 end; 1458 1459 Inc(Y); 1460 end; 1461 end; 1462 1463 1464 { Helper routines for drawing Polygons and PolyPolygons } 1465 1466 procedure RenderPolyPolygon(Bitmap: TCustomBitmap32; 1467 const Points: TArrayOfArrayOfFixedPoint; Color: TColor32; 1468 FillLineCallback: TFillLineEvent; Mode: TPolyFillMode; 1469 const AAMode: TAntialiasMode; Transformation: TTransformation); 1470 var 1471 ChangedRect, DstRect: TFixedRect; 1472 P: TFixedPoint; 1473 AAShift: Integer; 1474 I: Integer; 1475 ScanLines: TScanLines; 1476 begin 1477 if not Bitmap.MeasuringMode then 1478 begin 1479 ChangedRect := PolyPolygonBounds(Points, Transformation); 1480 1481 with DstRect do 1482 if AAMode <> amNone then 1483 begin 1484 AAShift := AA_SHIFT[AAMode]; 1485 Left := Bitmap.ClipRect.Left shl AAShift; 1486 Right := Bitmap.ClipRect.Right shl AAShift - 1; 1487 Top := Bitmap.ClipRect.Top shl AAShift; 1488 Bottom := Bitmap.ClipRect.Bottom shl AAShift - 1; 1489 1490 P.X := ChangedRect.Top; 1491 P.Y := ChangedRect.Bottom; 1492 RoundShiftProcs[AAMode](P, P, nil); 1493 Top := Constrain(P.X, Top, Bottom); 1494 Bottom := Constrain(P.Y, Top, Bottom); 1495 end 1496 else 1497 begin 1498 Left := Bitmap.ClipRect.Left shl 8; 1499 Right := Bitmap.ClipRect.Right shl 8 - 1; 1500 Top := Constrain(SAR_16(ChangedRect.Top + $00007FFF), 1501 Bitmap.ClipRect.Top, Bitmap.ClipRect.Bottom - 1); 1502 Bottom := Constrain(SAR_16(ChangedRect.Bottom + $00007FFF), 1503 Bitmap.ClipRect.Top, Bitmap.ClipRect.Bottom - 1); 1504 end; 1505 1506 if DstRect.Top >= DstRect.Bottom then Exit; 1507 1508 ScanLinesCreate(ScanLines, DstRect.Bottom - DstRect.Top + 1); 1509 for I := 0 to High(Points) do 1510 AddPolygon(Points[I], DstRect, ScanLines, AAMode, Transformation); 1511 1512 SortLines(ScanLines); 1513 Bitmap.BeginUpdate; 1514 try 1515 if AAMode <> amNone then 1516 if Assigned(FillLineCallback) then 1517 CustomFillLines2(Bitmap, DstRect.Top, ScanLines, FillLineCallback, Mode, AAMode) 1518 else 1519 ColorFillLines2(Bitmap, DstRect.Top, ScanLines, Color, Mode, AAMode) 1520 else 1521 if Assigned(FillLineCallback) then 1522 CustomFillLines(Bitmap, DstRect.Top, ScanLines, FillLineCallback, Mode) 1523 else 1524 ColorFillLines(Bitmap, DstRect.Top, ScanLines, Color, Mode); 1525 finally 1526 Bitmap.EndUpdate; 1527 ScanLinesDestroy(ScanLines); 1528 end; 1529 Bitmap.Changed(MakeRect(ChangedRect, rrOutside)); 1530 end 1531 else 1532 Bitmap.Changed(MakeRect(PolyPolygonBounds(Points, Transformation), rrOutside)); 1533 end; 1534 1535 procedure RenderPolygon(Bitmap: TCustomBitmap32; 1536 const Points: TArrayOfFixedPoint; Color: TColor32; 1537 FillLineCallback: TFillLineEvent; Mode: TPolyFillMode; 1538 const AAMode: TAntialiasMode; Transformation: TTransformation); 1539 var 1540 H: TArrayOfArrayOfFixedPoint; 1541 begin 1542 SetLength(H, 1); 1543 H[0] := Points; 1544 RenderPolyPolygon(Bitmap, H, Color, FillLineCallback, Mode, AAMode, Transformation); 1545 H[0] := nil; 1546 end; 1547 1548 1549 { Polygons } 1550 1551 procedure PolygonTS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 1552 Color: TColor32; Mode: TPolyFillMode; Transformation: TTransformation); 1553 begin 1554 RenderPolygon(Bitmap, Points, Color, nil, Mode, amNone, Transformation); 1555 end; 1556 1557 procedure PolygonTS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 1558 FillLineCallback: TFillLineEvent; Mode: TPolyFillMode; 1559 Transformation: TTransformation); 1560 begin 1561 RenderPolygon(Bitmap, Points, 0, FillLineCallback, Mode, amNone, Transformation); 1562 end; 1563 1564 procedure PolygonTS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 1565 Filler: TCustomPolygonFiller; Mode: TPolyFillMode; 1566 Transformation: TTransformation); 1567 begin 1568 RenderPolygon(Bitmap, Points, 0, Filler.FillLine, Mode, amNone, Transformation); 1569 end; 1570 1571 procedure PolygonXS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 1572 Color: TColor32; Mode: TPolyFillMode; 1573 const AAMode: TAntialiasMode; Transformation: TTransformation); 1574 begin 1575 RenderPolygon(Bitmap, Points, Color, nil, Mode, AAMode, Transformation); 1576 end; 1577 1578 procedure PolygonXS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 1579 FillLineCallback: TFillLineEvent; Mode: TPolyFillMode; 1580 const AAMode: TAntialiasMode; Transformation: TTransformation); 1581 begin 1582 RenderPolygon(Bitmap, Points, 0, FillLineCallback, Mode, AAMode, Transformation); 1583 end; 1584 1585 procedure PolygonXS(Bitmap: TCustomBitmap32; const Points: TArrayOfFixedPoint; 1586 Filler: TCustomPolygonFiller; Mode: TPolyFillMode; 1587 const AAMode: TAntialiasMode; Transformation: TTransformation); 1588 begin 1589 RenderPolygon(Bitmap, Points, 0, Filler.FillLine, Mode, AAMode, Transformation); 1590 end; 1591 1592 1593 { PolyPolygons } 1594 1595 procedure PolyPolygonTS(Bitmap: TCustomBitmap32; 1596 const Points: TArrayOfArrayOfFixedPoint; Color: TColor32; Mode: TPolyFillMode; 1597 Transformation: TTransformation); 1598 begin 1599 RenderPolyPolygon(Bitmap, Points, Color, nil, Mode, amNone, Transformation); 1600 end; 1601 1602 procedure PolyPolygonTS(Bitmap: TCustomBitmap32; 1603 const Points: TArrayOfArrayOfFixedPoint; FillLineCallback: TFillLineEvent; 1604 Mode: TPolyFillMode; Transformation: TTransformation); 1605 begin 1606 RenderPolyPolygon(Bitmap, Points, 0, FillLineCallback, Mode, amNone, Transformation); 1607 end; 1608 1609 procedure PolyPolygonTS(Bitmap: TCustomBitmap32; 1610 const Points: TArrayOfArrayOfFixedPoint; Filler: TCustomPolygonFiller; 1611 Mode: TPolyFillMode; Transformation: TTransformation); 1612 begin 1613 RenderPolyPolygon(Bitmap, Points, 0, Filler.FillLine, Mode, amNone, Transformation); 1614 end; 1615 1616 procedure PolyPolygonXS(Bitmap: TCustomBitmap32; 1617 const Points: TArrayOfArrayOfFixedPoint; Color: TColor32; Mode: TPolyFillMode; 1618 const AAMode: TAntialiasMode; Transformation: TTransformation); 1619 begin 1620 RenderPolyPolygon(Bitmap, Points, Color, nil, Mode, AAMode, Transformation); 1621 end; 1622 1623 procedure PolyPolygonXS(Bitmap: TCustomBitmap32; 1624 const Points: TArrayOfArrayOfFixedPoint; FillLineCallback: TFillLineEvent; 1625 Mode: TPolyFillMode; const AAMode: TAntialiasMode; 1626 Transformation: TTransformation); 1627 begin 1628 RenderPolyPolygon(Bitmap, Points, 0, FillLineCallback, Mode, AAMode, Transformation); 1629 end; 1630 1631 procedure PolyPolygonXS(Bitmap: TCustomBitmap32; 1632 const Points: TArrayOfArrayOfFixedPoint; Filler: TCustomPolygonFiller; 1633 Mode: TPolyFillMode; const AAMode: TAntialiasMode; 1634 Transformation: TTransformation); 1635 begin 1636 RenderPolyPolygon(Bitmap, Points, 0, Filler.FillLine, Mode, AAMode, Transformation); 1637 end; 1638 1639 1640 { Helper routines } 1641 1642 function PolygonBounds(const Points: TArrayOfFixedPoint; 1643 Transformation: TTransformation): TFixedRect; 1644 var 1645 I: Integer; 1646 begin 1647 with Result do 1648 begin 1649 Left := $7FFFFFFF; 1650 Right := -$7FFFFFFF; 1651 Top := $7FFFFFFF; 1652 Bottom := -$7FFFFFFF; 1653 1654 if Assigned(Transformation) then 1655 begin 1656 for I := 0 to High(Points) do 1657 with Transformation.Transform(Points[I]) do 1658 begin 1659 if X < Left then Left := X; 1660 if X > Right then Right := X; 1661 if Y < Top then Top := Y; 1662 if Y > Bottom then Bottom := Y; 1663 end 1664 end 1665 else 1666 for I := 0 to High(Points) do 1667 with Points[I] do 1668 begin 1669 if X < Left then Left := X; 1670 if X > Right then Right := X; 1671 if Y < Top then Top := Y; 1672 if Y > Bottom then Bottom := Y; 1673 end; 1674 end; 1675 end; 1676 1677 function PolyPolygonBounds(const Points: TArrayOfArrayOfFixedPoint; 1678 Transformation: TTransformation): TFixedRect; 1679 var 1680 I, J: Integer; 1681 begin 1682 with Result do 1683 begin 1684 Left := $7FFFFFFF; 1685 Right := -$7FFFFFFF; 1686 Top := $7FFFFFFF; 1687 Bottom := -$7FFFFFFF; 1688 1689 if Assigned(Transformation) then 1690 for I := 0 to High(Points) do 1691 for J := 0 to High(Points[I]) do 1692 with Transformation.Transform(Points[I, J]) do 1693 begin 1694 if X < Left then Left := X; 1695 if X > Right then Right := X; 1696 if Y < Top then Top := Y; 1697 if Y > Bottom then Bottom := Y; 1698 end 1699 else 1700 for I := 0 to High(Points) do 1701 for J := 0 to High(Points[I]) do 1702 with Points[I, J] do 1703 begin 1704 if X < Left then Left := X; 1705 if X > Right then Right := X; 1706 if Y < Top then Top := Y; 1707 if Y > Bottom then Bottom := Y; 1708 end; 1709 end; 1710 end; 1711 1712 function PtInPolygon(const Pt: TFixedPoint; const Points: TArrayOfFixedPoint): Boolean; 1713 var 1714 I: Integer; 1715 iPt, jPt: PFixedPoint; 1716 begin 1717 Result := False; 1718 iPt := @Points[0]; 1719 jPt := @Points[High(Points)]; 1720 for I := 0 to High(Points) do 1721 begin 1722 Result := Result xor (((Pt.Y >= iPt.Y) xor (Pt.Y >= jPt.Y)) and 1723 (Pt.X - iPt.X < MulDiv(jPt.X - iPt.X, Pt.Y - iPt.Y, jPt.Y - iPt.Y))); 1724 jPt := iPt; 1725 Inc(iPt); 1726 end; 1727 end; 1728 1729 { TPolygon32 } 1730 1731 procedure TPolygon32.Add(const P: TFixedPoint); 1732 var 1733 H, L: Integer; 1734 begin 1735 H := High(Points); 1736 L := Length(Points[H]); 1737 SetLength(Points[H], L + 1); 1738 Points[H][L] := P; 1739 Normals := nil; 1740 end; 1741 1742 procedure TPolygon32.AddPoints(var First: TFixedPoint; Count: Integer); 1743 var 1744 H, L, I: Integer; 1745 begin 1746 H := High(Points); 1747 L := Length(Points[H]); 1748 SetLength(Points[H], L + Count); 1749 for I := 0 to Count - 1 do 1750 Points[H, L + I] := PFixedPointArray(@First)[I]; 1751 Normals := nil; 1752 end; 1753 1754 procedure TPolygon32.CopyPropertiesTo(Dst: TPolygon32); 1755 begin 1756 Dst.Antialiased := Antialiased; 1757 Dst.AntialiasMode := AntialiasMode; 1758 Dst.Closed := Closed; 1759 Dst.FillMode := FillMode; 1760 end; 1761 1762 procedure TPolygon32.AssignTo(Dst: TPersistent); 1763 var 1764 DstPolygon: TPolygon32; 1765 Index: Integer; 1766 begin 1767 if Dst is TPolygon32 then 1768 begin 1769 DstPolygon := TPolygon32(Dst); 1770 CopyPropertiesTo(DstPolygon); 1771 SetLength(DstPolygon.FNormals, Length(Normals)); 1772 for Index := 0 to Length(Normals) - 1 do 1773 begin 1774 DstPolygon.Normals[Index] := Copy(Normals[Index]); 1775 end; 1776 1777 SetLength(DstPolygon.FPoints, Length(Points)); 1778 for Index := 0 to Length(Points) - 1 do 1779 begin 1780 DstPolygon.Points[Index] := Copy(Points[Index]); 1781 end; 1782 end 1783 else 1784 inherited; 1785 end; 1786 1787 function TPolygon32.GetBoundingRect: TFixedRect; 1788 begin 1789 Result := PolyPolygonBounds(Points); 1790 end; 1791 1792 procedure TPolygon32.BuildNormals; 1793 var 1794 I, J, Count, NextI: Integer; 1795 dx, dy, f: Single; 1796 begin 1797 if Length(Normals) <> 0 then Exit; 1798 SetLength(FNormals, Length(Points)); 1799 1800 for J := 0 to High(Points) do 1801 begin 1802 Count := Length(Points[J]); 1803 SetLength(Normals[J], Count); 1804 1805 if Count = 0 then Continue; 1806 if Count = 1 then 1807 begin 1808 FillChar(Normals[J][0], SizeOf(TFixedPoint), 0); 1809 Continue; 1810 end; 1811 1812 I := 0; 1813 NextI := 1; 1814 dx := 0; 1815 dy := 0; 1816 1817 while I < Count do 1818 begin 1819 if Closed and (NextI >= Count) then NextI := 0; 1820 if NextI < Count then 1821 begin 1822 dx := (Points[J][NextI].X - Points[J][I].X) / $10000; 1823 dy := (Points[J][NextI].Y - Points[J][I].Y) / $10000; 1824 end; 1825 if (dx <> 0) or (dy <> 0) then 1826 begin 1827 f := 1 / GR32_Math.Hypot(dx, dy); 1828 dx := dx * f; 1829 dy := dy * f; 1830 end; 1831 with Normals[J][I] do 1832 begin 1833 X := Fixed(dy); 1834 Y := Fixed(-dx); 1835 end; 1836 Inc(I); 1837 Inc(NextI); 1838 end; 1839 end; 1840 end; 1841 1842 procedure TPolygon32.Clear; 1843 begin 1844 Points := nil; 1845 Normals := nil; 1846 NewLine; 1847 end; 1848 1849 function TPolygon32.ContainsPoint(const P: TFixedPoint): Boolean; 1850 var 1851 I: Integer; 1852 begin 1853 Result := False; 1854 for I := 0 to High(FPoints) do 1855 if PtInPolygon(P, FPoints[I]) then 1856 begin 1857 Result := True; 1858 Exit; 1859 end; 1860 end; 1861 1862 constructor TPolygon32.Create; 1863 begin 1864 inherited; 1865 FClosed := True; 1866 FAntialiasMode := DefaultAAMode; 1867 NewLine; // initiate a new contour 1868 end; 1869 1870 destructor TPolygon32.Destroy; 1871 begin 1872 Clear; 1873 inherited; 1874 end; 1875 1876 procedure TPolygon32.Draw(Bitmap: TCustomBitmap32; OutlineColor, FillColor: TColor32; Transformation: TTransformation); 1877 begin 1878 Bitmap.BeginUpdate; 1879 1880 if Antialiased then 1881 begin 1882 if (FillColor and $FF000000) <> 0 then 1883 PolyPolygonXS(Bitmap, Points, FillColor, FillMode, AntialiasMode, Transformation); 1884 if (OutlineColor and $FF000000) <> 0 then 1885 PolyPolylineXS(Bitmap, Points, OutlineColor, Closed, Transformation); 1886 end 1887 else 1888 begin 1889 if (FillColor and $FF000000) <> 0 then 1890 PolyPolygonTS(Bitmap, Points, FillColor, FillMode, Transformation); 1891 if (OutlineColor and $FF000000) <> 0 then 1892 PolyPolylineTS(Bitmap, Points, OutlineColor, Closed, Transformation); 1893 end; 1894 1895 Bitmap.EndUpdate; 1896 Bitmap.Changed; 1897 end; 1898 1899 procedure TPolygon32.Draw(Bitmap: TCustomBitmap32; OutlineColor: TColor32; 1900 FillCallback: TFillLineEvent; Transformation: TTransformation); 1901 begin 1902 Bitmap.BeginUpdate; 1903 1904 if Antialiased then 1905 begin 1906 {$IFDEF FPC} 1907 RenderPolyPolygon(Bitmap, Points, 0, FillCallback, FillMode, AntialiasMode, Transformation); 1908 {$ELSE} 1909 PolyPolygonXS(Bitmap, Points, FillCallback, FillMode, AntialiasMode, Transformation); 1910 {$ENDIF} 1911 if (OutlineColor and $FF000000) <> 0 then 1912 PolyPolylineXS(Bitmap, Points, OutlineColor, Closed, Transformation); 1913 end 1914 else 1915 begin 1916 {$IFDEF FPC} 1917 RenderPolyPolygon(Bitmap, Points, 0, FillCallback, FillMode, amNone, Transformation); 1918 {$ELSE} 1919 PolyPolygonTS(Bitmap, Points, FillCallback, FillMode, Transformation); 1920 {$ENDIF} 1921 if (OutlineColor and $FF000000) <> 0 then 1922 PolyPolylineTS(Bitmap, Points, OutlineColor, Closed, Transformation); 1923 end; 1924 1925 Bitmap.EndUpdate; 1926 Bitmap.Changed; 1927 end; 1928 1929 procedure TPolygon32.Draw(Bitmap: TCustomBitmap32; OutlineColor: TColor32; 1930 Filler: TCustomPolygonFiller; Transformation: TTransformation); 1931 begin 1932 {$IFDEF FPC} 1933 Bitmap.BeginUpdate; 1934 1935 if Antialiased then 1936 begin 1937 RenderPolyPolygon(Bitmap, Points, 0, Filler.FillLine, FillMode, AntialiasMode, Transformation); 1938 if (OutlineColor and $FF000000) <> 0 then 1939 PolyPolylineXS(Bitmap, Points, OutlineColor, Closed, Transformation); 1940 end 1941 else 1942 begin 1943 RenderPolyPolygon(Bitmap, Points, 0, Filler.FillLine, FillMode, amNone, Transformation); 1944 if (OutlineColor and $FF000000) <> 0 then 1945 PolyPolylineTS(Bitmap, Points, OutlineColor, Closed, Transformation); 1946 end; 1947 1948 Bitmap.EndUpdate; 1949 Bitmap.Changed; 1950 1951 {$ELSE} 1952 Draw(Bitmap, OutlineColor, Filler.FillLine, Transformation); 1953 {$ENDIF} 1954 end; 1955 1956 procedure TPolygon32.DrawEdge(Bitmap: TCustomBitmap32; Color: TColor32; Transformation: TTransformation); 1957 begin 1958 Bitmap.BeginUpdate; 1959 1960 if Antialiased then 1961 PolyPolylineXS(Bitmap, Points, Color, Closed, Transformation) 1962 else 1963 PolyPolylineTS(Bitmap, Points, Color, Closed, Transformation); 1964 1965 Bitmap.EndUpdate; 1966 Bitmap.Changed; 1967 end; 1968 1969 procedure TPolygon32.DrawFill(Bitmap: TCustomBitmap32; Color: TColor32; Transformation: TTransformation); 1970 begin 1971 Bitmap.BeginUpdate; 1972 1973 if Antialiased then 1974 PolyPolygonXS(Bitmap, Points, Color, FillMode, AntialiasMode, Transformation) 1975 else 1976 PolyPolygonTS(Bitmap, Points, Color, FillMode, Transformation); 1977 1978 Bitmap.EndUpdate; 1979 Bitmap.Changed; 1980 end; 1981 1982 procedure TPolygon32.DrawFill(Bitmap: TCustomBitmap32; FillCallback: TFillLineEvent; 1983 Transformation: TTransformation); 1984 begin 1985 Bitmap.BeginUpdate; 1986 1987 {$IFDEF FPC} 1988 if Antialiased then 1989 RenderPolyPolygon(Bitmap, Points, 0, FillCallback, FillMode, AntialiasMode, Transformation) 1990 else 1991 RenderPolyPolygon(Bitmap, Points, 0, FillCallback, FillMode, amNone, Transformation); 1992 {$ELSE} 1993 if Antialiased then 1994 PolyPolygonXS(Bitmap, Points, FillCallback, FillMode, AntialiasMode, Transformation) 1995 else 1996 PolyPolygonTS(Bitmap, Points, FillCallback, FillMode, Transformation); 1997 {$ENDIF} 1998 1999 Bitmap.EndUpdate; 2000 Bitmap.Changed; 2001 end; 2002 2003 procedure TPolygon32.DrawFill(Bitmap: TCustomBitmap32; Filler: TCustomPolygonFiller; 2004 Transformation: TTransformation); 2005 begin 2006 {$IFDEF FPC} 2007 Bitmap.BeginUpdate; 2008 if Antialiased then 2009 RenderPolyPolygon(Bitmap, Points, 0, Filler.FillLine, FillMode, AntialiasMode, Transformation) 2010 else 2011 RenderPolyPolygon(Bitmap, Points, 0, Filler.FillLine, FillMode, amNone, Transformation); 2012 2013 Bitmap.EndUpdate; 2014 Bitmap.Changed; 2015 {$ELSE} 2016 DrawFill(Bitmap, Filler.FillLine, Transformation); 2017 {$ENDIF} 2018 end; 2019 2020 function TPolygon32.Grow(const Delta: TFixed; EdgeSharpness: Single = 0): TPolygon32; 2021 var 2022 J, I, PrevI: Integer; 2023 PX, PY, AX, AY, BX, BY, CX, CY, R, D, E: Integer; 2024 2025 procedure AddPoint(LongDeltaX, LongDeltaY: Integer); 2026 var 2027 N, L: Integer; 2028 begin 2029 with Result do 2030 begin 2031 N := High(Points); 2032 L := Length(Points[N]); 2033 SetLength(Points[N], L + 1); 2034 end; 2035 with Result.Points[N][L] do 2036 begin 2037 X := PX + LongDeltaX; 2038 Y := PY + LongDeltaY; 2039 end; 2040 end; 2041 2042 begin 2043 BuildNormals; 2044 2045 if EdgeSharpness > 0.99 then 2046 EdgeSharpness := 0.99 2047 else if EdgeSharpness < 0 then 2048 EdgeSharpness := 0; 2049 2050 D := Delta; 2051 E := Round(D * (1 - EdgeSharpness)); 2052 2053 Result := TPolygon32.Create; 2054 CopyPropertiesTo(Result); 2055 2056 if Delta = 0 then 2057 begin 2058 // simply copy the data 2059 SetLength(Result.FPoints, Length(Points)); 2060 for J := 0 to High(Points) do 2061 Result.Points[J] := Copy(Points[J], 0, Length(Points[J])); 2062 Exit; 2063 end; 2064 2065 Result.Points := nil; 2066 2067 for J := 0 to High(Points) do 2068 begin 2069 if Length(Points[J]) < 2 then Continue; 2070 2071 Result.NewLine; 2072 2073 for I := 0 to High(Points[J]) do 2074 begin 2075 with Points[J][I] do 2076 begin 2077 PX := X; 2078 PY := Y; 2079 end; 2080 2081 with Normals[J][I] do 2082 begin 2083 BX := MulDiv(X, D, $10000); 2084 BY := MulDiv(Y, D, $10000); 2085 end; 2086 2087 if (I > 0) or Closed then 2088 begin 2089 PrevI := I - 1; 2090 if PrevI < 0 then PrevI := High(Points[J]); 2091 with Normals[J][PrevI] do 2092 begin 2093 AX := MulDiv(X, D, $10000); 2094 AY := MulDiv(Y, D, $10000); 2095 end; 2096 2097 if (I = High(Points[J])) and (not Closed) then AddPoint(AX, AY) 2098 else 2099 begin 2100 CX := AX + BX; 2101 CY := AY + BY; 2102 R := MulDiv(AX, CX, D) + MulDiv(AY, CY, D); 2103 if R > E then AddPoint(MulDiv(CX, D, R), MulDiv(CY, D, R)) 2104 else 2105 begin 2106 AddPoint(AX, AY); 2107 AddPoint(BX, BY); 2108 end; 2109 end; 2110 end 2111 else AddPoint(BX, BY); 2112 end; 2113 end; 2114 end; 2115 2116 procedure TPolygon32.NewLine; 2117 begin 2118 SetLength(FPoints, Length(Points) + 1); 2119 Normals := nil; 2120 end; 2121 2122 procedure TPolygon32.Offset(const Dx, Dy: TFixed); 2123 var 2124 J, I: Integer; 2125 begin 2126 for J := 0 to High(Points) do 2127 for I := 0 to High(Points[J]) do 2128 with Points[J][I] do 2129 begin 2130 Inc(X, Dx); 2131 Inc(Y, Dy); 2132 end; 2133 end; 2134 2135 function TPolygon32.Outline: TPolygon32; 2136 var 2137 J, I, L, H: Integer; 2138 begin 2139 BuildNormals; 2140 2141 Result := TPolygon32.Create; 2142 CopyPropertiesTo(Result); 2143 2144 Result.Points := nil; 2145 2146 for J := 0 to High(Points) do 2147 begin 2148 if Length(Points[J]) < 2 then Continue; 2149 2150 if Closed then 2151 begin 2152 Result.NewLine; 2153 for I := 0 to High(Points[J]) do Result.Add(Points[J][I]); 2154 Result.NewLine; 2155 for I := High(Points[J]) downto 0 do Result.Add(Points[J][I]); 2156 end 2157 else // not closed 2158 begin 2159 // unrolled... 2160 SetLength(Result.FPoints, Length(Result.FPoints) + 1); 2161 Result.FNormals:= nil; 2162 2163 L:= Length(Points[J]); 2164 H:= High(Result.FPoints); 2165 SetLength(Result.FPoints[H], L * 2); 2166 for I := 0 to High(Points[J]) do 2167 Result.FPoints[H][I]:= (Points[J][I]); 2168 for I := High(Points[J]) downto 0 do 2169 Result.FPoints[H][2 * L - (I + 1)]:= (Points[J][I]); 2170 end; 2171 end; 2172 end; 2173 2174 procedure TPolygon32.Transform(Transformation: TTransformation); 2175 begin 2176 Points := TransformPoints(Points, Transformation); 2177 end; 1337 { TCustomPolygonFiller } 1338 1339 procedure TCustomPolygonFiller.BeginRendering; 1340 begin 1341 // implemented by descendants 1342 end; 1343 1344 procedure TCustomPolygonFiller.EndRendering; 1345 begin 1346 // implemented by descendants 1347 end; 1348 1349 { TCallbackPolygonFiller } 1350 1351 function TCallbackPolygonFiller.GetFillLine: TFillLineEvent; 1352 begin 1353 Result := FFillLineEvent; 1354 end; 1355 1356 1357 { TInvertPolygonFiller } 1358 1359 procedure TInvertPolygonFiller.FillLineBlend(Dst: PColor32; DstX, DstY, 1360 Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); 1361 var 1362 X: Integer; 1363 BlendMemEx: TBlendMemEx; 1364 begin 1365 BlendMemEx := BLEND_MEM_EX[CombineMode]^; 1366 for X := DstX to DstX + Length - 1 do 1367 begin 1368 BlendMemEx(InvertColor(Dst^), Dst^, AlphaValues^); 1369 EMMS; 1370 Inc(Dst); 1371 Inc(AlphaValues); 1372 end; 1373 end; 1374 1375 function TInvertPolygonFiller.GetFillLine: TFillLineEvent; 1376 begin 1377 Result := FillLineBlend; 1378 end; 1379 1380 1381 { TClearPolygonFiller } 1382 1383 constructor TClearPolygonFiller.Create(Color: TColor32 = $00808080); 1384 begin 1385 inherited Create; 1386 FColor := Color; 1387 end; 1388 1389 procedure TClearPolygonFiller.FillLineClear(Dst: PColor32; DstX, DstY, 1390 Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); 1391 begin 1392 FillLongword(Dst^, Length, FColor); 1393 end; 1394 1395 function TClearPolygonFiller.GetFillLine: TFillLineEvent; 1396 begin 1397 Result := FillLineClear; 1398 end; 1399 2178 1400 2179 1401 { TBitmapPolygonFiller } 2180 1402 2181 1403 procedure TBitmapPolygonFiller.FillLineOpaque(Dst: PColor32; DstX, DstY, 2182 Length: Integer; AlphaValues: PColor32 );1404 Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); 2183 1405 var 2184 1406 PatternX, PatternY, X: Integer; … … 2223 1445 end; 2224 1446 2225 procedure TBitmapPolygonFiller.FillLineBlend(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32); 1447 procedure TBitmapPolygonFiller.FillLineBlend(Dst: PColor32; DstX, DstY, 1448 Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); 2226 1449 var 2227 1450 PatternX, PatternY, X: Integer; … … 2268 1491 end; 2269 1492 2270 procedure TBitmapPolygonFiller.FillLineBlendMasterAlpha(Dst: PColor32; DstX, DstY, 2271 Length: Integer; AlphaValues: PColor32); 1493 procedure TBitmapPolygonFiller.FillLineBlendMasterAlpha(Dst: PColor32; 1494 DstX, DstY, Length: Integer; AlphaValues: PColor32; 1495 CombineMode: TCombineMode); 2272 1496 var 2273 1497 PatternX, PatternY, X: Integer; … … 2309 1533 end; 2310 1534 2311 procedure TBitmapPolygonFiller.FillLineCustomCombine(Dst: PColor32; DstX, DstY, 2312 Length: Integer; AlphaValues: PColor32); 1535 procedure TBitmapPolygonFiller.FillLineCustomCombine(Dst: PColor32; 1536 DstX, DstY, Length: Integer; AlphaValues: PColor32; 1537 CombineMode: TCombineMode); 2313 1538 var 2314 1539 PatternX, PatternY, X: Integer; … … 2372 1597 { TSamplerFiller } 2373 1598 1599 constructor TSamplerFiller.Create(Sampler: TCustomSampler = nil); 1600 begin 1601 inherited Create; 1602 FSampler := Sampler; 1603 SamplerChanged; 1604 end; 1605 1606 procedure TSamplerFiller.EndRendering; 1607 begin 1608 if Assigned(FSampler) then 1609 FSampler.FinalizeSampling 1610 else 1611 raise Exception.Create(RCStrNoSamplerSpecified); 1612 end; 1613 2374 1614 procedure TSamplerFiller.SampleLineOpaque(Dst: PColor32; DstX, DstY, 2375 Length: Integer; AlphaValues: PColor32 );1615 Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); 2376 1616 var 2377 1617 X: Integer; 2378 1618 BlendMemEx: TBlendMemEx; 2379 1619 begin 2380 BlendMemEx := BLEND_MEM_EX[ cmBlend]^;1620 BlendMemEx := BLEND_MEM_EX[CombineMode]^; 2381 1621 for X := DstX to DstX + Length - 1 do 2382 1622 begin … … 2388 1628 end; 2389 1629 1630 procedure TSamplerFiller.SamplerChanged; 1631 begin 1632 if Assigned(FSampler) then 1633 FGetSample := FSampler.GetSampleInt; 1634 end; 1635 1636 procedure TSamplerFiller.BeginRendering; 1637 begin 1638 if Assigned(FSampler) then 1639 FSampler.PrepareSampling 1640 else 1641 raise Exception.Create(RCStrNoSamplerSpecified); 1642 end; 1643 2390 1644 function TSamplerFiller.GetFillLine: TFillLineEvent; 2391 1645 begin … … 2395 1649 procedure TSamplerFiller.SetSampler(const Value: TCustomSampler); 2396 1650 begin 2397 FSampler := Value; 2398 FGetSample := FSampler.GetSampleInt; 2399 end; 1651 if FSampler <> Value then 1652 begin 1653 FSampler := Value; 1654 SamplerChanged; 1655 end; 1656 end; 1657 1658 1659 { TCustomPolygonRenderer } 1660 1661 procedure TCustomPolygonRenderer.PolygonFS( 1662 const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect; 1663 Transformation: TTransformation); 1664 begin 1665 PolyPolygonFS(PolyPolygon(Points), ClipRect, Transformation); 1666 end; 1667 1668 procedure TCustomPolygonRenderer.PolygonFS( 1669 const Points: TArrayOfFloatPoint; const ClipRect: TFloatRect); 1670 begin 1671 PolyPolygonFS(PolyPolygon(Points), ClipRect); 1672 end; 1673 1674 procedure TCustomPolygonRenderer.PolyPolygonFS( 1675 const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); 1676 begin 1677 // implemented by descendants 1678 end; 1679 1680 procedure TCustomPolygonRenderer.PolyPolygonFS( 1681 const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect; 1682 Transformation: TTransformation); 1683 var 1684 APoints: TArrayOfArrayOfFloatPoint; 1685 begin 1686 if Assigned(Transformation) then 1687 APoints := TransformPolyPolygon(Points, Transformation) 1688 else 1689 APoints := Points; 1690 PolyPolygonFS(APoints, ClipRect); 1691 end; 1692 1693 { TPolygonRenderer32 } 1694 1695 constructor TPolygonRenderer32.Create(Bitmap: TBitmap32; 1696 Fillmode: TPolyFillMode); 1697 begin 1698 inherited Create; 1699 FBitmap := Bitmap; 1700 FFillMode := Fillmode; 1701 end; 1702 1703 procedure TPolygonRenderer32.PolygonFS(const Points: TArrayOfFloatPoint); 1704 begin 1705 PolyPolygonFS(PolyPolygon(Points), FloatRect(FBitmap.ClipRect)); 1706 end; 1707 1708 procedure TPolygonRenderer32.PolyPolygonFS(const Points: TArrayOfArrayOfFloatPoint); 1709 begin 1710 PolyPolygonFS(Points, FloatRect(FBitmap.ClipRect)); 1711 end; 1712 1713 procedure TPolygonRenderer32.SetBitmap(const Value: TBitmap32); 1714 begin 1715 if FBitmap <> Value then 1716 begin 1717 FBitmap := Value; 1718 Changed; 1719 end; 1720 end; 1721 1722 procedure TPolygonRenderer32.SetColor(const Value: TColor32); 1723 begin 1724 if FColor <> Value then 1725 begin 1726 FColor := Value; 1727 Changed; 1728 end; 1729 end; 1730 1731 procedure TPolygonRenderer32.SetFiller(const Value: TCustomPolygonFiller); 1732 begin 1733 if FFiller <> Value then 1734 begin 1735 FFiller := Value; 1736 Changed; 1737 end; 1738 end; 1739 1740 procedure TPolygonRenderer32.SetFillMode(const Value: TPolyFillMode); 1741 begin 1742 if FFillMode <> Value then 1743 begin 1744 FFillMode := Value; 1745 Changed; 1746 end; 1747 end; 1748 1749 { TPolygonRenderer32VPR } 1750 1751 {$IFDEF USESTACKALLOC} 1752 {$W+} 1753 {$ENDIF} 1754 procedure TPolygonRenderer32VPR.FillSpan(const Span: TValueSpan; DstY: Integer); 1755 var 1756 AlphaValues: PColor32Array; 1757 Count: Integer; 1758 begin 1759 Count := Span.X2 - Span.X1 + 1; 1760 {$IFDEF USESTACKALLOC} 1761 AlphaValues := StackAlloc(Count * SizeOf(TColor32)); 1762 {$ELSE} 1763 GetMem(AlphaValues, Count * SizeOf(TColor32)); 1764 {$ENDIF} 1765 FFillProc(Span.Values, AlphaValues, Count, FColor); 1766 FFiller.FillLine(@Bitmap.ScanLine[DstY][Span.X1], Span.X1, DstY, Count, 1767 PColor32(AlphaValues), Bitmap.CombineMode); 1768 EMMS; 1769 {$IFDEF USESTACKALLOC} 1770 StackFree(AlphaValues); 1771 {$ELSE} 1772 FreeMem(AlphaValues); 1773 {$ENDIF} 1774 end; 1775 {$IFDEF USESTACKALLOC} 1776 {$W-} 1777 {$ENDIF} 1778 1779 function TPolygonRenderer32VPR.GetRenderSpan: TRenderSpanEvent; 1780 begin 1781 if Assigned(FFiller) then 1782 Result := FillSpan 1783 else 1784 Result := RenderSpan; 1785 end; 1786 1787 procedure TPolygonRenderer32VPR.PolyPolygonFS( 1788 const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); 1789 {$IFDEF CHANGENOTIFICATIONS} 1790 var 1791 I: Integer; 1792 {$ENDIF} 1793 begin 1794 UpdateFillProcs; 1795 if Assigned(FFiller) then 1796 begin 1797 FFiller.BeginRendering; 1798 RenderPolyPolygon(Points, ClipRect, GetRenderSpan()); 1799 FFiller.EndRendering; 1800 end 1801 else 1802 RenderPolyPolygon(Points, ClipRect, GetRenderSpan()); 1803 1804 {$IFDEF CHANGENOTIFICATIONS} 1805 if TBitmap32Access(Bitmap).UpdateCount = 0 then 1806 for I := 0 to High(Points) do 1807 if Length(Points[I]) > 0 then 1808 Bitmap.Changed(MakeRect(PolygonBounds(Points[I]))); 1809 {$ENDIF} 1810 end; 1811 1812 {$W+} 1813 procedure TPolygonRenderer32VPR.RenderSpan(const Span: TValueSpan; 1814 DstY: Integer); 1815 var 1816 AlphaValues: PColor32Array; 1817 Count: Integer; 1818 begin 1819 Count := Span.X2 - Span.X1 + 1; 1820 {$IFDEF USESTACKALLOC} 1821 AlphaValues := StackAlloc(Count * SizeOf(TColor32)); 1822 {$ELSE} 1823 GetMem(AlphaValues, Count * SizeOf(TColor32)); 1824 {$ENDIF} 1825 FFillProc(Span.Values, AlphaValues, Count, FColor); 1826 if Bitmap.CombineMode = cmMerge then 1827 MergeLine(@AlphaValues[0], @Bitmap.ScanLine[DstY][Span.X1], Count) 1828 else 1829 BlendLine(@AlphaValues[0], @Bitmap.ScanLine[DstY][Span.X1], Count); 1830 EMMS; 1831 {$IFDEF USESTACKALLOC} 1832 StackFree(AlphaValues); 1833 {$ELSE} 1834 FreeMem(AlphaValues); 1835 {$ENDIF} 1836 end; 1837 {$W-} 1838 1839 procedure TPolygonRenderer32VPR.UpdateFillProcs; 1840 const 1841 FillProcs: array [Boolean, TPolyFillMode] of TFillProc = ( 1842 (MakeAlphaEvenOddUP, MakeAlphaNonZeroUP), 1843 (MakeAlphaEvenOddUPF, MakeAlphaNonZeroUPF) 1844 ); 1845 begin 1846 FFillProc := FillProcs[Assigned(FFiller), FillMode]; 1847 end; 1848 1849 { TPolygonRenderer32LCD } 1850 1851 procedure TPolygonRenderer32LCD.PolyPolygonFS( 1852 const Points: TArrayOfArrayOfFloatPoint; const ClipRect: TFloatRect); 1853 var 1854 R: TFloatRect; 1855 APoints: TArrayOfArrayOfFloatPoint; 1856 {$IFDEF CHANGENOTIFICATIONS} 1857 I: Integer; 1858 {$ENDIF} 1859 begin 1860 APoints := ScalePolyPolygon(Points, 3, 1); 1861 R.Top := ClipRect.Top; 1862 R.Bottom := ClipRect.Bottom; 1863 R.Left := ClipRect.Left * 3; 1864 R.Right := ClipRect.Right * 3; 1865 RenderPolyPolygon(APoints, R, RenderSpan); 1866 {$IFDEF CHANGENOTIFICATIONS} 1867 if TBitmap32Access(Bitmap).UpdateCount = 0 then 1868 for I := 0 to High(Points) do 1869 if length(Points[I]) > 0 then 1870 Bitmap.Changed(MakeRect(PolygonBounds(Points[I]))); 1871 {$ENDIF} 1872 end; 1873 1874 {$W+} 1875 procedure TPolygonRenderer32LCD.RenderSpan(const Span: TValueSpan; 1876 DstY: Integer); 1877 const 1878 PADDING = 5; 1879 var 1880 AlphaValues: SysUtils.PByteArray; 1881 Count: Integer; 1882 X1, Offset: Integer; 1883 const 1884 MakeAlpha: array [TPolyFillMode] of TMakeAlphaProcLCD = (MakeAlphaEvenOddLCD, MakeAlphaNonZeroLCD); 1885 begin 1886 Count := Span.X2 - Span.X1 + 1; 1887 X1 := DivMod(Span.X1, 3, Offset); 1888 1889 // Left Padding + Right Padding + Filter Width = 2 + 2 + 2 = 6 1890 {$IFDEF USESTACKALLOC} 1891 AlphaValues := StackAlloc((Count + 6 + PADDING) * SizeOf(Byte)); 1892 {$ELSE} 1893 GetMem(AlphaValues, (Count + 6 + PADDING) * SizeOf(Byte)); 1894 {$ENDIF} 1895 AlphaValues[0] := 0; 1896 AlphaValues[1] := 0; 1897 if (X1 > 0) then 1898 begin 1899 Dec(X1); 1900 Inc(Offset, 3); 1901 AlphaValues[2] := 0; 1902 AlphaValues[3] := 0; 1903 AlphaValues[4] := 0; 1904 end; 1905 1906 MakeAlpha[FFillMode](Span.Values, PByteArray(@AlphaValues[PADDING]), Count, FColor); 1907 CombineLineLCD(@AlphaValues[PADDING - Offset], PColor32Array(@Bitmap.ScanLine[DstY][X1]), FColor, (Count + Offset + 2) div 3); 1908 1909 {$IFDEF USESTACKALLOC} 1910 StackFree(AlphaValues); 1911 {$ELSE} 1912 FreeMem(AlphaValues); 1913 {$ENDIF} 1914 end; 1915 {$W-} 1916 1917 1918 { TPolygonRenderer32LCD2 } 1919 1920 {$W+} 1921 procedure TPolygonRenderer32LCD2.RenderSpan(const Span: TValueSpan; 1922 DstY: Integer); 1923 const 1924 PADDING = 5; 1925 var 1926 AlphaValues: SysUtils.PByteArray; 1927 Count: Integer; 1928 X1, Offset: Integer; 1929 const 1930 MakeAlpha: array [TPolyFillMode] of TMakeAlphaProcLCD = (MakeAlphaEvenOddLCD2, MakeAlphaNonZeroLCD2); 1931 begin 1932 Count := Span.X2 - Span.X1 + 1; 1933 X1 := DivMod(Span.X1, 3, Offset); 1934 1935 // Left Padding + Right Padding + Filter Width = 2 + 2 + 2 = 6 1936 {$IFDEF USESTACKALLOC} 1937 AlphaValues := StackAlloc((Count + 6 + PADDING) * SizeOf(Byte)); 1938 {$ELSE} 1939 GetMem(AlphaValues, (Count + 6 + PADDING) * SizeOf(Byte)); 1940 {$ENDIF} 1941 AlphaValues[0] := 0; 1942 AlphaValues[1] := 0; 1943 if (X1 > 0) then 1944 begin 1945 Dec(X1); 1946 Inc(Offset, 3); 1947 AlphaValues[2] := 0; 1948 AlphaValues[3] := 0; 1949 AlphaValues[4] := 0; 1950 end; 1951 1952 Dec(Offset, 1); 1953 MakeAlpha[FFillMode](Span.Values, PByteArray(@AlphaValues[PADDING]), Count, FColor); 1954 Inc(Count); 1955 CombineLineLCD(@AlphaValues[PADDING - Offset], PColor32Array(@Bitmap.ScanLine[DstY][X1]), FColor, (Count + Offset + 2) div 3); 1956 1957 {$IFDEF USESTACKALLOC} 1958 StackFree(AlphaValues); 1959 {$ELSE} 1960 FreeMem(AlphaValues); 1961 {$ENDIF} 1962 end; 1963 {$W-} 1964 1965 initialization 1966 RegisterPolygonRenderer(TPolygonRenderer32VPR); 1967 RegisterPolygonRenderer(TPolygonRenderer32LCD); 1968 RegisterPolygonRenderer(TPolygonRenderer32LCD2); 1969 1970 finalization 1971 PolygonRendererList.Free; 2400 1972 2401 1973 end. -
GraphicTest/Packages/Graphics32/GR32_RangeBars.pas
r450 r522 74 74 FOnUserChange: TNotifyEvent; 75 75 procedure SetButtonSize(Value: Integer); 76 procedure SetBorderStyle(Value: TBorderStyle); {$IFDEF FPC} override; {$ENDIF}77 76 procedure SetHandleColor(Value: TColor); 78 77 procedure SetHighLightColor(Value: TColor); … … 101 100 {$ENDIF} 102 101 protected 103 GenChange: Boolean;104 DragZone: TRBZone;105 HotZone: TRBZone;106 Timer: TTimer;107 TimerMode: Integer;108 StoredX, StoredY: Integer;109 PosBeforeDrag: Single;102 FGenChange: Boolean; 103 FDragZone: TRBZone; 104 FHotZone: TRBZone; 105 FTimer: TTimer; 106 FTimerMode: Integer; 107 FStored: TPoint; 108 FPosBeforeDrag: Single; 110 109 procedure DoChange; virtual; 111 110 procedure DoDrawButton(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); virtual; … … 124 123 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; 125 124 procedure Paint; override; 125 procedure SetBorderStyle(Value: TBorderStyle); {$IFDEF FPC} override; {$ENDIF} 126 126 procedure StartDragTracking; 127 127 procedure StartHotTracking; … … 632 632 begin 633 633 MouseLeft; 634 inherited; 634 635 end; 635 636 … … 642 643 ParentColor := False; 643 644 Color := clScrollBar; 644 Timer := TTimer.Create(Self);645 Timer.OnTimer := TimerHandler;645 FTimer := TTimer.Create(Self); 646 FTimer.OnTimer := TimerHandler; 646 647 FShowArrows := True; 647 648 FBorderStyle := bsSingle; … … 657 658 begin 658 659 if Assigned(FOnChange) then FOnChange(Self); 659 if GenChange and Assigned(FOnUserChange) then FOnUserChange(Self);660 if FGenChange and Assigned(FOnUserChange) then FOnUserChange(Self); 660 661 end; 661 662 … … 1021 1022 inherited; 1022 1023 if Button <> mbLeft then Exit; 1023 DragZone := GetZone(X, Y);1024 FDragZone := GetZone(X, Y); 1024 1025 Invalidate; 1025 StoredX := X;1026 StoredY := Y;1026 FStored.X := X; 1027 FStored.Y := Y; 1027 1028 StartDragTracking; 1028 1029 end; … … 1038 1039 begin 1039 1040 inherited; 1040 if ( DragZone = zNone) and DrawEnabled then1041 if (FDragZone = zNone) and DrawEnabled then 1041 1042 begin 1042 1043 NewHotZone := GetZone(X, Y); 1043 if NewHotZone <> HotZone then1044 begin 1045 HotZone := NewHotZone;1046 if HotZone <> zNone then StartHotTracking;1044 if NewHotZone <> FHotZone then 1045 begin 1046 FHotZone := NewHotZone; 1047 if FHotZone <> zNone then StartHotTracking; 1047 1048 Invalidate; 1048 1049 end; … … 1053 1054 begin 1054 1055 inherited; 1055 DragZone := zNone;1056 FDragZone := zNone; 1056 1057 Invalidate; 1057 1058 StopDragTracking; … … 1078 1079 BtnRect := R; 1079 1080 with BtnRect do if Horz then Right := Left + BSize else Bottom := Top + BSize; 1080 DoDrawButton(BtnRect, CPrevDirs[Horz], DragZone = zBtnPrev, ShowEnabled,HotZone = zBtnPrev);1081 DoDrawButton(BtnRect, CPrevDirs[Horz], FDragZone = zBtnPrev, ShowEnabled, FHotZone = zBtnPrev); 1081 1082 1082 1083 { right / bottom button } 1083 1084 BtnRect := R; 1084 1085 with BtnRect do if Horz then Left := Right - BSize else Top := Bottom - BSize; 1085 DoDrawButton(BtnRect, CNextDirs[Horz], DragZone = zBtnNext, ShowEnabled,HotZone = zBtnNext);1086 DoDrawButton(BtnRect, CNextDirs[Horz], FDragZone = zBtnNext, ShowEnabled, FHotZone = zBtnNext); 1086 1087 end; 1087 1088 … … 1091 1092 ShowHandle := not GR32.IsRectEmpty(HandleRect); 1092 1093 1093 DoDrawTrack(GetZoneRect(zTrackPrev), CPrevDirs[Horz], DragZone = zTrackPrev, ShowEnabled,HotZone = zTrackPrev);1094 DoDrawTrack(GetZoneRect(zTrackNext), CNextDirs[Horz], DragZone = zTrackNext, ShowEnabled,HotZone = zTrackNext);1095 if ShowHandle then DoDrawHandle(HandleRect, Horz, DragZone = zHandle,HotZone = zHandle);1094 DoDrawTrack(GetZoneRect(zTrackPrev), CPrevDirs[Horz], FDragZone = zTrackPrev, ShowEnabled, FHotZone = zTrackPrev); 1095 DoDrawTrack(GetZoneRect(zTrackNext), CNextDirs[Horz], FDragZone = zTrackNext, ShowEnabled, FHotZone = zTrackNext); 1096 if ShowHandle then DoDrawHandle(HandleRect, Horz, FDragZone = zHandle, FHotZone = zHandle); 1096 1097 end; 1097 1098 … … 1219 1220 procedure TArrowBar.StartDragTracking; 1220 1221 begin 1221 Timer.Interval := FIRST_DELAY;1222 TimerMode := tmScroll;1222 FTimer.Interval := FIRST_DELAY; 1223 FTimerMode := tmScroll; 1223 1224 TimerHandler(Self); 1224 TimerMode := tmScrollFirst;1225 Timer.Enabled := True;1225 FTimerMode := tmScrollFirst; 1226 FTimer.Enabled := True; 1226 1227 end; 1227 1228 1228 1229 procedure TArrowBar.StartHotTracking; 1229 1230 begin 1230 Timer.Interval := HOTTRACK_INTERVAL;1231 TimerMode := tmHotTrack;1232 Timer.Enabled := True;1231 FTimer.Interval := HOTTRACK_INTERVAL; 1232 FTimerMode := tmHotTrack; 1233 FTimer.Enabled := True; 1233 1234 end; 1234 1235 … … 1240 1241 procedure TArrowBar.StopHotTracking; 1241 1242 begin 1242 Timer.Enabled := False;1243 HotZone := zNone;1243 FTimer.Enabled := False; 1244 FHotZone := zNone; 1244 1245 Invalidate; 1245 1246 end; … … 1249 1250 Pt: TPoint; 1250 1251 begin 1251 case TimerMode of1252 case FTimerMode of 1252 1253 tmScrollFirst: 1253 1254 begin 1254 Timer.Interval := SCROLL_INTERVAL;1255 TimerMode := tmScroll;1255 FTimer.Interval := SCROLL_INTERVAL; 1256 FTimerMode := tmScroll; 1256 1257 end; 1257 1258 tmHotTrack: … … 1431 1432 Shift: TShiftState; X, Y: Integer); 1432 1433 begin 1433 if Range <= EffectiveWindow then DragZone := zNone1434 if Range <= EffectiveWindow then FDragZone := zNone 1434 1435 else 1435 1436 begin 1436 1437 inherited; 1437 if DragZone = zHandle then1438 if FDragZone = zHandle then 1438 1439 begin 1439 1440 StopDragTracking; 1440 PosBeforeDrag := Position;1441 FPosBeforeDrag := Position; 1441 1442 end; 1442 1443 end; … … 1450 1451 begin 1451 1452 inherited; 1452 if DragZone = zHandle then1453 if FDragZone = zHandle then 1453 1454 begin 1454 1455 WinSz := EffectiveWindow; 1455 1456 1456 1457 if Range <= WinSz then Exit; 1457 if Kind = sbHorizontal then Delta := X - StoredX else Delta := Y - StoredY;1458 if Kind = sbHorizontal then Delta := X - FStored.X else Delta := Y - FStored.Y; 1458 1459 1459 1460 if Kind = sbHorizontal then ClientSz := ClientWidth else ClientSz := ClientHeight; … … 1465 1466 else Delta := Delta * Range / ClientSz; 1466 1467 1467 GenChange := True;1468 Position := PosBeforeDrag + Delta;1469 GenChange := False;1468 FGenChange := True; 1469 Position := FPosBeforeDrag + Delta; 1470 FGenChange := False; 1470 1471 end; 1471 1472 end; … … 1561 1562 begin 1562 1563 inherited; 1563 GenChange := True;1564 FGenChange := True; 1564 1565 OldPosition := Position; 1565 1566 1566 case DragZone of1567 case FDragZone of 1567 1568 zBtnPrev: 1568 1569 begin … … 1591 1592 end; 1592 1593 end; 1593 GenChange := False;1594 FGenChange := False; 1594 1595 end; 1595 1596 … … 1677 1678 begin 1678 1679 inherited; 1679 if DragZone = zHandle then1680 if FDragZone = zHandle then 1680 1681 begin 1681 1682 StopDragTracking; 1682 PosBeforeDrag := Position;1683 FPosBeforeDrag := Position; 1683 1684 end; 1684 1685 end; … … 1691 1692 begin 1692 1693 inherited; 1693 if DragZone = zHandle then1694 begin 1695 if Kind = sbHorizontal then Delta := X - StoredX else Delta := Y - StoredY;1694 if FDragZone = zHandle then 1695 begin 1696 if Kind = sbHorizontal then Delta := X - FStored.X else Delta := Y - FStored.Y; 1696 1697 R := GetTrackBoundary; 1697 1698 … … 1701 1702 Delta := Delta * (Max - Min) / (ClientSz - GetHandleSize); 1702 1703 1703 GenChange := True;1704 Position := Round( PosBeforeDrag + Delta);1705 GenChange := False;1704 FGenChange := True; 1705 Position := Round(FPosBeforeDrag + Delta); 1706 FGenChange := False; 1706 1707 end; 1707 1708 end; … … 1779 1780 begin 1780 1781 inherited; 1781 GenChange := True;1782 FGenChange := True; 1782 1783 OldPosition := Position; 1783 1784 1784 case DragZone of1785 case FDragZone of 1785 1786 zBtnPrev: 1786 1787 begin … … 1809 1810 end; 1810 1811 end; 1811 GenChange := False;1812 FGenChange := False; 1812 1813 end; 1813 1814 -
GraphicTest/Packages/Graphics32/GR32_Rasterizers.pas
r450 r522 47 47 Windows, 48 48 {$ENDIF} 49 Classes, GR32, GR32_Blend , GR32_OrdinalMaps;49 Classes, GR32, GR32_Blend; 50 50 51 51 type … … 184 184 185 185 uses 186 GR32_Resamplers, GR32_Containers, GR32_System, Math, GR32_Math, SysUtils; 186 Math, SysUtils, GR32_Math, GR32_System, GR32_LowLevel, GR32_Resamplers, 187 GR32_Containers, GR32_OrdinalMaps; 187 188 188 189 type 189 T ThreadPersistentAccess = class(TThreadPersistent);190 TCustomBitmap32Access = class(TCustomBitmap32); 190 191 191 192 TLineRasterizerData = record … … 292 293 R: TRect; 293 294 begin 294 UpdateCount := T ThreadPersistentAccess(Dst).UpdateCount;295 UpdateCount := TCustomBitmap32Access(Dst).UpdateCount; 295 296 if Assigned(FSampler) then 296 297 begin … … 302 303 DoRasterize(Dst, R); 303 304 finally 304 while T ThreadPersistentAccess(Dst).UpdateCount > UpdateCount do305 T ThreadPersistentAccess(Dst).EndUpdate;305 while TCustomBitmap32Access(Dst).UpdateCount > UpdateCount do 306 TCustomBitmap32Access(Dst).EndUpdate; 306 307 FSampler.FinalizeSampling; 307 308 end; … … 430 431 Size := NextPowerOf2(Max(W, H)); 431 432 432 SetLength(ForwardBuffer, Size );433 SetLength(ForwardBuffer, Size + 1); 433 434 434 435 I := 2; 435 while I < Size do436 while I <= Size do 436 437 begin 437 438 ForwardBuffer[I] := ForwardBuffer[I shr 1] + 1; … … 452 453 P2.X := L + P1.X; 453 454 P2.Y := T + P1.Y; 455 454 456 AssignColor(Dst.Bits[P2.X + P2.Y * RowSize], GetSample(P2.X, P2.Y)); 455 457 … … 482 484 FUpdateRows := True; 483 485 end; 486 487 {$DEFINE UseInternalFill} 484 488 485 489 procedure TProgressiveRasterizer.DoRasterize(Dst: TCustomBitmap32; … … 491 495 Step: Integer; 492 496 GetSample: TGetSampleInt; 493 begin 494 GetSample := FSampler.GetSampleInt; 495 OnChanged := Dst.OnAreaChanged; 496 DoUpdate := (TThreadPersistentAccess(Dst).UpdateCount = 0) and Assigned(OnChanged); 497 W := DstRect.Right - DstRect.Left; 498 H := DstRect.Bottom - DstRect.Top; 499 J := DstRect.Top; 500 Step := 1 shl FSteps; 501 while J < DstRect.Bottom do 502 begin 503 I := DstRect.Left; 504 B := Min(J + Step, DstRect.Bottom); 505 while I < DstRect.Right - Step do 506 begin 507 Dst.FillRect(I, J, I + Step, B, GetSample(I, J)); 508 Inc(I, Step); 509 end; 510 Dst.FillRect(I, J, DstRect.Right, B, GetSample(I, J)); 511 if DoUpdate and FUpdateRows then 512 OnChanged(Dst, Rect(DstRect.Left, J, DstRect.Right, B), AREAINFO_RECT); 513 Inc(J, Step); 514 end; 515 if DoUpdate and (not FUpdateRows) then OnChanged(Dst, DstRect, AREAINFO_RECT); 516 517 Shift := FSteps; 518 while Step > 1 do 519 begin 520 Dec(Shift); 521 Step := Step div 2; 522 Wk := W div Step - 1; 523 Hk := H div Step; 524 for J := 0 to Hk do 525 begin 526 Y := DstRect.Top + J shl Shift; 527 B := Min(Y + Step, DstRect.Bottom); 528 if Odd(J) then 529 for I := 0 to Wk do 497 498 {$IFDEF UseInternalFill} 499 Bits: PColor32Array; 500 501 procedure IntFillRect(X1, Y1, X2, Y2: Integer; C: TColor32); 502 var 503 Y: Integer; 504 P: PColor32Array; 505 begin 506 for Y := Y1 to Y2 - 1 do 507 begin 508 P := Pointer(@Bits[Y * W]); 509 FillLongword(P[X1], X2 - X1, C); 510 end; 511 end; 512 {$ENDIF} 513 514 begin 515 GetSample := FSampler.GetSampleInt; 516 OnChanged := Dst.OnAreaChanged; 517 {$IFDEF UseInternalFill} 518 Bits := Dst.Bits; 519 {$ENDIF} 520 DoUpdate := (TCustomBitmap32Access(Dst).UpdateCount = 0) and Assigned(OnChanged); 521 W := DstRect.Right - DstRect.Left; 522 H := DstRect.Bottom - DstRect.Top; 523 J := DstRect.Top; 524 Step := 1 shl FSteps; 525 while J < DstRect.Bottom do 526 begin 527 I := DstRect.Left; 528 B := Min(J + Step, DstRect.Bottom); 529 while I < DstRect.Right - Step do 530 begin 531 {$IFDEF UseInternalFill} 532 IntFillRect(I, J, I + Step, B, GetSample(I, J)); 533 {$ELSE} 534 Dst.FillRect(I, J, I + Step, B, GetSample(I, J)); 535 {$ENDIF} 536 Inc(I, Step); 537 end; 538 {$IFDEF UseInternalFill} 539 IntFillRect(I, J, DstRect.Right, B, GetSample(I, J)); 540 if DoUpdate and FUpdateRows then 541 OnChanged(Dst, Rect(DstRect.Left, J, DstRect.Right, B), AREAINFO_RECT); 542 {$ELSE} 543 Dst.FillRect(I, J, DstRect.Right, B, GetSample(I, J)); 544 {$ENDIF} 545 Inc(J, Step); 546 end; 547 if DoUpdate and (not FUpdateRows) then OnChanged(Dst, DstRect, AREAINFO_RECT); 548 549 Shift := FSteps; 550 while Step > 1 do 551 begin 552 Dec(Shift); 553 Step := Step div 2; 554 Wk := W div Step - 1; 555 Hk := H div Step; 556 for J := 0 to Hk do 557 begin 558 Y := DstRect.Top + J shl Shift; 559 B := Min(Y + Step, DstRect.Bottom); 560 if Odd(J) then 561 for I := 0 to Wk do 562 begin 563 X := DstRect.Left + I shl Shift; 564 {$IFDEF UseInternalFill} 565 IntFillRect(X, Y, X + Step, B, GetSample(X, Y)); 566 {$ELSE} 567 Dst.FillRect(X, Y, X + Step, B, GetSample(X, Y)); 568 {$ENDIF} 569 end 570 else 571 for I := 0 to Wk do 572 if Odd(I) then 530 573 begin 531 574 X := DstRect.Left + I shl Shift; 575 {$IFDEF UseInternalFill} 576 IntFillRect(X, Y, X + Step, B, GetSample(X, Y)); 577 {$ELSE} 532 578 Dst.FillRect(X, Y, X + Step, B, GetSample(X, Y)); 533 end 534 else 535 for I := 0 to Wk do 536 if Odd(I) then 537 begin 538 X := DstRect.Left + I shl Shift; 539 Dst.FillRect(X, Y, X + Step, B, GetSample(X, Y)); 540 end; 541 X := DstRect.Left + Wk shl Shift; 542 Dst.FillRect(X, Y, DstRect.Right, B, GetSample(X, Y)); 543 if FUpdateRows and DoUpdate then 544 OnChanged(Dst, Rect(DstRect.Left, Y, DstRect.Right, B), AREAINFO_RECT); 545 end; 546 if DoUpdate and (not FUpdateRows) then OnChanged(Dst, DstRect, AREAINFO_RECT); 547 end; 579 {$ENDIF} 580 end; 581 X := DstRect.Left + Wk shl Shift; 582 {$IFDEF UseInternalFill} 583 IntFillRect(X, Y, DstRect.Right, B, GetSample(X, Y)); 584 if FUpdateRows and DoUpdate then 585 OnChanged(Dst, Rect(DstRect.Left, Y, DstRect.Right, B), AREAINFO_RECT); 586 {$ELSE} 587 Dst.FillRect(X, Y, DstRect.Right, B, GetSample(X, Y)); 588 {$ENDIF} 589 end; 590 if DoUpdate and (not FUpdateRows) then OnChanged(Dst, DstRect, AREAINFO_RECT); 591 end; 548 592 end; 549 593 -
GraphicTest/Packages/Graphics32/GR32_Reg.pas
r450 r522 60 60 GR32_Layers, 61 61 GR32_RangeBars, 62 GR32_ColorPicker, 63 GR32_ColorSwatch, 62 64 GR32_Resamplers; 63 65 … … 66 68 begin 67 69 RegisterComponents('Graphics32', [TPaintBox32, TImage32, TBitmap32List, 68 TRangeBar, TGaugeBar, TImgView32{$IFDEF Windows}, TSyntheticImage32{$ENDIF}]); 70 TRangeBar, TGaugeBar, TImgView32{$IFDEF Windows}, TSyntheticImage32{$ENDIF}, 71 TColorPickerComponent, TColorPickerRGBA, TColorPickerHS, TColorPickerHSV, 72 TColorPickerGTK, {$IFDEF COMPILER2010_UP} TColor32Dialog,{$ENDIF} 73 TColorSwatch]); 69 74 RegisterPropertyEditor(TypeInfo(TColor32), nil, '', TColor32Property); 70 75 RegisterPropertyEditor(TypeInfo(TBitmap32), nil, '', TBitmap32Property); … … 83 88 84 89 end. 90 -
GraphicTest/Packages/Graphics32/GR32_RepaintOpt.pas
r450 r522 42 42 LCLIntf, 43 43 {$ELSE} 44 Windows,44 Types, Windows, 45 45 {$ENDIF} 46 Classes, SysUtils, GR32, GR32_ LowLevel, GR32_Containers, GR32_Layers;46 Classes, SysUtils, GR32, GR32_Containers, GR32_Layers; 47 47 48 48 type -
GraphicTest/Packages/Graphics32/GR32_Resamplers.pas
r450 r522 50 50 {$ENDIF} 51 51 Classes, SysUtils, GR32, GR32_Transforms, GR32_Containers, 52 GR32_OrdinalMaps, GR32_Blend , GR32_System, GR32_Bindings;52 GR32_OrdinalMaps, GR32_Blend; 53 53 54 54 procedure BlockTransfer( … … 343 343 procedure SetKernel(const Value: TCustomKernel); 344 344 function GetKernelClassName: string; 345 procedure SetKernelClassName( Value: string);345 procedure SetKernelClassName(const Value: string); 346 346 procedure SetKernelMode(const Value: TKernelMode); 347 347 procedure SetTableSize(Value: Integer); … … 578 578 procedure IncBuffer(var Buffer: TBufferEntry; Color: TColor32); {$IFDEF USEINLINING} inline; {$ENDIF} 579 579 procedure MultiplyBuffer(var Buffer: TBufferEntry; W: Integer); {$IFDEF USEINLINING} inline; {$ENDIF} 580 function BufferToColor32( Buffer: TBufferEntry; Shift: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}580 function BufferToColor32(const Buffer: TBufferEntry; Shift: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF} 581 581 procedure ShrBuffer(var Buffer: TBufferEntry; Shift: Integer); {$IFDEF USEINLINING} inline; {$ENDIF} 582 583 { Downsample byte map } 584 procedure DownsampleByteMap2x(Source, Dest: TByteMap); 585 procedure DownsampleByteMap3x(Source, Dest: TByteMap); 586 procedure DownsampleByteMap4x(Source, Dest: TByteMap); 582 587 583 588 { Registration routines } … … 605 610 606 611 uses 607 GR32_LowLevel, GR32_Rasterizers, GR32_Math, Math; 612 GR32_System, GR32_Bindings, GR32_LowLevel, GR32_Rasterizers, GR32_Math, 613 GR32_Gamma, Math; 608 614 609 615 resourcestring … … 611 617 612 618 const 613 CAlbrecht2 : array [0..1] of Double = (5.383553946707251E-1, 4.616446053292749E-1); 614 CAlbrecht3 : array [0..2] of Double = (3.46100822018625E-1, 4.97340635096738E-1, 615 1.56558542884637E-1); 616 CAlbrecht4 : array [0..3] of Double = (2.26982412792069E-1, 4.57254070828427E-1, 617 2.73199027957384E-1, 4.25644884221201E-2); 618 CAlbrecht5 : array [0..4] of Double = (1.48942606015830E-1, 3.86001173639176E-1, 619 3.40977403214053E-1, 1.139879604246E-1, 620 1.00908567063414E-2); 621 CAlbrecht6 : array [0..5] of Double = (9.71676200107429E-2, 3.08845222524055E-1, 622 3.62623371437917E-1, 1.88953325525116E-1, 623 4.02095714148751E-2, 2.20088908729420E-3); 624 CAlbrecht7 : array [0..6] of Double = (6.39644241143904E-2, 2.39938645993528E-1, 625 3.50159563238205E-1, 2.47741118970808E-1, 626 8.54382560558580E-2, 1.23202033692932E-2, 627 4.37788257917735E-4); 628 CAlbrecht8 : array [0..7] of Double = (4.21072107042137E-2, 1.82076226633776E-1, 629 3.17713781059942E-1, 2.84438001373442E-1, 630 1.36762237777383E-1, 3.34038053504025E-2, 631 3.41677216705768E-3, 8.19649337831348E-5); 632 CAlbrecht9 : array [0..8] of Double = (2.76143731612611E-2, 1.35382228758844E-1, 633 2.75287234472237E-1, 2.98843335317801E-1, 634 1.85319330279284E-1, 6.48884482549063E-2, 635 1.17641910285655E-2, 8.85987580106899E-4, 636 1.48711469943406E-5); 637 CAlbrecht10 : array [0..9] of Double = (1.79908225352538E-2, 9.87959586065210E-2, 638 2.29883817001211E-1, 2.94113019095183E-1, 639 2.24338977814325E-1, 1.03248806248099E-1, 640 2.75674109448523E-2, 3.83958622947123E-3, 641 2.18971708430106E-4, 2.62981665347889E-6); 642 CAlbrecht11 : array [0..10] of Double = (1.18717127796602E-2, 7.19533651951142E-2, 643 1.87887160922585E-1, 2.75808174097291E-1, 644 2.48904243244464E-1, 1.41729867200712E-1, 645 5.02002976228256E-2, 1.04589649084984E-2, 646 1.13615112741660E-3, 4.96285981703436E-5, 647 4.34303262685720E-7); 619 CAlbrecht2 : array [0..1] of Double = (5.383553946707251E-1, 620 4.616446053292749E-1); 621 CAlbrecht3 : array [0..2] of Double = (3.46100822018625E-1, 622 4.97340635096738E-1, 1.56558542884637E-1); 623 CAlbrecht4 : array [0..3] of Double = (2.26982412792069E-1, 624 4.57254070828427E-1, 2.73199027957384E-1, 4.25644884221201E-2); 625 CAlbrecht5 : array [0..4] of Double = (1.48942606015830E-1, 626 3.86001173639176E-1, 3.40977403214053E-1, 1.139879604246E-1, 627 1.00908567063414E-2); 628 CAlbrecht6 : array [0..5] of Double = (9.71676200107429E-2, 629 3.08845222524055E-1, 3.62623371437917E-1, 1.88953325525116E-1, 630 4.02095714148751E-2, 2.20088908729420E-3); 631 CAlbrecht7 : array [0..6] of Double = (6.39644241143904E-2, 632 2.39938645993528E-1, 3.50159563238205E-1, 2.47741118970808E-1, 633 8.54382560558580E-2, 1.23202033692932E-2, 4.37788257917735E-4); 634 CAlbrecht8 : array [0..7] of Double = (4.21072107042137E-2, 635 1.82076226633776E-1, 3.17713781059942E-1, 2.84438001373442E-1, 636 1.36762237777383E-1, 3.34038053504025E-2, 3.41677216705768E-3, 637 8.19649337831348E-5); 638 CAlbrecht9 : array [0..8] of Double = (2.76143731612611E-2, 639 1.35382228758844E-1, 2.75287234472237E-1, 2.98843335317801E-1, 640 1.85319330279284E-1, 6.48884482549063E-2, 1.17641910285655E-2, 641 8.85987580106899E-4, 1.48711469943406E-5); 642 CAlbrecht10: array [0..9] of Double = (1.79908225352538E-2, 643 9.87959586065210E-2, 2.29883817001211E-1, 2.94113019095183E-1, 644 2.24338977814325E-1, 1.03248806248099E-1, 2.75674109448523E-2, 645 3.83958622947123E-3, 2.18971708430106E-4, 2.62981665347889E-6); 646 CAlbrecht11: array [0..10] of Double = (1.18717127796602E-2, 647 7.19533651951142E-2, 1.87887160922585E-1, 2.75808174097291E-1, 648 2.48904243244464E-1, 1.41729867200712E-1, 5.02002976228256E-2, 649 1.04589649084984E-2, 1.13615112741660E-3, 4.96285981703436E-5, 650 4.34303262685720E-7); 651 648 652 type 649 653 TTransformationAccess = class(TTransformation); … … 660 664 TMappingTable = array of TCluster; 661 665 662 663 type664 666 TKernelSamplerClass = class of TKernelSampler; 665 667 … … 741 743 end; 742 744 743 function BufferToColor32( Buffer: TBufferEntry; Shift: Integer): TColor32;745 function BufferToColor32(const Buffer: TBufferEntry; Shift: Integer): TColor32; 744 746 begin 745 747 with TColor32Entry(Result) do … … 1719 1721 C := Src.Bits[X + ClusterY[Y].Pos * Src.Width]; 1720 1722 ClustYW := ClusterY[Y].Weight; 1721 Inc(Ca, C shr 24* ClustYW);1722 Inc(Cr, (C and $00FF0000) shr 16 * ClustYW);1723 Inc(Cg, (C and $0000FF00) shr 8 * ClustYW);1724 Inc(Cb, (C and $000000FF) * ClustYW);1723 Inc(Ca, Integer(C shr 24) * ClustYW); 1724 Inc(Cr, Integer(C and $00FF0000) shr 16 * ClustYW); 1725 Inc(Cg, Integer(C and $0000FF00) shr 8 * ClustYW); 1726 Inc(Cb, Integer(C and $000000FF) * ClustYW); 1725 1727 end; 1726 1728 with HorzBuffer[X - MapXLoPos] do … … 1812 1814 Inc(NativeUInt(RowSrc), OffSrc); 1813 1815 {$ELSE} 1814 Inc( Cardinal(RowSrc), OffSrc);1816 Inc(PByte(RowSrc), OffSrc); 1815 1817 {$ENDIF} 1816 1818 end; … … 2294 2296 Inc(NativeUInt(RowSrc), OffSrc * dy); 2295 2297 {$ELSE} 2296 Inc( Cardinal(RowSrc), OffSrc * dy);2298 Inc(PByte(RowSrc), OffSrc * dy); 2297 2299 {$ENDIF} 2298 2300 end; … … 2491 2493 2492 2494 2495 { TByteMap downsample functions } 2496 2497 procedure DownsampleByteMap2x(Source, Dest: TByteMap); 2498 var 2499 X, Y: Integer; 2500 ScnLn: array [0 .. 2] of PByteArray; 2501 begin 2502 for Y := 0 to (Source.Height div 2) - 1 do 2503 begin 2504 ScnLn[0] := Dest.ScanLine[Y]; 2505 ScnLn[1] := Source.ScanLine[Y * 2]; 2506 ScnLn[2] := Source.ScanLine[Y * 2 + 1]; 2507 for X := 0 to (Source.Width div 2) - 1 do 2508 ScnLn[0, X] := ( 2509 ScnLn[1, 2 * X] + ScnLn[1, 2 * X + 1] + 2510 ScnLn[2, 2 * X] + ScnLn[2, 2 * X + 1]) div 4; 2511 end; 2512 end; 2513 2514 procedure DownsampleByteMap3x(Source, Dest: TByteMap); 2515 var 2516 X, Y: Integer; 2517 x3: Integer; 2518 ScnLn: array [0 .. 3] of PByteArray; 2519 begin 2520 for Y := 0 to (Source.Height div 3) - 1 do 2521 begin 2522 ScnLn[0] := Dest.ScanLine[Y]; 2523 ScnLn[1] := Source.ScanLine[3 * Y]; 2524 ScnLn[2] := Source.ScanLine[3 * Y + 1]; 2525 ScnLn[3] := Source.ScanLine[3 * Y + 2]; 2526 for X := 0 to (Source.Width div 3) - 1 do 2527 begin 2528 x3 := 3 * X; 2529 ScnLn[0, X] := ( 2530 ScnLn[1, x3] + ScnLn[1, x3 + 1] + ScnLn[1, x3 + 2] + 2531 ScnLn[2, x3] + ScnLn[2, x3 + 1] + ScnLn[2, x3 + 2] + 2532 ScnLn[3, x3] + ScnLn[3, x3 + 1] + ScnLn[3, x3 + 2]) div 9; 2533 end; 2534 end; 2535 end; 2536 2537 procedure DownsampleByteMap4x(Source, Dest: TByteMap); 2538 var 2539 X, Y: Integer; 2540 x4: Integer; 2541 ScnLn: array [0 .. 4] of PByteArray; 2542 begin 2543 for Y := 0 to (Source.Height div 4) - 1 do 2544 begin 2545 ScnLn[0] := Dest.ScanLine[Y]; 2546 ScnLn[1] := Source.ScanLine[Y * 4]; 2547 ScnLn[2] := Source.ScanLine[Y * 4 + 1]; 2548 ScnLn[3] := Source.ScanLine[Y * 4 + 2]; 2549 ScnLn[4] := Source.ScanLine[Y * 4 + 3]; 2550 for X := 0 to (Source.Width div 4) - 1 do 2551 begin 2552 x4 := 4 * X; 2553 ScnLn[0, X] := ( 2554 ScnLn[1, x4] + ScnLn[1, x4 + 1] + ScnLn[1, x4 + 2] + ScnLn[1, x4 + 3] + 2555 ScnLn[2, x4] + ScnLn[2, x4 + 1] + ScnLn[2, x4 + 2] + ScnLn[2, x4 + 3] + 2556 ScnLn[3, x4] + ScnLn[3, x4 + 1] + ScnLn[3, x4 + 2] + ScnLn[3, x4 + 3] + 2557 ScnLn[4, x4] + ScnLn[4, x4 + 1] + ScnLn[4, x4 + 2] + ScnLn[4, x4 + 3]) div 16; 2558 end; 2559 end; 2560 end; 2561 2493 2562 2494 2563 { TCustomKernel } … … 2935 3004 end; 2936 3005 2937 procedure TKernelResampler.SetKernelClassName( Value: string);3006 procedure TKernelResampler.SetKernelClassName(const Value: string); 2938 3007 var 2939 3008 KernelClass: TCustomKernelClass; … … 3173 3242 end else 3174 3243 begin 3175 Inc(HorzEntry.R, Div255(Alpha * SrcP.R) * W);3176 Inc(HorzEntry.G, Div255(Alpha * SrcP.G) * W);3177 Inc(HorzEntry.B, Div255(Alpha * SrcP.B) * W);3244 Inc(HorzEntry.R, Integer(Div255(Alpha * SrcP.R)) * W); 3245 Inc(HorzEntry.G, Integer(Div255(Alpha * SrcP.G)) * W); 3246 Inc(HorzEntry.B, Integer(Div255(Alpha * SrcP.B)) * W); 3178 3247 end; 3179 3248 end; … … 3196 3265 begin 3197 3266 // Sample premultiplied values 3198 OuterPremultColorR := Div255(Alpha * TColor32Entry(FOuterColor).R);3199 OuterPremultColorG := Div255(Alpha * TColor32Entry(FOuterColor).G);3200 OuterPremultColorB := Div255(Alpha * TColor32Entry(FOuterColor).B);3267 OuterPremultColorR := Integer(Div255(Alpha * TColor32Entry(FOuterColor).R)); 3268 OuterPremultColorG := Integer(Div255(Alpha * TColor32Entry(FOuterColor).G)); 3269 OuterPremultColorB := Integer(Div255(Alpha * TColor32Entry(FOuterColor).B)); 3201 3270 3202 3271 for I := -KWidth to KWidth do … … 3364 3433 if FKernelMode in [kmTableNearest, kmTableLinear] then 3365 3434 begin 3366 FWeightTable := TIntegerMap.Create; 3367 FWeightTable.SetSize(W * 2 + 1, FTableSize + 1); 3435 FWeightTable := TIntegerMap.Create(W * 2 + 1, FTableSize + 1); 3368 3436 for I := 0 to FTableSize do 3369 3437 begin … … 3382 3450 end; 3383 3451 3452 3384 3453 { TCustomBitmap32NearestResampler } 3385 3454 … … 3518 3587 end; 3519 3588 3520 WX := GAMMA_ TABLE[((X shr 8) and $FF) xor $FF];3589 WX := GAMMA_ENCODING_TABLE[((X shr 8) and $FF) xor $FF]; 3521 3590 Result := CombineReg(CombineReg(C1, C2, WX), 3522 3591 CombineReg(C3, C4, WX), 3523 GAMMA_ TABLE[((Y shr 8) and $FF) xor $FF]);3592 GAMMA_ENCODING_TABLE[((Y shr 8) and $FF) xor $FF]); 3524 3593 EMMS; 3525 3594 end … … 3558 3627 DstH := DstRect.Bottom - DstRect.Top; 3559 3628 if (DstW > SrcW) and (DstH > SrcH) and (SrcW > 1) and (SrcH > 1) then 3560 StretchHorzStretchVertLinear(Dst, DstRect, DstClip, Src, SrcRect, CombineOp, CombineCallBack) 3629 StretchHorzStretchVertLinear(Dst, DstRect, DstClip, Src, SrcRect, CombineOp, 3630 CombineCallBack) 3561 3631 else 3562 GR32_Resamplers.Resample(Dst, DstRect, DstClip, Src, SrcRect, FLinearKernel, CombineOp, CombineCallBack); 3632 GR32_Resamplers.Resample(Dst, DstRect, DstClip, Src, SrcRect, FLinearKernel, 3633 CombineOp, CombineCallBack); 3563 3634 end; 3564 3635 … … 3568 3639 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); 3569 3640 begin 3570 DraftResample(Dst, DstRect, DstClip, Src, SrcRect, FLinearKernel, CombineOp, CombineCallBack) 3641 DraftResample(Dst, DstRect, DstClip, Src, SrcRect, FLinearKernel, CombineOp, 3642 CombineCallBack) 3571 3643 end; 3572 3644 … … 3577 3649 U, V: TFixed; 3578 3650 begin 3579 FTransformationReverseTransformFixed(X * FixedOne + FixedHalf, Y * FixedOne + FixedHalf, U, V); 3651 FTransformationReverseTransformFixed(X * FixedOne + FixedHalf, 3652 Y * FixedOne + FixedHalf, U, V); 3580 3653 Result := FGetSampleFixed(U - FixedHalf, V - FixedHalf); 3581 3654 end; … … 4139 4212 end; 4140 4213 4141 {CPU target and feature Function templates}4214 {CPU target and feature function templates} 4142 4215 4143 4216 const -
GraphicTest/Packages/Graphics32/GR32_System.pas
r450 r522 70 70 function ReadNanoseconds: string; 71 71 function ReadMilliseconds: string; 72 function ReadSeconds: String; 72 function ReadSeconds: string; 73 73 74 function ReadValue: Int64; 74 75 end; … … 127 128 128 129 function TPerfTimer.ReadNanoseconds: string; 129 var 130 t : timeval; 131 begin 132 fpgettimeofday(@t,nil); 133 // Build a 64 bit microsecond tick from the seconds and microsecond longints 134 Result := IntToStr( ( (Int64(t.tv_sec) * 1000000) + t.tv_usec ) div 1000 ); 130 begin 131 Result := IntToStr(ReadValue); 135 132 end; 136 133 137 134 function TPerfTimer.ReadMilliseconds: string; 138 var 139 t : timeval; 140 begin 141 fpgettimeofday(@t,nil); 142 // Build a 64 bit microsecond tick from the seconds and microsecond longints 143 Result := IntToStr( ( (Int64(t.tv_sec) * 1000000) + t.tv_usec ) * 1000 ); 135 begin 136 Result := IntToStr(ReadValue div 1000); 144 137 end; 145 138 146 139 function TPerfTimer.ReadSeconds: string; 147 var 148 t : timeval; 149 begin 150 fpgettimeofday(@t,nil); 151 // Build a 64 bit microsecond tick from the seconds and microsecond longints 152 Result := IntToStr( ( (Int64(t.tv_sec) * 1000000) + t.tv_usec ) ); 140 begin 141 Result := IntToStr(ReadValue div 1000000); 153 142 end; 154 143 155 144 function TPerfTimer.ReadValue: Int64; 156 var t : timeval; 157 begin 158 fpgettimeofday(@t,nil); 159 // Build a 64 bit microsecond tick from the seconds and microsecond longints 160 Result := (Int64(t.tv_sec) * 1000000) + t.tv_usec; 161 Result := Result div 1000; 145 begin 146 Result := GetTickCount - FStart; 162 147 end; 163 148 164 149 procedure TPerfTimer.Start; 165 var 166 t : timeval; 167 begin 168 fpgettimeofday(@t,nil); 169 // Build a 64 bit microsecond tick from the seconds and microsecond longints 170 FStart := (Int64(t.tv_sec) * 1000000) + t.tv_usec; 150 begin 151 FStart := GetTickCount; 171 152 end; 172 153 {$ENDIF} … … 242 223 {$IFNDEF PUREPASCAL} 243 224 const 244 CPUISChecks: Array[TCPUInstructionSet] of Cardinal =225 CPUISChecks: array [TCPUInstructionSet] of Cardinal = 245 226 ($800000, $400000, $2000000, $4000000, $80000000, $40000000); 246 227 {ciMMX , ciEMMX, ciSSE , ciSSE2 , ci3DNow , ci3DNowExt} … … 248 229 function CPUID_Available: Boolean; 249 230 asm 231 {$IFDEF TARGET_x86} 232 MOV EDX,False 233 PUSHFD 234 POP EAX 235 MOV ECX,EAX 236 XOR EAX,$00200000 237 PUSH EAX 238 POPFD 239 PUSHFD 240 POP EAX 241 XOR ECX,EAX 242 JZ @1 243 MOV EDX,True 244 @1: PUSH EAX 245 POPFD 246 MOV EAX,EDX 247 {$ENDIF} 250 248 {$IFDEF TARGET_x64} 251 249 MOV EDX,False … … 264 262 POPFQ 265 263 MOV EAX,EDX 266 {$ELSE}267 MOV EDX,False268 PUSHFD269 POP EAX270 MOV ECX,EAX271 XOR EAX,$00200000272 PUSH EAX273 POPFD274 PUSHFD275 POP EAX276 XOR ECX,EAX277 JZ @1278 MOV EDX,True279 @1: PUSH EAX280 POPFD281 MOV EAX,EDX282 264 {$ENDIF} 283 265 end; … … 285 267 function CPU_Signature: Integer; 286 268 asm 287 {$IFDEF TARGET_x64} 288 PUSH RBX 289 MOV EAX,1 290 CPUID 291 POP RBX 292 {$ELSE} 269 {$IFDEF TARGET_x86} 293 270 PUSH EBX 294 271 MOV EAX,1 … … 300 277 POP EBX 301 278 {$ENDIF} 302 end;303 304 function CPU_Features: Integer;305 asm306 279 {$IFDEF TARGET_x64} 307 280 PUSH RBX … … 309 282 CPUID 310 283 POP RBX 311 MOV EAX,EDX 312 {$ELSE} 284 {$ENDIF} 285 end; 286 287 function CPU_Features: Integer; 288 asm 289 {$IFDEF TARGET_x86} 313 290 PUSH EBX 314 291 MOV EAX,1 … … 321 298 MOV EAX,EDX 322 299 {$ENDIF} 300 {$IFDEF TARGET_x64} 301 PUSH RBX 302 MOV EAX,1 303 CPUID 304 POP RBX 305 MOV EAX,EDX 306 {$ENDIF} 323 307 end; 324 308 325 309 function CPU_ExtensionsAvailable: Boolean; 326 310 asm 327 {$IFDEF TARGET_x64} 328 PUSH RBX 329 MOV @Result, True 330 MOV EAX, $80000000 331 CPUID 332 CMP EAX, $80000000 333 JBE @NOEXTENSION 334 JMP @EXIT 335 @NOEXTENSION: 336 MOV @Result, False 337 @EXIT: 338 POP RBX 339 {$ELSE} 311 {$IFDEF TARGET_x86} 340 312 PUSH EBX 341 313 MOV @Result, True … … 354 326 POP EBX 355 327 {$ENDIF} 328 {$IFDEF TARGET_x64} 329 PUSH RBX 330 MOV @Result, True 331 MOV EAX, $80000000 332 CPUID 333 CMP EAX, $80000000 334 JBE @NOEXTENSION 335 JMP @EXIT 336 @NOEXTENSION: 337 MOV @Result, False 338 @EXIT: 339 POP RBX 340 {$ENDIF} 356 341 end; 357 342 358 343 function CPU_ExtFeatures: Integer; 359 344 asm 360 {$IFDEF TARGET_x64} 361 PUSH RBX 362 MOV EAX, $80000001 363 CPUID 364 POP RBX 365 MOV EAX,EDX 366 {$ELSE} 345 {$IFDEF TARGET_x86} 367 346 PUSH EBX 368 347 MOV EAX, $80000001 … … 373 352 {$ENDIF} 374 353 POP EBX 354 MOV EAX,EDX 355 {$ENDIF} 356 {$IFDEF TARGET_x64} 357 PUSH RBX 358 MOV EAX, $80000001 359 CPUID 360 POP RBX 375 361 MOV EAX,EDX 376 362 {$ENDIF} -
GraphicTest/Packages/Graphics32/GR32_Transforms.pas
r450 r522 48 48 Windows, 49 49 {$ENDIF} 50 SysUtils, Classes, GR32, GR32_Blend, GR32_VectorMaps, GR32_Rasterizers;50 SysUtils, Classes, Types, GR32, GR32_VectorMaps, GR32_Rasterizers; 51 51 52 52 type … … 55 55 56 56 type 57 TFloatMatrix = array [0..2, 0..2] of TFloat; // 3x3 TFloat precision58 TFixedMatrix = array [0..2, 0..2] of TFixed; // 3x3 fixed precision57 TFloatMatrix = array [0..2, 0..2] of TFloat; // 3x3 TFloat precision 58 TFixedMatrix = array [0..2, 0..2] of TFixed; // 3x3 fixed precision 59 59 60 60 const … … 65 65 66 66 type 67 TVector3f = array [0..2] of TFloat;68 TVector3i = array [0..2] of Integer;67 TVector3f = array [0..2] of TFloat; 68 TVector3i = array [0..2] of Integer; 69 69 70 70 // Matrix conversion routines … … 94 94 procedure TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); virtual; 95 95 public 96 constructor Create; virtual; 96 97 procedure Changed; override; 97 98 function HasTransformedBounds: Boolean; virtual; … … 106 107 property SrcRect: TFloatRect read FSrcRect write SetSrcRect; 107 108 end; 108 109 TAffineTransformation = class(TTransformation) 109 TTransformationClass = class of TTransformation; 110 111 TNestedTransformation = class(TTransformation) 112 private 113 FItems: TList; 114 FOwner: TPersistent; 115 function GetCount: Integer; 116 function GetItem(Index: Integer): TTransformation; 117 procedure SetItem(Index: Integer; const Value: TTransformation); 110 118 protected 111 FInverseMatrix: TFloatMatrix; 119 procedure PrepareTransform; override; 120 procedure ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); override; 121 procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; 122 procedure TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); override; 123 procedure TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); override; 124 public 125 constructor Create; override; 126 destructor Destroy; override; 127 function Add(ItemClass: TTransformationClass): TTransformation; 128 procedure Clear; 129 procedure Delete(Index: Integer); 130 function Insert(Index: Integer; ItemClass: TTransformationClass): TTransformation; 131 132 property Owner: TPersistent read FOwner; 133 property Count: Integer read GetCount; 134 property Items[Index: Integer]: TTransformation read GetItem write SetItem; default; 135 end; 136 137 T3x3Transformation = class(TTransformation) 138 protected 139 FMatrix, FInverseMatrix: TFloatMatrix; 112 140 FFixedMatrix, FInverseFixedMatrix: TFixedMatrix; 113 141 procedure PrepareTransform; override; 142 procedure ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); override; 114 143 procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; 115 procedure ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); override;144 procedure TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); override; 116 145 procedure TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); override; 117 procedure TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); override;118 146 public 119 Matrix: TFloatMatrix; 120 constructor Create; virtual; 147 property Matrix: TFloatMatrix read FMatrix; 148 end; 149 150 TAffineTransformation = class(T3x3Transformation) 151 private 152 FStack: ^TFloatMatrix; 153 FStackLevel: Integer; 154 public 155 constructor Create; override; 156 121 157 function GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; override; 122 procedure Clear; 158 procedure Push; 159 procedure Pop; 160 procedure Clear; overload; 161 procedure Clear(BaseMatrix: TFloatMatrix); overload; 123 162 procedure Rotate(Alpha: TFloat); overload; // degrees 124 163 procedure Rotate(Cx, Cy, Alpha: TFloat); overload; // degrees … … 129 168 end; 130 169 131 TProjectiveTransformation = class(T Transformation)170 TProjectiveTransformation = class(T3x3Transformation) 132 171 private 133 Wx0, Wx1, Wx2, Wx3: TFloat; 134 Wy0, Wy1, Wy2, Wy3: TFloat; 135 procedure SetX0(Value: TFloat); 136 procedure SetX1(Value: TFloat); 137 procedure SetX2(Value: TFloat); 138 procedure SetX3(Value: TFloat); 139 procedure SetY0(Value: TFloat); 140 procedure SetY1(Value: TFloat); 141 procedure SetY2(Value: TFloat); 142 procedure SetY3(Value: TFloat); 172 FQuadX: array [0..3] of TFloat; 173 FQuadY: array [0..3] of TFloat; 174 procedure SetX(Index: Integer; const Value: TFloat); {$IFDEF UseInlining} inline; {$ENDIF} 175 procedure SetY(Index: Integer; const Value: TFloat); {$IFDEF UseInlining} inline; {$ENDIF} 176 function GetX(Index: Integer): TFloat; {$IFDEF UseInlining} inline; {$ENDIF} 177 function GetY(Index: Integer): TFloat; {$IFDEF UseInlining} inline; {$ENDIF} 143 178 protected 144 FMatrix, FInverseMatrix: TFloatMatrix;145 FFixedMatrix, FInverseFixedMatrix: TFixedMatrix;146 179 procedure PrepareTransform; override; 180 procedure ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); override; 147 181 procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; 148 procedure ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); override;182 procedure TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); override; 149 183 procedure TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); override; 150 procedure TransformFixed(SrcX, SrcY: TFixed; out DstX, DstY: TFixed); override;151 184 public 152 function GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; override; 185 function GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; override; 186 property X[Index: Integer]: TFloat read GetX write SetX; 187 property Y[index: Integer]: TFloat read GetX write SetY; 153 188 published 154 property X0: TFloat read Wx0 write SetX0;155 property X1: TFloat read Wx1 write SetX1;156 property X2: TFloat read Wx2 write SetX2;157 property X3: TFloat read Wx3 write SetX3;158 property Y0: TFloat read Wy0 write SetY0;159 property Y1: TFloat read Wy1 write SetY1;160 property Y2: TFloat read Wy2 write SetY2;161 property Y3: TFloat read Wy3 write SetY3;189 property X0: TFloat index 0 read GetX write SetX; 190 property X1: TFloat index 1 read GetX write SetX; 191 property X2: TFloat index 2 read GetX write SetX; 192 property X3: TFloat index 3 read GetX write SetX; 193 property Y0: TFloat index 0 read GetY write SetY; 194 property Y1: TFloat index 1 read GetY write SetY; 195 property Y2: TFloat index 2 read GetY write SetY; 196 property Y3: TFloat index 3 read GetY write SetY; 162 197 end; 163 198 … … 171 206 procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; 172 207 public 173 constructor Create; virtual;208 constructor Create; override; 174 209 function GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; override; 175 210 published … … 186 221 procedure PrepareTransform; override; 187 222 procedure ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; 223 procedure TransformFloat(DstX, DstY: TFloat; out SrcX, SrcY: TFloat); override; 188 224 public 189 constructor Create; virtual;225 constructor Create; override; 190 226 published 191 227 property BloatPower: TFloat read FBloatPower write SetBloatPower; … … 277 313 procedure ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, SrcY: TFixed); override; 278 314 public 279 constructor Create; virtual;315 constructor Create; override; 280 316 destructor Destroy; override; 281 317 function HasTransformedBounds: Boolean; override; … … 316 352 317 353 uses 318 Math, GR32_LowLevel, GR32_Math, GR32_System, GR32_Bindings, GR32_Resamplers; 354 Math, GR32_Blend, GR32_LowLevel, GR32_Math, GR32_Bindings, 355 GR32_Resamplers; 319 356 320 357 resourcestring 321 358 RCStrSrcRectIsEmpty = 'SrcRect is empty!'; 322 359 RCStrMappingRectIsEmpty = 'MappingRect is empty!'; 360 RStrStackEmpty = 'Stack empty'; 323 361 324 362 type … … 516 554 Transformer: TTransformer; 517 555 begin 518 IntersectRect(DstRect, DstClip, Dst.ClipRect);556 GR32.IntersectRect(DstRect, DstClip, Dst.ClipRect); 519 557 520 558 if (DstRect.Right < DstRect.Left) or (DstRect.Bottom < DstRect.Top) then Exit; … … 538 576 I: Integer; 539 577 begin 540 IntersectRect(ARect, ARect, ABitmap.BoundsRect);578 GR32.IntersectRect(ARect, ARect, ABitmap.BoundsRect); 541 579 with ARect, ABitmap do 542 580 if (Right > Left) and (Bottom > Top) and … … 573 611 end; 574 612 613 constructor TTransformation.Create; 614 begin 615 // virtual constructor to be overriden in derived classes 616 end; 617 575 618 function TTransformation.GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; 576 619 begin … … 619 662 out SrcX, SrcY: TFloat); 620 663 begin 621 // ReverseTransformFloat is the top precisionlevel, all de cendants must override at least this level!664 // ReverseTransformFloat is the top precisionlevel, all descendants must override at least this level! 622 665 raise ETransformNotImplemented.CreateFmt(RCStrReverseTransformationNotImplemented, [Self.Classname]); 623 666 end; … … 641 684 function TTransformation.Transform(const P: TFloatPoint): TFloatPoint; 642 685 begin 643 If not TransformValid then PrepareTransform;686 if not TransformValid then PrepareTransform; 644 687 TransformFloat(P.X, P.Y, Result.X, Result.Y); 645 688 end; … … 647 690 function TTransformation.Transform(const P: TFixedPoint): TFixedPoint; 648 691 begin 649 If not TransformValid then PrepareTransform;692 if not TransformValid then PrepareTransform; 650 693 TransformFixed(P.X, P.Y, Result.X, Result.Y); 651 694 end; … … 653 696 function TTransformation.Transform(const P: TPoint): TPoint; 654 697 begin 655 If not TransformValid then PrepareTransform;698 if not TransformValid then PrepareTransform; 656 699 TransformInt(P.X, P.Y, Result.X, Result.Y); 657 700 end; … … 669 712 procedure TTransformation.TransformFloat(SrcX, SrcY: TFloat; out DstX, DstY: TFloat); 670 713 begin 671 // TransformFloat is the top precisionlevel, all de cendants must override at least this level!714 // TransformFloat is the top precisionlevel, all descendants must override at least this level! 672 715 raise ETransformNotImplemented.CreateFmt(RCStrForwardTransformationNotImplemented, [Self.Classname]); 673 716 end; … … 682 725 end; 683 726 727 728 { TNestedTransformation } 729 730 constructor TNestedTransformation.Create; 731 begin 732 FItems := TList.Create; 733 end; 734 735 destructor TNestedTransformation.Destroy; 736 begin 737 if Assigned(FItems) then Clear; 738 FItems.Free; 739 inherited; 740 end; 741 742 function TNestedTransformation.Add( 743 ItemClass: TTransformationClass): TTransformation; 744 begin 745 Result := ItemClass.Create; 746 {$IFDEF NEXTGEN} 747 Result.__ObjAddRef; 748 {$ENDIF} 749 FItems.Add(Result); 750 end; 751 752 procedure TNestedTransformation.Clear; 753 begin 754 BeginUpdate; 755 try 756 while FItems.Count > 0 do 757 Delete(FItems.Count - 1); 758 finally 759 EndUpdate; 760 end; 761 end; 762 763 procedure TNestedTransformation.Delete(Index: Integer); 764 begin 765 TTransformation(FItems[Index]).Free; 766 FItems.Delete(Index); 767 end; 768 769 function TNestedTransformation.GetCount: Integer; 770 begin 771 Result := FItems.Count; 772 end; 773 774 function TNestedTransformation.GetItem(Index: Integer): TTransformation; 775 begin 776 Result := FItems[Index]; 777 end; 778 779 function TNestedTransformation.Insert(Index: Integer; 780 ItemClass: TTransformationClass): TTransformation; 781 begin 782 BeginUpdate; 783 try 784 Result := Add(ItemClass); 785 finally 786 EndUpdate; 787 end; 788 end; 789 790 procedure TNestedTransformation.PrepareTransform; 791 var 792 Index: Integer; 793 begin 794 for Index := 0 to Count - 1 do 795 TTransformation(FItems[Index]).PrepareTransform; 796 end; 797 798 procedure TNestedTransformation.ReverseTransformFixed(DstX, DstY: TFixed; 799 out SrcX, SrcY: TFixed); 800 var 801 Index: Integer; 802 begin 803 for Index := 0 to Count - 1 do 804 begin 805 TTransformation(FItems[Index]).ReverseTransformFixed(DstX, DstY, SrcX, 806 SrcY); 807 DstX := SrcX; 808 DstY := SrcY; 809 end; 810 end; 811 812 procedure TNestedTransformation.ReverseTransformFloat(DstX, DstY: TFloat; 813 out SrcX, SrcY: TFloat); 814 var 815 Index: Integer; 816 begin 817 for Index := 0 to Count - 1 do 818 begin 819 TTransformation(FItems[Index]).ReverseTransformFloat(DstX, DstY, SrcX, 820 SrcY); 821 DstX := SrcX; 822 DstY := SrcY; 823 end; 824 end; 825 826 procedure TNestedTransformation.SetItem(Index: Integer; 827 const Value: TTransformation); 828 begin 829 TCollectionItem(FItems[Index]).Assign(Value); 830 end; 831 832 procedure TNestedTransformation.TransformFixed(SrcX, SrcY: TFixed; out DstX, 833 DstY: TFixed); 834 var 835 Index: Integer; 836 begin 837 for Index := 0 to Count - 1 do 838 begin 839 TTransformation(FItems[Index]).TransformFixed(SrcX, SrcY, DstX, DstY); 840 SrcX := DstX; 841 SrcY := DstY; 842 end; 843 end; 844 845 procedure TNestedTransformation.TransformFloat(SrcX, SrcY: TFloat; out DstX, 846 DstY: TFloat); 847 var 848 Index: Integer; 849 begin 850 for Index := 0 to Count - 1 do 851 begin 852 TTransformation(FItems[Index]).TransformFloat(SrcX, SrcY, DstX, DstY); 853 SrcX := DstX; 854 SrcY := DstY; 855 end; 856 end; 857 858 859 { T3x3Transformation } 860 861 procedure T3x3Transformation.PrepareTransform; 862 begin 863 FInverseMatrix := Matrix; 864 Invert(FInverseMatrix); 865 866 // calculate a fixed point (65536) factors 867 FInverseFixedMatrix := FixedMatrix(FInverseMatrix); 868 FFixedMatrix := FixedMatrix(Matrix); 869 870 TransformValid := True; 871 end; 872 873 procedure T3x3Transformation.ReverseTransformFixed(DstX, DstY: TFixed; out SrcX, 874 SrcY: TFixed); 875 begin 876 SrcX := FixedMul(DstX, FInverseFixedMatrix[0, 0]) + 877 FixedMul(DstY, FInverseFixedMatrix[1, 0]) + FInverseFixedMatrix[2, 0]; 878 SrcY := FixedMul(DstX, FInverseFixedMatrix[0, 1]) + 879 FixedMul(DstY, FInverseFixedMatrix[1, 1]) + FInverseFixedMatrix[2, 1]; 880 end; 881 882 procedure T3x3Transformation.ReverseTransformFloat(DstX, DstY: TFloat; out SrcX, 883 SrcY: TFloat); 884 begin 885 SrcX := DstX * FInverseMatrix[0, 0] + DstY * FInverseMatrix[1, 0] + 886 FInverseMatrix[2, 0]; 887 SrcY := DstX * FInverseMatrix[0, 1] + DstY * FInverseMatrix[1, 1] + 888 FInverseMatrix[2, 1]; 889 end; 890 891 procedure T3x3Transformation.TransformFixed(SrcX, SrcY: TFixed; out DstX, 892 DstY: TFixed); 893 begin 894 DstX := FixedMul(SrcX, FFixedMatrix[0, 0]) + 895 FixedMul(SrcY, FFixedMatrix[1, 0]) + FFixedMatrix[2, 0]; 896 DstY := FixedMul(SrcX, FFixedMatrix[0, 1]) + 897 FixedMul(SrcY, FFixedMatrix[1, 1]) + FFixedMatrix[2, 1]; 898 end; 899 900 procedure T3x3Transformation.TransformFloat(SrcX, SrcY: TFloat; out DstX, 901 DstY: TFloat); 902 begin 903 DstX := SrcX * Matrix[0, 0] + SrcY * Matrix[1, 0] + Matrix[2, 0]; 904 DstY := SrcX * Matrix[0, 1] + SrcY * Matrix[1, 1] + Matrix[2, 1]; 905 end; 906 907 684 908 { TAffineTransformation } 685 909 910 constructor TAffineTransformation.Create; 911 begin 912 FStackLevel := 0; 913 FStack := nil; 914 Clear; 915 end; 916 686 917 procedure TAffineTransformation.Clear; 687 918 begin 688 Matrix := IdentityMatrix; 689 Changed; 690 end; 691 692 constructor TAffineTransformation.Create; 693 begin 694 Clear; 919 FMatrix := IdentityMatrix; 920 Changed; 921 end; 922 923 procedure TAffineTransformation.Clear(BaseMatrix: TFloatMatrix); 924 begin 925 FMatrix := BaseMatrix; 926 Changed; 695 927 end; 696 928 … … 713 945 end; 714 946 715 procedure TAffineTransformation.PrepareTransform; 716 begin 717 FInverseMatrix := Matrix; 718 Invert(FInverseMatrix); 719 720 // calculate a fixed point (65536) factors 721 FInverseFixedMatrix := FixedMatrix(FInverseMatrix); 722 FFixedMatrix := FixedMatrix(Matrix); 723 724 TransformValid := True; 947 procedure TAffineTransformation.Push; 948 begin 949 Inc(FStackLevel); 950 ReallocMem(FStack, FStackLevel * SizeOf(TFloatMatrix)); 951 Move(FMatrix, FStack^[FStackLevel - 1], SizeOf(TFloatMatrix)); 952 end; 953 954 procedure TAffineTransformation.Pop; 955 begin 956 if FStackLevel <= 0 then 957 raise Exception.Create(RStrStackEmpty); 958 959 Move(FStack^[FStackLevel - 1], FMatrix, SizeOf(TFloatMatrix)); 960 Dec(FStackLevel); 961 Changed; 725 962 end; 726 963 … … 735 972 M[0, 0] := C; M[1, 0] := S; 736 973 M[0, 1] := -S; M[1, 1] := C; 737 Matrix := Mult(M, Matrix);974 FMatrix := Mult(M, Matrix); 738 975 Changed; 739 976 end; … … 750 987 M[0, 0] := C; M[1, 0] := S; 751 988 M[0, 1] := -S; M[1, 1] := C; 752 Matrix := Mult(M, Matrix);989 FMatrix := Mult(M, Matrix); 753 990 if (Cx <> 0) or (Cy <> 0) then Translate(Cx, Cy); 754 991 Changed; … … 762 999 M[0, 0] := Sx; 763 1000 M[1, 1] := Sy; 764 Matrix := Mult(M, Matrix);1001 FMatrix := Mult(M, Matrix); 765 1002 Changed; 766 1003 end; … … 773 1010 M[0, 0] := Value; 774 1011 M[1, 1] := Value; 775 Matrix := Mult(M, Matrix);1012 FMatrix := Mult(M, Matrix); 776 1013 Changed; 777 1014 end; … … 784 1021 M[1, 0] := Fx; 785 1022 M[0, 1] := Fy; 786 Matrix := Mult(M, Matrix); 787 Changed; 788 end; 789 790 procedure TAffineTransformation.ReverseTransformFloat( 791 DstX, DstY: TFloat; 792 out SrcX, SrcY: TFloat); 793 begin 794 SrcX := DstX * FInverseMatrix[0,0] + DstY * FInverseMatrix[1,0] + FInverseMatrix[2,0]; 795 SrcY := DstX * FInverseMatrix[0,1] + DstY * FInverseMatrix[1,1] + FInverseMatrix[2,1]; 796 end; 797 798 procedure TAffineTransformation.ReverseTransformFixed( 799 DstX, DstY: TFixed; 800 out SrcX, SrcY: TFixed); 801 begin 802 SrcX := FixedMul(DstX, FInverseFixedMatrix[0,0]) + FixedMul(DstY, FInverseFixedMatrix[1,0]) + FInverseFixedMatrix[2,0]; 803 SrcY := FixedMul(DstX, FInverseFixedMatrix[0,1]) + FixedMul(DstY, FInverseFixedMatrix[1,1]) + FInverseFixedMatrix[2,1]; 804 end; 805 806 procedure TAffineTransformation.TransformFloat( 807 SrcX, SrcY: TFloat; 808 out DstX, DstY: TFloat); 809 begin 810 DstX := SrcX * Matrix[0,0] + SrcY * Matrix[1,0] + Matrix[2,0]; 811 DstY := SrcX * Matrix[0,1] + SrcY * Matrix[1,1] + Matrix[2,1]; 812 end; 813 814 procedure TAffineTransformation.TransformFixed( 815 SrcX, SrcY: TFixed; 816 out DstX, DstY: TFixed); 817 begin 818 DstX := FixedMul(SrcX, FFixedMatrix[0,0]) + FixedMul(SrcY, FFixedMatrix[1,0]) + FFixedMatrix[2,0]; 819 DstY := FixedMul(SrcX, FFixedMatrix[0,1]) + FixedMul(SrcY, FFixedMatrix[1,1]) + FFixedMatrix[2,1]; 1023 FMatrix := Mult(M, Matrix); 1024 Changed; 820 1025 end; 821 1026 … … 825 1030 begin 826 1031 M := IdentityMatrix; 827 M[2,0] := Dx; 828 M[2,1] := Dy; 829 Matrix := Mult(M, Matrix); 830 Changed; 1032 M[2, 0] := Dx; 1033 M[2, 1] := Dy; 1034 FMatrix := Mult(M, Matrix); 1035 1036 Changed; 831 1037 end; 832 1038 … … 836 1042 function TProjectiveTransformation.GetTransformedBounds(const ASrcRect: TFloatRect): TFloatRect; 837 1043 begin 838 Result.Left := Min(Min(Wx0, Wx1), Min(Wx2, Wx3)); 839 Result.Right := Max(Max(Wx0, Wx1), Max(Wx2, Wx3)); 840 Result.Top := Min(Min(Wy0, Wy1), Min(Wy2, Wy3)); 841 Result.Bottom := Max(Max(Wy0, Wy1), Max(Wy2, Wy3)); 1044 Result.Left := Min(Min(FQuadX[0], FQuadX[1]), Min(FQuadX[2], FQuadX[3])); 1045 Result.Right := Max(Max(FQuadX[0], FQuadX[1]), Max(FQuadX[2], FQuadX[3])); 1046 Result.Top := Min(Min(FQuadY[0], FQuadY[1]), Min(FQuadY[2], FQuadY[3])); 1047 Result.Bottom := Max(Max(FQuadY[0], FQuadY[1]), Max(FQuadY[2], FQuadY[3])); 1048 end; 1049 1050 function TProjectiveTransformation.GetX(Index: Integer): TFloat; 1051 begin 1052 Result := FQuadX[Index]; 1053 end; 1054 1055 function TProjectiveTransformation.GetY(Index: Integer): TFloat; 1056 begin 1057 Result := FQuadY[Index]; 842 1058 end; 843 1059 … … 848 1064 R: TFloatMatrix; 849 1065 begin 850 px := Wx0 - Wx1 + Wx2 - Wx3;851 py := Wy0 - Wy1 + Wy2 - Wy3;1066 px := FQuadX[0] - FQuadX[1] + FQuadX[2] - FQuadX[3]; 1067 py := FQuadY[0] - FQuadY[1] + FQuadY[2] - FQuadY[3]; 852 1068 853 1069 if (px = 0) and (py = 0) then 854 1070 begin 855 1071 // affine mapping 856 FMatrix[0, 0] := Wx1 - Wx0;857 FMatrix[1, 0] := Wx2 - Wx1;858 FMatrix[2, 0] := Wx0;859 860 FMatrix[0, 1] := Wy1 - Wy0;861 FMatrix[1, 1] := Wy2 - Wy1;862 FMatrix[2, 1] := Wy0;863 864 FMatrix[0, 2] := 0;865 FMatrix[1, 2] := 0;866 FMatrix[2, 2] := 1;1072 FMatrix[0, 0] := FQuadX[1] - FQuadX[0]; 1073 FMatrix[1, 0] := FQuadX[2] - FQuadX[1]; 1074 FMatrix[2, 0] := FQuadX[0]; 1075 1076 FMatrix[0, 1] := FQuadY[1] - FQuadY[0]; 1077 FMatrix[1, 1] := FQuadY[2] - FQuadY[1]; 1078 FMatrix[2, 1] := FQuadY[0]; 1079 1080 FMatrix[0, 2] := 0; 1081 FMatrix[1, 2] := 0; 1082 FMatrix[2, 2] := 1; 867 1083 end 868 1084 else 869 1085 begin 870 1086 // projective mapping 871 dx1 := Wx1 - Wx2;872 dx2 := Wx3 - Wx2;873 dy1 := Wy1 - Wy2;874 dy2 := Wy3 - Wy2;1087 dx1 := FQuadX[1] - FQuadX[2]; 1088 dx2 := FQuadX[3] - FQuadX[2]; 1089 dy1 := FQuadY[1] - FQuadY[2]; 1090 dy2 := FQuadY[3] - FQuadY[2]; 875 1091 k := dx1 * dy2 - dx2 * dy1; 876 1092 if k <> 0 then … … 880 1096 h := (dx1 * py - dy1 * px) * k; 881 1097 882 FMatrix[0, 0] := Wx1 - Wx0 + g * Wx1;883 FMatrix[1, 0] := Wx3 - Wx0 + h * Wx3;884 FMatrix[2, 0] := Wx0;885 886 FMatrix[0, 1] := Wy1 - Wy0 + g * Wy1;887 FMatrix[1, 1] := Wy3 - Wy0 + h * Wy3;888 FMatrix[2, 1] := Wy0;889 890 FMatrix[0, 2] := g;891 FMatrix[1, 2] := h;892 FMatrix[2, 2] := 1;1098 FMatrix[0, 0] := FQuadX[1] - FQuadX[0] + g * FQuadX[1]; 1099 FMatrix[1, 0] := FQuadX[3] - FQuadX[0] + h * FQuadX[3]; 1100 FMatrix[2, 0] := FQuadX[0]; 1101 1102 FMatrix[0, 1] := FQuadY[1] - FQuadY[0] + g * FQuadY[1]; 1103 FMatrix[1, 1] := FQuadY[3] - FQuadY[0] + h * FQuadY[3]; 1104 FMatrix[2, 1] := FQuadY[0]; 1105 1106 FMatrix[0, 2] := g; 1107 FMatrix[1, 2] := h; 1108 FMatrix[2, 2] := 1; 893 1109 end 894 1110 else … … 900 1116 // denormalize texture space (u, v) 901 1117 R := IdentityMatrix; 902 R[0, 0] := 1 / (SrcRect.Right - SrcRect.Left);903 R[1, 1] := 1 / (SrcRect.Bottom - SrcRect.Top);1118 R[0, 0] := 1 / (SrcRect.Right - SrcRect.Left); 1119 R[1, 1] := 1 / (SrcRect.Bottom - SrcRect.Top); 904 1120 FMatrix := Mult(FMatrix, R); 905 1121 906 1122 R := IdentityMatrix; 907 R[2, 0] := -SrcRect.Left;908 R[2, 1] := -SrcRect.Top;1123 R[2, 0] := -SrcRect.Left; 1124 R[2, 1] := -SrcRect.Top; 909 1125 FMatrix := Mult(FMatrix, R); 910 1126 911 FInverseMatrix := FMatrix; 912 Invert(FInverseMatrix); 913 914 FInverseFixedMatrix := FixedMatrix(FInverseMatrix); 915 FFixedMatrix := FixedMatrix(FMatrix); 916 917 TransformValid := True; 918 end; 919 920 procedure TProjectiveTransformation.SetX0(Value: TFloat); 921 begin 922 Wx0 := Value; 923 Changed; 924 end; 925 926 procedure TProjectiveTransformation.SetX1(Value: TFloat); 927 begin 928 Wx1 := Value; 929 Changed; 930 end; 931 932 procedure TProjectiveTransformation.SetX2(Value: TFloat); 933 begin 934 Wx2 := Value; 935 Changed; 936 end; 937 938 procedure TProjectiveTransformation.SetX3(Value: TFloat); 939 begin 940 Wx3 := Value; 941 Changed; 942 end; 943 944 procedure TProjectiveTransformation.SetY0(Value: TFloat); 945 begin 946 Wy0 := Value; 947 Changed; 948 end; 949 950 procedure TProjectiveTransformation.SetY1(Value: TFloat); 951 begin 952 Wy1 := Value; 953 Changed; 954 end; 955 956 procedure TProjectiveTransformation.SetY2(Value: TFloat); 957 begin 958 Wy2 := Value; 959 Changed; 960 end; 961 962 procedure TProjectiveTransformation.SetY3(Value: TFloat); 963 begin 964 Wy3 := Value; 965 Changed; 966 end; 967 968 procedure TProjectiveTransformation.ReverseTransformFloat( 969 DstX, DstY: TFloat; 970 out SrcX, SrcY: TFloat); 971 var 972 X, Y, Z: TFloat; 973 begin 974 EMMS; 975 X := DstX; Y := DstY; 976 Z := FInverseMatrix[0,2] * X + FInverseMatrix[1,2] * Y + FInverseMatrix[2,2]; 977 978 if Z = 0 then Exit 979 else if Z = 1 then 980 begin 981 SrcX := FInverseMatrix[0,0] * X + FInverseMatrix[1,0] * Y + FInverseMatrix[2,0]; 982 SrcY := FInverseMatrix[0,1] * X + FInverseMatrix[1,1] * Y + FInverseMatrix[2,1]; 983 end 984 else 985 begin 986 Z := 1 / Z; 987 SrcX := (FInverseMatrix[0,0] * X + FInverseMatrix[1,0] * Y + FInverseMatrix[2,0]) * Z; 988 SrcY := (FInverseMatrix[0,1] * X + FInverseMatrix[1,1] * Y + FInverseMatrix[2,1]) * Z; 989 end; 1127 inherited; 1128 end; 1129 1130 procedure TProjectiveTransformation.SetX(Index: Integer; const Value: TFloat); 1131 begin 1132 FQuadX[Index] := Value; 1133 Changed; 1134 end; 1135 1136 procedure TProjectiveTransformation.SetY(Index: Integer; const Value: TFloat); 1137 begin 1138 FQuadY[Index] := Value; 1139 Changed; 990 1140 end; 991 1141 … … 996 1146 Zf: TFloat; 997 1147 begin 998 Z := FixedMul(FInverseFixedMatrix[0,2], DstX) + 999 FixedMul(FInverseFixedMatrix[1,2], DstY) + 1000 FInverseFixedMatrix[2,2]; 1148 Z := FixedMul(FInverseFixedMatrix[0, 2], DstX) + 1149 FixedMul(FInverseFixedMatrix[1, 2], DstY) + FInverseFixedMatrix[2, 2]; 1001 1150 1002 1151 if Z = 0 then Exit; 1003 1152 1004 SrcX := FixedMul(FInverseFixedMatrix[0,0], DstX) + 1005 FixedMul(FInverseFixedMatrix[1,0], DstY) + 1006 FInverseFixedMatrix[2,0]; 1007 1008 SrcY := FixedMul(FInverseFixedMatrix[0,1], DstX) + 1009 FixedMul(FInverseFixedMatrix[1,1], DstY) + 1010 FInverseFixedMatrix[2,1]; 1153 {$IFDEF UseInlining} 1154 SrcX := FixedMul(DstX, FInverseFixedMatrix[0, 0]) + 1155 FixedMul(DstY, FInverseFixedMatrix[1, 0]) + FInverseFixedMatrix[2, 0]; 1156 SrcY := FixedMul(DstX, FInverseFixedMatrix[0,1]) + 1157 FixedMul(DstY, FInverseFixedMatrix[1, 1]) + FInverseFixedMatrix[2, 1]; 1158 {$ELSE} 1159 inherited; 1160 {$ENDIF} 1011 1161 1012 1162 if Z <> FixedOne then … … 1019 1169 end; 1020 1170 1171 procedure TProjectiveTransformation.ReverseTransformFloat( 1172 DstX, DstY: TFloat; 1173 out SrcX, SrcY: TFloat); 1174 var 1175 Z: TFloat; 1176 begin 1177 EMMS; 1178 Z := FInverseMatrix[0, 2] * DstX + FInverseMatrix[1, 2] * DstY + 1179 FInverseMatrix[2, 2]; 1180 1181 if Z = 0 then Exit; 1182 1183 {$IFDEF UseInlining} 1184 SrcX := DstX * FInverseMatrix[0, 0] + DstY * FInverseMatrix[1, 0] + 1185 FInverseMatrix[2, 0]; 1186 SrcY := DstX * FInverseMatrix[0, 1] + DstY * FInverseMatrix[1, 1] + 1187 FInverseMatrix[2, 1]; 1188 {$ELSE} 1189 inherited; 1190 {$ENDIF} 1191 1192 if Z <> 1 then 1193 begin 1194 Z := 1 / Z; 1195 SrcX := SrcX * Z; 1196 SrcY := SrcY * Z; 1197 end; 1198 end; 1021 1199 1022 1200 procedure TProjectiveTransformation.TransformFixed(SrcX, SrcY: TFixed; … … 1026 1204 Zf: TFloat; 1027 1205 begin 1028 Z := FixedMul(FFixedMatrix[0,2], SrcX) + 1029 FixedMul(FFixedMatrix[1,2], SrcY) + 1030 FFixedMatrix[2,2]; 1206 Z := FixedMul(FFixedMatrix[0, 2], SrcX) + 1207 FixedMul(FFixedMatrix[1, 2], SrcY) + FFixedMatrix[2, 2]; 1031 1208 1032 1209 if Z = 0 then Exit; 1033 1210 1034 DstX := FixedMul(FFixedMatrix[0,0], SrcX) + 1035 FixedMul(FFixedMatrix[1,0], SrcY) + 1036 FFixedMatrix[2,0]; 1037 1038 DstY := FixedMul(FFixedMatrix[0,1], SrcX) + 1039 FixedMul(FFixedMatrix[1,1], SrcY) + 1040 FFixedMatrix[2,1]; 1211 {$IFDEF UseInlining} 1212 DstX := FixedMul(SrcX, FFixedMatrix[0, 0]) + 1213 FixedMul(SrcY, FFixedMatrix[1, 0]) + FFixedMatrix[2, 0]; 1214 DstY := FixedMul(SrcX, FFixedMatrix[0, 1]) + 1215 FixedMul(SrcY, FFixedMatrix[1, 1]) + FFixedMatrix[2, 1]; 1216 {$ELSE} 1217 inherited; 1218 {$ENDIF} 1041 1219 1042 1220 if Z <> FixedOne then … … 1052 1230 out DstX, DstY: TFloat); 1053 1231 var 1054 X, Y,Z: TFloat;1232 Z: TFloat; 1055 1233 begin 1056 1234 EMMS; 1057 X := SrcX; Y := SrcY; 1058 Z := FMatrix[0,2] * X + FMatrix[1,2] * Y + FMatrix[2,2]; 1059 1060 if Z = 0 then Exit 1061 else if Z = 1 then 1062 begin 1063 DstX := FMatrix[0,0] * X + FMatrix[1,0] * Y + FMatrix[2,0]; 1064 DstY := FMatrix[0,1] * X + FMatrix[1,1] * Y + FMatrix[2,1]; 1065 end 1066 else 1235 Z := FMatrix[0, 2] * SrcX + FMatrix[1, 2] * SrcY + FMatrix[2, 2]; 1236 1237 if Z = 0 then Exit; 1238 1239 {$IFDEF UseInlining} 1240 DstX := SrcX * Matrix[0, 0] + SrcY * Matrix[1, 0] + Matrix[2, 0]; 1241 DstY := SrcX * Matrix[0, 1] + SrcY * Matrix[1, 1] + Matrix[2, 1]; 1242 {$ELSE} 1243 inherited; 1244 {$ENDIF} 1245 1246 if Z <> 1 then 1067 1247 begin 1068 1248 Z := 1 / Z; 1069 DstX := (FMatrix[0,0] * X + FMatrix[1,0] * Y + FMatrix[2,0]) * Z; 1070 DstY := (FMatrix[0,1] * X + FMatrix[1,1] * Y + FMatrix[2,1]) * Z; 1071 end; 1072 end; 1249 DstX := DstX * Z; 1250 DstY := DstY * Z; 1251 end; 1252 end; 1253 1073 1254 1074 1255 { TTwirlTransformation } … … 1148 1329 GR32_Math.SinCos(FPiH * DstY, SinY, CosY); 1149 1330 GR32_Math.SinCos(FPiW * DstX, SinX, CosX); 1331 t := FBP * SinY * SinX; 1332 SrcX := DstX + t * CosX; 1333 SrcY := DstY + t * CosY; 1334 end; 1335 1336 procedure TBloatTransformation.TransformFloat(DstX, DstY: TFloat; 1337 out SrcX, SrcY: TFloat); 1338 var 1339 SinY, CosY, SinX, CosX, t: Single; 1340 begin 1341 GR32_Math.SinCos(-FPiH * DstY, SinY, CosY); 1342 GR32_Math.SinCos(-FPiW * DstX, SinX, CosX); 1150 1343 t := FBP * SinY * SinX; 1151 1344 SrcX := DstX + t * CosX; … … 1580 1773 MapPtr: PFixedPointArray; 1581 1774 begin 1582 IntersectRect(DstRect, VectorMap.BoundsRect, DstRect);1583 if IsRectEmpty(DstRect) then Exit;1775 GR32.IntersectRect(DstRect, VectorMap.BoundsRect, DstRect); 1776 if GR32.IsRectEmpty(DstRect) then Exit; 1584 1777 1585 1778 if not TTransformationAccess(Transformation).TransformValid then -
GraphicTest/Packages/Graphics32/GR32_VectorMaps.pas
r450 r522 118 118 119 119 uses 120 GR32_Lowlevel, GR32_ Blend, GR32_Transforms, GR32_Math, SysUtils;120 GR32_Lowlevel, GR32_Math, SysUtils; 121 121 122 122 resourcestring … … 249 249 {$IFDEF HAS_NATIVEINT} 250 250 Result := CombineVectorsReg(CombineVectorsReg(PFixedPoint(P)^, 251 PFixedPoint(NativeUInt(P) + H)^, WX), CombineVectorsReg(252 PFixedPoint(NativeUInt(P) + W)^, PFixedPoint(NativeUInt(P) + W + H)^, WX),253 WY);251 PFixedPoint(NativeUInt(P) + NativeUInt(H))^, WX), CombineVectorsReg( 252 PFixedPoint(NativeUInt(P) + NativeUInt(W))^, 253 PFixedPoint(NativeUInt(P) + NativeUInt(W + H))^, WX), WY); 254 254 {$ELSE} 255 255 Result := CombineVectorsReg(CombineVectorsReg(PFixedPoint(P)^, 256 PFixedPoint(Cardinal(P) + H)^, WX), CombineVectorsReg(257 PFixedPoint(Cardinal(P) + W)^, PFixedPoint(Cardinal(P) + W + H)^, WX),258 WY);256 PFixedPoint(Cardinal(P) + Cardinal(H))^, WX), CombineVectorsReg( 257 PFixedPoint(Cardinal(P) + Cardinal(W))^, 258 PFixedPoint(Cardinal(P) + Cardinal(W) + Cardinal(H))^, WX), WY); 259 259 {$ENDIF} 260 260 end else … … 322 322 Reset(MeshFile, 1); 323 323 BlockRead(MeshFile, Header, SizeOf(TPSLiquifyMeshHeader)); 324 if Lower case(String(Header.Ident)) <> Lowercase(MeshIdent) then324 if LowerCase(string(Header.Ident)) <> LowerCase(MeshIdent) then 325 325 Exception.Create(RCStrBadFormat); 326 326 with Header do … … 433 433 var 434 434 I: Integer; 435 {$IFDEF COMPILERRX1} 436 f: single; 437 {$ENDIF} 435 438 begin 436 439 for I := 0 to Length(FVectors) - 1 do … … 438 441 //Not a mistake! Converting physical mem. directly to avoid temporary floating point buffer 439 442 //Do no change to PFloat.. the type is relative to the msh format. 443 444 //Workaround for Delphi 10.1 Internal Error C6949 ... 445 {$IFDEF COMPILERRX1} 446 f := FVectors[I].X * FixedToFloat; 447 FVectors[I].X := PInteger(@f)^; 448 f := FVectors[I].Y * FixedToFloat; 449 FVectors[I].Y := PInteger(@f)^; 450 {$ELSE} 440 451 PSingle(@FVectors[I].X)^ := FVectors[I].X * FixedToFloat; 441 452 PSingle(@FVectors[I].Y)^ := FVectors[I].Y * FixedToFloat; 453 {$ENDIF} 442 454 end; 443 455 end; … … 589 601 Inc(VectorPtr); 590 602 Inc(Top); 591 until Top = Width *Height;592 593 TopDone: Top := Top div Width;603 until Top = Self.Width * Self.Height; 604 605 TopDone: Top := Top div Self.Width; 594 606 595 607 //Find Bottom 596 Bottom := Width *Height - 1;608 Bottom := Self.Width * Self.Height - 1; 597 609 VectorPtr := @Vectors[Bottom]; 598 610 repeat … … 602 614 until Bottom < 0; 603 615 604 BottomDone: Bottom := Bottom div Width - 1;616 BottomDone: Bottom := Bottom div Self.Width - 1; 605 617 606 618 //Find Left … … 613 625 until J >= Bottom; 614 626 Inc(Left) 615 until Left >= Width;627 until Left >= Self.Width; 616 628 617 629 LeftDone: 618 630 619 631 //Find Right 620 Right := Width - 1;632 Right := Self.Width - 1; 621 633 repeat 622 634 J := Bottom; … … 628 640 until Right <= Left; 629 641 630 631 642 end; 632 643 RightDone: 633 644 if IsRectEmpty(Result) then 634 Result := Rect(0, 0,0,0);645 Result := Rect(0, 0, 0, 0); 635 646 end; 636 647 -
GraphicTest/Packages/Graphics32/GR32_XPThemes.pas
r450 r522 229 229 constructor TThemeNexus.Create; 230 230 begin 231 FWindowHandle := Classes.AllocateHWnd(WndProc);231 FWindowHandle := {$IFDEF FPC}Classes.{$ENDIF}AllocateHWnd(WndProc); 232 232 OpenVisualStyles; 233 233 end; … … 236 236 begin 237 237 CloseVisualStyles; 238 Classes.DeallocateHWnd(FWindowHandle);238 {$IFDEF FPC}Classes.{$ENDIF}DeallocateHWnd(FWindowHandle); 239 239 inherited; 240 240 end; -
GraphicTest/Packages/Graphics32/Packages/GR32_D2005.dpk
r450 r522 40 40 GR32_OrdinalMaps in '..\GR32_OrdinalMaps.pas', 41 41 GR32_VectorMaps in '..\GR32_VectorMaps.pas', 42 GR32_DrawingEx in '..\GR32_DrawingEx.pas',43 42 GR32_Filters in '..\GR32_Filters.pas', 44 43 GR32_Layers in '..\GR32_Layers.pas', -
GraphicTest/Packages/Graphics32/Packages/GR32_D7.dpk
r450 r522 24 24 {$IMAGEBASE $400000} 25 25 {$DESCRIPTION 'Graphics32'} 26 {$RUNONLY} 26 27 {$IMPLICITBUILD ON} 27 28 … … 41 42 GR32_OrdinalMaps in '..\GR32_OrdinalMaps.pas', 42 43 GR32_VectorMaps in '..\GR32_VectorMaps.pas', 43 GR32_DrawingEx in '..\GR32_DrawingEx.pas',44 44 GR32_Filters in '..\GR32_Filters.pas', 45 45 GR32_Layers in '..\GR32_Layers.pas', … … 55 55 GR32_Backends_Generic in '..\GR32_Backends_Generic.pas', 56 56 GR32_Backends_VCL in '..\GR32_Backends_VCL.pas', 57 GR32_XPThemes in '..\GR32_XPThemes.pas'; 57 GR32_XPThemes in '..\GR32_XPThemes.pas', 58 GR32_VPR in '..\GR32_VPR.pas', 59 GR32_Paths in '..\GR32_Paths.pas', 60 GR32_VectorUtils in '..\GR32_VectorUtils.pas', 61 GR32_Geometry in '..\GR32_Geometry.pas', 62 GR32_Text_VCL in '..\GR32_Text_VCL.pas', 63 GR32_Brushes in '..\GR32_Brushes.pas'; 58 64 59 65 end. -
GraphicTest/Packages/Graphics32/Packages/GR32_DSGN_D5.dpk
r450 r522 1 1 package GR32_DSGN_D5; 2 2 3 4 5 3 {$R *.RES} 6 7 4 {$R '..\GR32_Reg.dcr'} 8 9 5 {$ALIGN ON} 10 6 {$ASSERTIONS ON} -
GraphicTest/Packages/Graphics32/Packages/GR32_DSGN_D6.dpk
r450 r522 1 1 package GR32_DSGN_D6; 2 2 3 4 5 3 {$R *.res} 6 7 4 {$R '..\GR32_Reg.dcr'} 8 9 5 {$ALIGN 8} 10 11 6 {$ASSERTIONS ON} 12 13 7 {$BOOLEVAL OFF} 14 15 8 {$DEBUGINFO ON} 16 17 9 {$EXTENDEDSYNTAX ON} 18 19 10 {$IMPORTEDDATA ON} 20 21 11 {$IOCHECKS ON} 22 23 12 {$LOCALSYMBOLS ON} 24 25 13 {$LONGSTRINGS ON} 26 27 14 {$OPENSTRINGS ON} 28 29 15 {$OPTIMIZATION ON} 30 31 16 {$OVERFLOWCHECKS OFF} 32 33 17 {$RANGECHECKS OFF} 34 35 18 {$REFERENCEINFO ON} 36 37 19 {$SAFEDIVIDE OFF} 38 39 20 {$STACKFRAMES OFF} 40 41 21 {$TYPEDADDRESS OFF} 42 43 22 {$VARSTRINGCHECKS ON} 44 45 23 {$WRITEABLECONST OFF} 46 47 24 {$MINENUMSIZE 1} 48 49 25 {$IMAGEBASE $400000} 50 51 26 {$DESCRIPTION 'Graphics32 Design Time Package'} 52 53 27 {$IMPLICITBUILD ON} 54 28 55 56 57 29 requires 58 59 30 designide, 60 61 31 vcl, 62 63 32 GR32_D6, 64 65 33 rtl; 66 67 68 34 69 35 contains … … 73 39 GR32_Dsgn_Misc in '..\GR32_Dsgn_Misc.pas'; 74 40 75 76 77 78 41 end. 79 42 -
GraphicTest/Packages/Graphics32/Packages/GR32_DSGN_D7.dpk
r450 r522 37 37 GR32_Reg in '..\GR32_Reg.pas', 38 38 GR32_Dsgn_Color in '..\GR32_Dsgn_Color.pas', 39 GR32_Dsgn_Misc in '..\GR32_Dsgn_Misc.pas'; 39 GR32_Dsgn_Misc in '..\GR32_Dsgn_Misc.pas', 40 GR32_ColorGradients in '..\GR32_ColorGradients.pas', 41 GR32_ColorPicker in '..\GR32_ColorPicker.pas', 42 GR32_ColorSwatch in '..\GR32_ColorSwatch.pas'; 40 43 41 44 end. -
GraphicTest/Packages/Graphics32/Packages/GR32_DSGN_RS2007.dpk
r450 r522 26 26 {$DESCRIPTION 'Graphics32 Design Time Package'} 27 27 {$DESIGNONLY} 28 {$IMPLICITBUILD O FF}28 {$IMPLICITBUILD ON} 29 29 30 30 requires -
GraphicTest/Packages/Graphics32/Packages/GR32_L.pas
r450 r522 3 3 } 4 4 5 unit GR32_L; 5 unit GR32_L; 6 6 7 {$warn 5023 off : no warning about unused units} 7 8 interface 8 9 9 10 uses 10 GR32, GR32_Math, GR32_LowLevel, GR32_System, GR32_Containers, GR32_Blend, 11 GR32, GR32_Math, GR32_LowLevel, GR32_System, GR32_Containers, GR32_Blend, 11 12 GR32_Transforms, GR32_OrdinalMaps, GR32_VectorMaps, GR32_DrawingEx, 12 13 GR32_Filters, GR32_Layers, GR32_Image, GR32_ExtImage, GR32_RangeBars, -
GraphicTest/Packages/Graphics32/Packages/GR32_RS2006.dpk
r450 r522 31 31 32 32 contains 33 GR32 in '..\GR32.pas', 34 GR32_Bindings in '..\GR32_Bindings.pas', 35 GR32_Math in '..\GR32_Math.pas', 36 GR32_LowLevel in '..\GR32_LowLevel.pas', 37 GR32_System in '..\GR32_System.pas', 38 GR32_Containers in '..\GR32_Containers.pas', 39 GR32_Blend in '..\GR32_Blend.pas', 40 GR32_Transforms in '..\GR32_Transforms.pas', 41 GR32_OrdinalMaps in '..\GR32_OrdinalMaps.pas', 42 GR32_VectorMaps in '..\GR32_VectorMaps.pas', 43 GR32_DrawingEx in '..\GR32_DrawingEx.pas', 44 GR32_Filters in '..\GR32_Filters.pas', 45 GR32_Layers in '..\GR32_Layers.pas', 46 GR32_Image in '..\GR32_Image.pas', 47 GR32_ExtImage in '..\GR32_ExtImage.pas', 48 GR32_RangeBars in '..\GR32_RangeBars.pas', 49 GR32_Polygons in '..\GR32_Polygons.pas', 50 GR32_RepaintOpt in '..\GR32_RepaintOpt.pas', 51 GR32_MicroTiles in '..\GR32_MicroTiles.pas', 52 GR32_Rasterizers in '..\GR32_Rasterizers.pas', 53 GR32_Resamplers in '..\GR32_Resamplers.pas', 54 GR32_Backends in '..\GR32_Backends.pas', 55 GR32_Backends_Generic in '..\GR32_Backends_Generic.pas', 56 GR32_Backends_VCL in '..\GR32_Backends_VCL.pas', 57 GR32_XPThemes in '..\GR32_XPThemes.pas'; 33 GR32 in '..\..\GR32.pas', 34 GR32_Backends in '..\..\GR32_Backends.pas', 35 GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', 36 GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', 37 GR32_Bindings in '..\..\GR32_Bindings.pas', 38 GR32_Blend in '..\..\GR32_Blend.pas', 39 GR32_BlendASM in '..\..\GR32_BlendASM.pas', 40 GR32_BlendMMX in '..\..\GR32_BlendMMX.pas', 41 GR32_BlendSSE2 in '..\..\GR32_BlendSSE2.pas', 42 GR32_Brushes in '..\..\GR32_Brushes.pas', 43 GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', 44 GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', 45 GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', 46 GR32_Containers in '..\..\GR32_Containers.pas', 47 GR32_ExtImage in '..\..\GR32_ExtImage.pas', 48 GR32_Filters in '..\..\GR32_Filters.pas', 49 GR32_Gamma in '..\..\GR32_Gamma.pas', 50 GR32_Geometry in '..\..\GR32_Geometry.pas', 51 GR32_Image in '..\..\GR32_Image.pas', 52 GR32_Layers in '..\..\GR32_Layers.pas', 53 GR32_LowLevel in '..\..\GR32_LowLevel.pas', 54 GR32_Math in '..\..\GR32_Math.pas', 55 GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', 56 GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', 57 GR32_Paths in '..\..\GR32_Paths.pas', 58 GR32_Polygons in '..\..\GR32_Polygons.pas', 59 GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', 60 GR32_RangeBars in '..\..\GR32_RangeBars.pas', 61 GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', 62 GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', 63 GR32_Resamplers in '..\..\GR32_Resamplers.pas', 64 GR32_System in '..\..\GR32_System.pas', 65 GR32_Transforms in '..\..\GR32_Transforms.pas', 66 GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', 67 GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', 68 GR32_VPR in '..\..\GR32_VPR.pas', 69 GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', 70 GR32_XPThemes in '..\..\GR32_XPThemes.pas'; 58 71 59 72 end. -
GraphicTest/Packages/Graphics32/Packages/GR32_RS2007.dpk
r450 r522 25 25 {$DESCRIPTION 'Graphics32'} 26 26 {$RUNONLY} 27 {$IMPLICITBUILD O FF}27 {$IMPLICITBUILD ON} 28 28 29 29 requires … … 31 31 32 32 contains 33 GR32 in '..\GR32.pas', 34 GR32_Bindings in '..\GR32_Bindings.pas', 35 GR32_Math in '..\GR32_Math.pas', 36 GR32_Backends in '..\GR32_Backends.pas', 37 GR32_Backends_Generic in '..\GR32_Backends_Generic.pas', 38 GR32_Backends_VCL in '..\GR32_Backends_VCL.pas', 39 GR32_LowLevel in '..\GR32_LowLevel.pas', 40 GR32_System in '..\GR32_System.pas', 41 GR32_Containers in '..\GR32_Containers.pas', 42 GR32_Blend in '..\GR32_Blend.pas', 43 GR32_Transforms in '..\GR32_Transforms.pas', 44 GR32_OrdinalMaps in '..\GR32_OrdinalMaps.pas', 45 GR32_VectorMaps in '..\GR32_VectorMaps.pas', 46 GR32_DrawingEx in '..\GR32_DrawingEx.pas', 47 GR32_Filters in '..\GR32_Filters.pas', 48 GR32_Layers in '..\GR32_Layers.pas', 49 GR32_Image in '..\GR32_Image.pas', 50 GR32_ExtImage in '..\GR32_ExtImage.pas', 51 GR32_RangeBars in '..\GR32_RangeBars.pas', 52 GR32_Polygons in '..\GR32_Polygons.pas', 53 GR32_RepaintOpt in '..\GR32_RepaintOpt.pas', 54 GR32_MicroTiles in '..\GR32_MicroTiles.pas', 55 GR32_Rasterizers in '..\GR32_Rasterizers.pas', 56 GR32_Resamplers in '..\GR32_Resamplers.pas', 57 GR32_XPThemes in '..\GR32_XPThemes.pas'; 33 GR32 in '..\..\GR32.pas', 34 GR32_Backends in '..\..\GR32_Backends.pas', 35 GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', 36 GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', 37 GR32_Bindings in '..\..\GR32_Bindings.pas', 38 GR32_Blend in '..\..\GR32_Blend.pas', 39 GR32_BlendASM in '..\..\GR32_BlendASM.pas', 40 GR32_BlendMMX in '..\..\GR32_BlendMMX.pas', 41 GR32_BlendSSE2 in '..\..\GR32_BlendSSE2.pas', 42 GR32_Brushes in '..\..\GR32_Brushes.pas', 43 GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', 44 GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', 45 GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', 46 GR32_Containers in '..\..\GR32_Containers.pas', 47 GR32_ExtImage in '..\..\GR32_ExtImage.pas', 48 GR32_Filters in '..\..\GR32_Filters.pas', 49 GR32_Gamma in '..\..\GR32_Gamma.pas', 50 GR32_Geometry in '..\..\GR32_Geometry.pas', 51 GR32_Image in '..\..\GR32_Image.pas', 52 GR32_Layers in '..\..\GR32_Layers.pas', 53 GR32_LowLevel in '..\..\GR32_LowLevel.pas', 54 GR32_Math in '..\..\GR32_Math.pas', 55 GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', 56 GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', 57 GR32_Paths in '..\..\GR32_Paths.pas', 58 GR32_Polygons in '..\..\GR32_Polygons.pas', 59 GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', 60 GR32_RangeBars in '..\..\GR32_RangeBars.pas', 61 GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', 62 GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', 63 GR32_Resamplers in '..\..\GR32_Resamplers.pas', 64 GR32_System in '..\..\GR32_System.pas', 65 GR32_Transforms in '..\..\GR32_Transforms.pas', 66 GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', 67 GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', 68 GR32_VPR in '..\..\GR32_VPR.pas', 69 GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', 70 GR32_XPThemes in '..\..\GR32_XPThemes.pas'; 58 71 59 72 end. -
GraphicTest/Packages/Graphics32/Packages/GR32_RS2009.dpk
r450 r522 25 25 {$DESCRIPTION 'Graphics32'} 26 26 {$RUNONLY} 27 {$IMPLICITBUILD O FF}27 {$IMPLICITBUILD ON} 28 28 29 29 requires … … 31 31 32 32 contains 33 GR32 in '..\GR32.pas', 34 GR32_Bindings in '..\GR32_Bindings.pas', 35 GR32_Math in '..\GR32_Math.pas', 36 GR32_Backends in '..\GR32_Backends.pas', 37 GR32_Backends_Generic in '..\GR32_Backends_Generic.pas', 38 GR32_Backends_VCL in '..\GR32_Backends_VCL.pas', 39 GR32_LowLevel in '..\GR32_LowLevel.pas', 40 GR32_System in '..\GR32_System.pas', 41 GR32_Containers in '..\GR32_Containers.pas', 42 GR32_Blend in '..\GR32_Blend.pas', 43 GR32_Transforms in '..\GR32_Transforms.pas', 44 GR32_OrdinalMaps in '..\GR32_OrdinalMaps.pas', 45 GR32_VectorMaps in '..\GR32_VectorMaps.pas', 46 GR32_DrawingEx in '..\GR32_DrawingEx.pas', 47 GR32_Filters in '..\GR32_Filters.pas', 48 GR32_Layers in '..\GR32_Layers.pas', 49 GR32_Image in '..\GR32_Image.pas', 50 GR32_ExtImage in '..\GR32_ExtImage.pas', 51 GR32_RangeBars in '..\GR32_RangeBars.pas', 52 GR32_Polygons in '..\GR32_Polygons.pas', 53 GR32_RepaintOpt in '..\GR32_RepaintOpt.pas', 54 GR32_MicroTiles in '..\GR32_MicroTiles.pas', 55 GR32_Rasterizers in '..\GR32_Rasterizers.pas', 56 GR32_Resamplers in '..\GR32_Resamplers.pas', 57 GR32_XPThemes in '..\GR32_XPThemes.pas'; 33 GR32 in '..\..\GR32.pas', 34 GR32_Backends in '..\..\GR32_Backends.pas', 35 GR32_Backends_Generic in '..\..\GR32_Backends_Generic.pas', 36 GR32_Backends_VCL in '..\..\GR32_Backends_VCL.pas', 37 GR32_Bindings in '..\..\GR32_Bindings.pas', 38 GR32_Blend in '..\..\GR32_Blend.pas', 39 GR32_BlendASM in '..\..\GR32_BlendASM.pas', 40 GR32_BlendMMX in '..\..\GR32_BlendMMX.pas', 41 GR32_BlendSSE2 in '..\..\GR32_BlendSSE2.pas', 42 GR32_Brushes in '..\..\GR32_Brushes.pas', 43 GR32_ColorGradients in '..\..\GR32_ColorGradients.pas', 44 GR32_ColorPicker in '..\..\GR32_ColorPicker.pas', 45 GR32_ColorSwatch in '..\..\GR32_ColorSwatch.pas', 46 GR32_Containers in '..\..\GR32_Containers.pas', 47 GR32_ExtImage in '..\..\GR32_ExtImage.pas', 48 GR32_Filters in '..\..\GR32_Filters.pas', 49 GR32_Gamma in '..\..\GR32_Gamma.pas', 50 GR32_Geometry in '..\..\GR32_Geometry.pas', 51 GR32_Image in '..\..\GR32_Image.pas', 52 GR32_Layers in '..\..\GR32_Layers.pas', 53 GR32_LowLevel in '..\..\GR32_LowLevel.pas', 54 GR32_Math in '..\..\GR32_Math.pas', 55 GR32_MicroTiles in '..\..\GR32_MicroTiles.pas', 56 GR32_OrdinalMaps in '..\..\GR32_OrdinalMaps.pas', 57 GR32_Paths in '..\..\GR32_Paths.pas', 58 GR32_Polygons in '..\..\GR32_Polygons.pas', 59 GR32_PolygonsAggLite in '..\..\GR32_PolygonsAggLite.pas', 60 GR32_RangeBars in '..\..\GR32_RangeBars.pas', 61 GR32_Rasterizers in '..\..\GR32_Rasterizers.pas', 62 GR32_RepaintOpt in '..\..\GR32_RepaintOpt.pas', 63 GR32_Resamplers in '..\..\GR32_Resamplers.pas', 64 GR32_System in '..\..\GR32_System.pas', 65 GR32_Transforms in '..\..\GR32_Transforms.pas', 66 GR32_VectorMaps in '..\..\GR32_VectorMaps.pas', 67 GR32_VectorUtils in '..\..\GR32_VectorUtils.pas', 68 GR32_VPR in '..\..\GR32_VPR.pas', 69 GR32_Text_VCL in '..\..\GR32_Text_VCL.pas', 70 GR32_XPThemes in '..\..\GR32_XPThemes.pas'; 58 71 59 72 end.
Note:
See TracChangeset
for help on using the changeset viewer.