source: trunk/Packages/Graphics32/GR32_Resamplers.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 120.4 KB
Line 
1unit GR32_Resamplers;
2
3(* ***** BEGIN LICENSE BLOCK *****
4 * Version: MPL 1.1 or LGPL 2.1 with linking exception
5 *
6 * The contents of this file are subject to the Mozilla Public License Version
7 * 1.1 (the "License"); you may not use this file except in compliance with
8 * the License. You may obtain a copy of the License at
9 * http://www.mozilla.org/MPL/
10 *
11 * Software distributed under the License is distributed on an "AS IS" basis,
12 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13 * for the specific language governing rights and limitations under the
14 * License.
15 *
16 * Alternatively, the contents of this file may be used under the terms of the
17 * Free Pascal modified version of the GNU Lesser General Public License
18 * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions
19 * of this license are applicable instead of those above.
20 * Please see the file LICENSE.txt for additional information concerning this
21 * license.
22 *
23 * The Original Code is Graphics32
24 *
25 * The Initial Developers of the Original Code is
26 * Mattias Andersson <mattias@centaurix.com>
27 * (parts of this unit were taken from GR32_Transforms.pas by Alex A. Denisov)
28 *
29 * Portions created by the Initial Developer are Copyright (C) 2000-2009
30 * the Initial Developer. All Rights Reserved.
31 *
32 * Contributor(s):
33 * Michael Hansen <dyster_tid@hotmail.com>
34 *
35 * ***** END LICENSE BLOCK ***** *)
36
37interface
38
39{$I GR32.inc}
40
41{$IFNDEF FPC}
42{-$IFDEF USE_3DNOW}
43{$ENDIF}
44
45uses
46{$IFDEF FPC}
47 LCLIntf,
48{$ELSE}
49 Windows, Types,
50{$ENDIF}
51 Classes, SysUtils, GR32, GR32_Transforms, GR32_Containers,
52 GR32_OrdinalMaps, GR32_Blend;
53
54procedure BlockTransfer(
55 Dst: TCustomBitmap32; DstX: Integer; DstY: Integer; DstClip: TRect;
56 Src: TCustomBitmap32; SrcRect: TRect;
57 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent = nil);
58
59procedure BlockTransferX(
60 Dst: TCustomBitmap32; DstX, DstY: TFixed;
61 Src: TCustomBitmap32; SrcRect: TRect;
62 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent = nil);
63
64procedure StretchTransfer(
65 Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
66 Src: TCustomBitmap32; SrcRect: TRect;
67 Resampler: TCustomResampler;
68 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent = nil);
69
70procedure BlendTransfer(
71 Dst: TCustomBitmap32; DstX, DstY: Integer; DstClip: TRect;
72 SrcF: TCustomBitmap32; SrcRectF: TRect;
73 SrcB: TCustomBitmap32; SrcRectB: TRect;
74 BlendCallback: TBlendReg); overload;
75
76procedure BlendTransfer(
77 Dst: TCustomBitmap32; DstX, DstY: Integer; DstClip: TRect;
78 SrcF: TCustomBitmap32; SrcRectF: TRect;
79 SrcB: TCustomBitmap32; SrcRectB: TRect;
80 BlendCallback: TBlendRegEx; MasterAlpha: Integer); overload;
81
82const
83 MAX_KERNEL_WIDTH = 16;
84
85type
86 PKernelEntry = ^TKernelEntry;
87 TKernelEntry = array [-MAX_KERNEL_WIDTH..MAX_KERNEL_WIDTH] of Integer;
88
89 TArrayOfKernelEntry = array of TArrayOfInteger;
90 PKernelEntryArray = ^TKernelEntryArray;
91 TKernelEntryArray = array [0..0] of TArrayOfInteger;
92
93 TFilterMethod = function(Value: TFloat): TFloat of object;
94
95 EBitmapException = class(Exception);
96 ESrcInvalidException = class(Exception);
97 ENestedException = class(Exception);
98
99 TGetSampleInt = function(X, Y: Integer): TColor32 of object;
100 TGetSampleFloat = function(X, Y: TFloat): TColor32 of object;
101 TGetSampleFixed = function(X, Y: TFixed): TColor32 of object;
102
103 { TCustomKernel }
104 TCustomKernel = class(TPersistent)
105 protected
106 FObserver: TNotifiablePersistent;
107 protected
108 procedure AssignTo(Dst: TPersistent); override;
109 function RangeCheck: Boolean; virtual;
110 public
111 constructor Create; virtual;
112 procedure Changed;
113 function Filter(Value: TFloat): TFloat; virtual; abstract;
114 function GetWidth: TFloat; virtual; abstract;
115 property Observer: TNotifiablePersistent read FObserver;
116 end;
117 TCustomKernelClass = class of TCustomKernel;
118
119 { TBoxKernel }
120 TBoxKernel = class(TCustomKernel)
121 public
122 function Filter(Value: TFloat): TFloat; override;
123 function GetWidth: TFloat; override;
124 end;
125
126 { TLinearKernel }
127 TLinearKernel = class(TCustomKernel)
128 public
129 function Filter(Value: TFloat): TFloat; override;
130 function GetWidth: TFloat; override;
131 end;
132
133 { TCosineKernel }
134 TCosineKernel = class(TCustomKernel)
135 public
136 function Filter(Value: TFloat): TFloat; override;
137 function GetWidth: TFloat; override;
138 end;
139
140 { TSplineKernel }
141 TSplineKernel = class(TCustomKernel)
142 protected
143 function RangeCheck: Boolean; override;
144 public
145 function Filter(Value: TFloat): TFloat; override;
146 function GetWidth: TFloat; override;
147 end;
148
149 { TMitchellKernel }
150 TMitchellKernel = class(TCustomKernel)
151 protected
152 function RangeCheck: Boolean; override;
153 public
154 function Filter(Value: TFloat): TFloat; override;
155 function GetWidth: TFloat; override;
156 end;
157
158 { TCubicKernel }
159 TCubicKernel = class(TCustomKernel)
160 private
161 FCoeff: TFloat;
162 procedure SetCoeff(const Value: TFloat);
163 protected
164 function RangeCheck: Boolean; override;
165 public
166 constructor Create; override;
167 function Filter(Value: TFloat): TFloat; override;
168 function GetWidth: TFloat; override;
169 published
170 property Coeff: TFloat read FCoeff write SetCoeff;
171 end;
172
173 { THermiteKernel }
174 THermiteKernel = class(TCustomKernel)
175 private
176 FBias: TFloat;
177 FTension: TFloat;
178 procedure SetBias(const Value: TFloat);
179 procedure SetTension(const Value: TFloat);
180 protected
181 function RangeCheck: Boolean; override;
182 public
183 constructor Create; override;
184 function Filter(Value: TFloat): TFloat; override;
185 function GetWidth: TFloat; override;
186 published
187 property Bias: TFloat read FBias write SetBias;
188 property Tension: TFloat read FTension write SetTension;
189 end;
190
191 { TWindowedSincKernel }
192 TWindowedSincKernel = class(TCustomKernel)
193 private
194 FWidth : TFloat;
195 FWidthReciprocal : TFloat;
196 protected
197 function RangeCheck: Boolean; override;
198 function Window(Value: TFloat): TFloat; virtual; abstract;
199 public
200 constructor Create; override;
201 function Filter(Value: TFloat): TFloat; override;
202 procedure SetWidth(Value: TFloat);
203 function GetWidth: TFloat; override;
204 property WidthReciprocal : TFloat read FWidthReciprocal;
205 published
206 property Width: TFloat read FWidth write SetWidth;
207 end;
208
209 { TAlbrecht-Kernel }
210 TAlbrechtKernel = class(TWindowedSincKernel)
211 private
212 FTerms: Integer;
213 FCoefPointer : Array [0..11] of Double;
214 procedure SetTerms(Value : Integer);
215 protected
216 function Window(Value: TFloat): TFloat; override;
217 public
218 constructor Create; override;
219 published
220 property Terms: Integer read FTerms write SetTerms;
221 end;
222
223 { TLanczosKernel }
224 TLanczosKernel = class(TWindowedSincKernel)
225 protected
226 function Window(Value: TFloat): TFloat; override;
227 public
228 end;
229
230 { TGaussianKernel }
231 TGaussianKernel = class(TWindowedSincKernel)
232 private
233 FSigma: TFloat;
234 FSigmaReciprocalLn2: TFloat;
235 procedure SetSigma(const Value: TFloat);
236 protected
237 function Window(Value: TFloat): TFloat; override;
238 public
239 constructor Create; override;
240 published
241 property Sigma: TFloat read FSigma write SetSigma;
242 end;
243
244 { TBlackmanKernel }
245 TBlackmanKernel = class(TWindowedSincKernel)
246 protected
247 function Window(Value: TFloat): TFloat; override;
248 end;
249
250 { THannKernel }
251 THannKernel = class(TWindowedSincKernel)
252 protected
253 function Window(Value: TFloat): TFloat; override;
254 end;
255
256 { THammingKernel }
257 THammingKernel = class(TWindowedSincKernel)
258 protected
259 function Window(Value: TFloat): TFloat; override;
260 end;
261
262 { TSinshKernel }
263 TSinshKernel = class(TCustomKernel)
264 private
265 FWidth: TFloat;
266 FCoeff: TFloat;
267 procedure SetCoeff(const Value: TFloat);
268 protected
269 function RangeCheck: Boolean; override;
270 public
271 constructor Create; override;
272 procedure SetWidth(Value: TFloat);
273 function GetWidth: TFloat; override;
274 function Filter(Value: TFloat): TFloat; override;
275 published
276 property Coeff: TFloat read FCoeff write SetCoeff;
277 property Width: TFloat read GetWidth write SetWidth;
278 end;
279
280
281 { TNearestResampler }
282 TNearestResampler = class(TCustomResampler)
283 private
284 FGetSampleInt: TGetSampleInt;
285 protected
286 function GetPixelTransparentEdge(X, Y: Integer): TColor32;
287 function GetWidth: TFloat; override;
288 procedure Resample(
289 Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
290 Src: TCustomBitmap32; SrcRect: TRect;
291 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); override;
292 public
293 function GetSampleInt(X, Y: Integer): TColor32; override;
294 function GetSampleFixed(X, Y: TFixed): TColor32; override;
295 function GetSampleFloat(X, Y: TFloat): TColor32; override;
296 procedure PrepareSampling; override;
297 end;
298
299 { TLinearResampler }
300 TLinearResampler = class(TCustomResampler)
301 private
302 FLinearKernel: TLinearKernel;
303 FGetSampleFixed: TGetSampleFixed;
304 protected
305 function GetWidth: TFloat; override;
306 function GetPixelTransparentEdge(X, Y: TFixed): TColor32;
307 procedure Resample(
308 Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
309 Src: TCustomBitmap32; SrcRect: TRect;
310 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); override;
311 public
312 constructor Create; override;
313 destructor Destroy; override;
314 function GetSampleFixed(X, Y: TFixed): TColor32; override;
315 function GetSampleFloat(X, Y: TFloat): TColor32; override;
316 procedure PrepareSampling; override;
317 end;
318
319 { TDraftResampler }
320 TDraftResampler = class(TLinearResampler)
321 protected
322 procedure Resample(
323 Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
324 Src: TCustomBitmap32; SrcRect: TRect;
325 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); override;
326 end;
327
328 { TKernelResampler }
329 { This resampler class will perform resampling by using an arbitrary
330 reconstruction kernel. By using the kmTableNearest and kmTableLinear
331 kernel modes, kernel values are precomputed in a look-up table. This
332 allows GetSample to execute faster for complex kernels. }
333
334 TKernelMode = (kmDynamic, kmTableNearest, kmTableLinear);
335
336 TKernelResampler = class(TCustomResampler)
337 private
338 FKernel: TCustomKernel;
339 FKernelMode: TKernelMode;
340 FWeightTable: TIntegerMap;
341 FTableSize: Integer;
342 FOuterColor: TColor32;
343 procedure SetKernel(const Value: TCustomKernel);
344 function GetKernelClassName: string;
345 procedure SetKernelClassName(const Value: string);
346 procedure SetKernelMode(const Value: TKernelMode);
347 procedure SetTableSize(Value: Integer);
348 protected
349 function GetWidth: TFloat; override;
350 public
351 constructor Create; override;
352 destructor Destroy; override;
353 function GetSampleFloat(X, Y: TFloat): TColor32; override;
354 procedure Resample(
355 Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
356 Src: TCustomBitmap32; SrcRect: TRect;
357 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent); override;
358 procedure PrepareSampling; override;
359 procedure FinalizeSampling; override;
360 published
361 property KernelClassName: string read GetKernelClassName write SetKernelClassName;
362 property Kernel: TCustomKernel read FKernel write SetKernel;
363 property KernelMode: TKernelMode read FKernelMode write SetKernelMode;
364 property TableSize: Integer read FTableSize write SetTableSize;
365 end;
366
367 { TNestedSampler }
368 TNestedSampler = class(TCustomSampler)
369 private
370 FSampler: TCustomSampler;
371 FGetSampleInt: TGetSampleInt;
372 FGetSampleFixed: TGetSampleFixed;
373 FGetSampleFloat: TGetSampleFloat;
374 procedure SetSampler(const Value: TCustomSampler);
375 protected
376 procedure AssignTo(Dst: TPersistent); override;
377 public
378 constructor Create(ASampler: TCustomSampler); reintroduce; virtual;
379 procedure PrepareSampling; override;
380 procedure FinalizeSampling; override;
381 function HasBounds: Boolean; override;
382 function GetSampleBounds: TFloatRect; override;
383 published
384 property Sampler: TCustomSampler read FSampler write SetSampler;
385 end;
386
387 { TTransformer }
388 TReverseTransformInt = procedure(DstX, DstY: Integer; out SrcX, SrcY: Integer) of object;
389 TReverseTransformFixed = procedure(DstX, DstY: TFixed; out SrcX, SrcY: TFixed) of object;
390 TReverseTransformFloat = procedure(DstX, DstY: TFloat; out SrcX, SrcY: TFloat) of object;
391
392 TTransformer = class(TNestedSampler)
393 private
394 FTransformation: TTransformation;
395 FTransformationReverseTransformInt: TReverseTransformInt;
396 FTransformationReverseTransformFixed: TReverseTransformFixed;
397 FTransformationReverseTransformFloat: TReverseTransformFloat;
398 procedure SetTransformation(const Value: TTransformation);
399 public
400 constructor Create(ASampler: TCustomSampler; ATransformation: TTransformation); reintroduce;
401 procedure PrepareSampling; override;
402 function GetSampleInt(X, Y: Integer): TColor32; override;
403 function GetSampleFixed(X, Y: TFixed): TColor32; override;
404 function GetSampleFloat(X, Y: TFloat): TColor32; override;
405 function HasBounds: Boolean; override;
406 function GetSampleBounds: TFloatRect; override;
407 published
408 property Transformation: TTransformation read FTransformation write SetTransformation;
409 end;
410
411 { TSuperSampler }
412 TSamplingRange = 1..MaxInt;
413
414 TSuperSampler = class(TNestedSampler)
415 private
416 FSamplingY: TSamplingRange;
417 FSamplingX: TSamplingRange;
418 FDistanceX: TFixed;
419 FDistanceY: TFixed;
420 FOffsetX: TFixed;
421 FOffsetY: TFixed;
422 FScale: TFixed;
423 procedure SetSamplingX(const Value: TSamplingRange);
424 procedure SetSamplingY(const Value: TSamplingRange);
425 public
426 constructor Create(Sampler: TCustomSampler); override;
427 function GetSampleFixed(X, Y: TFixed): TColor32; override;
428 published
429 property SamplingX: TSamplingRange read FSamplingX write SetSamplingX;
430 property SamplingY: TSamplingRange read FSamplingY write SetSamplingY;
431 end;
432
433 { TAdaptiveSuperSampler }
434 TRecurseProc = function(X, Y, W: TFixed; const C1, C2: TColor32): TColor32 of object;
435
436 TAdaptiveSuperSampler = class(TNestedSampler)
437 private
438 FMinOffset: TFixed;
439 FLevel: Integer;
440 FTolerance: Integer;
441 procedure SetLevel(const Value: Integer);
442 function DoRecurse(X, Y, Offset: TFixed; const A, B, C, D, E: TColor32): TColor32;
443 function QuadrantColor(const C1, C2: TColor32; X, Y, Offset: TFixed;
444 Proc: TRecurseProc): TColor32;
445 function RecurseAC(X, Y, Offset: TFixed; const A, C: TColor32): TColor32;
446 function RecurseBD(X, Y, Offset: TFixed; const B, D: TColor32): TColor32;
447 protected
448 function CompareColors(C1, C2: TColor32): Boolean; virtual;
449 public
450 constructor Create(Sampler: TCustomSampler); override;
451 function GetSampleFixed(X, Y: TFixed): TColor32; override;
452 published
453 property Level: Integer read FLevel write SetLevel;
454 property Tolerance: Integer read FTolerance write FTolerance;
455 end;
456
457 { TPatternSampler }
458 TFloatSamplePattern = array of array of TArrayOfFloatPoint;
459 TFixedSamplePattern = array of array of TArrayOfFixedPoint;
460
461 TPatternSampler = class(TNestedSampler)
462 private
463 FPattern: TFixedSamplePattern;
464 procedure SetPattern(const Value: TFixedSamplePattern);
465 protected
466 WrapProcVert: TWrapProc;
467 public
468 destructor Destroy; override;
469 function GetSampleFixed(X, Y: TFixed): TColor32; override;
470 property Pattern: TFixedSamplePattern read FPattern write SetPattern;
471 end;
472
473 { Auxiliary record used in accumulation routines }
474 PBufferEntry = ^TBufferEntry;
475 TBufferEntry = record
476 B, G, R, A: Integer;
477 end;
478
479 { TKernelSampler }
480 TKernelSampler = class(TNestedSampler)
481 private
482 FKernel: TIntegerMap;
483 FStartEntry: TBufferEntry;
484 FCenterX: Integer;
485 FCenterY: Integer;
486 protected
487 procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
488 Weight: Integer); virtual; abstract;
489 function ConvertBuffer(var Buffer: TBufferEntry): TColor32; virtual;
490 public
491 constructor Create(ASampler: TCustomSampler); override;
492 destructor Destroy; override;
493 function GetSampleInt(X, Y: Integer): TColor32; override;
494 function GetSampleFixed(X, Y: TFixed): TColor32; override;
495 published
496 property Kernel: TIntegerMap read FKernel write FKernel;
497 property CenterX: Integer read FCenterX write FCenterX;
498 property CenterY: Integer read FCenterY write FCenterY;
499 end;
500
501 { TConvolver }
502 TConvolver = class(TKernelSampler)
503 protected
504 procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
505 Weight: Integer); override;
506 end;
507
508 { TSelectiveConvolver }
509 TSelectiveConvolver = class(TConvolver)
510 private
511 FRefColor: TColor32;
512 FDelta: Integer;
513 FWeightSum: TBufferEntry;
514 protected
515 procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
516 Weight: Integer); override;
517 function ConvertBuffer(var Buffer: TBufferEntry): TColor32; override;
518 public
519 constructor Create(ASampler: TCustomSampler); override;
520 function GetSampleInt(X, Y: Integer): TColor32; override;
521 function GetSampleFixed(X, Y: TFixed): TColor32; override;
522 published
523 property Delta: Integer read FDelta write FDelta;
524 end;
525
526 { TMorphologicalSampler }
527 TMorphologicalSampler = class(TKernelSampler)
528 protected
529 function ConvertBuffer(var Buffer: TBufferEntry): TColor32; override;
530 end;
531
532 { TDilater }
533 TDilater = class(TMorphologicalSampler)
534 protected
535 procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
536 Weight: Integer); override;
537 end;
538
539 { TEroder }
540 TEroder = class(TMorphologicalSampler)
541 protected
542 procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
543 Weight: Integer); override;
544 public
545 constructor Create(ASampler: TCustomSampler); override;
546 end;
547
548 { TExpander }
549 TExpander = class(TKernelSampler)
550 protected
551 procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
552 Weight: Integer); override;
553 end;
554
555 { TContracter }
556 TContracter = class(TExpander)
557 private
558 FMaxWeight: TColor32;
559 protected
560 procedure UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
561 Weight: Integer); override;
562 public
563 procedure PrepareSampling; override;
564 function GetSampleInt(X, Y: Integer): TColor32; override;
565 function GetSampleFixed(X, Y: TFixed): TColor32; override;
566 end;
567
568function CreateJitteredPattern(TileWidth, TileHeight, SamplesX, SamplesY: Integer): TFixedSamplePattern;
569
570{ Convolution and morphological routines }
571procedure Convolve(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);
572procedure Dilate(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);
573procedure Erode(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);
574procedure Expand(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);
575procedure Contract(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);
576
577{ Auxiliary routines for accumulating colors in a buffer }
578procedure IncBuffer(var Buffer: TBufferEntry; Color: TColor32); {$IFDEF USEINLINING} inline; {$ENDIF}
579procedure MultiplyBuffer(var Buffer: TBufferEntry; W: Integer); {$IFDEF USEINLINING} inline; {$ENDIF}
580function BufferToColor32(const Buffer: TBufferEntry; Shift: Integer): TColor32; {$IFDEF USEINLINING} inline; {$ENDIF}
581procedure ShrBuffer(var Buffer: TBufferEntry; Shift: Integer); {$IFDEF USEINLINING} inline; {$ENDIF}
582
583{ Downsample byte map }
584procedure DownsampleByteMap2x(Source, Dest: TByteMap);
585procedure DownsampleByteMap3x(Source, Dest: TByteMap);
586procedure DownsampleByteMap4x(Source, Dest: TByteMap);
587
588{ Registration routines }
589procedure RegisterResampler(ResamplerClass: TCustomResamplerClass);
590procedure RegisterKernel(KernelClass: TCustomKernelClass);
591
592var
593 KernelList: TClassList;
594 ResamplerList: TClassList;
595
596const
597 EMPTY_ENTRY: TBufferEntry = (B: 0; G: 0; R: 0; A: 0);
598
599var
600 BlockAverage: function(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32;
601 Interpolator: function(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32;
602
603resourcestring
604 SDstNil = 'Destination bitmap is nil';
605 SSrcNil = 'Source bitmap is nil';
606 SSrcInvalid = 'Source rectangle is invalid';
607 SSamplerNil = 'Nested sampler is nil';
608
609implementation
610
611uses
612 GR32_System, GR32_Bindings, GR32_LowLevel, GR32_Rasterizers, GR32_Math,
613 GR32_Gamma, Math;
614
615resourcestring
616 RCStrInvalidSrcRect = 'Invalid SrcRect';
617
618const
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
652type
653 TTransformationAccess = class(TTransformation);
654 TCustomBitmap32Access = class(TCustomBitmap32);
655 TCustomResamplerAccess = class(TCustomResampler);
656
657 PPointRec = ^TPointRec;
658 TPointRec = record
659 Pos: Integer;
660 Weight: Cardinal;
661 end;
662
663 TCluster = array of TPointRec;
664 TMappingTable = array of TCluster;
665
666 TKernelSamplerClass = class of TKernelSampler;
667
668{ Auxiliary rasterization routine for kernel-based samplers }
669procedure RasterizeKernelSampler(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap;
670 CenterX, CenterY: Integer; SamplerClass: TKernelSamplerClass);
671var
672 Sampler: TKernelSampler;
673 Rasterizer: TRasterizer;
674begin
675 Rasterizer := DefaultRasterizerClass.Create;
676 try
677 Dst.SetSizeFrom(Src);
678 Sampler := SamplerClass.Create(Src.Resampler);
679 Sampler.Kernel := Kernel;
680 try
681 Rasterizer.Sampler := Sampler;
682 Rasterizer.Rasterize(Dst);
683 finally
684 Sampler.Free;
685 end;
686 finally
687 Rasterizer.Free;
688 end;
689end;
690
691procedure Convolve(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);
692begin
693 RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TConvolver);
694end;
695
696procedure Dilate(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);
697begin
698 RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TDilater);
699end;
700
701procedure Erode(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);
702begin
703 RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TEroder);
704end;
705
706procedure Expand(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);
707begin
708 RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TExpander);
709end;
710
711procedure Contract(Src, Dst: TCustomBitmap32; Kernel: TIntegerMap; CenterX, CenterY: Integer);
712begin
713 RasterizeKernelSampler(Src, Dst, Kernel, CenterX, CenterY, TContracter);
714end;
715
716{ Auxiliary routines }
717
718procedure IncBuffer(var Buffer: TBufferEntry; Color: TColor32);
719begin
720 with TColor32Entry(Color) do
721 begin
722 Inc(Buffer.B, B);
723 Inc(Buffer.G, G);
724 Inc(Buffer.R, R);
725 Inc(Buffer.A, A);
726 end;
727end;
728
729procedure MultiplyBuffer(var Buffer: TBufferEntry; W: Integer);
730begin
731 Buffer.B := Buffer.B * W;
732 Buffer.G := Buffer.G * W;
733 Buffer.R := Buffer.R * W;
734 Buffer.A := Buffer.A * W;
735end;
736
737procedure ShrBuffer(var Buffer: TBufferEntry; Shift: Integer);
738begin
739 Buffer.B := Buffer.B shr Shift;
740 Buffer.G := Buffer.G shr Shift;
741 Buffer.R := Buffer.R shr Shift;
742 Buffer.A := Buffer.A shr Shift;
743end;
744
745function BufferToColor32(const Buffer: TBufferEntry; Shift: Integer): TColor32;
746begin
747 with TColor32Entry(Result) do
748 begin
749 B := Buffer.B shr Shift;
750 G := Buffer.G shr Shift;
751 R := Buffer.R shr Shift;
752 A := Buffer.A shr Shift;
753 end;
754end;
755
756procedure CheckBitmaps(Dst, Src: TCustomBitmap32); {$IFDEF USEINLINING}inline;{$ENDIF}
757begin
758 if not Assigned(Dst) then raise EBitmapException.Create(SDstNil);
759 if not Assigned(Src) then raise EBitmapException.Create(SSrcNil);
760end;
761
762procedure BlendBlock(
763 Dst: TCustomBitmap32; DstRect: TRect;
764 Src: TCustomBitmap32; SrcX, SrcY: Integer;
765 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent);
766var
767 SrcP, DstP: PColor32;
768 SP, DP: PColor32;
769 MC: TColor32;
770 W, I, DstY: Integer;
771 BlendLine: TBlendLine;
772 BlendLineEx: TBlendLineEx;
773begin
774 { Internal routine }
775 W := DstRect.Right - DstRect.Left;
776 SrcP := Src.PixelPtr[SrcX, SrcY];
777 DstP := Dst.PixelPtr[DstRect.Left, DstRect.Top];
778
779 case CombineOp of
780 dmOpaque:
781 begin
782 for DstY := DstRect.Top to DstRect.Bottom - 1 do
783 begin
784 //Move(SrcP^, DstP^, W shl 2); // for FastCode
785 MoveLongWord(SrcP^, DstP^, W);
786 Inc(SrcP, Src.Width);
787 Inc(DstP, Dst.Width);
788 end;
789 end;
790 dmBlend:
791 if Src.MasterAlpha >= 255 then
792 begin
793 BlendLine := BLEND_LINE[Src.CombineMode]^;
794 for DstY := DstRect.Top to DstRect.Bottom - 1 do
795 begin
796 BlendLine(SrcP, DstP, W);
797 Inc(SrcP, Src.Width);
798 Inc(DstP, Dst.Width);
799 end
800 end
801 else
802 begin
803 BlendLineEx := BLEND_LINE_EX[Src.CombineMode]^;
804 for DstY := DstRect.Top to DstRect.Bottom - 1 do
805 begin
806 BlendLineEx(SrcP, DstP, W, Src.MasterAlpha);
807 Inc(SrcP, Src.Width);
808 Inc(DstP, Dst.Width);
809 end
810 end;
811 dmTransparent:
812 begin
813 MC := Src.OuterColor;
814 for DstY := DstRect.Top to DstRect.Bottom - 1 do
815 begin
816 SP := SrcP;
817 DP := DstP;
818 { TODO: Write an optimized routine for fast masked transfers. }
819 for I := 0 to W - 1 do
820 begin
821 if MC <> SP^ then DP^ := SP^;
822 Inc(SP); Inc(DP);
823 end;
824 Inc(SrcP, Src.Width);
825 Inc(DstP, Dst.Width);
826 end;
827 end;
828 else // dmCustom:
829 begin
830 for DstY := DstRect.Top to DstRect.Bottom - 1 do
831 begin
832 SP := SrcP;
833 DP := DstP;
834 for I := 0 to W - 1 do
835 begin
836 CombineCallBack(SP^, DP^, Src.MasterAlpha);
837 Inc(SP); Inc(DP);
838 end;
839 Inc(SrcP, Src.Width);
840 Inc(DstP, Dst.Width);
841 end;
842 end;
843 end;
844end;
845
846procedure BlockTransfer(
847 Dst: TCustomBitmap32; DstX: Integer; DstY: Integer; DstClip: TRect;
848 Src: TCustomBitmap32; SrcRect: TRect;
849 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent);
850var
851 SrcX, SrcY: Integer;
852begin
853 CheckBitmaps(Dst, Src);
854 if Dst.Empty or Src.Empty or ((CombineOp = dmBlend) and (Src.MasterAlpha = 0)) then Exit;
855
856 SrcX := SrcRect.Left;
857 SrcY := SrcRect.Top;
858
859 GR32.IntersectRect(DstClip, DstClip, Dst.BoundsRect);
860 GR32.IntersectRect(SrcRect, SrcRect, Src.BoundsRect);
861
862 GR32.OffsetRect(SrcRect, DstX - SrcX, DstY - SrcY);
863 GR32.IntersectRect(SrcRect, DstClip, SrcRect);
864 if GR32.IsRectEmpty(SrcRect) then
865 exit;
866
867 DstClip := SrcRect;
868 GR32.OffsetRect(SrcRect, SrcX - DstX, SrcY - DstY);
869
870 if not Dst.MeasuringMode then
871 begin
872 try
873 if (CombineOp = dmCustom) and not Assigned(CombineCallBack) then
874 CombineOp := dmOpaque;
875
876 BlendBlock(Dst, DstClip, Src, SrcRect.Left, SrcRect.Top, CombineOp, CombineCallBack);
877 finally
878 EMMS;
879 end;
880 end;
881
882 Dst.Changed(DstClip);
883end;
884
885{$WARNINGS OFF}
886procedure BlockTransferX(
887 Dst: TCustomBitmap32; DstX, DstY: TFixed;
888 Src: TCustomBitmap32; SrcRect: TRect;
889 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent = nil);
890type
891 TColor32Array = array [0..1] of TColor32;
892 PColor32Array = ^TColor32Array;
893var
894 I, Index, SrcW, SrcRectW, SrcRectH, DstW, DstH: Integer;
895 FracX, FracY: Integer;
896 Buffer: array [0..1] of TArrayOfColor32;
897 SrcP, Buf1, Buf2: PColor32Array;
898 DstP: PColor32;
899 C1, C2, C3, C4: TColor32;
900 LW, RW, TW, BW, MA: Integer;
901 DstBounds: TRect;
902
903 BlendLineEx: TBlendLineEx;
904 BlendMemEx: TBlendMemEx;
905begin
906 CheckBitmaps(Dst, Src);
907 if Dst.Empty or Src.Empty or ((CombineOp = dmBlend) and (Src.MasterAlpha = 0)) then Exit;
908
909 SrcRectW := SrcRect.Right - SrcRect.Left - 1;
910 SrcRectH := SrcRect.Bottom - SrcRect.Top - 1;
911
912 FracX := (DstX and $FFFF) shr 8;
913 FracY := (DstY and $FFFF) shr 8;
914
915 DstX := DstX div $10000;
916 DstY := DstY div $10000;
917
918 DstW := Dst.Width;
919 DstH := Dst.Height;
920
921 MA := Src.MasterAlpha;
922
923 if (DstX >= DstW) or (DstY >= DstH) or (MA = 0) then Exit;
924
925 if (DstX + SrcRectW <= 0) or (Dsty + SrcRectH <= 0) then Exit;
926
927 if DstX < 0 then LW := $FF else LW := FracX xor $FF;
928 if DstY < 0 then TW := $FF else TW := FracY xor $FF;
929 if DstX + SrcRectW >= DstW then RW := $FF else RW := FracX;
930 if DstY + SrcRectH >= DstH then BW := $FF else BW := FracY;
931
932 DstBounds := Dst.BoundsRect;
933 Dec(DstBounds.Right);
934 Dec(DstBounds.Bottom);
935 GR32.OffsetRect(DstBounds, SrcRect.Left - DstX, SrcRect.Top - DstY);
936 GR32.IntersectRect(SrcRect, SrcRect, DstBounds);
937
938 if GR32.IsRectEmpty(SrcRect) then Exit;
939
940 SrcW := Src.Width;
941
942 SrcRectW := SrcRect.Right - SrcRect.Left;
943 SrcRectH := SrcRect.Bottom - SrcRect.Top;
944
945 if DstX < 0 then DstX := 0;
946 if DstY < 0 then DstY := 0;
947
948 if not Dst.MeasuringMode then
949 begin
950 SetLength(Buffer[0], SrcRectW + 1);
951 SetLength(Buffer[1], SrcRectW + 1);
952
953 BlendLineEx := BLEND_LINE_EX[Src.CombineMode]^;
954 BlendMemEx := BLEND_MEM_EX[Src.CombineMode]^;
955
956 try
957 SrcP := PColor32Array(Src.PixelPtr[SrcRect.Left, SrcRect.Top - 1]);
958 DstP := Dst.PixelPtr[DstX, DstY];
959
960 Buf1 := @Buffer[0][0];
961 Buf2 := @Buffer[1][0];
962
963 if SrcRect.Top > 0 then
964 begin
965 MoveLongWord(SrcP[0], Buf1[0], SrcRectW);
966 CombineLine(@Buf1[1], @Buf1[0], SrcRectW, FracX);
967
968 if SrcRect.Left > 0 then
969 {$IFDEF HAS_NATIVEINT}
970 C2 := CombineReg(PColor32(NativeUInt(SrcP) - 4)^, SrcP[0], FracX xor $FF)
971 {$ELSE}
972 C2 := CombineReg(PColor32(Integer(SrcP) - 4)^, SrcP[0], FracX xor $FF)
973 {$ENDIF}
974 else
975 C2 := SrcP[0];
976
977 if SrcRect.Right < SrcW then
978 C4 := CombineReg(SrcP[SrcRectW - 1], SrcP[SrcRectW], FracX)
979 else
980 C4 := SrcP[SrcRectW - 1];
981 end;
982
983 Inc(PColor32(SrcP), SrcW);
984 MoveLongWord(SrcP^, Buf2^, SrcRectW);
985 CombineLine(@Buf2[1], @Buf2[0], SrcRectW, FracX xor $FF);
986
987 if SrcRect.Left > 0 then
988 {$IFDEF HAS_NATIVEINT}
989 C1 := CombineReg(PColor32(NativeUInt(SrcP) - 4)^, SrcP[0], FracX)
990 {$ELSE}
991 C1 := CombineReg(PColor32(Integer(SrcP) - 4)^, SrcP[0], FracX)
992 {$ENDIF}
993 else
994 C1 := SrcP[0];
995
996 if SrcRect.Right < SrcW then
997 C3 := CombineReg(SrcP[SrcRectW - 1], SrcP[SrcRectW], FracX)
998 else
999 C3 := SrcP[SrcRectW - 1];
1000
1001 if SrcRect.Top > 0 then
1002 begin
1003 BlendMemEx(CombineReg(C1, C2, FracY), DstP^, LW * TW * MA shr 16);
1004 CombineLine(@Buf2[0], @Buf1[0], SrcRectW, FracY xor $FF);
1005 end
1006 else
1007 begin
1008 BlendMemEx(C1, DstP^, LW * TW * MA shr 16);
1009 MoveLongWord(Buf2^, Buf1^, SrcRectW);
1010 end;
1011
1012 Inc(DstP, 1);
1013 BlendLineEx(@Buf1[0], DstP, SrcRectW - 1, TW * MA shr 8);
1014
1015 Inc(DstP, SrcRectW - 1);
1016
1017 if SrcRect.Top > 0 then
1018 BlendMemEx(CombineReg(C3, C4, FracY), DstP^, RW * TW * MA shr 16)
1019 else
1020 BlendMemEx(C3, DstP^, RW * TW * MA shr 16);
1021
1022 Inc(DstP, DstW - SrcRectW);
1023
1024 Index := 1;
1025 for I := SrcRect.Top to SrcRect.Bottom - 2 do
1026 begin
1027 Buf1 := @Buffer[Index][0];
1028 Buf2 := @Buffer[Index xor 1][0];
1029 Inc(PColor32(SrcP), SrcW);
1030
1031 MoveLongWord(SrcP[0], Buf2^, SrcRectW);
1032
1033 // Horizontal translation
1034 CombineLine(@Buf2[1], @Buf2[0], SrcRectW, FracX xor $FF);
1035
1036 if SrcRect.Left > 0 then
1037 {$IFDEF HAS_NATIVEINT}
1038 C2 := CombineReg(PColor32(NativeUInt(SrcP) - 4)^, SrcP[0], FracX xor $FF)
1039 {$ELSE}
1040 C2 := CombineReg(PColor32(Integer(SrcP) - 4)^, SrcP[0], FracX xor $FF)
1041 {$ENDIF}
1042 else
1043 C2 := SrcP[0];
1044
1045 BlendMemEx(CombineReg(C1, C2, FracY), DstP^, LW * MA shr 8);
1046 Inc(DstP);
1047 C1 := C2;
1048
1049 // Vertical translation
1050 CombineLine(@Buf2[0], @Buf1[0], SrcRectW, FracY xor $FF);
1051
1052 // Blend horizontal line to Dst
1053 BlendLineEx(@Buf1[0], DstP, SrcRectW - 1, MA);
1054 Inc(DstP, SrcRectW - 1);
1055
1056 if SrcRect.Right < SrcW then
1057 C4 := CombineReg(SrcP[SrcRectW - 1], SrcP[SrcRectW], FracX)
1058 else
1059 C4 := SrcP[SrcRectW - 1];
1060
1061 BlendMemEx(CombineReg(C3, C4, FracY), DstP^, RW * MA shr 8);
1062
1063 Inc(DstP, DstW - SrcRectW);
1064 C3 := C4;
1065
1066 Index := Index xor 1;
1067 end;
1068
1069 Buf1 := @Buffer[Index][0];
1070 Buf2 := @Buffer[Index xor 1][0];
1071
1072 Inc(PColor32(SrcP), SrcW);
1073
1074 if SrcRect.Bottom < Src.Height then
1075 begin
1076 MoveLongWord(SrcP[0], Buf2^, SrcRectW);
1077 CombineLine(@Buf2[1], @Buf2[0], SrcRectW, FracY xor $FF);
1078 CombineLine(@Buf2[0], @Buf1[0], SrcRectW, FracY xor $FF);
1079 if SrcRect.Left > 0 then
1080 {$IFDEF HAS_NATIVEINT}
1081 C2 := CombineReg(PColor32(NativeUInt(SrcP) - 4)^, SrcP[0], FracX xor $FF)
1082 {$ELSE}
1083 C2 := CombineReg(PColor32(Integer(SrcP) - 4)^, SrcP[0], FracX xor $FF)
1084 {$ENDIF}
1085 else
1086 C2 := SrcP[0];
1087 BlendMemEx(CombineReg(C1, C2, FracY), DstP^, LW * BW * MA shr 16)
1088 end
1089 else
1090 BlendMemEx(C1, DstP^, LW * BW * MA shr 16);
1091
1092 Inc(DstP);
1093 BlendLineEx(@Buf1[0], DstP, SrcRectW - 1, BW * MA shr 8);
1094 Inc(DstP, SrcRectW - 1);
1095
1096 if SrcRect.Bottom < Src.Height then
1097 begin
1098 if SrcRect.Right < SrcW then
1099 C4 := CombineReg(SrcP[SrcRectW - 1], SrcP[SrcRectW], FracX)
1100 else
1101 C4 := SrcP[SrcRectW - 1];
1102 BlendMemEx(CombineReg(C3, C4, FracY), DstP^, RW * BW * MA shr 16);
1103 end
1104 else
1105 BlendMemEx(C3, DstP^, RW * BW * MA shr 16);
1106
1107 finally
1108 EMMS;
1109 Buffer[0] := nil;
1110 Buffer[1] := nil;
1111 end;
1112 end;
1113
1114 Dst.Changed(MakeRect(DstX, DstY, DstX + SrcRectW + 1, DstY + SrcRectH + 1));
1115end;
1116{$WARNINGS ON}
1117
1118procedure BlendTransfer(
1119 Dst: TCustomBitmap32; DstX, DstY: Integer; DstClip: TRect;
1120 SrcF: TCustomBitmap32; SrcRectF: TRect;
1121 SrcB: TCustomBitmap32; SrcRectB: TRect;
1122 BlendCallback: TBlendReg);
1123var
1124 I, J, SrcFX, SrcFY, SrcBX, SrcBY: Integer;
1125 PSrcF, PSrcB, PDst: PColor32Array;
1126begin
1127 if not Assigned(Dst) then raise EBitmapException.Create(SDstNil);
1128 if not Assigned(SrcF) then raise EBitmapException.Create(SSrcNil);
1129 if not Assigned(SrcB) then raise EBitmapException.Create(SSrcNil);
1130
1131 if Dst.Empty or SrcF.Empty or SrcB.Empty or not Assigned(BlendCallback) then Exit;
1132
1133 if not Dst.MeasuringMode then
1134 begin
1135 SrcFX := SrcRectF.Left - DstX;
1136 SrcFY := SrcRectF.Top - DstY;
1137 SrcBX := SrcRectB.Left - DstX;
1138 SrcBY := SrcRectB.Top - DstY;
1139
1140 GR32.IntersectRect(DstClip, DstClip, Dst.BoundsRect);
1141 GR32.IntersectRect(SrcRectF, SrcRectF, SrcF.BoundsRect);
1142 GR32.IntersectRect(SrcRectB, SrcRectB, SrcB.BoundsRect);
1143
1144 GR32.OffsetRect(SrcRectF, -SrcFX, -SrcFY);
1145 GR32.OffsetRect(SrcRectB, -SrcBX, -SrcFY);
1146
1147 GR32.IntersectRect(DstClip, DstClip, SrcRectF);
1148 GR32.IntersectRect(DstClip, DstClip, SrcRectB);
1149
1150 if not GR32.IsRectEmpty(DstClip) then
1151 try
1152 for I := DstClip.Top to DstClip.Bottom - 1 do
1153 begin
1154 PSrcF := PColor32Array(SrcF.PixelPtr[SrcFX, SrcFY + I]);
1155 PSrcB := PColor32Array(SrcB.PixelPtr[SrcBX, SrcBY + I]);
1156 PDst := Dst.ScanLine[I];
1157 for J := DstClip.Left to DstClip.Right - 1 do
1158 PDst[J] := BlendCallback(PSrcF[J], PSrcB[J]);
1159 end;
1160 finally
1161 EMMS;
1162 end;
1163 end;
1164 Dst.Changed(DstClip);
1165end;
1166
1167procedure BlendTransfer(
1168 Dst: TCustomBitmap32; DstX, DstY: Integer; DstClip: TRect;
1169 SrcF: TCustomBitmap32; SrcRectF: TRect;
1170 SrcB: TCustomBitmap32; SrcRectB: TRect;
1171 BlendCallback: TBlendRegEx; MasterAlpha: Integer);
1172var
1173 I, J, SrcFX, SrcFY, SrcBX, SrcBY: Integer;
1174 PSrcF, PSrcB, PDst: PColor32Array;
1175begin
1176 if not Assigned(Dst) then raise EBitmapException.Create(SDstNil);
1177 if not Assigned(SrcF) then raise EBitmapException.Create(SSrcNil);
1178 if not Assigned(SrcB) then raise EBitmapException.Create(SSrcNil);
1179
1180 if Dst.Empty or SrcF.Empty or SrcB.Empty or not Assigned(BlendCallback) then Exit;
1181
1182 if not Dst.MeasuringMode then
1183 begin
1184 SrcFX := SrcRectF.Left - DstX;
1185 SrcFY := SrcRectF.Top - DstY;
1186 SrcBX := SrcRectB.Left - DstX;
1187 SrcBY := SrcRectB.Top - DstY;
1188
1189 GR32.IntersectRect(DstClip, DstClip, Dst.BoundsRect);
1190 GR32.IntersectRect(SrcRectF, SrcRectF, SrcF.BoundsRect);
1191 GR32.IntersectRect(SrcRectB, SrcRectB, SrcB.BoundsRect);
1192
1193 GR32.OffsetRect(SrcRectF, -SrcFX, -SrcFY);
1194 GR32.OffsetRect(SrcRectB, -SrcBX, -SrcFY);
1195
1196 GR32.IntersectRect(DstClip, DstClip, SrcRectF);
1197 GR32.IntersectRect(DstClip, DstClip, SrcRectB);
1198
1199 if not GR32.IsRectEmpty(DstClip) then
1200 try
1201 for I := DstClip.Top to DstClip.Bottom - 1 do
1202 begin
1203 PSrcF := PColor32Array(SrcF.PixelPtr[SrcFX, SrcFY + I]);
1204 PSrcB := PColor32Array(SrcB.PixelPtr[SrcBX, SrcBY + I]);
1205 PDst := Dst.ScanLine[I];
1206 for J := DstClip.Left to DstClip.Right - 1 do
1207 PDst[J] := BlendCallback(PSrcF[J], PSrcB[J], MasterAlpha);
1208 end;
1209 finally
1210 EMMS;
1211 end;
1212 end;
1213 Dst.Changed(DstClip);
1214end;
1215
1216procedure StretchNearest(
1217 Dst: TCustomBitmap32; DstRect, DstClip: TRect;
1218 Src: TCustomBitmap32; SrcRect: TRect;
1219 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent);
1220var
1221 R: TRect;
1222 SrcW, SrcH, DstW, DstH, DstClipW, DstClipH: Integer;
1223 SrcY, OldSrcY: Integer;
1224 I, J: Integer;
1225 MapHorz: PIntegerArray;
1226 SrcLine, DstLine: PColor32Array;
1227 Buffer: TArrayOfColor32;
1228 Scale: TFloat;
1229 BlendLine: TBlendLine;
1230 BlendLineEx: TBlendLineEx;
1231 DstLinePtr, MapPtr: PColor32;
1232begin
1233 GR32.IntersectRect(DstClip, DstClip, MakeRect(0, 0, Dst.Width, Dst.Height));
1234 GR32.IntersectRect(DstClip, DstClip, DstRect);
1235 if GR32.IsRectEmpty(DstClip) then Exit;
1236 GR32.IntersectRect(R, DstClip, DstRect);
1237 if GR32.IsRectEmpty(R) then Exit;
1238 if (SrcRect.Left < 0) or (SrcRect.Top < 0) or (SrcRect.Right > Src.Width) or
1239 (SrcRect.Bottom > Src.Height) then
1240 raise Exception.Create(RCStrInvalidSrcRect);
1241
1242 SrcW := SrcRect.Right - SrcRect.Left;
1243 SrcH := SrcRect.Bottom - SrcRect.Top;
1244 DstW := DstRect.Right - DstRect.Left;
1245 DstH := DstRect.Bottom - DstRect.Top;
1246 DstClipW := DstClip.Right - DstClip.Left;
1247 DstClipH := DstClip.Bottom - DstClip.Top;
1248 try
1249 if (SrcW = DstW) and (SrcH = DstH) then
1250 begin
1251 { Copy without resampling }
1252 BlendBlock(Dst, DstClip, Src, SrcRect.Left + DstClip.Left - DstRect.Left,
1253 SrcRect.Top + DstClip.Top - DstRect.Top, CombineOp, CombineCallBack);
1254 end
1255 else
1256 begin
1257 GetMem(MapHorz, DstClipW * SizeOf(Integer));
1258 try
1259 if DstW > 1 then
1260 begin
1261 if FullEdge then
1262 begin
1263 Scale := SrcW / DstW;
1264 for I := 0 to DstClipW - 1 do
1265 MapHorz^[I] := Trunc(SrcRect.Left + (I + DstClip.Left - DstRect.Left) * Scale);
1266 end
1267 else
1268 begin
1269 Scale := (SrcW - 1) / (DstW - 1);
1270 for I := 0 to DstClipW - 1 do
1271 MapHorz^[I] := Round(SrcRect.Left + (I + DstClip.Left - DstRect.Left) * Scale);
1272 end;
1273
1274 Assert(MapHorz^[0] >= SrcRect.Left);
1275 Assert(MapHorz^[DstClipW - 1] < SrcRect.Right);
1276 end
1277 else
1278 MapHorz^[0] := (SrcRect.Left + SrcRect.Right - 1) div 2;
1279
1280 if DstH <= 1 then Scale := 0
1281 else if FullEdge then Scale := SrcH / DstH
1282 else Scale := (SrcH - 1) / (DstH - 1);
1283
1284 if CombineOp = dmOpaque then
1285 begin
1286 DstLine := PColor32Array(Dst.PixelPtr[DstClip.Left, DstClip.Top]);
1287 OldSrcY := -1;
1288
1289 for J := 0 to DstClipH - 1 do
1290 begin
1291 if DstH <= 1 then
1292 SrcY := (SrcRect.Top + SrcRect.Bottom - 1) div 2
1293 else if FullEdge then
1294 SrcY := Trunc(SrcRect.Top + (J + DstClip.Top - DstRect.Top) * Scale)
1295 else
1296 SrcY := Round(SrcRect.Top + (J + DstClip.Top - DstRect.Top) * Scale);
1297
1298 if SrcY <> OldSrcY then
1299 begin
1300 SrcLine := Src.ScanLine[SrcY];
1301 DstLinePtr := @DstLine[0];
1302 MapPtr := @MapHorz^[0];
1303 for I := 0 to DstClipW - 1 do
1304 begin
1305 DstLinePtr^ := SrcLine[MapPtr^];
1306 Inc(DstLinePtr);
1307 Inc(MapPtr);
1308 end;
1309 OldSrcY := SrcY;
1310 end
1311 else
1312 MoveLongWord(DstLine[-Dst.Width], DstLine[0], DstClipW);
1313 Inc(DstLine, Dst.Width);
1314 end;
1315 end
1316 else
1317 begin
1318 SetLength(Buffer, DstClipW);
1319 DstLine := PColor32Array(Dst.PixelPtr[DstClip.Left, DstClip.Top]);
1320 OldSrcY := -1;
1321
1322 if Src.MasterAlpha >= 255 then
1323 begin
1324 BlendLine := BLEND_LINE[Src.CombineMode]^;
1325 BlendLineEx := nil; // stop compiler warnings...
1326 end
1327 else
1328 begin
1329 BlendLineEx := BLEND_LINE_EX[Src.CombineMode]^;
1330 BlendLine := nil; // stop compiler warnings...
1331 end;
1332
1333 for J := 0 to DstClipH - 1 do
1334 begin
1335 if DstH > 1 then
1336 begin
1337 EMMS;
1338 if FullEdge then
1339 SrcY := Trunc(SrcRect.Top + (J + DstClip.Top - DstRect.Top) * Scale)
1340 else
1341 SrcY := Round(SrcRect.Top + (J + DstClip.Top - DstRect.Top) * Scale);
1342 end
1343 else
1344 SrcY := (SrcRect.Top + SrcRect.Bottom - 1) div 2;
1345
1346 if SrcY <> OldSrcY then
1347 begin
1348 SrcLine := Src.ScanLine[SrcY];
1349 DstLinePtr := @Buffer[0];
1350 MapPtr := @MapHorz^[0];
1351 for I := 0 to DstClipW - 1 do
1352 begin
1353 DstLinePtr^ := SrcLine[MapPtr^];
1354 Inc(DstLinePtr);
1355 Inc(MapPtr);
1356 end;
1357 OldSrcY := SrcY;
1358 end;
1359
1360 case CombineOp of
1361 dmBlend:
1362 if Src.MasterAlpha >= 255 then
1363 BlendLine(@Buffer[0], @DstLine[0], DstClipW)
1364 else
1365 BlendLineEx(@Buffer[0], @DstLine[0], DstClipW, Src.MasterAlpha);
1366 dmTransparent:
1367 for I := 0 to DstClipW - 1 do
1368 if Buffer[I] <> Src.OuterColor then DstLine[I] := Buffer[I];
1369 dmCustom:
1370 for I := 0 to DstClipW - 1 do
1371 CombineCallBack(Buffer[I], DstLine[I], Src.MasterAlpha);
1372 end;
1373
1374 Inc(DstLine, Dst.Width);
1375 end;
1376 end;
1377 finally
1378 FreeMem(MapHorz);
1379 end;
1380 end;
1381 finally
1382 EMMS;
1383 end;
1384end;
1385
1386procedure StretchHorzStretchVertLinear(
1387 Dst: TCustomBitmap32; DstRect, DstClip: TRect;
1388 Src: TCustomBitmap32; SrcRect: TRect;
1389 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent);
1390//Assure DstRect is >= SrcRect, otherwise quality loss will occur
1391var
1392 SrcW, SrcH, DstW, DstH, DstClipW, DstClipH: Integer;
1393 MapHorz, MapVert: array of TPointRec;
1394 t2, Scale: TFloat;
1395 SrcLine, DstLine: PColor32Array;
1396 SrcIndex: Integer;
1397 SrcPtr1, SrcPtr2: PColor32;
1398 I, J: Integer;
1399 WY: Cardinal;
1400 C: TColor32;
1401 BlendMemEx: TBlendMemEx;
1402begin
1403 SrcW := SrcRect.Right - SrcRect.Left;
1404 SrcH := SrcRect.Bottom - SrcRect.Top;
1405 DstW := DstRect.Right - DstRect.Left;
1406 DstH := DstRect.Bottom - DstRect.Top;
1407 DstClipW := DstClip.Right - DstClip.Left;
1408 DstClipH := DstClip.Bottom - DstClip.Top;
1409
1410 SetLength(MapHorz, DstClipW);
1411 if FullEdge then Scale := SrcW / DstW
1412 else Scale := (SrcW - 1) / (DstW - 1);
1413 for I := 0 to DstClipW - 1 do
1414 begin
1415 if FullEdge then t2 := SrcRect.Left - 0.5 + (I + DstClip.Left - DstRect.Left + 0.5) * Scale
1416 else t2 := SrcRect.Left + (I + DstClip.Left - DstRect.Left) * Scale;
1417 if t2 < 0 then t2 := 0
1418 else if t2 > Src.Width - 1 then t2 := Src.Width - 1;
1419 MapHorz[I].Pos := Floor(t2);
1420 MapHorz[I].Weight := 256 - Round(Frac(t2) * 256);
1421 //Pre-pack weights to reduce MMX Reg. setups per pixel:
1422 //MapHorz[I].Weight:= MapHorz[I].Weight shl 16 + MapHorz[I].Weight;
1423 end;
1424 I := DstClipW - 1;
1425 while MapHorz[I].Pos = SrcRect.Right - 1 do
1426 begin
1427 Dec(MapHorz[I].Pos);
1428 MapHorz[I].Weight := 0;
1429 Dec(I);
1430 end;
1431
1432 SetLength(MapVert, DstClipH);
1433 if FullEdge then Scale := SrcH / DstH
1434 else Scale := (SrcH - 1) / (DstH - 1);
1435 for I := 0 to DstClipH - 1 do
1436 begin
1437 if FullEdge then t2 := SrcRect.Top - 0.5 + (I + DstClip.Top - DstRect.Top + 0.5) * Scale
1438 else t2 := SrcRect.Top + (I + DstClip.Top - DstRect.Top) * Scale;
1439 if t2 < 0 then t2 := 0
1440 else if t2 > Src.Height - 1 then t2 := Src.Height - 1;
1441 MapVert[I].Pos := Floor(t2);
1442 MapVert[I].Weight := 256 - Round(Frac(t2) * 256);
1443 //Pre-pack weights to reduce MMX Reg. setups per pixel:
1444 //MapVert[I].Weight := MapVert[I].Weight shl 16 + MapVert[I].Weight;
1445 end;
1446 I := DstClipH - 1;
1447 while MapVert[I].Pos = SrcRect.Bottom - 1 do
1448 begin
1449 Dec(MapVert[I].Pos);
1450 MapVert[I].Weight := 0;
1451 Dec(I);
1452 end;
1453
1454 DstLine := PColor32Array(Dst.PixelPtr[DstClip.Left, DstClip.Top]);
1455 SrcW := Src.Width;
1456 DstW := Dst.Width;
1457 case CombineOp of
1458 dmOpaque:
1459 for J := 0 to DstClipH - 1 do
1460 begin
1461 SrcLine := Src.ScanLine[MapVert[J].Pos];
1462 WY := MapVert[J].Weight;
1463
1464 SrcIndex := MapHorz[0].Pos;
1465 SrcPtr1 := @SrcLine[SrcIndex];
1466 SrcPtr2 := @SrcLine[SrcIndex + SrcW];
1467 for I := 0 to DstClipW - 1 do
1468 begin
1469 if SrcIndex <> MapHorz[I].Pos then
1470 begin
1471 SrcIndex := MapHorz[I].Pos;
1472 SrcPtr1 := @SrcLine[SrcIndex];
1473 SrcPtr2 := @SrcLine[SrcIndex + SrcW];
1474 end;
1475 DstLine[I] := Interpolator(MapHorz[I].Weight, WY, SrcPtr1, SrcPtr2);
1476 end;
1477 Inc(DstLine, DstW);
1478 end;
1479 dmBlend:
1480 begin
1481 BlendMemEx := BLEND_MEM_EX[Src.CombineMode]^;
1482 for J := 0 to DstClipH - 1 do
1483 begin
1484 SrcLine := Src.ScanLine[MapVert[J].Pos];
1485 WY := MapVert[J].Weight;
1486 SrcIndex := MapHorz[0].Pos;
1487 SrcPtr1 := @SrcLine[SrcIndex];
1488 SrcPtr2 := @SrcLine[SrcIndex + SrcW];
1489 for I := 0 to DstClipW - 1 do
1490 begin
1491 if SrcIndex <> MapHorz[I].Pos then
1492 begin
1493 SrcIndex := MapHorz[I].Pos;
1494 SrcPtr1 := @SrcLine[SrcIndex];
1495 SrcPtr2 := @SrcLine[SrcIndex + SrcW];
1496 end;
1497 C := Interpolator(MapHorz[I].Weight, WY, SrcPtr1, SrcPtr2);
1498 BlendMemEx(C, DstLine[I], Src.MasterAlpha)
1499 end;
1500 Inc(DstLine, Dst.Width);
1501 end
1502 end;
1503 dmTransparent:
1504 begin
1505 for J := 0 to DstClipH - 1 do
1506 begin
1507 SrcLine := Src.ScanLine[MapVert[J].Pos];
1508 WY := MapVert[J].Weight;
1509 SrcIndex := MapHorz[0].Pos;
1510 SrcPtr1 := @SrcLine[SrcIndex];
1511 SrcPtr2 := @SrcLine[SrcIndex + SrcW];
1512 for I := 0 to DstClipW - 1 do
1513 begin
1514 if SrcIndex <> MapHorz[I].Pos then
1515 begin
1516 SrcIndex := MapHorz[I].Pos;
1517 SrcPtr1 := @SrcLine[SrcIndex];
1518 SrcPtr2 := @SrcLine[SrcIndex + SrcW];
1519 end;
1520 C := Interpolator(MapHorz[I].Weight, WY, SrcPtr1, SrcPtr2);
1521 if C <> Src.OuterColor then DstLine[I] := C;
1522 end;
1523 Inc(DstLine, Dst.Width);
1524 end
1525 end;
1526 else // cmCustom
1527 for J := 0 to DstClipH - 1 do
1528 begin
1529 SrcLine := Src.ScanLine[MapVert[J].Pos];
1530 WY := MapVert[J].Weight;
1531 SrcIndex := MapHorz[0].Pos;
1532 SrcPtr1 := @SrcLine[SrcIndex];
1533 SrcPtr2 := @SrcLine[SrcIndex + SrcW];
1534 for I := 0 to DstClipW - 1 do
1535 begin
1536 if SrcIndex <> MapHorz[I].Pos then
1537 begin
1538 SrcIndex := MapHorz[I].Pos;
1539 SrcPtr1 := @SrcLine[SrcIndex];
1540 SrcPtr2 := @SrcLine[SrcIndex + SrcW];
1541 end;
1542 C := Interpolator(MapHorz[I].Weight, WY, SrcPtr1, SrcPtr2);
1543 CombineCallBack(C, DstLine[I], Src.MasterAlpha);
1544 end;
1545 Inc(DstLine, Dst.Width);
1546 end;
1547 end;
1548 EMMS;
1549end;
1550
1551function BuildMappingTable(
1552 DstLo, DstHi: Integer;
1553 ClipLo, ClipHi: Integer;
1554 SrcLo, SrcHi: Integer;
1555 Kernel: TCustomKernel): TMappingTable;
1556var
1557 SrcW, DstW, ClipW: Integer;
1558 Filter: TFilterMethod;
1559 FilterWidth: TFloat;
1560 Scale, OldScale: TFloat;
1561 Center: TFloat;
1562 Count: Integer;
1563 Left, Right: Integer;
1564 I, J, K: Integer;
1565 Weight: Integer;
1566begin
1567 SrcW := SrcHi - SrcLo;
1568 DstW := DstHi - DstLo;
1569 ClipW := ClipHi - ClipLo;
1570 if SrcW = 0 then
1571 begin
1572 Result := nil;
1573 Exit;
1574 end
1575 else if SrcW = 1 then
1576 begin
1577 SetLength(Result, ClipW);
1578 for I := 0 to ClipW - 1 do
1579 begin
1580 SetLength(Result[I], 1);
1581 Result[I][0].Pos := SrcLo;
1582 Result[I][0].Weight := 256;
1583 end;
1584 Exit;
1585 end;
1586 SetLength(Result, ClipW);
1587 if ClipW = 0 then Exit;
1588
1589 if FullEdge then Scale := DstW / SrcW
1590 else Scale := (DstW - 1) / (SrcW - 1);
1591
1592 Filter := Kernel.Filter;
1593 FilterWidth := Kernel.GetWidth;
1594 K := 0;
1595
1596 if Scale = 0 then
1597 begin
1598 Assert(Length(Result) = 1);
1599 SetLength(Result[0], 1);
1600 Result[0][0].Pos := (SrcLo + SrcHi) div 2;
1601 Result[0][0].Weight := 256;
1602 end
1603 else if Scale < 1 then
1604 begin
1605 OldScale := Scale;
1606 Scale := 1 / Scale;
1607 FilterWidth := FilterWidth * Scale;
1608 for I := 0 to ClipW - 1 do
1609 begin
1610 if FullEdge then
1611 Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale
1612 else
1613 Center := SrcLo + (I - DstLo + ClipLo) * Scale;
1614 Left := Floor(Center - FilterWidth);
1615 Right := Ceil(Center + FilterWidth);
1616 Count := -256;
1617 for J := Left to Right do
1618 begin
1619 Weight := Round(256 * Filter((Center - J) * OldScale) * OldScale);
1620 if Weight <> 0 then
1621 begin
1622 Inc(Count, Weight);
1623 K := Length(Result[I]);
1624 SetLength(Result[I], K + 1);
1625 Result[I][K].Pos := Constrain(J, SrcLo, SrcHi - 1);
1626 Result[I][K].Weight := Weight;
1627 end;
1628 end;
1629 if Length(Result[I]) = 0 then
1630 begin
1631 SetLength(Result[I], 1);
1632 Result[I][0].Pos := Floor(Center);
1633 Result[I][0].Weight := 256;
1634 end
1635 else if Count <> 0 then
1636 Dec(Result[I][K div 2].Weight, Count);
1637 end;
1638 end
1639 else // scale > 1
1640 begin
1641 Scale := 1 / Scale;
1642 for I := 0 to ClipW - 1 do
1643 begin
1644 if FullEdge then
1645 Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale
1646 else
1647 Center := SrcLo + (I - DstLo + ClipLo) * Scale;
1648 Left := Floor(Center - FilterWidth);
1649 Right := Ceil(Center + FilterWidth);
1650 Count := -256;
1651 for J := Left to Right do
1652 begin
1653 Weight := Round(256 * Filter(Center - j));
1654 if Weight <> 0 then
1655 begin
1656 Inc(Count, Weight);
1657 K := Length(Result[I]);
1658 SetLength(Result[I], k + 1);
1659 Result[I][K].Pos := Constrain(j, SrcLo, SrcHi - 1);
1660 Result[I][K].Weight := Weight;
1661 end;
1662 end;
1663 if Count <> 0 then
1664 Dec(Result[I][K div 2].Weight, Count);
1665 end;
1666 end;
1667end;
1668
1669{$WARNINGS OFF}
1670procedure Resample(
1671 Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
1672 Src: TCustomBitmap32; SrcRect: TRect;
1673 Kernel: TCustomKernel;
1674 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent);
1675var
1676 DstClipW: Integer;
1677 MapX, MapY: TMappingTable;
1678 I, J, X, Y: Integer;
1679 MapXLoPos, MapXHiPos: Integer;
1680 HorzBuffer: array of TBufferEntry;
1681 ClusterX, ClusterY: TCluster;
1682 Wt, Cr, Cg, Cb, Ca: Integer;
1683 C: Cardinal;
1684 ClustYW: Integer;
1685 DstLine: PColor32Array;
1686 RangeCheck: Boolean;
1687 BlendMemEx: TBlendMemEx;
1688begin
1689 if (CombineOp = dmCustom) and not Assigned(CombineCallBack) then
1690 CombineOp := dmOpaque;
1691
1692 { check source and destination }
1693 if (CombineOp = dmBlend) and (Src.MasterAlpha = 0) then Exit;
1694
1695 BlendMemEx := BLEND_MEM_EX[Src.CombineMode]^; // store in local variable
1696
1697 DstClipW := DstClip.Right - DstClip.Left;
1698
1699 // mapping tables
1700 MapX := BuildMappingTable(DstRect.Left, DstRect.Right, DstClip.Left, DstClip.Right, SrcRect.Left, SrcRect.Right, Kernel);
1701 MapY := BuildMappingTable(DstRect.Top, DstRect.Bottom, DstClip.Top, DstClip.Bottom, SrcRect.Top, SrcRect.Bottom, Kernel);
1702 ClusterX := nil;
1703 ClusterY := nil;
1704 try
1705 RangeCheck := Kernel.RangeCheck; //StretchFilter in [sfLanczos, sfMitchell];
1706 if (MapX = nil) or (MapY = nil) then Exit;
1707
1708 MapXLoPos := MapX[0][0].Pos;
1709 MapXHiPos := MapX[DstClipW - 1][High(MapX[DstClipW - 1])].Pos;
1710 SetLength(HorzBuffer, MapXHiPos - MapXLoPos + 1);
1711
1712 { transfer pixels }
1713 for J := DstClip.Top to DstClip.Bottom - 1 do
1714 begin
1715 ClusterY := MapY[J - DstClip.Top];
1716 for X := MapXLoPos to MapXHiPos do
1717 begin
1718 Ca := 0; Cr := 0; Cg := 0; Cb := 0;
1719 for Y := 0 to Length(ClusterY) - 1 do
1720 begin
1721 C := Src.Bits[X + ClusterY[Y].Pos * Src.Width];
1722 ClustYW := ClusterY[Y].Weight;
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);
1727 end;
1728 with HorzBuffer[X - MapXLoPos] do
1729 begin
1730 R := Cr;
1731 G := Cg;
1732 B := Cb;
1733 A := Ca;
1734 end;
1735 end;
1736
1737 DstLine := Dst.ScanLine[J];
1738 for I := DstClip.Left to DstClip.Right - 1 do
1739 begin
1740 ClusterX := MapX[I - DstClip.Left];
1741 Ca := 0; Cr := 0; Cg := 0; Cb := 0;
1742 for X := 0 to Length(ClusterX) - 1 do
1743 begin
1744 Wt := ClusterX[X].Weight;
1745 with HorzBuffer[ClusterX[X].Pos - MapXLoPos] do
1746 begin
1747 Inc(Ca, A * Wt);
1748 Inc(Cr, R * Wt);
1749 Inc(Cg, G * Wt);
1750 Inc(Cb, B * Wt);
1751 end;
1752 end;
1753
1754 if RangeCheck then
1755 begin
1756 if Ca > $FF0000 then Ca := $FF0000
1757 else if Ca < 0 then Ca := 0
1758 else Ca := Ca and $00FF0000;
1759
1760 if Cr > $FF0000 then Cr := $FF0000
1761 else if Cr < 0 then Cr := 0
1762 else Cr := Cr and $00FF0000;
1763
1764 if Cg > $FF0000 then Cg := $FF0000
1765 else if Cg < 0 then Cg := 0
1766 else Cg := Cg and $00FF0000;
1767
1768 if Cb > $FF0000 then Cb := $FF0000
1769 else if Cb < 0 then Cb := 0
1770 else Cb := Cb and $00FF0000;
1771
1772 C := (Ca shl 8) or Cr or (Cg shr 8) or (Cb shr 16);
1773 end
1774 else
1775 C := ((Ca and $00FF0000) shl 8) or (Cr and $00FF0000) or ((Cg and $00FF0000) shr 8) or ((Cb and $00FF0000) shr 16);
1776
1777 // combine it with the background
1778 case CombineOp of
1779 dmOpaque: DstLine[I] := C;
1780 dmBlend: BlendMemEx(C, DstLine[I], Src.MasterAlpha);
1781 dmTransparent: if C <> Src.OuterColor then DstLine[I] := C;
1782 dmCustom: CombineCallBack(C, DstLine[I], Src.MasterAlpha);
1783 end;
1784 end;
1785 end;
1786 finally
1787 EMMS;
1788 MapX := nil;
1789 MapY := nil;
1790 end;
1791end;
1792{$WARNINGS ON}
1793
1794{ Draft Resample Routines }
1795
1796function BlockAverage_Pas(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32;
1797var
1798 C: PColor32Entry;
1799 ix, iy, iA, iR, iG, iB, Area: Cardinal;
1800begin
1801 iR := 0; iB := iR; iG := iR; iA := iR;
1802 for iy := 1 to Dly do
1803 begin
1804 C := PColor32Entry(RowSrc);
1805 for ix := 1 to Dlx do
1806 begin
1807 Inc(iB, C.B);
1808 Inc(iG, C.G);
1809 Inc(iR, C.R);
1810 Inc(iA, C.A);
1811 Inc(C);
1812 end;
1813 {$IFDEF HAS_NATIVEINT}
1814 Inc(NativeUInt(RowSrc), OffSrc);
1815 {$ELSE}
1816 Inc(PByte(RowSrc), OffSrc);
1817 {$ENDIF}
1818 end;
1819
1820 Area := Dlx * Dly;
1821 Area := $1000000 div Area;
1822 Result := iA * Area and $FF000000 or
1823 iR * Area shr 8 and $FF0000 or
1824 iG * Area shr 16 and $FF00 or
1825 iB * Area shr 24 and $FF;
1826end;
1827
1828{$IFNDEF PUREPASCAL}
1829function BlockAverage_MMX(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32;
1830asm
1831{$IFDEF TARGET_X64}
1832 MOV R10D,ECX
1833 MOV R11D,EDX
1834
1835 SHL R10,$02
1836 SUB R9,R10
1837
1838 PXOR MM1,MM1
1839 PXOR MM2,MM2
1840 PXOR MM7,MM7
1841
1842@@LoopY:
1843 MOV R10,RCX
1844 PXOR MM0,MM0
1845 LEA R8,[R8+R10*4]
1846 NEG R10
1847@@LoopX:
1848 MOVD MM6,[R8+R10*4]
1849 PUNPCKLBW MM6,MM7
1850 PADDW MM0,MM6
1851 INC R10
1852 JNZ @@LoopX
1853
1854 MOVQ MM6,MM0
1855 PUNPCKLWD MM6,MM7
1856 PADDD MM1,MM6
1857 MOVQ MM6,MM0
1858 PUNPCKHWD MM6,MM7
1859 PADDD MM2,MM6
1860 ADD R8,R9
1861 DEC EDX
1862 JNZ @@LoopY
1863
1864 MOV EAX, ECX
1865 MUL R11D
1866 MOV ECX,EAX
1867 MOV EAX,$01000000
1868 DIV ECX
1869 MOV ECX,EAX
1870
1871 MOVD EAX,MM1
1872 MUL ECX
1873 SHR EAX,$18
1874 MOV R11D,EAX
1875
1876 PSRLQ MM1,$20
1877 MOVD EAX,MM1
1878 MUL ECX
1879 SHR EAX,$10
1880 AND EAX,$0000FF00
1881 ADD R11D,EAX
1882
1883 MOVD EAX,MM2
1884 MUL ECX
1885 SHR EAX,$08
1886 AND EAX,$00FF0000
1887 ADD R11D,EAX
1888
1889 PSRLQ MM2,$20
1890 MOVD EAX,MM2
1891 MUL ECX
1892 AND EAX,$FF000000
1893 ADD EAX,R11D
1894{$ELSE}
1895 PUSH EBX
1896 PUSH ESI
1897 PUSH EDI
1898
1899 MOV EBX,OffSrc
1900 MOV ESI,EAX
1901 MOV EDI,EDX
1902
1903 SHL ESI,$02
1904 SUB EBX,ESI
1905
1906 PXOR MM1,MM1
1907 PXOR MM2,MM2
1908 PXOR MM7,MM7
1909
1910@@LoopY:
1911 MOV ESI,EAX
1912 PXOR MM0,MM0
1913 LEA ECX,[ECX+ESI*4]
1914 NEG ESI
1915@@LoopX:
1916 MOVD MM6,[ECX+ESI*4]
1917 PUNPCKLBW MM6,MM7
1918 PADDW MM0,MM6
1919 INC ESI
1920 JNZ @@LoopX
1921
1922 MOVQ MM6,MM0
1923 PUNPCKLWD MM6,MM7
1924 PADDD MM1,MM6
1925 MOVQ MM6,MM0
1926 PUNPCKHWD MM6,MM7
1927 PADDD MM2,MM6
1928 ADD ECX,EBX
1929 DEC EDX
1930 JNZ @@LoopY
1931
1932 MUL EDI
1933 MOV ECX,EAX
1934 MOV EAX,$01000000
1935 DIV ECX
1936 MOV ECX,EAX
1937
1938 MOVD EAX,MM1
1939 MUL ECX
1940 SHR EAX,$18
1941 MOV EDI,EAX
1942
1943 PSRLQ MM1,$20
1944 MOVD EAX,MM1
1945 MUL ECX
1946 SHR EAX,$10
1947 AND EAX,$0000FF00
1948 ADD EDI,EAX
1949
1950 MOVD EAX,MM2
1951 MUL ECX
1952 SHR EAX,$08
1953 AND EAX,$00FF0000
1954 ADD EDI,EAX
1955
1956 PSRLQ MM2,$20
1957 MOVD EAX,MM2
1958 MUL ECX
1959 AND EAX,$FF000000
1960 ADD EAX,EDI
1961
1962 POP EDI
1963 POP ESI
1964 POP EBX
1965{$ENDIF}
1966end;
1967
1968{$IFDEF USE_3DNOW}
1969function BlockAverage_3DNow(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32;
1970asm
1971 PUSH EBX
1972 PUSH ESI
1973 PUSH EDI
1974
1975 MOV EBX,OffSrc
1976 MOV ESI,EAX
1977 MOV EDI,EDX
1978
1979 SHL ESI,$02
1980 SUB EBX,ESI
1981
1982 PXOR MM1,MM1
1983 PXOR MM2,MM2
1984 PXOR MM7,MM7
1985
1986@@LoopY:
1987 MOV ESI,EAX
1988 PXOR MM0,MM0
1989 LEA ECX,[ECX+ESI*4]
1990 NEG ESI
1991 db $0F,$0D,$84,$B1,$00,$02,$00,$00 // PREFETCH [ECX + ESI * 4 + 512]
1992@@LoopX:
1993 MOVD MM6,[ECX + ESI * 4]
1994 PUNPCKLBW MM6,MM7
1995 PADDW MM0,MM6
1996 INC ESI
1997
1998 JNZ @@LoopX
1999
2000 MOVQ MM6,MM0
2001 PUNPCKLWD MM6,MM7
2002 PADDD MM1,MM6
2003 MOVQ MM6,MM0
2004 PUNPCKHWD MM6,MM7
2005 PADDD MM2,MM6
2006 ADD ECX,EBX
2007 DEC EDX
2008
2009 JNZ @@LoopY
2010
2011 MUL EDI
2012 MOV ECX,EAX
2013 MOV EAX,$01000000
2014 div ECX
2015 MOV ECX,EAX
2016
2017 MOVD EAX,MM1
2018 MUL ECX
2019 SHR EAX,$18
2020 MOV EDI,EAX
2021
2022 PSRLQ MM1,$20
2023 MOVD EAX,MM1
2024 MUL ECX
2025 SHR EAX,$10
2026 AND EAX,$0000FF00
2027 ADD EDI,EAX
2028
2029 MOVD EAX,MM2
2030 MUL ECX
2031 SHR EAX,$08
2032 AND EAX,$00FF0000
2033 ADD EDI,EAX
2034
2035 PSRLQ MM2,$20
2036 MOVD EAX,MM2
2037 MUL ECX
2038 AND EAX,$FF000000
2039 ADD EAX,EDI
2040
2041 POP EDI
2042 POP ESI
2043 POP EBX
2044end;
2045{$ENDIF}
2046
2047function BlockAverage_SSE2(Dlx, Dly: Cardinal; RowSrc: PColor32; OffSrc: Cardinal): TColor32;
2048asm
2049{$IFDEF TARGET_X64}
2050 MOV EAX,ECX
2051 MOV R10D,EDX
2052
2053 SHL EAX,$02
2054 SUB R9D,EAX
2055
2056 PXOR XMM1,XMM1
2057 PXOR XMM2,XMM2
2058 PXOR XMM7,XMM7
2059
2060@@LoopY:
2061 MOV EAX,ECX
2062 PXOR XMM0,XMM0
2063 LEA R8,[R8+RAX*4]
2064 NEG RAX
2065@@LoopX:
2066 MOVD XMM6,[R8+RAX*4]
2067 PUNPCKLBW XMM6,XMM7
2068 PADDW XMM0,XMM6
2069 INC RAX
2070 JNZ @@LoopX
2071
2072 MOVQ XMM6,XMM0
2073 PUNPCKLWD XMM6,XMM7
2074 PADDD XMM1,XMM6
2075 ADD R8,R9
2076 DEC EDX
2077 JNZ @@LoopY
2078
2079 MOV EAX, ECX
2080 MUL R10D
2081 MOV ECX,EAX
2082 MOV EAX,$01000000
2083 DIV ECX
2084 MOV ECX,EAX
2085
2086 MOVD EAX,XMM1
2087 MUL ECX
2088 SHR EAX,$18
2089 MOV R10D,EAX
2090
2091 SHUFPS XMM1,XMM1,$39
2092 MOVD EAX,XMM1
2093 MUL ECX
2094 SHR EAX,$10
2095 AND EAX,$0000FF00
2096 ADD R10D,EAX
2097
2098 PSHUFD XMM1,XMM1,$39
2099 MOVD EAX,XMM1
2100 MUL ECX
2101 SHR EAX,$08
2102 AND EAX,$00FF0000
2103 ADD R10D,EAX
2104
2105 PSHUFD XMM1,XMM1,$39
2106 MOVD EAX,XMM1
2107 MUL ECX
2108 AND EAX,$FF000000
2109 ADD EAX,R10D
2110{$ELSE}
2111 PUSH EBX
2112 PUSH ESI
2113 PUSH EDI
2114
2115 MOV EBX,OffSrc
2116 MOV ESI,EAX
2117 MOV EDI,EDX
2118
2119 SHL ESI,$02
2120 SUB EBX,ESI
2121
2122 PXOR XMM1,XMM1
2123 PXOR XMM2,XMM2
2124 PXOR XMM7,XMM7
2125
2126@@LoopY:
2127 MOV ESI,EAX
2128 PXOR XMM0,XMM0
2129 LEA ECX,[ECX+ESI*4]
2130 NEG ESI
2131@@LoopX:
2132 MOVD XMM6,[ECX+ESI*4]
2133 PUNPCKLBW XMM6,XMM7
2134 PADDW XMM0,XMM6
2135 INC ESI
2136 JNZ @@LoopX
2137
2138 MOVQ XMM6,XMM0
2139 PUNPCKLWD XMM6,XMM7
2140 PADDD XMM1,XMM6
2141 ADD ECX,EBX
2142 DEC EDX
2143 JNZ @@LoopY
2144
2145 MUL EDI
2146 MOV ECX,EAX
2147 MOV EAX,$01000000
2148 DIV ECX
2149 MOV ECX,EAX
2150
2151 MOVD EAX,XMM1
2152 MUL ECX
2153 SHR EAX,$18
2154 MOV EDI,EAX
2155
2156 SHUFPS XMM1,XMM1,$39
2157 MOVD EAX,XMM1
2158 MUL ECX
2159 SHR EAX,$10
2160 AND EAX,$0000FF00
2161 ADD EDI,EAX
2162
2163 PSHUFD XMM1,XMM1,$39
2164 MOVD EAX,XMM1
2165 MUL ECX
2166 SHR EAX,$08
2167 AND EAX,$00FF0000
2168 ADD EDI,EAX
2169
2170 PSHUFD XMM1,XMM1,$39
2171 MOVD EAX,XMM1
2172 MUL ECX
2173 AND EAX,$FF000000
2174 ADD EAX,EDI
2175
2176 POP EDI
2177 POP ESI
2178 POP EBX
2179{$ENDIF}
2180end;
2181{$ENDIF}
2182
2183
2184procedure DraftResample(Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
2185 Src: TCustomBitmap32; SrcRect: TRect; Kernel: TCustomKernel;
2186 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent);
2187var
2188 SrcW, SrcH,
2189 DstW, DstH,
2190 DstClipW, DstClipH: Cardinal;
2191 RowSrc: PColor32;
2192 xsrc: PColor32;
2193 OffSrc,
2194 dy, dx,
2195 c1, c2, r1, r2,
2196 xs: Cardinal;
2197 C: TColor32;
2198 DstLine: PColor32Array;
2199 ScaleFactor: TFloat;
2200 I,J, sc, sr, cx, cy: Integer;
2201 BlendMemEx: TBlendMemEx;
2202begin
2203 { rangechecking and rect intersection done by caller }
2204
2205 SrcW := SrcRect.Right - SrcRect.Left;
2206 SrcH := SrcRect.Bottom - SrcRect.Top;
2207
2208 DstW := DstRect.Right - DstRect.Left;
2209 DstH := DstRect.Bottom - DstRect.Top;
2210
2211 DstClipW := DstClip.Right - DstClip.Left;
2212 DstClipH := DstClip.Bottom - DstClip.Top;
2213
2214 BlendMemEx := BLEND_MEM_EX[Src.CombineMode]^;
2215
2216 if (DstW > SrcW)or(DstH > SrcH) then begin
2217 if (SrcW < 2) or (SrcH < 2) then
2218 Resample(Dst, DstRect, DstClip, Src, SrcRect, Kernel, CombineOp,
2219 CombineCallBack)
2220 else
2221 StretchHorzStretchVertLinear(Dst, DstRect, DstClip, Src, SrcRect, CombineOp,
2222 CombineCallBack);
2223 end
2224 else
2225 begin //Full Scaledown, ignores Fulledge - cannot be integrated into this resampling method
2226 OffSrc := Src.Width * 4;
2227
2228 ScaleFactor:= SrcW / DstW;
2229 cx := Trunc( (DstClip.Left - DstRect.Left) * ScaleFactor);
2230 r2 := Trunc(ScaleFactor);
2231 sr := Trunc( $10000 * ScaleFactor );
2232
2233 ScaleFactor:= SrcH / DstH;
2234 cy := Trunc( (DstClip.Top - DstRect.Top) * ScaleFactor);
2235 c2 := Trunc(ScaleFactor);
2236 sc := Trunc( $10000 * ScaleFactor );
2237
2238 DstLine := PColor32Array(Dst.PixelPtr[0, DstClip.Top]);
2239 RowSrc := Src.PixelPtr[SrcRect.Left + cx, SrcRect.Top + cy ];
2240
2241 xs := r2;
2242 c1 := 0;
2243 Dec(DstClip.Left, 2);
2244 Inc(DstClipW);
2245 Inc(DstClipH);
2246
2247 for J := 2 to DstClipH do
2248 begin
2249 dy := c2 - c1;
2250 c1 := c2;
2251 c2 := FixedMul(J, sc);
2252 r1 := 0;
2253 r2 := xs;
2254 xsrc := RowSrc;
2255
2256 case CombineOp of
2257 dmOpaque:
2258 for I := 2 to DstClipW do
2259 begin
2260 dx := r2 - r1; r1 := r2;
2261 r2 := FixedMul(I, sr);
2262 DstLine[DstClip.Left + I] := BlockAverage(dx, dy, xsrc, OffSrc);
2263 Inc(xsrc, dx);
2264 end;
2265 dmBlend:
2266 for I := 2 to DstClipW do
2267 begin
2268 dx := r2 - r1; r1 := r2;
2269 r2 := FixedMul(I, sr);
2270 BlendMemEx(BlockAverage(dx, dy, xsrc, OffSrc),
2271 DstLine[DstClip.Left + I], Src.MasterAlpha);
2272 Inc(xsrc, dx);
2273 end;
2274 dmTransparent:
2275 for I := 2 to DstClipW do
2276 begin
2277 dx := r2 - r1; r1 := r2;
2278 r2 := FixedMul(I, sr);
2279 C := BlockAverage(dx, dy, xsrc, OffSrc);
2280 if C <> Src.OuterColor then DstLine[DstClip.Left + I] := C;
2281 Inc(xsrc, dx);
2282 end;
2283 dmCustom:
2284 for I := 2 to DstClipW do
2285 begin
2286 dx := r2 - r1; r1 := r2;
2287 r2 := FixedMul(I, sr);
2288 CombineCallBack(BlockAverage(dx, dy, xsrc, OffSrc),
2289 DstLine[DstClip.Left + I], Src.MasterAlpha);
2290 Inc(xsrc, dx);
2291 end;
2292 end;
2293
2294 Inc(DstLine, Dst.Width);
2295 {$IFDEF HAS_NATIVEINT}
2296 Inc(NativeUInt(RowSrc), OffSrc * dy);
2297 {$ELSE}
2298 Inc(PByte(RowSrc), OffSrc * dy);
2299 {$ENDIF}
2300 end;
2301 end;
2302 EMMS;
2303end;
2304
2305{ Special interpolators (for sfLinear and sfDraft) }
2306
2307function Interpolator_Pas(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32;
2308var
2309 C1, C3: TColor32;
2310begin
2311 if WX_256 > $FF then WX_256:= $FF;
2312 if WY_256 > $FF then WY_256:= $FF;
2313 C1 := C11^; Inc(C11);
2314 C3 := C21^; Inc(C21);
2315 Result := CombineReg(CombineReg(C1, C11^, WX_256),
2316 CombineReg(C3, C21^, WX_256), WY_256);
2317end;
2318
2319{$IFNDEF PUREPASCAL}
2320function Interpolator_MMX(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32;
2321asm
2322{$IFDEF TARGET_X64}
2323 MOV RAX, RCX
2324 MOVQ MM1,QWORD PTR [R8]
2325 MOVQ MM2,MM1
2326 MOVQ MM3,QWORD PTR [R9]
2327{$ELSE}
2328 MOVQ MM1,[ECX]
2329 MOVQ MM2,MM1
2330 MOV ECX,C21
2331 MOVQ MM3,[ECX]
2332{$ENDIF}
2333 PSRLQ MM1,32
2334 MOVQ MM4,MM3
2335 PSRLQ MM3,32
2336 MOVD MM5,EAX
2337 PSHUFW MM5,MM5,0
2338 PXOR MM0,MM0
2339 PUNPCKLBW MM1,MM0
2340 PUNPCKLBW MM2,MM0
2341 PSUBW MM2,MM1
2342 PMULLW MM2,MM5
2343 PSLLW MM1,8
2344 PADDW MM2,MM1
2345 PSRLW MM2,8
2346 PUNPCKLBW MM3,MM0
2347 PUNPCKLBW MM4,MM0
2348 PSUBW MM4,MM3
2349 PSLLW MM3,8
2350 PMULLW MM4,MM5
2351 PADDW MM4,MM3
2352 PSRLW MM4,8
2353 MOVD MM5,EDX
2354 PSHUFW MM5,MM5,0
2355 PSUBW MM2,MM4
2356 PMULLW MM2,MM5
2357 PSLLW MM4,8
2358 PADDW MM2,MM4
2359 PSRLW MM2,8
2360 PACKUSWB MM2,MM0
2361 MOVD EAX,MM2
2362end;
2363
2364function Interpolator_SSE2(WX_256, WY_256: Cardinal; C11, C21: PColor32): TColor32;
2365asm
2366{$IFDEF TARGET_X64}
2367 MOV RAX, RCX
2368 MOVQ XMM1,QWORD PTR [R8]
2369 MOVQ XMM2,XMM1
2370 MOVQ XMM3,QWORD PTR [R9]
2371{$ELSE}
2372 MOVQ XMM1,[ECX]
2373 MOVQ XMM2,XMM1
2374 MOV ECX,C21
2375 MOVQ XMM3,[ECX]
2376{$ENDIF}
2377 PSRLQ XMM1,32
2378 MOVQ XMM4,XMM3
2379 PSRLQ XMM3,32
2380 MOVD XMM5,EAX
2381 PSHUFLW XMM5,XMM5,0
2382 PXOR XMM0,XMM0
2383 PUNPCKLBW XMM1,XMM0
2384 PUNPCKLBW XMM2,XMM0
2385 PSUBW XMM2,XMM1
2386 PMULLW XMM2,XMM5
2387 PSLLW XMM1,8
2388 PADDW XMM2,XMM1
2389 PSRLW XMM2,8
2390 PUNPCKLBW XMM3,XMM0
2391 PUNPCKLBW XMM4,XMM0
2392 PSUBW XMM4,XMM3
2393 PSLLW XMM3,8
2394 PMULLW XMM4,XMM5
2395 PADDW XMM4,XMM3
2396 PSRLW XMM4,8
2397 MOVD XMM5,EDX
2398 PSHUFLW XMM5,XMM5,0
2399 PSUBW XMM2,XMM4
2400 PMULLW XMM2,XMM5
2401 PSLLW XMM4,8
2402 PADDW XMM2,XMM4
2403 PSRLW XMM2,8
2404 PACKUSWB XMM2,XMM0
2405 MOVD EAX,XMM2
2406end;
2407{$ENDIF}
2408
2409{ Stretch Transfer }
2410
2411{$WARNINGS OFF}
2412procedure StretchTransfer(
2413 Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
2414 Src: TCustomBitmap32; SrcRect: TRect;
2415 Resampler: TCustomResampler;
2416 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent);
2417var
2418 SrcW, SrcH: Integer;
2419 DstW, DstH: Integer;
2420 R: TRect;
2421 RatioX, RatioY: Single;
2422begin
2423 CheckBitmaps(Dst, Src);
2424
2425 // transform dest rect when the src rect is out of the src bitmap's bounds
2426 if (SrcRect.Left < 0) or (SrcRect.Right > Src.Width) or
2427 (SrcRect.Top < 0) or (SrcRect.Bottom > Src.Height) then
2428 begin
2429 RatioX := (DstRect.Right - DstRect.Left) / (SrcRect.Right - SrcRect.Left);
2430 RatioY := (DstRect.Bottom - DstRect.Top) / (SrcRect.Bottom - SrcRect.Top);
2431
2432 if SrcRect.Left < 0 then
2433 begin
2434 DstRect.Left := DstRect.Left + Ceil(-SrcRect.Left * RatioX);
2435 SrcRect.Left := 0;
2436 end;
2437
2438 if SrcRect.Top < 0 then
2439 begin
2440 DstRect.Top := DstRect.Top + Ceil(-SrcRect.Top * RatioY);
2441 SrcRect.Top := 0;
2442 end;
2443
2444 if SrcRect.Right > Src.Width then
2445 begin
2446 DstRect.Right := DstRect.Right - Floor((SrcRect.Right - Src.Width) * RatioX);
2447 SrcRect.Right := Src.Width;
2448 end;
2449
2450 if SrcRect.Bottom > Src.Height then
2451 begin
2452 DstRect.Bottom := DstRect.Bottom - Floor((SrcRect.Bottom - Src.Height) * RatioY);
2453 SrcRect.Bottom := Src.Height;
2454 end;
2455 end;
2456
2457 if Src.Empty or Dst.Empty or
2458 ((CombineOp = dmBlend) and (Src.MasterAlpha = 0)) or
2459 GR32.IsRectEmpty(SrcRect) then
2460 Exit;
2461
2462 if not Dst.MeasuringMode then
2463 begin
2464 GR32.IntersectRect(DstClip, DstClip, Dst.BoundsRect);
2465 GR32.IntersectRect(DstClip, DstClip, DstRect);
2466 if GR32.IsRectEmpty(DstClip) then Exit;
2467 GR32.IntersectRect(R, DstClip, DstRect);
2468 if GR32.IsRectEmpty(R) then Exit;
2469
2470 if (CombineOp = dmCustom) and not Assigned(CombineCallBack) then
2471 CombineOp := dmOpaque;
2472
2473 SrcW := SrcRect.Right - SrcRect.Left;
2474 SrcH := SrcRect.Bottom - SrcRect.Top;
2475 DstW := DstRect.Right - DstRect.Left;
2476 DstH := DstRect.Bottom - DstRect.Top;
2477
2478 try
2479 if (SrcW = DstW) and (SrcH = DstH) then
2480 BlendBlock(Dst, DstClip, Src, SrcRect.Left + DstClip.Left - DstRect.Left,
2481 SrcRect.Top + DstClip.Top - DstRect.Top, CombineOp, CombineCallBack)
2482 else
2483 TCustomResamplerAccess(Resampler).Resample(
2484 Dst, DstRect, DstClip, Src, SrcRect, CombineOp, CombineCallBack);
2485 finally
2486 EMMS;
2487 end;
2488 end;
2489
2490 Dst.Changed(DstRect);
2491end;
2492{$WARNINGS ON}
2493
2494
2495{ TByteMap downsample functions }
2496
2497procedure DownsampleByteMap2x(Source, Dest: TByteMap);
2498var
2499 X, Y: Integer;
2500 ScnLn: array [0 .. 2] of PByteArray;
2501begin
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;
2512end;
2513
2514procedure DownsampleByteMap3x(Source, Dest: TByteMap);
2515var
2516 X, Y: Integer;
2517 x3: Integer;
2518 ScnLn: array [0 .. 3] of PByteArray;
2519begin
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;
2535end;
2536
2537procedure DownsampleByteMap4x(Source, Dest: TByteMap);
2538var
2539 X, Y: Integer;
2540 x4: Integer;
2541 ScnLn: array [0 .. 4] of PByteArray;
2542begin
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;
2560end;
2561
2562
2563{ TCustomKernel }
2564
2565procedure TCustomKernel.AssignTo(Dst: TPersistent);
2566begin
2567 if Dst is TCustomKernel then
2568 SmartAssign(Self, Dst)
2569 else
2570 inherited;
2571end;
2572
2573procedure TCustomKernel.Changed;
2574begin
2575 if Assigned(FObserver) then FObserver.Changed;
2576end;
2577
2578constructor TCustomKernel.Create;
2579begin
2580end;
2581
2582function TCustomKernel.RangeCheck: Boolean;
2583begin
2584 Result := False;
2585end;
2586
2587
2588{ TBoxKernel }
2589
2590function TBoxKernel.Filter(Value: TFloat): TFloat;
2591begin
2592 if (Value >= -0.5) and (Value <= 0.5) then Result := 1.0
2593 else Result := 0;
2594end;
2595
2596function TBoxKernel.GetWidth: TFloat;
2597begin
2598 Result := 1;
2599end;
2600
2601{ TLinearKernel }
2602
2603function TLinearKernel.Filter(Value: TFloat): TFloat;
2604begin
2605 if Value < -1 then Result := 0
2606 else if Value < 0 then Result := 1 + Value
2607 else if Value < 1 then Result := 1 - Value
2608 else Result := 0;
2609end;
2610
2611function TLinearKernel.GetWidth: TFloat;
2612begin
2613 Result := 1;
2614end;
2615
2616{ TCosineKernel }
2617
2618function TCosineKernel.Filter(Value: TFloat): TFloat;
2619begin
2620 Result := 0;
2621 if Abs(Value) < 1 then
2622 Result := (Cos(Value * Pi) + 1) * 0.5;
2623end;
2624
2625function TCosineKernel.GetWidth: TFloat;
2626begin
2627 Result := 1;
2628end;
2629
2630{ TSplineKernel }
2631
2632function TSplineKernel.Filter(Value: TFloat): TFloat;
2633var
2634 tt: TFloat;
2635const
2636 TwoThirds = 2 / 3;
2637 OneSixth = 1 / 6;
2638begin
2639 Value := Abs(Value);
2640 if Value < 1 then
2641 begin
2642 tt := Sqr(Value);
2643 Result := 0.5 * tt * Value - tt + TwoThirds;
2644 end
2645 else if Value < 2 then
2646 begin
2647 Value := 2 - Value;
2648 Result := OneSixth * Sqr(Value) * Value;
2649 end
2650 else Result := 0;
2651end;
2652
2653function TSplineKernel.RangeCheck: Boolean;
2654begin
2655 Result := True;
2656end;
2657
2658function TSplineKernel.GetWidth: TFloat;
2659begin
2660 Result := 2;
2661end;
2662
2663{ TWindowedSincKernel }
2664
2665function SInc(Value: TFloat): TFloat;
2666begin
2667 if Value <> 0 then
2668 begin
2669 Value := Value * Pi;
2670 Result := Sin(Value) / Value;
2671 end
2672 else Result := 1;
2673end;
2674
2675constructor TWindowedSincKernel.Create;
2676begin
2677 FWidth := 3;
2678 FWidthReciprocal := 1 / FWidth;
2679end;
2680
2681function TWindowedSincKernel.Filter(Value: TFloat): TFloat;
2682begin
2683 Value := Abs(Value);
2684 if Value < FWidth then
2685 Result := SInc(Value) * Window(Value)
2686 else
2687 Result := 0;
2688end;
2689
2690function TWindowedSincKernel.RangeCheck: Boolean;
2691begin
2692 Result := True;
2693end;
2694
2695procedure TWindowedSincKernel.SetWidth(Value: TFloat);
2696begin
2697 Value := Min(MAX_KERNEL_WIDTH, Value);
2698 if Value <> FWidth then
2699 begin
2700 FWidth := Value;
2701 FWidthReciprocal := 1 / FWidth;
2702 Changed;
2703 end;
2704end;
2705
2706function TWindowedSincKernel.GetWidth: TFloat;
2707begin
2708 Result := FWidth;
2709end;
2710
2711{ TAlbrechtKernel }
2712
2713constructor TAlbrechtKernel.Create;
2714begin
2715 inherited;
2716 Terms := 7;
2717end;
2718
2719procedure TAlbrechtKernel.SetTerms(Value: Integer);
2720begin
2721 if (Value < 2) then Value := 2;
2722 if (Value > 11) then Value := 11;
2723 if FTerms <> Value then
2724 begin
2725 FTerms := Value;
2726 case Value of
2727 2 : Move(CAlbrecht2 [0], FCoefPointer[0], Value * SizeOf(Double));
2728 3 : Move(CAlbrecht3 [0], FCoefPointer[0], Value * SizeOf(Double));
2729 4 : Move(CAlbrecht4 [0], FCoefPointer[0], Value * SizeOf(Double));
2730 5 : Move(CAlbrecht5 [0], FCoefPointer[0], Value * SizeOf(Double));
2731 6 : Move(CAlbrecht6 [0], FCoefPointer[0], Value * SizeOf(Double));
2732 7 : Move(CAlbrecht7 [0], FCoefPointer[0], Value * SizeOf(Double));
2733 8 : Move(CAlbrecht8 [0], FCoefPointer[0], Value * SizeOf(Double));
2734 9 : Move(CAlbrecht9 [0], FCoefPointer[0], Value * SizeOf(Double));
2735 10 : Move(CAlbrecht10[0], FCoefPointer[0], Value * SizeOf(Double));
2736 11 : Move(CAlbrecht11[0], FCoefPointer[0], Value * SizeOf(Double));
2737 end;
2738 end;
2739end;
2740
2741function TAlbrechtKernel.Window(Value: TFloat): TFloat;
2742var
2743 cs : Double;
2744 i : Integer;
2745begin
2746 cs := Cos(Pi * Value * FWidthReciprocal);
2747 i := FTerms - 1;
2748 Result := FCoefPointer[i];
2749 while i > 0 do
2750 begin
2751 Dec(i);
2752 Result := Result * cs + FCoefPointer[i];
2753 end;
2754end;
2755
2756{ TLanczosKernel }
2757
2758function TLanczosKernel.Window(Value: TFloat): TFloat;
2759begin
2760 Result := SInc(Value * FWidthReciprocal); // Get rid of division
2761end;
2762
2763{ TMitchellKernel }
2764
2765function TMitchellKernel.Filter(Value: TFloat): TFloat;
2766var
2767 tt, ttt: TFloat;
2768const OneEighteenth = 1 / 18;
2769begin
2770 Value := Abs(Value);
2771 tt := Sqr(Value);
2772 ttt := tt * Value;
2773 if Value < 1 then Result := (21 * ttt - 36 * tt + 16 ) * OneEighteenth // get rid of divisions
2774 else if Value < 2 then Result := (- 7 * ttt + 36 * tt - 60 * Value + 32) * OneEighteenth // "
2775 else Result := 0;
2776end;
2777
2778function TMitchellKernel.RangeCheck: Boolean;
2779begin
2780 Result := True;
2781end;
2782
2783function TMitchellKernel.GetWidth: TFloat;
2784begin
2785 Result := 2;
2786end;
2787
2788{ TCubicKernel }
2789
2790constructor TCubicKernel.Create;
2791begin
2792 FCoeff := -0.5;
2793end;
2794
2795function TCubicKernel.Filter(Value: TFloat): TFloat;
2796var
2797 tt, ttt: TFloat;
2798begin
2799 Value := Abs(Value);
2800 tt := Sqr(Value);
2801 ttt := tt * Value;
2802 if Value < 1 then
2803 Result := (FCoeff + 2) * ttt - (FCoeff + 3) * tt + 1
2804 else if Value < 2 then
2805 Result := FCoeff * (ttt - 5 * tt + 8 * Value - 4)
2806 else
2807 Result := 0;
2808end;
2809
2810function TCubicKernel.RangeCheck: Boolean;
2811begin
2812 Result := True;
2813end;
2814
2815function TCubicKernel.GetWidth: TFloat;
2816begin
2817 Result := 2;
2818end;
2819
2820{ TGaussKernel }
2821
2822constructor TGaussianKernel.Create;
2823begin
2824 inherited;
2825 FSigma := 1.33;
2826 FSigmaReciprocalLn2 := -Ln(2) / FSigma;
2827end;
2828
2829procedure TGaussianKernel.SetSigma(const Value: TFloat);
2830begin
2831 if (FSigma <> Value) and (FSigma <> 0) then
2832 begin
2833 FSigma := Value;
2834 FSigmaReciprocalLn2 := -Ln(2) / FSigma;
2835 Changed;
2836 end;
2837end;
2838
2839function TGaussianKernel.Window(Value: TFloat): TFloat;
2840begin
2841 Result := Exp(Sqr(Value) * FSigmaReciprocalLn2); // get rid of nasty LN2 and divition
2842end;
2843
2844procedure TCubicKernel.SetCoeff(const Value: TFloat);
2845begin
2846 if Value <> FCoeff then
2847 begin
2848 FCoeff := Value;
2849 Changed;
2850 end
2851end;
2852
2853{ TBlackmanKernel }
2854
2855function TBlackmanKernel.Window(Value: TFloat): TFloat;
2856begin
2857 Value := Cos(Pi * Value * FWidthReciprocal); // get rid of division
2858 Result := 0.34 + 0.5 * Value + 0.16 * sqr(Value);
2859end;
2860
2861{ THannKernel }
2862
2863function THannKernel.Window(Value: TFloat): TFloat;
2864begin
2865 Result := 0.5 + 0.5 * Cos(Pi * Value * FWidthReciprocal); // get rid of division
2866end;
2867
2868{ THammingKernel }
2869
2870function THammingKernel.Window(Value: TFloat): TFloat;
2871begin
2872 Result := 0.54 + 0.46 * Cos(Pi * Value * FWidthReciprocal); // get rid of division
2873end;
2874
2875{ TSinshKernel }
2876
2877constructor TSinshKernel.Create;
2878begin
2879 FWidth := 3;
2880 FCoeff := 0.5;
2881end;
2882
2883function TSinshKernel.Filter(Value: TFloat): TFloat;
2884begin
2885 if Value = 0 then
2886 Result := 1
2887 else
2888 Result := FCoeff * Sin(Pi * Value) / Sinh(Pi * FCoeff * Value);
2889end;
2890
2891function TSinshKernel.RangeCheck: Boolean;
2892begin
2893 Result := True;
2894end;
2895
2896procedure TSinshKernel.SetWidth(Value: TFloat);
2897begin
2898 if FWidth <> Value then
2899 begin
2900 FWidth := Value;
2901 Changed;
2902 end;
2903end;
2904
2905function TSinshKernel.GetWidth: TFloat;
2906begin
2907 Result := FWidth;
2908end;
2909
2910procedure TSinshKernel.SetCoeff(const Value: TFloat);
2911begin
2912 if (FCoeff <> Value) and (FCoeff <> 0) then
2913 begin
2914 FCoeff := Value;
2915 Changed;
2916 end;
2917end;
2918
2919{ THermiteKernel }
2920
2921constructor THermiteKernel.Create;
2922begin
2923 FBias := 0;
2924 FTension := 0;
2925end;
2926
2927function THermiteKernel.Filter(Value: TFloat): TFloat;
2928var
2929 Z: Integer;
2930 t, t2, t3, m0, m1, a0, a1, a2, a3: TFloat;
2931begin
2932 t := (1 - FTension) * 0.5;
2933 m0 := (1 + FBias) * t;
2934 m1 := (1 - FBias) * t;
2935
2936 Z := Floor(Value);
2937 t := Abs(Z - Value);
2938 t2 := t * t;
2939 t3 := t2 * t;
2940
2941 a1 := t3 - 2 * t2 + t;
2942 a2 := t3 - t2;
2943 a3 := -2 * t3 + 3 * t2;
2944 a0 := -a3 + 1;
2945
2946 case Z of
2947 -2: Result := a2 * m1;
2948 -1: Result := a3 + a1 * m1 + a2 * (m0 - m1);
2949 0: Result := a0 + a1 * (m0 - m1) - a2 * m0;
2950 1: Result := -a1 * m0;
2951 else
2952 Result := 0;
2953 end;
2954end;
2955
2956function THermiteKernel.GetWidth: TFloat;
2957begin
2958 Result := 2;
2959end;
2960
2961function THermiteKernel.RangeCheck: Boolean;
2962begin
2963 Result := True;
2964end;
2965
2966procedure THermiteKernel.SetBias(const Value: TFloat);
2967begin
2968 if FBias <> Value then
2969 begin
2970 FBias := Value;
2971 Changed;
2972 end;
2973end;
2974
2975procedure THermiteKernel.SetTension(const Value: TFloat);
2976begin
2977 if FTension <> Value then
2978 begin
2979 FTension := Value;
2980 Changed;
2981 end;
2982end;
2983
2984
2985
2986{ TKernelResampler }
2987
2988constructor TKernelResampler.Create;
2989begin
2990 inherited;
2991 Kernel := TBoxKernel.Create;
2992 FTableSize := 32;
2993end;
2994
2995destructor TKernelResampler.Destroy;
2996begin
2997 FKernel.Free;
2998 inherited;
2999end;
3000
3001function TKernelResampler.GetKernelClassName: string;
3002begin
3003 Result := FKernel.ClassName;
3004end;
3005
3006procedure TKernelResampler.SetKernelClassName(const Value: string);
3007var
3008 KernelClass: TCustomKernelClass;
3009begin
3010 if (Value <> '') and (FKernel.ClassName <> Value) and Assigned(KernelList) then
3011 begin
3012 KernelClass := TCustomKernelClass(KernelList.Find(Value));
3013 if Assigned(KernelClass) then
3014 begin
3015 FKernel.Free;
3016 FKernel := KernelClass.Create;
3017 Changed;
3018 end;
3019 end;
3020end;
3021
3022procedure TKernelResampler.SetKernel(const Value: TCustomKernel);
3023begin
3024 if Assigned(Value) and (FKernel <> Value) then
3025 begin
3026 FKernel.Free;
3027 FKernel := Value;
3028 Changed;
3029 end;
3030end;
3031
3032procedure TKernelResampler.Resample(Dst: TCustomBitmap32; DstRect,
3033 DstClip: TRect; Src: TCustomBitmap32; SrcRect: TRect; CombineOp: TDrawMode;
3034 CombineCallBack: TPixelCombineEvent);
3035begin
3036 GR32_Resamplers.Resample(Dst, DstRect, DstClip, Src, SrcRect, FKernel, CombineOp, CombineCallBack);
3037end;
3038
3039{$WARNINGS OFF}
3040
3041function TKernelResampler.GetSampleFloat(X, Y: TFloat): TColor32;
3042var
3043 clX, clY: Integer;
3044 fracX, fracY: Integer;
3045 fracXS: TFloat absolute fracX;
3046 fracYS: TFloat absolute fracY;
3047
3048 Filter: TFilterMethod;
3049 WrapProcVert: TWrapProcEx absolute Filter;
3050 WrapProcHorz: TWrapProcEx;
3051 Colors: PColor32EntryArray;
3052 KWidth, W, Wv, I, J, Incr, Dev: Integer;
3053 SrcP: PColor32Entry;
3054 C: TColor32Entry absolute SrcP;
3055 LoX, HiX, LoY, HiY, MappingY: Integer;
3056
3057 HorzKernel, VertKernel: TKernelEntry;
3058 PHorzKernel, PVertKernel, FloorKernel, CeilKernel: PKernelEntry;
3059
3060 HorzEntry, VertEntry: TBufferEntry;
3061 MappingX: TKernelEntry;
3062 Edge: Boolean;
3063
3064 Alpha: integer;
3065 OuterPremultColorR, OuterPremultColorG, OuterPremultColorB: Byte;
3066begin
3067 KWidth := Ceil(FKernel.GetWidth);
3068
3069 clX := Ceil(X);
3070 clY := Ceil(Y);
3071
3072 case PixelAccessMode of
3073 pamUnsafe, pamWrap:
3074 begin
3075 LoX := -KWidth; HiX := KWidth;
3076 LoY := -KWidth; HiY := KWidth;
3077 end;
3078
3079 pamSafe, pamTransparentEdge:
3080 begin
3081 with ClipRect do
3082 begin
3083 if not ((clX < Left) or (clX > Right) or (clY < Top) or (clY > Bottom)) then
3084 begin
3085 Edge := False;
3086
3087 if clX - KWidth < Left then
3088 begin
3089 LoX := Left - clX;
3090 Edge := True;
3091 end
3092 else
3093 LoX := -KWidth;
3094
3095 if clX + KWidth >= Right then
3096 begin
3097 HiX := Right - clX - 1;
3098 Edge := True;
3099 end
3100 else
3101 HiX := KWidth;
3102
3103 if clY - KWidth < Top then
3104 begin
3105 LoY := Top - clY;
3106 Edge := True;
3107 end
3108 else
3109 LoY := -KWidth;
3110
3111 if clY + KWidth >= Bottom then
3112 begin
3113 HiY := Bottom - clY - 1;
3114 Edge := True;
3115 end
3116 else
3117 HiY := KWidth;
3118
3119 end
3120 else
3121 begin
3122 if PixelAccessMode = pamTransparentEdge then
3123 Result := 0
3124 else
3125 Result := FOuterColor;
3126 Exit;
3127 end;
3128
3129 end;
3130 end;
3131 end;
3132
3133 case FKernelMode of
3134 kmDynamic:
3135 begin
3136 Filter := FKernel.Filter;
3137 fracXS := clX - X;
3138 fracYS := clY - Y;
3139
3140 PHorzKernel := @HorzKernel;
3141 PVertKernel := @VertKernel;
3142
3143 Dev := -256;
3144 for I := -KWidth to KWidth do
3145 begin
3146 W := Round(Filter(I + fracXS) * 256);
3147 HorzKernel[I] := W;
3148 Inc(Dev, W);
3149 end;
3150 Dec(HorzKernel[0], Dev);
3151
3152 Dev := -256;
3153 for I := -KWidth to KWidth do
3154 begin
3155 W := Round(Filter(I + fracYS) * 256);
3156 VertKernel[I] := W;
3157 Inc(Dev, W);
3158 end;
3159 Dec(VertKernel[0], Dev);
3160
3161 end;
3162 kmTableNearest:
3163 begin
3164 W := FWeightTable.Height - 2;
3165 PHorzKernel := @FWeightTable.ValPtr[KWidth - MAX_KERNEL_WIDTH, Round((clX - X) * W)]^;
3166 PVertKernel := @FWeightTable.ValPtr[KWidth - MAX_KERNEL_WIDTH, Round((clY - Y) * W)]^;
3167 end;
3168 kmTableLinear:
3169 begin
3170 W := (FWeightTable.Height - 2) * $10000;
3171 J := FWeightTable.Width * 4;
3172
3173 with TFixedRec(FracX) do
3174 begin
3175 Fixed := Round((clX - X) * W);
3176 PHorzKernel := @HorzKernel;
3177 FloorKernel := @FWeightTable.ValPtr[KWidth - MAX_KERNEL_WIDTH, Int]^;
3178 {$IFDEF HAS_NATIVEINT}
3179 CeilKernel := PKernelEntry(NativeUInt(FloorKernel) + J);
3180 {$ELSE}
3181 CeilKernel := PKernelEntry(Cardinal(FloorKernel) + J);
3182 {$ENDIF}
3183 Dev := -256;
3184 for I := -KWidth to KWidth do
3185 begin
3186 Wv := FloorKernel[I] + ((CeilKernel[I] - FloorKernel[I]) * Frac + $7FFF) div FixedOne;
3187 HorzKernel[I] := Wv;
3188 Inc(Dev, Wv);
3189 end;
3190 Dec(HorzKernel[0], Dev);
3191 end;
3192
3193 with TFixedRec(FracY) do
3194 begin
3195 Fixed := Round((clY - Y) * W);
3196 PVertKernel := @VertKernel;
3197 FloorKernel := @FWeightTable.ValPtr[KWidth - MAX_KERNEL_WIDTH, Int]^;
3198 {$IFDEF HAS_NATIVEINT}
3199 CeilKernel := PKernelEntry(NativeUInt(FloorKernel) + J);
3200 {$ELSE}
3201 CeilKernel := PKernelEntry(Cardinal(FloorKernel) + J);
3202 {$ENDIF}
3203 Dev := -256;
3204 for I := -KWidth to KWidth do
3205 begin
3206 Wv := FloorKernel[I] + ((CeilKernel[I] - FloorKernel[I]) * Frac + $7FFF) div FixedOne;
3207 VertKernel[I] := Wv;
3208 Inc(Dev, Wv);
3209 end;
3210 Dec(VertKernel[0], Dev);
3211 end;
3212 end;
3213
3214 end;
3215
3216 VertEntry := EMPTY_ENTRY;
3217 case PixelAccessMode of
3218 pamUnsafe, pamSafe, pamTransparentEdge:
3219 begin
3220 SrcP := PColor32Entry(Bitmap.PixelPtr[LoX + clX, LoY + clY]);
3221 Incr := Bitmap.Width - (HiX - LoX) - 1;
3222 for I := LoY to HiY do
3223 begin
3224 Wv := PVertKernel[I];
3225 if Wv <> 0 then
3226 begin
3227 HorzEntry := EMPTY_ENTRY;
3228 for J := LoX to HiX do
3229 begin
3230 // Alpha=0 should not contribute to sample.
3231 Alpha := SrcP.A;
3232 if (Alpha <> 0) then
3233 begin
3234 W := PHorzKernel[J];
3235 Inc(HorzEntry.A, Alpha * W);
3236 // Sample premultiplied values
3237 if (Alpha = 255) then
3238 begin
3239 Inc(HorzEntry.R, SrcP.R * W);
3240 Inc(HorzEntry.G, SrcP.G * W);
3241 Inc(HorzEntry.B, SrcP.B * W);
3242 end else
3243 begin
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);
3247 end;
3248 end;
3249 Inc(SrcP);
3250 end;
3251 Inc(VertEntry.A, HorzEntry.A * Wv);
3252 Inc(VertEntry.R, HorzEntry.R * Wv);
3253 Inc(VertEntry.G, HorzEntry.G * Wv);
3254 Inc(VertEntry.B, HorzEntry.B * Wv);
3255 end else Inc(SrcP, HiX - LoX + 1);
3256 Inc(SrcP, Incr);
3257 end;
3258
3259 if (PixelAccessMode = pamSafe) and Edge then
3260 begin
3261 Alpha := TColor32Entry(FOuterColor).A;
3262
3263 // Alpha=0 should not contribute to sample.
3264 if (Alpha <> 0) then
3265 begin
3266 // Sample premultiplied values
3267 OuterPremultColorR := Integer(Div255(Alpha * TColor32Entry(FOuterColor).R));
3268 OuterPremultColorG := Integer(Div255(Alpha * TColor32Entry(FOuterColor).G));
3269 OuterPremultColorB := Integer(Div255(Alpha * TColor32Entry(FOuterColor).B));
3270
3271 for I := -KWidth to KWidth do
3272 begin
3273 Wv := PVertKernel[I];
3274 if Wv <> 0 then
3275 begin
3276 HorzEntry := EMPTY_ENTRY;
3277 for J := -KWidth to KWidth do
3278 if (J < LoX) or (J > HiX) or (I < LoY) or (I > HiY) then
3279 begin
3280 W := PHorzKernel[J];
3281 Inc(HorzEntry.A, Alpha * W);
3282 Inc(HorzEntry.R, OuterPremultColorR * W);
3283 Inc(HorzEntry.G, OuterPremultColorG * W);
3284 Inc(HorzEntry.B, OuterPremultColorB * W);
3285 end;
3286 Inc(VertEntry.A, HorzEntry.A * Wv);
3287 Inc(VertEntry.R, HorzEntry.R * Wv);
3288 Inc(VertEntry.G, HorzEntry.G * Wv);
3289 Inc(VertEntry.B, HorzEntry.B * Wv);
3290 end;
3291 end
3292 end;
3293 end;
3294 end;
3295
3296 pamWrap:
3297 begin
3298 WrapProcHorz := GetWrapProcEx(Bitmap.WrapMode, ClipRect.Left, ClipRect.Right - 1);
3299 WrapProcVert := GetWrapProcEx(Bitmap.WrapMode, ClipRect.Top, ClipRect.Bottom - 1);
3300
3301 for I := -KWidth to KWidth do
3302 MappingX[I] := WrapProcHorz(clX + I, ClipRect.Left, ClipRect.Right - 1);
3303
3304 for I := -KWidth to KWidth do
3305 begin
3306 Wv := PVertKernel[I];
3307 if Wv <> 0 then
3308 begin
3309 MappingY := WrapProcVert(clY + I, ClipRect.Top, ClipRect.Bottom - 1);
3310 Colors := PColor32EntryArray(Bitmap.ScanLine[MappingY]);
3311 HorzEntry := EMPTY_ENTRY;
3312 for J := -KWidth to KWidth do
3313 begin
3314 C := Colors[MappingX[J]];
3315 Alpha := C.A;
3316 // Alpha=0 should not contribute to sample.
3317 if (Alpha <> 0) then
3318 begin
3319 W := PHorzKernel[J];
3320 Inc(HorzEntry.A, Alpha * W);
3321 // Sample premultiplied values
3322 if (Alpha = 255) then
3323 begin
3324 Inc(HorzEntry.R, C.R * W);
3325 Inc(HorzEntry.G, C.G * W);
3326 Inc(HorzEntry.B, C.B * W);
3327 end else
3328 begin
3329 Inc(HorzEntry.R, Div255(Alpha * C.R) * W);
3330 Inc(HorzEntry.G, Div255(Alpha * C.G) * W);
3331 Inc(HorzEntry.B, Div255(Alpha * C.B) * W);
3332 end;
3333 end;
3334 end;
3335 Inc(VertEntry.A, HorzEntry.A * Wv);
3336 Inc(VertEntry.R, HorzEntry.R * Wv);
3337 Inc(VertEntry.G, HorzEntry.G * Wv);
3338 Inc(VertEntry.B, HorzEntry.B * Wv);
3339 end;
3340 end;
3341 end;
3342 end;
3343
3344 // Round and unpremultiply result
3345 with TColor32Entry(Result) do
3346 begin
3347 if FKernel.RangeCheck then
3348 begin
3349 A := Clamp(TFixedRec(Integer(VertEntry.A + FixedHalf)).Int);
3350 if (A = 255) then
3351 begin
3352 R := Clamp(TFixedRec(Integer(VertEntry.R + FixedHalf)).Int);
3353 G := Clamp(TFixedRec(Integer(VertEntry.G + FixedHalf)).Int);
3354 B := Clamp(TFixedRec(Integer(VertEntry.B + FixedHalf)).Int);
3355 end else
3356 if (A <> 0) then
3357 begin
3358 R := Clamp(TFixedRec(Integer(VertEntry.R + FixedHalf)).Int * 255 div A);
3359 G := Clamp(TFixedRec(Integer(VertEntry.G + FixedHalf)).Int * 255 div A);
3360 B := Clamp(TFixedRec(Integer(VertEntry.B + FixedHalf)).Int * 255 div A);
3361 end else
3362 begin
3363 R := 0;
3364 G := 0;
3365 B := 0;
3366 end;
3367 end
3368 else
3369 begin
3370 A := TFixedRec(Integer(VertEntry.A + FixedHalf)).Int;
3371 if (A = 255) then
3372 begin
3373 R := TFixedRec(Integer(VertEntry.R + FixedHalf)).Int;
3374 G := TFixedRec(Integer(VertEntry.G + FixedHalf)).Int;
3375 B := TFixedRec(Integer(VertEntry.B + FixedHalf)).Int;
3376 end else
3377 if (A <> 0) then
3378 begin
3379 R := TFixedRec(Integer(VertEntry.R + FixedHalf)).Int * 255 div A;
3380 G := TFixedRec(Integer(VertEntry.G + FixedHalf)).Int * 255 div A;
3381 B := TFixedRec(Integer(VertEntry.B + FixedHalf)).Int * 255 div A;
3382 end else
3383 begin
3384 R := 0;
3385 G := 0;
3386 B := 0;
3387 end;
3388 end;
3389 end;
3390end;
3391{$WARNINGS ON}
3392
3393function TKernelResampler.GetWidth: TFloat;
3394begin
3395 Result := Kernel.GetWidth;
3396end;
3397
3398procedure TKernelResampler.SetKernelMode(const Value: TKernelMode);
3399begin
3400 if FKernelMode <> Value then
3401 begin
3402 FKernelMode := Value;
3403 Changed;
3404 end;
3405end;
3406
3407procedure TKernelResampler.SetTableSize(Value: Integer);
3408begin
3409 if Value < 2 then Value := 2;
3410 if FTableSize <> Value then
3411 begin
3412 FTableSize := Value;
3413 Changed;
3414 end;
3415end;
3416
3417procedure TKernelResampler.FinalizeSampling;
3418begin
3419 if FKernelMode in [kmTableNearest, kmTableLinear] then
3420 FWeightTable.Free;
3421 inherited;
3422end;
3423
3424procedure TKernelResampler.PrepareSampling;
3425var
3426 I, J, W, Weight, Dev: Integer;
3427 Fraction: TFloat;
3428 KernelPtr: PKernelEntry;
3429begin
3430 inherited;
3431 FOuterColor := Bitmap.OuterColor;
3432 W := Ceil(FKernel.GetWidth);
3433 if FKernelMode in [kmTableNearest, kmTableLinear] then
3434 begin
3435 FWeightTable := TIntegerMap.Create(W * 2 + 1, FTableSize + 1);
3436 for I := 0 to FTableSize do
3437 begin
3438 Fraction := I / (FTableSize - 1);
3439 KernelPtr := @FWeightTable.ValPtr[W - MAX_KERNEL_WIDTH, I]^;
3440 Dev := - 256;
3441 for J := -W to W do
3442 begin
3443 Weight := Round(FKernel.Filter(J + Fraction) * 256);
3444 KernelPtr[J] := Weight;
3445 Inc(Dev, Weight);
3446 end;
3447 Dec(KernelPtr[0], Dev);
3448 end;
3449 end;
3450end;
3451
3452
3453{ TCustomBitmap32NearestResampler }
3454
3455function TNearestResampler.GetSampleInt(X, Y: Integer): TColor32;
3456begin
3457 Result := FGetSampleInt(X, Y);
3458end;
3459
3460function TNearestResampler.GetSampleFixed(X, Y: TFixed): TColor32;
3461begin
3462 Result := FGetSampleInt(FixedRound(X), FixedRound(Y));
3463end;
3464
3465function TNearestResampler.GetSampleFloat(X, Y: TFloat): TColor32;
3466begin
3467 Result := FGetSampleInt(Round(X), Round(Y));
3468end;
3469
3470function TNearestResampler.GetWidth: TFloat;
3471begin
3472 Result := 1;
3473end;
3474
3475function TNearestResampler.GetPixelTransparentEdge(X,Y: Integer): TColor32;
3476var
3477 I, J: Integer;
3478begin
3479 with Bitmap, Bitmap.ClipRect do
3480 begin
3481 I := Clamp(X, Left, Right - 1);
3482 J := Clamp(Y, Top, Bottom - 1);
3483 Result := Pixel[I, J];
3484 if (I <> X) or (J <> Y) then
3485 Result := Result and $00FFFFFF;
3486 end;
3487end;
3488
3489procedure TNearestResampler.PrepareSampling;
3490begin
3491 inherited;
3492 case PixelAccessMode of
3493 pamUnsafe: FGetSampleInt := TCustomBitmap32Access(Bitmap).GetPixel;
3494 pamSafe: FGetSampleInt := TCustomBitmap32Access(Bitmap).GetPixelS;
3495 pamWrap: FGetSampleInt := TCustomBitmap32Access(Bitmap).GetPixelW;
3496 pamTransparentEdge: FGetSampleInt := GetPixelTransparentEdge;
3497 end;
3498end;
3499
3500procedure TNearestResampler.Resample(
3501 Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
3502 Src: TCustomBitmap32; SrcRect: TRect;
3503 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent);
3504begin
3505 StretchNearest(Dst, DstRect, DstClip, Src, SrcRect, CombineOp, CombineCallBack)
3506end;
3507
3508
3509{ TCustomBitmap32LinearResampler }
3510
3511constructor TLinearResampler.Create;
3512begin
3513 inherited;
3514 FLinearKernel := TLinearKernel.Create;
3515end;
3516
3517destructor TLinearResampler.Destroy;
3518begin
3519 FLinearKernel.Free;
3520 inherited Destroy;
3521end;
3522
3523function TLinearResampler.GetSampleFixed(X, Y: TFixed): TColor32;
3524begin
3525 Result := FGetSampleFixed(X, Y);
3526end;
3527
3528function TLinearResampler.GetSampleFloat(X, Y: TFloat): TColor32;
3529begin
3530 Result := FGetSampleFixed(Round(X * FixedOne), Round(Y * FixedOne));
3531end;
3532
3533function TLinearResampler.GetPixelTransparentEdge(X, Y: TFixed): TColor32;
3534var
3535 I, J, X1, X2, Y1, Y2, WX, R, B: TFixed;
3536 C1, C2, C3, C4: TColor32;
3537 PSrc: PColor32Array;
3538begin
3539 with TCustomBitmap32Access(Bitmap), Bitmap.ClipRect do
3540 begin
3541 R := Right - 1;
3542 B := Bottom - 1;
3543
3544 I := TFixedRec(X).Int;
3545 J := TFixedRec(Y).Int;
3546
3547 if (I >= Left) and (J >= Top) and (I < R) and (J < B) then
3548 begin //Safe
3549 Result := GET_T256(X shr 8, Y shr 8);
3550 EMMS;
3551 end
3552 else
3553 if (I >= Left - 1) and (J >= Top - 1) and (I <= R) and (J <= B) then
3554 begin //Near edge, on edge or outside
3555
3556 X1 := Clamp(I, R);
3557 X2 := Clamp(I + Sign(X), R);
3558 Y1 := Clamp(J, B) * Width;
3559 Y2 := Clamp(J + Sign(Y), B) * Width;
3560
3561 PSrc := @Bits[0];
3562 C1 := PSrc[X1 + Y1];
3563 C2 := PSrc[X2 + Y1];
3564 C3 := PSrc[X1 + Y2];
3565 C4 := PSrc[X2 + Y2];
3566
3567 if X <= Fixed(Left) then
3568 begin
3569 C1 := C1 and $00FFFFFF;
3570 C3 := C3 and $00FFFFFF;
3571 end
3572 else if I = R then
3573 begin
3574 C2 := C2 and $00FFFFFF;
3575 C4 := C4 and $00FFFFFF;
3576 end;
3577
3578 if Y <= Fixed(Top) then
3579 begin
3580 C1 := C1 and $00FFFFFF;
3581 C2 := C2 and $00FFFFFF;
3582 end
3583 else if J = B then
3584 begin
3585 C3 := C3 and $00FFFFFF;
3586 C4 := C4 and $00FFFFFF;
3587 end;
3588
3589 WX := GAMMA_ENCODING_TABLE[((X shr 8) and $FF) xor $FF];
3590 Result := CombineReg(CombineReg(C1, C2, WX),
3591 CombineReg(C3, C4, WX),
3592 GAMMA_ENCODING_TABLE[((Y shr 8) and $FF) xor $FF]);
3593 EMMS;
3594 end
3595 else
3596 Result := 0; //Nothing really makes sense here, return zero
3597 end;
3598end;
3599
3600procedure TLinearResampler.PrepareSampling;
3601begin
3602 inherited;
3603 case PixelAccessMode of
3604 pamUnsafe: FGetSampleFixed := TCustomBitmap32Access(Bitmap).GetPixelX;
3605 pamSafe: FGetSampleFixed := TCustomBitmap32Access(Bitmap).GetPixelXS;
3606 pamWrap: FGetSampleFixed := TCustomBitmap32Access(Bitmap).GetPixelXW;
3607 pamTransparentEdge: FGetSampleFixed := GetPixelTransparentEdge;
3608 end;
3609end;
3610
3611function TLinearResampler.GetWidth: TFloat;
3612begin
3613 Result := 1;
3614end;
3615
3616procedure TLinearResampler.Resample(
3617 Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
3618 Src: TCustomBitmap32; SrcRect: TRect;
3619 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent);
3620var
3621 SrcW, SrcH: TFloat;
3622 DstW, DstH: Integer;
3623begin
3624 SrcW := SrcRect.Right - SrcRect.Left;
3625 SrcH := SrcRect.Bottom - SrcRect.Top;
3626 DstW := DstRect.Right - DstRect.Left;
3627 DstH := DstRect.Bottom - DstRect.Top;
3628 if (DstW > SrcW) and (DstH > SrcH) and (SrcW > 1) and (SrcH > 1) then
3629 StretchHorzStretchVertLinear(Dst, DstRect, DstClip, Src, SrcRect, CombineOp,
3630 CombineCallBack)
3631 else
3632 GR32_Resamplers.Resample(Dst, DstRect, DstClip, Src, SrcRect, FLinearKernel,
3633 CombineOp, CombineCallBack);
3634end;
3635
3636procedure TDraftResampler.Resample(
3637 Dst: TCustomBitmap32; DstRect: TRect; DstClip: TRect;
3638 Src: TCustomBitmap32; SrcRect: TRect;
3639 CombineOp: TDrawMode; CombineCallBack: TPixelCombineEvent);
3640begin
3641 DraftResample(Dst, DstRect, DstClip, Src, SrcRect, FLinearKernel, CombineOp,
3642 CombineCallBack)
3643end;
3644
3645{ TTransformer }
3646
3647function TTransformer.GetSampleInt(X, Y: Integer): TColor32;
3648var
3649 U, V: TFixed;
3650begin
3651 FTransformationReverseTransformFixed(X * FixedOne + FixedHalf,
3652 Y * FixedOne + FixedHalf, U, V);
3653 Result := FGetSampleFixed(U - FixedHalf, V - FixedHalf);
3654end;
3655
3656function TTransformer.GetSampleFixed(X, Y: TFixed): TColor32;
3657var
3658 U, V: TFixed;
3659begin
3660 FTransformationReverseTransformFixed(X + FixedHalf, Y + FixedHalf, U, V);
3661 Result := FGetSampleFixed(U - FixedHalf, V - FixedHalf);
3662end;
3663
3664function TTransformer.GetSampleFloat(X, Y: TFloat): TColor32;
3665var
3666 U, V: TFloat;
3667begin
3668 FTransformationReverseTransformFloat(X + 0.5, Y + 0.5, U, V);
3669 Result := FGetSampleFloat(U - 0.5, V - 0.5);
3670end;
3671
3672procedure TTransformer.SetTransformation(const Value: TTransformation);
3673begin
3674 FTransformation := Value;
3675 if Assigned(Value) then
3676 begin
3677 FTransformationReverseTransformInt := TTransformationAccess(FTransformation).ReverseTransformInt;
3678 FTransformationReverseTransformFixed := TTransformationAccess(FTransformation).ReverseTransformFixed;
3679 FTransformationReverseTransformFloat := TTransformationAccess(FTransformation).ReverseTransformFloat;
3680 end;
3681end;
3682
3683constructor TTransformer.Create(ASampler: TCustomSampler; ATransformation: TTransformation);
3684begin
3685 inherited Create(ASampler);
3686 Transformation := ATransformation;
3687end;
3688
3689procedure TTransformer.PrepareSampling;
3690begin
3691 inherited;
3692 with TTransformationAccess(FTransformation) do
3693 if not TransformValid then
3694 PrepareTransform;
3695end;
3696
3697function TTransformer.GetSampleBounds: TFloatRect;
3698begin
3699 IntersectRect(Result, inherited GetSampleBounds, FTransformation.SrcRect);
3700 Result := FTransformation.GetTransformedBounds(Result);
3701end;
3702
3703function TTransformer.HasBounds: Boolean;
3704begin
3705 Result := FTransformation.HasTransformedBounds and inherited HasBounds;
3706end;
3707
3708
3709{ TSuperSampler }
3710
3711constructor TSuperSampler.Create(Sampler: TCustomSampler);
3712begin
3713 inherited Create(Sampler);
3714 FSamplingX := 4;
3715 FSamplingY := 4;
3716 SamplingX := 4;
3717 SamplingY := 4;
3718end;
3719
3720function TSuperSampler.GetSampleFixed(X, Y: TFixed): TColor32;
3721var
3722 I, J: Integer;
3723 dX, dY, tX: TFixed;
3724 Buffer: TBufferEntry;
3725begin
3726 Buffer := EMPTY_ENTRY;
3727 tX := X + FOffsetX;
3728 Inc(Y, FOffsetY);
3729 dX := FDistanceX;
3730 dY := FDistanceY;
3731 for J := 1 to FSamplingY do
3732 begin
3733 X := tX;
3734 for I := 1 to FSamplingX do
3735 begin
3736 IncBuffer(Buffer, FGetSampleFixed(X, Y));
3737 Inc(X, dX);
3738 end;
3739 Inc(Y, dY);
3740 end;
3741 MultiplyBuffer(Buffer, FScale);
3742 Result := BufferToColor32(Buffer, 16);
3743end;
3744
3745procedure TSuperSampler.SetSamplingX(const Value: TSamplingRange);
3746begin
3747 FSamplingX := Value;
3748 FDistanceX := Fixed(1 / Value);
3749 FOffsetX := Fixed(((1 / Value) - 1) * 0.5); // replaced "/2" by "*0.5"
3750 FScale := Fixed(1 / (FSamplingX * FSamplingY));
3751end;
3752
3753procedure TSuperSampler.SetSamplingY(const Value: TSamplingRange);
3754begin
3755 FSamplingY := Value;
3756 FDistanceY := Fixed(1 / Value);
3757 FOffsetY := Fixed(((1 / Value) - 1) * 0.5); // replaced "/2" by "*0.5"
3758 FScale := Fixed(1 / (FSamplingX * FSamplingY));
3759end;
3760
3761{ TAdaptiveSuperSampler }
3762
3763function TAdaptiveSuperSampler.CompareColors(C1, C2: TColor32): Boolean;
3764var
3765 Diff: TColor32Entry;
3766begin
3767 Diff.ARGB := ColorDifference(C1, C2);
3768 Result := FTolerance < Diff.R + Diff.G + Diff.B;
3769end;
3770
3771constructor TAdaptiveSuperSampler.Create(Sampler: TCustomSampler);
3772begin
3773 inherited Create(Sampler);
3774 Level := 4;
3775 Tolerance := 256;
3776end;
3777
3778function TAdaptiveSuperSampler.DoRecurse(X, Y, Offset: TFixed; const A, B,
3779 C, D, E: TColor32): TColor32;
3780var
3781 C1, C2, C3, C4: TColor32;
3782begin
3783 C1 := QuadrantColor(A, E, X - Offset, Y - Offset, Offset, RecurseAC);
3784 C2 := QuadrantColor(B, E, X + Offset, Y - Offset, Offset, RecurseBD);
3785 C3 := QuadrantColor(E, C, X + Offset, Y + Offset, Offset, RecurseAC);
3786 C4 := QuadrantColor(E, D, X - Offset, Y + Offset, Offset, RecurseBD);
3787 Result := ColorAverage(ColorAverage(C1, C2), ColorAverage(C3, C4));
3788end;
3789
3790function TAdaptiveSuperSampler.GetSampleFixed(X, Y: TFixed): TColor32;
3791var
3792 A, B, C, D, E: TColor32;
3793const
3794 FIXED_HALF = 32768;
3795begin
3796 A := FGetSampleFixed(X - FIXED_HALF, Y - FIXED_HALF);
3797 B := FGetSampleFixed(X + FIXED_HALF, Y - FIXED_HALF);
3798 C := FGetSampleFixed(X + FIXED_HALF, Y + FIXED_HALF);
3799 D := FGetSampleFixed(X - FIXED_HALF, Y + FIXED_HALF);
3800 E := FGetSampleFixed(X, Y);
3801 Result := Self.DoRecurse(X, Y, 16384, A, B, C, D, E);
3802 EMMS;
3803end;
3804
3805function TAdaptiveSuperSampler.QuadrantColor(const C1, C2: TColor32; X, Y,
3806 Offset: TFixed; Proc: TRecurseProc): TColor32;
3807begin
3808 if CompareColors(C1, C2) and (Offset >= FMinOffset) then
3809 Result := Proc(X, Y, Offset, C1, C2)
3810 else
3811 Result := ColorAverage(C1, C2);
3812end;
3813
3814function TAdaptiveSuperSampler.RecurseAC(X, Y, Offset: TFixed; const A,
3815 C: TColor32): TColor32;
3816var
3817 B, D, E: TColor32;
3818begin
3819 EMMS;
3820 B := FGetSampleFixed(X + Offset, Y - Offset);
3821 D := FGetSampleFixed(X - Offset, Y + Offset);
3822 E := FGetSampleFixed(X, Y);
3823 Result := DoRecurse(X, Y, Offset shr 1, A, B, C, D, E);
3824end;
3825
3826function TAdaptiveSuperSampler.RecurseBD(X, Y, Offset: TFixed; const B,
3827 D: TColor32): TColor32;
3828var
3829 A, C, E: TColor32;
3830begin
3831 EMMS;
3832 A := FGetSampleFixed(X - Offset, Y - Offset);
3833 C := FGetSampleFixed(X + Offset, Y + Offset);
3834 E := FGetSampleFixed(X, Y);
3835 Result := DoRecurse(X, Y, Offset shr 1, A, B, C, D, E);
3836end;
3837
3838procedure TAdaptiveSuperSampler.SetLevel(const Value: Integer);
3839begin
3840 FLevel := Value;
3841 FMinOffset := Fixed(1 / (1 shl Value));
3842end;
3843
3844{ TPatternSampler }
3845
3846destructor TPatternSampler.Destroy;
3847begin
3848 if Assigned(FPattern) then FPattern := nil;
3849 inherited;
3850end;
3851
3852function TPatternSampler.GetSampleFixed(X, Y: TFixed): TColor32;
3853var
3854 Points: TArrayOfFixedPoint;
3855 P: PFixedPoint;
3856 I, PY: Integer;
3857 Buffer: TBufferEntry;
3858 GetSample: TGetSampleFixed;
3859 WrapProcHorz: TWrapProc;
3860begin
3861 GetSample := FSampler.GetSampleFixed;
3862 PY := WrapProcVert(TFixedRec(Y).Int, High(FPattern));
3863 I := High(FPattern[PY]);
3864 WrapProcHorz := GetOptimalWrap(I);
3865 Points := FPattern[PY][WrapProcHorz(TFixedRec(X).Int, I)];
3866 Buffer := EMPTY_ENTRY;
3867 P := @Points[0];
3868 for I := 0 to High(Points) do
3869 begin
3870 IncBuffer(Buffer, GetSample(P.X + X, P.Y + Y));
3871 Inc(P);
3872 end;
3873 MultiplyBuffer(Buffer, FixedOne div Length(Points));
3874 Result := BufferToColor32(Buffer, 16);
3875end;
3876
3877procedure TPatternSampler.SetPattern(const Value: TFixedSamplePattern);
3878begin
3879 if Assigned(Value) then
3880 begin
3881 FPattern := nil;
3882 FPattern := Value;
3883 WrapProcVert := GetOptimalWrap(High(FPattern));
3884 end;
3885end;
3886
3887function JitteredPattern(XRes, YRes: Integer): TArrayOfFixedPoint;
3888var
3889 I, J: Integer;
3890begin
3891 SetLength(Result, XRes * YRes);
3892 for I := 0 to XRes - 1 do
3893 for J := 0 to YRes - 1 do
3894 with Result[I + J * XRes] do
3895 begin
3896 X := (Random(65536) + I * 65536) div XRes - 32768;
3897 Y := (Random(65536) + J * 65536) div YRes - 32768;
3898 end;
3899end;
3900
3901function CreateJitteredPattern(TileWidth, TileHeight, SamplesX, SamplesY: Integer): TFixedSamplePattern;
3902var
3903 I, J: Integer;
3904begin
3905 SetLength(Result, TileHeight, TileWidth);
3906 for I := 0 to TileWidth - 1 do
3907 for J := 0 to TileHeight - 1 do
3908 Result[J][I] := JitteredPattern(SamplesX, SamplesY);
3909end;
3910
3911procedure RegisterResampler(ResamplerClass: TCustomResamplerClass);
3912begin
3913 if not Assigned(ResamplerList) then ResamplerList := TClassList.Create;
3914 ResamplerList.ADD(ResamplerClass);
3915end;
3916
3917procedure RegisterKernel(KernelClass: TCustomKernelClass);
3918begin
3919 if not Assigned(KernelList) then KernelList := TClassList.Create;
3920 KernelList.ADD(KernelClass);
3921end;
3922
3923{ TNestedSampler }
3924
3925procedure TNestedSampler.AssignTo(Dst: TPersistent);
3926begin
3927 if Dst is TNestedSampler then
3928 SmartAssign(Self, Dst)
3929 else
3930 inherited;
3931end;
3932
3933constructor TNestedSampler.Create(ASampler: TCustomSampler);
3934begin
3935 inherited Create;
3936 Sampler := ASampler;
3937end;
3938
3939procedure TNestedSampler.FinalizeSampling;
3940begin
3941 if not Assigned(FSampler) then
3942 raise ENestedException.Create(SSamplerNil)
3943 else
3944 FSampler.FinalizeSampling;
3945end;
3946
3947{$WARNINGS OFF}
3948function TNestedSampler.GetSampleBounds: TFloatRect;
3949begin
3950 if not Assigned(FSampler) then
3951 raise ENestedException.Create(SSamplerNil)
3952 else
3953 Result := FSampler.GetSampleBounds;
3954end;
3955
3956function TNestedSampler.HasBounds: Boolean;
3957begin
3958 if not Assigned(FSampler) then
3959 raise ENestedException.Create(SSamplerNil)
3960 else
3961 Result := FSampler.HasBounds;
3962end;
3963{$WARNINGS ON}
3964
3965procedure TNestedSampler.PrepareSampling;
3966begin
3967 if not Assigned(FSampler) then
3968 raise ENestedException.Create(SSamplerNil)
3969 else
3970 FSampler.PrepareSampling;
3971end;
3972
3973procedure TNestedSampler.SetSampler(const Value: TCustomSampler);
3974begin
3975 FSampler := Value;
3976 if Assigned(Value) then
3977 begin
3978 FGetSampleInt := FSampler.GetSampleInt;
3979 FGetSampleFixed := FSampler.GetSampleFixed;
3980 FGetSampleFloat := FSampler.GetSampleFloat;
3981 end;
3982end;
3983
3984
3985{ TKernelSampler }
3986
3987function TKernelSampler.ConvertBuffer(var Buffer: TBufferEntry): TColor32;
3988begin
3989 Buffer.A := Constrain(Buffer.A, 0, $FFFF);
3990 Buffer.R := Constrain(Buffer.R, 0, $FFFF);
3991 Buffer.G := Constrain(Buffer.G, 0, $FFFF);
3992 Buffer.B := Constrain(Buffer.B, 0, $FFFF);
3993
3994 Result := BufferToColor32(Buffer, 8);
3995end;
3996
3997constructor TKernelSampler.Create(ASampler: TCustomSampler);
3998begin
3999 inherited;
4000 FKernel := TIntegerMap.Create;
4001 FStartEntry := EMPTY_ENTRY;
4002end;
4003
4004destructor TKernelSampler.Destroy;
4005begin
4006 FKernel.Free;
4007 inherited;
4008end;
4009
4010function TKernelSampler.GetSampleFixed(X, Y: TFixed): TColor32;
4011var
4012 I, J: Integer;
4013 Buffer: TBufferEntry;
4014begin
4015 X := X + FCenterX shl 16;
4016 Y := Y + FCenterY shl 16;
4017 Buffer := FStartEntry;
4018 for I := 0 to FKernel.Width - 1 do
4019 for J := 0 to FKernel.Height - 1 do
4020 UpdateBuffer(Buffer, FGetSampleFixed(X - I shl 16, Y - J shl 16), FKernel[I, J]);
4021
4022 Result := ConvertBuffer(Buffer);
4023end;
4024
4025function TKernelSampler.GetSampleInt(X, Y: Integer): TColor32;
4026var
4027 I, J: Integer;
4028 Buffer: TBufferEntry;
4029begin
4030 X := X + FCenterX;
4031 Y := Y + FCenterY;
4032 Buffer := FStartEntry;
4033 for I := 0 to FKernel.Width - 1 do
4034 for J := 0 to FKernel.Height - 1 do
4035 UpdateBuffer(Buffer, FGetSampleInt(X - I, Y - J), FKernel[I, J]);
4036
4037 Result := ConvertBuffer(Buffer);
4038end;
4039
4040{ TConvolver }
4041
4042procedure TConvolver.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
4043 Weight: Integer);
4044begin
4045 with TColor32Entry(Color) do
4046 begin
4047 Inc(Buffer.A, A * Weight);
4048 Inc(Buffer.R, R * Weight);
4049 Inc(Buffer.G, G * Weight);
4050 Inc(Buffer.B, B * Weight);
4051 end;
4052end;
4053
4054{ TDilater }
4055
4056procedure TDilater.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
4057 Weight: Integer);
4058begin
4059 with TColor32Entry(Color) do
4060 begin
4061 Buffer.A := Max(Buffer.A, A + Weight);
4062 Buffer.R := Max(Buffer.R, R + Weight);
4063 Buffer.G := Max(Buffer.G, G + Weight);
4064 Buffer.B := Max(Buffer.B, B + Weight);
4065 end;
4066end;
4067
4068{ TEroder }
4069
4070constructor TEroder.Create(ASampler: TCustomSampler);
4071const
4072 START_ENTRY: TBufferEntry = (B: $FFFF; G: $FFFF; R: $FFFF; A: $FFFF);
4073begin
4074 inherited;
4075 FStartEntry := START_ENTRY;
4076end;
4077
4078procedure TEroder.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
4079 Weight: Integer);
4080begin
4081 with TColor32Entry(Color) do
4082 begin
4083 Buffer.A := Min(Buffer.A, A - Weight);
4084 Buffer.R := Min(Buffer.R, R - Weight);
4085 Buffer.G := Min(Buffer.G, G - Weight);
4086 Buffer.B := Min(Buffer.B, B - Weight);
4087 end;
4088end;
4089
4090{ TExpander }
4091
4092procedure TExpander.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
4093 Weight: Integer);
4094begin
4095 with TColor32Entry(Color) do
4096 begin
4097 Buffer.A := Max(Buffer.A, A * Weight);
4098 Buffer.R := Max(Buffer.R, R * Weight);
4099 Buffer.G := Max(Buffer.G, G * Weight);
4100 Buffer.B := Max(Buffer.B, B * Weight);
4101 end;
4102end;
4103
4104{ TContracter }
4105
4106function TContracter.GetSampleFixed(X, Y: TFixed): TColor32;
4107begin
4108 Result := ColorSub(FMaxWeight, inherited GetSampleFixed(X, Y));
4109end;
4110
4111function TContracter.GetSampleInt(X, Y: Integer): TColor32;
4112begin
4113 Result := ColorSub(FMaxWeight, inherited GetSampleInt(X, Y));
4114end;
4115
4116procedure TContracter.PrepareSampling;
4117var
4118 I, J, W: Integer;
4119begin
4120 W := Low(Integer);
4121 for I := 0 to FKernel.Width - 1 do
4122 for J := 0 to FKernel.Height - 1 do
4123 W := Max(W, FKernel[I, J]);
4124 if W > 255 then W := 255;
4125 FMaxWeight := Gray32(W, W);
4126end;
4127
4128procedure TContracter.UpdateBuffer(var Buffer: TBufferEntry; Color: TColor32;
4129 Weight: Integer);
4130begin
4131 inherited UpdateBuffer(Buffer, Color xor $FFFFFFFF, Weight);
4132end;
4133
4134{ TMorphologicalSampler }
4135
4136function TMorphologicalSampler.ConvertBuffer(
4137 var Buffer: TBufferEntry): TColor32;
4138begin
4139 Buffer.A := Constrain(Buffer.A, 0, $FF);
4140 Buffer.R := Constrain(Buffer.R, 0, $FF);
4141 Buffer.G := Constrain(Buffer.G, 0, $FF);
4142 Buffer.B := Constrain(Buffer.B, 0, $FF);
4143
4144 with TColor32Entry(Result) do
4145 begin
4146 A := Buffer.A;
4147 R := Buffer.R;
4148 G := Buffer.G;
4149 B := Buffer.B;
4150 end;
4151end;
4152
4153{ TSelectiveConvolver }
4154
4155function TSelectiveConvolver.ConvertBuffer(var Buffer: TBufferEntry): TColor32;
4156begin
4157 with TColor32Entry(Result) do
4158 begin
4159 A := Buffer.A div FWeightSum.A;
4160 R := Buffer.R div FWeightSum.R;
4161 G := Buffer.G div FWeightSum.G;
4162 B := Buffer.B div FWeightSum.B;
4163 end;
4164end;
4165
4166constructor TSelectiveConvolver.Create(ASampler: TCustomSampler);
4167begin
4168 inherited;
4169 FDelta := 30;
4170end;
4171
4172function TSelectiveConvolver.GetSampleFixed(X, Y: TFixed): TColor32;
4173begin
4174 FRefColor := FGetSampleFixed(X, Y);
4175 FWeightSum := EMPTY_ENTRY;
4176 Result := inherited GetSampleFixed(X, Y);
4177end;
4178
4179function TSelectiveConvolver.GetSampleInt(X, Y: Integer): TColor32;
4180begin
4181 FRefColor := FGetSampleInt(X, Y);
4182 FWeightSum := EMPTY_ENTRY;
4183 Result := inherited GetSampleInt(X, Y);
4184end;
4185
4186procedure TSelectiveConvolver.UpdateBuffer(var Buffer: TBufferEntry;
4187 Color: TColor32; Weight: Integer);
4188begin
4189 with TColor32Entry(Color) do
4190 begin
4191 if Abs(TColor32Entry(FRefColor).A - A) <= FDelta then
4192 begin
4193 Inc(Buffer.A, A * Weight);
4194 Inc(FWeightSum.A, Weight);
4195 end;
4196 if Abs(TColor32Entry(FRefColor).R - R) <= FDelta then
4197 begin
4198 Inc(Buffer.R, R * Weight);
4199 Inc(FWeightSum.R, Weight);
4200 end;
4201 if Abs(TColor32Entry(FRefColor).G - G) <= FDelta then
4202 begin
4203 Inc(Buffer.G, G * Weight);
4204 Inc(FWeightSum.G, Weight);
4205 end;
4206 if Abs(TColor32Entry(FRefColor).B - B) <= FDelta then
4207 begin
4208 Inc(Buffer.B, B * Weight);
4209 Inc(FWeightSum.B, Weight);
4210 end;
4211 end;
4212end;
4213
4214{CPU target and feature function templates}
4215
4216const
4217 FID_BLOCKAVERAGE = 0;
4218 FID_INTERPOLATOR = 1;
4219
4220var
4221 Registry: TFunctionRegistry;
4222
4223procedure RegisterBindings;
4224begin
4225 Registry := NewRegistry('GR32_Resamplers bindings');
4226 Registry.RegisterBinding(FID_BLOCKAVERAGE, @@BlockAverage);
4227 Registry.RegisterBinding(FID_INTERPOLATOR, @@Interpolator);
4228
4229 Registry.ADD(FID_BLOCKAVERAGE, @BlockAverage_Pas);
4230 Registry.ADD(FID_INTERPOLATOR, @Interpolator_Pas);
4231{$IFNDEF PUREPASCAL}
4232 Registry.ADD(FID_BLOCKAVERAGE, @BlockAverage_MMX, [ciMMX]);
4233{$IFDEF USE_3DNOW}
4234 Registry.ADD(FID_BLOCKAVERAGE, @BlockAverage_3DNow, [ci3DNow]);
4235{$ENDIF}
4236 Registry.ADD(FID_BLOCKAVERAGE, @BlockAverage_SSE2, [ciSSE2]);
4237 Registry.ADD(FID_INTERPOLATOR, @Interpolator_MMX, [ciMMX, ciSSE]);
4238 Registry.ADD(FID_INTERPOLATOR, @Interpolator_SSE2, [ciSSE2]);
4239{$ENDIF}
4240 Registry.RebindAll;
4241end;
4242
4243initialization
4244 RegisterBindings;
4245
4246 { Register resamplers }
4247 RegisterResampler(TNearestResampler);
4248 RegisterResampler(TLinearResampler);
4249 RegisterResampler(TDraftResampler);
4250 RegisterResampler(TKernelResampler);
4251
4252 { Register kernels }
4253 RegisterKernel(TBoxKernel);
4254 RegisterKernel(TLinearKernel);
4255 RegisterKernel(TCosineKernel);
4256 RegisterKernel(TSplineKernel);
4257 RegisterKernel(TCubicKernel);
4258 RegisterKernel(TMitchellKernel);
4259 RegisterKernel(TAlbrechtKernel);
4260 RegisterKernel(TLanczosKernel);
4261 RegisterKernel(TGaussianKernel);
4262 RegisterKernel(TBlackmanKernel);
4263 RegisterKernel(THannKernel);
4264 RegisterKernel(THammingKernel);
4265 RegisterKernel(TSinshKernel);
4266 RegisterKernel(THermiteKernel);
4267
4268finalization
4269 ResamplerList.Free;
4270 KernelList.Free;
4271
4272end.
Note: See TracBrowser for help on using the repository browser.