source: trunk/Packages/bgrabitmap/bgraresample.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 48.8 KB
Line 
1unit BGRAResample;
2
3{$mode objfpc}{$H+}
4
5interface
6
7{ This unit provides resampling functions, i.e. resizing of bitmaps with or
8 without interpolation filters.
9
10 SimpleStretch does a boxed resample with limited antialiasing.
11
12 FineResample uses floating point coordinates to get an antialiased resample.
13 It can use minimal interpolation (4 pixels when upsizing) for simple interpolation
14 filters (linear and cosine-like) or wide kernel resample for complex interpolation.
15 In this cas, it calls WideKernelResample.
16
17 WideKernelResample can be called by custom filter kernel, derived
18 from TWideKernelFilter. It is slower of course than simple interpolation. }
19
20uses
21 Types, SysUtils, BGRABitmapTypes;
22
23{------------------------------- Simple stretch ------------------------------------}
24
25function SimpleStretch(bmp: TBGRACustomBitmap;
26 NewWidth, NewHeight: integer): TBGRACustomBitmap;
27procedure StretchPutImage(bmp: TBGRACustomBitmap;
28 NewWidth, NewHeight: integer; dest: TBGRACustomBitmap; OffsetX,OffsetY: Integer; ADrawMode: TDrawMode; AOpacity: byte; ANoTransition: boolean = false);
29procedure DownSamplePutImage(source: TBGRACustomBitmap; factorX,factorY: integer; dest: TBGRACustomBitmap; OffsetX,OffsetY: Integer; ADrawMode: TDrawMode);
30function DownSample(source: TBGRACustomBitmap; factorX,factorY: integer): TBGRACustomBitmap;
31
32{---------------------------- Interpolation filters --------------------------------}
33
34function FineInterpolation(t: single; ResampleFilter: TResampleFilter): single;
35function FineInterpolation256(t256: integer; ResampleFilter: TResampleFilter): integer;
36
37type
38 TWideKernelFilter = class
39 function Interpolation(t: single): single; virtual; abstract;
40 function ShouldCheckRange: boolean; virtual; abstract;
41 function KernelWidth: single; virtual; abstract;
42 end;
43
44 TMitchellKernel = class(TWideKernelFilter)
45 function Interpolation(t: single): single; override;
46 function ShouldCheckRange: boolean; override;
47 function KernelWidth: single; override;
48 end;
49
50 { TSplineKernel }
51
52 TSplineKernel = class(TWideKernelFilter)
53 public
54 Coeff: single;
55 constructor Create; overload;
56 constructor Create(ACoeff: single); overload;
57 function Interpolation(t: single): single; override;
58 function ShouldCheckRange: boolean; override;
59 function KernelWidth: single; override;
60 end;
61
62 { TCubicKernel }
63
64 TCubicKernel = class(TWideKernelFilter)
65 function pow3(x: single): single; inline;
66 function Interpolation(t: single): single; override;
67 function ShouldCheckRange: boolean; override;
68 function KernelWidth: single; override;
69 end;
70
71 { TLanczosKernel }
72
73 TLanczosKernel = class(TWideKernelFilter)
74 private
75 FNumberOfLobes: integer;
76 FFactor: ValReal;
77 procedure SetNumberOfLobes(AValue: integer);
78 public
79 constructor Create(ANumberOfLobes: integer);
80 function Interpolation(t: single): single; override;
81 function ShouldCheckRange: boolean; override;
82 function KernelWidth: single; override;
83
84 property NumberOfLobes : integer read FNumberOfLobes write SetNumberOfLobes;
85 end;
86
87function CreateInterpolator(style: TSplineStyle): TWideKernelFilter;
88
89{-------------------------------- Fine resample ------------------------------------}
90
91function FineResample(bmp: TBGRACustomBitmap;
92 NewWidth, NewHeight: integer; ResampleFilter: TResampleFilter): TBGRACustomBitmap;
93
94function WideKernelResample(bmp: TBGRACustomBitmap;
95 NewWidth, NewHeight: integer; ResampleFilterSmaller, ResampleFilterLarger: TWideKernelFilter): TBGRACustomBitmap;
96
97implementation
98
99uses Math, BGRABlend;
100
101function SimpleStretch(bmp: TBGRACustomBitmap;
102 newWidth, newHeight: integer): TBGRACustomBitmap;
103begin
104 if (NewWidth = bmp.Width) and (NewHeight = bmp.Height) then
105 begin
106 Result := bmp.Duplicate;
107 exit;
108 end;
109 Result := bmp.NewBitmap(NewWidth, NewHeight);
110 StretchPutImage(bmp, newWidth,newHeight, result, 0,0, dmSet, 255);
111end;
112
113procedure StretchPutImage(bmp: TBGRACustomBitmap; NewWidth, NewHeight: integer;
114 dest: TBGRACustomBitmap; OffsetX, OffsetY: Integer; ADrawMode: TDrawMode; AOpacity: byte; ANoTransition: boolean);
115type
116 TTransitionState = (tsNone, tsPlain, tsLeft, tsMiddle, tsRight);
117var
118 x_src,y_src, y_src2, prev_y_src, prev_y_src2: NativeInt;
119 inc_x_src, mod_x_src, acc_x_src, inc_y_src, mod_y_src, acc_y_src,
120 acc_x_src2, acc_y_src2: NativeInt;
121 x_dest, y_dest: NativeInt;
122
123 PDest, PSrc1, PSrc2: PBGRAPixel;
124 vertColors: packed array[1..2] of TBGRAPixel;
125 DeltaSrcX: NativeInt;
126 targetRect: TRect;
127 tempData: PBGRAPixel;
128 prevHorizTransition,horizTransition,prevVertTransition,vertTransition: TTransitionState;
129 horizSlightlyDifferent,vertSlightlyDifferent: boolean;
130
131 procedure LinearMix(PSrc: PBGRAPixel; DeltaSrc: integer; AccSrcQuarter: boolean;
132 PDest: PBGRAPixel; slightlyDifferent: boolean; var transition: TTransitionState);
133 var
134 asum: NativeInt;
135 a1,a2: NativeInt;
136 newTransition: TTransitionState;
137 begin
138 if (DeltaSrc=0) or ANoTransition then
139 begin
140 PDest^ := PSrc^;
141 transition:= tsPlain;
142 end
143 else
144 begin
145 if slightlyDifferent then
146 begin
147 if AccSrcQuarter then newTransition:= tsRight else
148 newTransition:= tsLeft;
149 end else
150 newTransition:= tsMiddle;
151
152 if (newTransition = tsMiddle) or ((newTransition = tsRight) and (transition = tsLeft)) or
153 ((newTransition = tsLeft) and (transition = tsRight)) then
154 begin
155 transition:= tsMiddle;
156 if ADrawMode = dmXor then
157 begin
158 pdest^.alpha := (psrc^.alpha + (psrc+DeltaSrc)^.alpha + 1) shr 1;
159 pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red + 1) shr 1;
160 pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green + 1) shr 1;
161 pdest^.blue := (psrc^.blue + (psrc+DeltaSrc)^.blue + 1) shr 1;
162 end else
163 begin
164 asum := psrc^.alpha + (psrc+DeltaSrc)^.alpha;
165 if asum = 0 then
166 pdest^ := BGRAPixelTransparent
167 else if asum = 510 then
168 begin
169 pdest^.alpha := 255;
170 pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red + 1) shr 1;
171 pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green + 1) shr 1;
172 pdest^.blue := (psrc^.blue + (psrc+DeltaSrc)^.blue + 1) shr 1;
173 end else
174 begin
175 pdest^.alpha := asum shr 1;
176 a1 := psrc^.alpha;
177 a2 := (psrc+DeltaSrc)^.alpha;
178 pdest^.red := (psrc^.red*a1 + (psrc+DeltaSrc)^.red*a2 + (asum shr 1)) div asum;
179 pdest^.green := (psrc^.green*a1 + (psrc+DeltaSrc)^.green*a2 + (asum shr 1)) div asum;
180 pdest^.blue := (psrc^.blue*a1 + (psrc+DeltaSrc)^.blue*a2 + (asum shr 1)) div asum;
181 end;
182 end;
183 end else
184 if newTransition = tsRight then
185 begin
186 transition := tsRight;
187 if ADrawMode = dmXor then
188 begin
189 pdest^.alpha := (psrc^.alpha + (psrc+DeltaSrc)^.alpha*3 + 2) shr 2;
190 pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red*3 + 2) shr 2;
191 pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green*3 + 2) shr 2;
192 pdest^.blue := (psrc^.blue + (psrc+DeltaSrc)^.blue*3 + 2) shr 2;
193 end else
194 begin
195 asum := psrc^.alpha + (psrc+DeltaSrc)^.alpha*3;
196 if asum = 0 then
197 pdest^ := BGRAPixelTransparent
198 else if asum = 1020 then
199 begin
200 pdest^.alpha := 255;
201 pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red*3 + 2) shr 2;
202 pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green*3 + 2) shr 2;
203 pdest^.blue := (psrc^.blue + (psrc+DeltaSrc)^.blue*3 + 2) shr 2;
204 end else
205 begin
206 pdest^.alpha := asum shr 2;
207 a1 := psrc^.alpha;
208 a2 := (psrc+DeltaSrc)^.alpha;
209 pdest^.red := (psrc^.red*a1 + (psrc+DeltaSrc)^.red*a2*3 + (asum shr 1)) div asum;
210 pdest^.green := (psrc^.green*a1 + (psrc+DeltaSrc)^.green*a2*3 + (asum shr 1)) div asum;
211 pdest^.blue := (psrc^.blue*a1 + (psrc+DeltaSrc)^.blue*a2*3 + (asum shr 1)) div asum;
212 end;
213 end;
214 end else
215 begin
216 transition:= tsLeft;
217 if ADrawMode = dmXor then
218 begin
219 pdest^.alpha := (psrc^.alpha*3 + (psrc+DeltaSrc)^.alpha + 2) shr 2;
220 pdest^.red := (psrc^.red*3 + (psrc+DeltaSrc)^.red + 2) shr 2;
221 pdest^.green := (psrc^.green*3 + (psrc+DeltaSrc)^.green + 2) shr 2;
222 pdest^.blue := (psrc^.blue*3 + (psrc+DeltaSrc)^.blue + 2) shr 2;
223 end else
224 begin
225 asum := psrc^.alpha*3 + (psrc+DeltaSrc)^.alpha;
226 if asum = 0 then
227 pdest^ := BGRAPixelTransparent
228 else if asum = 1020 then
229 begin
230 pdest^.alpha := 255;
231 pdest^.red := (psrc^.red*3 + (psrc+DeltaSrc)^.red + 2) shr 2;
232 pdest^.green := (psrc^.green*3 + (psrc+DeltaSrc)^.green + 2) shr 2;
233 pdest^.blue := (psrc^.blue*3 + (psrc+DeltaSrc)^.blue + 2) shr 2;
234 end else
235 begin
236 pdest^.alpha := asum shr 2;
237 a1 := psrc^.alpha;
238 a2 := (psrc+DeltaSrc)^.alpha;
239 pdest^.red := (psrc^.red*a1*3 + (psrc+DeltaSrc)^.red*a2 + (asum shr 1)) div asum;
240 pdest^.green := (psrc^.green*a1*3 + (psrc+DeltaSrc)^.green*a2 + (asum shr 1)) div asum;
241 pdest^.blue := (psrc^.blue*a1*3 + (psrc+DeltaSrc)^.blue*a2 + (asum shr 1)) div asum;
242 end;
243 end;
244 end;
245 end;
246 end;
247
248begin
249 if (newWidth <= 0) or (newHeight <= 0) or (bmp.Width <= 0)
250 or (bmp.Height <= 0) then
251 exit;
252
253 targetRect := rect(0,0,NewWidth,NewHeight);
254 if OffsetX < dest.ClipRect.Left then targetRect.Left:= dest.ClipRect.Left-OffsetX;
255 if OffsetY < dest.ClipRect.Top then targetRect.Top:= dest.ClipRect.Top-OffsetY;
256 if OffsetX+NewWidth > dest.ClipRect.Right then targetRect.Right := dest.ClipRect.Right-OffsetX;
257 if OffsetY+NewHeight > dest.ClipRect.Bottom then targetRect.Bottom := dest.ClipRect.Bottom-OffsetY;
258 if (targetRect.Right <= targetRect.Left) or (targetRect.Bottom <= targetRect.Top) then exit;
259
260 bmp.LoadFromBitmapIfNeeded;
261
262 if (ADrawMode <> dmSet) or (AOpacity <> 255) then
263 getmem(tempData, (targetRect.Right-targetRect.Left)*sizeof(TBGRAPixel) )
264 else
265 tempData := nil;
266
267 inc_x_src := bmp.Width div newwidth;
268 mod_x_src := bmp.Width mod newwidth;
269 inc_y_src := bmp.Height div newheight;
270 mod_y_src := bmp.Height mod newheight;
271
272 prev_y_src := -1;
273 prev_y_src2 := -1;
274
275 acc_y_src := targetRect.Top*mod_y_src;
276 y_src := targetRect.Top*inc_y_src + (acc_y_src div NewHeight);
277 acc_y_src := acc_y_src mod NewHeight;
278
279 y_src := y_src+ (bmp.Height div 4) div newheight;
280 acc_y_src := acc_y_src+ (bmp.Height div 4) mod newheight;
281
282 y_src2 := y_src+ (bmp.Height div 2) div newheight;
283 acc_y_src2 := acc_y_src+ (bmp.Height div 2) mod newheight;
284 if acc_y_src2 > NewHeight then
285 begin
286 dec(acc_y_src2, NewHeight);
287 inc(y_src2);
288 end;
289 horizSlightlyDifferent := (NewWidth > bmp.Width*2 div 3) and (NewWidth < bmp.Width*4 div 3);
290 prevVertTransition:= tsNone;
291 vertSlightlyDifferent := (NewHeight > bmp.Height*2 div 3) and (NewHeight < bmp.Height*4 div 3);
292 for y_dest := targetRect.Top to targetRect.Bottom - 1 do
293 begin
294 if (y_src = prev_y_src) and (y_src2 = prev_y_src2) and not vertSlightlyDifferent then
295 begin
296 if tempData = nil then
297 move((dest.ScanLine[y_dest-1+OffsetY]+OffsetX+targetRect.Left)^,(dest.ScanLine[y_dest+OffsetY]+OffsetX+targetRect.Left)^,(targetRect.Right-targetRect.Left)*sizeof(TBGRAPixel))
298 else
299 PutPixels(dest.ScanLine[y_dest+OffsetY]+OffsetX+targetRect.Left,tempData,targetRect.right-targetRect.left,ADrawMode,AOpacity);
300 end else
301 begin
302 if tempData = nil then
303 PDest := dest.ScanLine[y_dest+OffsetY]+OffsetX+targetRect.Left
304 else
305 PDest := tempData;
306 PSrc1 := bmp.Scanline[y_src];
307
308 acc_x_src := targetRect.Left*mod_x_src;
309 x_src := targetRect.Left*inc_x_src + (acc_x_src div NewWidth);
310 acc_x_src := acc_x_src mod NewWidth;
311
312 x_src := x_src+ (bmp.Width div 4) div NewWidth;
313 acc_x_src := acc_x_src+ (bmp.Width div 4) mod NewWidth;
314
315 DeltaSrcX := (bmp.Width div 2) div NewWidth;
316 acc_x_src2 := acc_x_src+ (bmp.Width div 2) mod NewWidth;
317 if acc_x_src2 > NewWidth then
318 begin
319 dec(acc_x_src2, NewWidth);
320 inc(DeltaSrcX);
321 end;
322 inc(Psrc1, x_src);
323 prevHorizTransition := tsNone;
324
325 if y_src2=y_src then
326 begin
327 horizTransition:= prevHorizTransition;
328 for x_dest := targetRect.left to targetRect.right - 1 do
329 begin
330 LinearMix(psrc1, DeltaSrcX, acc_x_src2 >= NewWidth shr 2, PDest, horizSlightlyDifferent, horizTransition);
331
332 Inc(PSrc1, inc_x_src);
333 Inc(acc_x_src, mod_x_src);
334 if acc_x_src >= newWidth then
335 begin
336 Dec(acc_x_src, newWidth);
337 Inc(PSrc1);
338 dec(DeltaSrcX);
339 end;
340 Inc(acc_x_src2, mod_x_src);
341 if acc_x_src2 >= newWidth then
342 begin
343 Dec(acc_x_src2, newWidth);
344 Inc(DeltaSrcX);
345 end;
346 inc(PDest);
347 end;
348 prevVertTransition:= tsPlain;
349 end else
350 begin
351 PSrc2 := bmp.Scanline[y_src2]+x_src;
352 for x_dest := targetRect.left to targetRect.right - 1 do
353 begin
354 horizTransition:= prevHorizTransition;
355 LinearMix(psrc1, DeltaSrcX, acc_x_src2 >= NewWidth shr 2, @vertColors[1], horizSlightlyDifferent, horizTransition);
356 horizTransition:= prevHorizTransition;
357 LinearMix(psrc2, DeltaSrcX, acc_x_src2 >= NewWidth shr 2, @vertColors[2], horizSlightlyDifferent, horizTransition);
358 prevHorizTransition:= horizTransition;
359 vertTransition:= prevVertTransition;
360 LinearMix(@vertColors[1],1,acc_y_src2 >= NewHeight shr 2,PDest,vertSlightlyDifferent,vertTransition);
361
362 Inc(PSrc1, inc_x_src);
363 Inc(PSrc2, inc_x_src);
364 Inc(acc_x_src, mod_x_src);
365 if acc_x_src >= newWidth then
366 begin
367 Dec(acc_x_src, newWidth);
368 Inc(PSrc1);
369 Inc(PSrc2);
370 dec(DeltaSrcX);
371 end;
372 Inc(acc_x_src2, mod_x_src);
373 if acc_x_src2 >= newWidth then
374 begin
375 Dec(acc_x_src2, newWidth);
376 Inc(DeltaSrcX);
377 end;
378 inc(PDest);
379 end;
380 prevVertTransition:= vertTransition;
381 end;
382
383 if tempData <> nil then
384 PutPixels(dest.ScanLine[y_dest+OffsetY]+OffsetX+targetRect.Left,tempData,targetRect.right-targetRect.left,ADrawMode,AOpacity);
385 end;
386
387 prev_y_src := y_src;
388 prev_y_src2 := y_src2;
389
390 Inc(y_src, inc_y_src);
391 Inc(acc_y_src, mod_y_src);
392 if acc_y_src >= newheight then
393 begin
394 Dec(acc_y_src, newheight);
395 Inc(y_src);
396 end;
397
398 Inc(y_src2, inc_y_src);
399 Inc(acc_y_src2, mod_y_src);
400 if acc_y_src2 >= newheight then
401 begin
402 Dec(acc_y_src2, newheight);
403 Inc(y_src2);
404 end;
405 end;
406 dest.InvalidateBitmap;
407 if Assigned(tempData) then FreeMem(tempData);
408end;
409
410procedure DownSamplePutImage2(source: TBGRACustomBitmap;
411 dest: TBGRACustomBitmap; OffsetX, OffsetY: Integer; ADrawMode: TDrawMode);
412const factorX = 2; factorY = 2; nbi= factorX*factorY;
413var xb,yb,ys: NativeInt;
414 pdest: PBGRAPixel;
415 psrc1,psrc2: PBGRAPixel;
416 asum,maxsum: NativeUInt;
417 newWidth,newHeight: NativeInt;
418 r,g,b: NativeUInt;
419begin
420 if (source.Width mod factorX <> 0) or (source.Height mod factorY <> 0) then
421 raise exception.Create('Source size must be a multiple of factorX and factorY');
422 newWidth := source.Width div factorX;
423 newHeight := source.Height div factorY;
424 ys := 0;
425 maxsum := 255*NativeInt(factorX)*NativeInt(factorY);
426 for yb := 0 to newHeight-1 do
427 begin
428 pdest := dest.ScanLine[yb+OffsetY]+OffsetX;
429 psrc1 := source.Scanline[ys]; inc(ys);
430 psrc2 := source.Scanline[ys]; inc(ys);
431 for xb := newWidth-1 downto 0 do
432 begin
433 asum := 0;
434 asum := psrc1^.alpha + psrc2^.alpha + (psrc1+1)^.alpha + (psrc2+1)^.alpha;
435 if asum = maxsum then
436 begin
437 pdest^.alpha := 255;
438 r := psrc1^.red + psrc2^.red + (psrc1+1)^.red + (psrc2+1)^.red;
439 g := psrc1^.green + psrc2^.green + (psrc1+1)^.green + (psrc2+1)^.green;
440 b := psrc1^.blue + psrc2^.blue + (psrc1+1)^.blue + (psrc2+1)^.blue;
441 inc(psrc1,factorX); inc(psrc2,factorX);
442 pdest^.red := (r + (nbi shr 1)) shr 2;
443 pdest^.green := (g + (nbi shr 1)) shr 2;
444 pdest^.blue := (b + (nbi shr 1)) shr 2;
445 end else
446 if ADrawMode <> dmSetExceptTransparent then
447 begin
448 if asum = 0 then
449 begin
450 if ADrawMode = dmSet then
451 pdest^ := BGRAPixelTransparent;
452 inc(psrc1,factorX); inc(psrc2,factorX);
453 end
454 else
455 begin
456 r := psrc1^.red*psrc1^.alpha + psrc2^.red*psrc2^.alpha + (psrc1+1)^.red*(psrc1+1)^.alpha + (psrc2+1)^.red*(psrc2+1)^.alpha;
457 g := psrc1^.green*psrc1^.alpha + psrc2^.green*psrc2^.alpha + (psrc1+1)^.green*(psrc1+1)^.alpha + (psrc2+1)^.green*(psrc2+1)^.alpha;
458 b := psrc1^.blue*psrc1^.alpha + psrc2^.blue*psrc2^.alpha + (psrc1+1)^.blue*(psrc1+1)^.alpha + (psrc2+1)^.blue*(psrc2+1)^.alpha;
459 inc(psrc1,factorX); inc(psrc2,factorX);
460 if ADrawMode = dmSet then
461 begin
462 pdest^.alpha := (asum + (nbi shr 1)) shr 2;
463 pdest^.red := (r + (asum shr 1)) div asum;
464 pdest^.green := (g + (asum shr 1)) div asum;
465 pdest^.blue := (b + (asum shr 1)) div asum;
466 end
467 else
468 begin
469 if ADrawMode = dmDrawWithTransparency then
470 DrawPixelInlineWithAlphaCheck(pdest,BGRA((r + (asum shr 1)) div asum,
471 (g + (asum shr 1)) div asum,
472 (b + (asum shr 1)) div asum,
473 (asum + (nbi shr 1)) shr 2)) else
474 if ADrawMode = dmFastBlend then
475 FastBlendPixelInline(pdest,BGRA((r + (asum shr 1)) div asum,
476 (g + (asum shr 1)) div asum,
477 (b + (asum shr 1)) div asum,
478 (asum + (nbi shr 1)) shr 2));
479 end;
480 end;
481 end;
482 inc(pdest);
483 end;
484 end;
485end;
486
487procedure DownSamplePutImage3(source: TBGRACustomBitmap;
488 dest: TBGRACustomBitmap; OffsetX, OffsetY: Integer; ADrawMode: TDrawMode);
489const factorX = 3; factorY = 3; nbi= factorX*factorY;
490var xb,yb,ys: NativeInt;
491 pdest: PBGRAPixel;
492 psrc1,psrc2,psrc3: PBGRAPixel;
493 asum,maxsum: NativeUInt;
494 newWidth,newHeight: NativeInt;
495 r,g,b: NativeUInt;
496begin
497 if (source.Width mod factorX <> 0) or (source.Height mod factorY <> 0) then
498 raise exception.Create('Source size must be a multiple of factorX and factorY');
499 newWidth := source.Width div factorX;
500 newHeight := source.Height div factorY;
501 ys := 0;
502 maxsum := 255*NativeInt(factorX)*NativeInt(factorY);
503 for yb := 0 to newHeight-1 do
504 begin
505 pdest := dest.ScanLine[yb+OffsetY]+OffsetX;
506 psrc1 := source.Scanline[ys]; inc(ys);
507 psrc2 := source.Scanline[ys]; inc(ys);
508 psrc3 := source.Scanline[ys]; inc(ys);
509 for xb := newWidth-1 downto 0 do
510 begin
511 asum := 0;
512 asum := psrc1^.alpha + psrc2^.alpha + psrc3^.alpha
513 + (psrc1+1)^.alpha + (psrc2+1)^.alpha + (psrc3+1)^.alpha
514 + (psrc1+2)^.alpha + (psrc2+2)^.alpha + (psrc3+2)^.alpha;
515 if asum = maxsum then
516 begin
517 pdest^.alpha := 255;
518 r := psrc1^.red + psrc2^.red + psrc3^.red
519 + (psrc1+1)^.red + (psrc2+1)^.red + (psrc3+1)^.red
520 + (psrc1+2)^.red + (psrc2+2)^.red + (psrc3+2)^.red;
521 g := psrc1^.green + psrc2^.green + psrc3^.green
522 + (psrc1+1)^.green + (psrc2+1)^.green + (psrc3+1)^.green
523 + (psrc1+2)^.green + (psrc2+2)^.green + (psrc3+2)^.green;
524 b := psrc1^.blue + psrc2^.blue + psrc3^.blue
525 + (psrc1+1)^.blue + (psrc2+1)^.blue + (psrc3+1)^.blue
526 + (psrc1+2)^.blue + (psrc2+2)^.blue + (psrc3+2)^.blue;
527 inc(psrc1,factorX); inc(psrc2,factorX); inc(psrc3,factorX);
528 pdest^.red := (r + (nbi shr 1)) div 9;
529 pdest^.green := (g + (nbi shr 1)) div 9;
530 pdest^.blue := (b + (nbi shr 1)) div 9;
531 end else
532 if ADrawMode <> dmSetExceptTransparent then
533 begin
534 if asum = 0 then
535 begin
536 if ADrawMode = dmSet then
537 pdest^ := BGRAPixelTransparent;
538 inc(psrc1,factorX); inc(psrc2,factorX); inc(psrc3,factorX);
539 end
540 else
541 begin
542 r := psrc1^.red*psrc1^.alpha + psrc2^.red*psrc2^.alpha + psrc3^.red*psrc3^.alpha
543 + (psrc1+1)^.red*(psrc1+1)^.alpha + (psrc2+1)^.red*(psrc2+1)^.alpha + (psrc3+1)^.red*(psrc3+1)^.alpha
544 + (psrc1+2)^.red*(psrc1+2)^.alpha + (psrc2+2)^.red*(psrc2+2)^.alpha + (psrc3+2)^.red*(psrc3+2)^.alpha;
545 g := psrc1^.green*psrc1^.alpha + psrc2^.green*psrc2^.alpha + psrc3^.green*psrc3^.alpha
546 + (psrc1+1)^.green*(psrc1+1)^.alpha + (psrc2+1)^.green*(psrc2+1)^.alpha + (psrc3+1)^.green*(psrc3+1)^.alpha
547 + (psrc1+2)^.green*(psrc1+2)^.alpha + (psrc2+2)^.green*(psrc2+2)^.alpha + (psrc3+2)^.green*(psrc3+2)^.alpha;
548 b := psrc1^.blue*psrc1^.alpha + psrc2^.blue*psrc2^.alpha + psrc3^.blue*psrc3^.alpha
549 + (psrc1+1)^.blue*(psrc1+1)^.alpha + (psrc2+1)^.blue*(psrc2+1)^.alpha + (psrc3+1)^.blue*(psrc3+1)^.alpha
550 + (psrc1+2)^.blue*(psrc1+2)^.alpha + (psrc2+2)^.blue*(psrc2+2)^.alpha + (psrc3+2)^.blue*(psrc3+2)^.alpha;
551 inc(psrc1,factorX); inc(psrc2,factorX); inc(psrc3,factorX);
552 if ADrawMode = dmSet then
553 begin
554 pdest^.alpha := (asum + (nbi shr 1)) div 9;
555 pdest^.red := (r + (asum shr 1)) div asum;
556 pdest^.green := (g + (asum shr 1)) div asum;
557 pdest^.blue := (b + (asum shr 1)) div asum;
558 end
559 else
560 begin
561 if ADrawMode = dmDrawWithTransparency then
562 DrawPixelInlineWithAlphaCheck(pdest,BGRA((r + (asum shr 1)) div asum,
563 (g + (asum shr 1)) div asum,
564 (b + (asum shr 1)) div asum,
565 (asum + (nbi shr 1)) div 9)) else
566 if ADrawMode = dmFastBlend then
567 FastBlendPixelInline(pdest,BGRA((r + (asum shr 1)) div asum,
568 (g + (asum shr 1)) div asum,
569 (b + (asum shr 1)) div asum,
570 (asum + (nbi shr 1)) div 9));
571 end;
572 end;
573 end;
574 inc(pdest);
575 end;
576 end;
577end;
578
579procedure DownSamplePutImage(source: TBGRACustomBitmap; factorX, factorY: integer;
580 dest: TBGRACustomBitmap; OffsetX, OffsetY: Integer; ADrawMode: TDrawMode);
581var xb,yb,ys,iy,ix: NativeInt;
582 pdest,psrci: PBGRAPixel;
583 psrc: array of PBGRAPixel;
584 asum,maxsum: NativeUInt;
585 newWidth,newHeight: NativeInt;
586 r,g,b,nbi: NativeUInt;
587begin
588 if ADrawMode = dmXor then raise exception.Create('dmXor drawmode not supported');
589 if (factorX = 2) and (factorY = 2) then
590 begin
591 DownSamplePutImage2(source,dest,OffsetX,OffsetY,ADrawMode);
592 exit;
593 end;
594 if (factorX = 3) and (factorY = 3) then
595 begin
596 DownSamplePutImage3(source,dest,OffsetX,OffsetY,ADrawMode);
597 exit;
598 end;
599 if (source.Width mod factorX <> 0) or (source.Height mod factorY <> 0) then
600 raise exception.Create('Source size must be a multiple of factorX and factorY');
601 newWidth := source.Width div factorX;
602 newHeight := source.Height div factorY;
603 ys := 0;
604 maxsum := 255*NativeInt(factorX)*NativeInt(factorY);
605 nbi := factorX*factorY;
606 setlength(psrc, factorY);
607 for yb := 0 to newHeight-1 do
608 begin
609 pdest := dest.ScanLine[yb+OffsetY]+OffsetX;
610 for iy := factorY-1 downto 0 do
611 begin
612 psrc[iy] := source.Scanline[ys];
613 inc(ys);
614 end;
615 for xb := newWidth-1 downto 0 do
616 begin
617 asum := 0;
618 for iy := factorY-1 downto 0 do
619 begin
620 psrci := psrc[iy];
621 for ix := factorX-1 downto 0 do
622 asum += (psrci+ix)^.alpha;
623 end;
624 if asum = maxsum then
625 begin
626 pdest^.alpha := 255;
627 r := 0;
628 g := 0;
629 b := 0;
630 for iy := factorY-1 downto 0 do
631 for ix := factorX-1 downto 0 do
632 begin
633 with psrc[iy]^ do
634 begin
635 r += red;
636 g += green;
637 b += blue;
638 end;
639 inc(psrc[iy]);
640 end;
641 pdest^.red := (r + (nbi shr 1)) div nbi;
642 pdest^.green := (g + (nbi shr 1)) div nbi;
643 pdest^.blue := (b + (nbi shr 1)) div nbi;
644 end else
645 if ADrawMode <> dmSetExceptTransparent then
646 begin
647 if asum = 0 then
648 begin
649 if ADrawMode = dmSet then
650 pdest^ := BGRAPixelTransparent;
651 for iy := factorY-1 downto 0 do
652 inc(psrc[iy],factorX);
653 end
654 else
655 begin
656 r := 0;
657 g := 0;
658 b := 0;
659 for iy := factorY-1 downto 0 do
660 for ix := factorX-1 downto 0 do
661 begin
662 with psrc[iy]^ do
663 begin
664 r += red*alpha;
665 g += green*alpha;
666 b += blue*alpha;
667 end;
668 inc(psrc[iy]);
669 end;
670 if ADrawMode = dmSet then
671 begin
672 pdest^.alpha := (asum + (nbi shr 1)) div nbi;
673 pdest^.red := (r + (asum shr 1)) div asum;
674 pdest^.green := (g + (asum shr 1)) div asum;
675 pdest^.blue := (b + (asum shr 1)) div asum;
676 end
677 else
678 begin
679 if ADrawMode = dmDrawWithTransparency then
680 DrawPixelInlineWithAlphaCheck(pdest,BGRA((r + (asum shr 1)) div asum,
681 (g + (asum shr 1)) div asum,
682 (b + (asum shr 1)) div asum,
683 (asum + (nbi shr 1)) div nbi)) else
684 if ADrawMode = dmFastBlend then
685 FastBlendPixelInline(pdest,BGRA((r + (asum shr 1)) div asum,
686 (g + (asum shr 1)) div asum,
687 (b + (asum shr 1)) div asum,
688 (asum + (nbi shr 1)) div nbi));
689 end;
690 end;
691 end;
692 inc(pdest);
693 end;
694 end;
695end;
696
697function DownSample(source: TBGRACustomBitmap; factorX, factorY: integer): TBGRACustomBitmap;
698begin
699 if (source.Width mod factorX <> 0) or (source.Height mod factorY <> 0) then
700 raise exception.Create('Source size must be a multiple of factorX and factorY');
701 result := source.NewBitmap(source.Width div factorX, source.Height div factorY);
702 DownSamplePutImage(source,factorX,factorY,result,0,0,dmSet);
703end;
704
705{---------------------------- Interpolation filters ----------------------------------------}
706
707function FineInterpolation(t: single; ResampleFilter: TResampleFilter): single;
708begin
709 if ResampleFilter <= rfLinear then
710 begin
711 if ResampleFilter = rfBox then
712 begin
713 result := round(t);
714 end else
715 result := t;
716 end else
717 begin
718 if t <= 0.5 then
719 result := t*t*2 else
720 result := 1-(1-t)*(1-t)*2;
721 if ResampleFilter <> rfCosine then result := (result+t)*0.5;
722 end;
723end;
724
725function FineInterpolation256(t256: integer; ResampleFilter: TResampleFilter): integer;
726begin
727 if ResampleFilter <= rfLinear then
728 begin
729 if ResampleFilter = rfBox then
730 begin
731 if t256 < 128 then
732 result := 0
733 else
734 result := 256;
735 end
736 else
737 result := t256;
738 end else
739 begin
740 if t256 <= 128 then
741 result := (t256*t256) shr 7 else
742 result := 256 - (((256-t256)*(256-t256)) shr 7);
743 if ResampleFilter <> rfCosine then result := (result+t256) shr 1;
744 end;
745end;
746
747{ TCubicKernel }
748
749function TCubicKernel.pow3(x: single): single;
750begin
751 if x <= 0.0 then
752 result:=0.0
753 else
754 result:=x * x * x;
755end;
756
757function TCubicKernel.Interpolation(t: single): single;
758const globalfactor = 1/6;
759begin
760 if t > 2 then
761 result := 0
762 else
763 result:= globalfactor *
764 (pow3(t + 2 ) - 4 * pow3(t + 1 ) + 6 * pow3(t ) - 4 * pow3(t - 1 ) );
765end;
766
767function TCubicKernel.ShouldCheckRange: boolean;
768begin
769 Result:= false;
770end;
771
772function TCubicKernel.KernelWidth: single;
773begin
774 Result:= 2;
775end;
776
777{ TMitchellKernel }
778
779function TMitchellKernel.Interpolation(t: single): single;
780var
781 tt, ttt: single;
782const OneEighteenth = 1 / 18;
783begin
784 t := Abs(t);
785 tt := Sqr(t);
786 ttt := tt * t;
787 if t < 1 then Result := (21 * ttt - 36 * tt + 16 ) * OneEighteenth
788 else if t < 2 then Result := (- 7 * ttt + 36 * tt - 60 * t + 32) * OneEighteenth
789 else Result := 0;
790end;
791
792function TMitchellKernel.ShouldCheckRange: Boolean;
793begin
794 Result := True;
795end;
796
797function TMitchellKernel.KernelWidth: single;
798begin
799 Result := 2;
800end;
801
802{ TSplineKernel }
803
804constructor TSplineKernel.Create;
805begin
806 coeff := 0.5;
807end;
808
809constructor TSplineKernel.Create(ACoeff: single);
810begin
811 Coeff := ACoeff;
812end;
813
814function TSplineKernel.Interpolation(t: single): single;
815var
816 tt, ttt: single;
817begin
818 t := Abs(t);
819 tt := Sqr(t);
820 ttt := tt * t;
821 if t < 1 then
822 Result := (2 - Coeff) * ttt - (3 - Coeff) * tt + 1
823 else if t < 2 then
824 Result := -Coeff * (ttt - 5 * tt + 8 * t - 4)
825 else
826 Result := 0;
827end;
828
829function TSplineKernel.ShouldCheckRange: Boolean;
830begin
831 Result := True;
832end;
833
834function TSplineKernel.KernelWidth: single;
835begin
836 Result := 2;
837end;
838
839{ TLanczosKernel }
840{ by stab }
841procedure TLanczosKernel.SetNumberOfLobes(AValue: integer);
842begin
843 if AValue < 1 then AValue := 1;
844 if FNumberOfLobes=AValue then Exit;
845 FNumberOfLobes:=AValue;
846 if AValue = 1 then FFactor := 1.5 else FFactor := AValue;
847end;
848
849constructor TLanczosKernel.Create(ANumberOfLobes: integer);
850begin
851 NumberOfLobes:= ANumberOfLobes;
852end;
853
854function TLanczosKernel.Interpolation(t: single): single;
855var Pi_t: ValReal;
856begin
857 if t = 0 then
858 Result := 1
859 else if t < FNumberOfLobes then
860 begin
861 Pi_t := pi * t;
862 Result := FFactor * sin(Pi_t) * sin(Pi_t / FNumberOfLobes) /
863 (Pi_t * Pi_t)
864 end
865 else
866 Result := 0;
867end;
868
869function TLanczosKernel.ShouldCheckRange: boolean;
870begin
871 Result := True;
872end;
873
874function TLanczosKernel.KernelWidth: single;
875begin
876 Result := FNumberOfLobes;
877end;
878
879{--------------------------------------------- Fine resample ------------------------------------------------}
880
881function FineResampleLarger(bmp: TBGRACustomBitmap;
882 newWidth, newHeight: integer; ResampleFilter: TResampleFilter): TBGRACustomBitmap;
883type
884 TInterpolationEntry = record
885 isrc1,isrc2,factCorr: integer;
886 end;
887var
888 yb, xb: integer;
889 pdest,psrc1,psrc2: PBGRAPixel;
890 xsrc, ysrc, xfactor, yfactor: double;
891 xTab,yTab: array of TInterpolationEntry;
892 xInfo,yInfo: TInterpolationEntry;
893 cUpLeft, cUpRight, cLowLeft, cLowRight: TBGRAPixel;
894 factHoriz, factVert: single;
895 fUpLeft, fUpRight, fLowLeft, fLowRight: integer;
896 faUpLeft, faUpRight, faLowLeft, faLowRight: integer;
897 rSum, gSum, bSum, aSum: integer;
898 temp: TBGRACustomBitmap;
899begin
900 if (newWidth < bmp.Width) or (newHeight < bmp.Height) then
901 raise ERangeError.Create('FineResampleLarger: New dimensions must be greater or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')');
902
903 if (newWidth = 0) or (newHeight = 0) then
904 begin
905 Result := bmp.NewBitmap(NewWidth, NewHeight);
906 exit;
907 end;
908
909 bmp.LoadFromBitmapIfNeeded;
910
911 if (bmp.Width = 1) and (bmp.Height = 1) then
912 begin
913 Result := bmp.NewBitmap(NewWidth, NewHeight);
914 Result.Fill(bmp.GetPixel(0, 0));
915 exit;
916 end
917 else
918 if bmp.Width = 1 then
919 begin
920 temp := bmp.NewBitmap(2, bmp.Height);
921 temp.PutImage(0, 0, bmp, dmSet);
922 temp.PutImage(1, 0, bmp, dmSet);
923 Result := FineResampleLarger(temp, 2, newHeight, ResampleFilter);
924 temp.Free;
925 temp := Result;
926 Result := SimpleStretch(temp, newWidth,temp.Height);
927 temp.Free;
928 exit;
929 end
930 else
931 if bmp.Height = 1 then
932 begin
933 temp := bmp.NewBitmap(bmp.Width, 2);
934 temp.PutImage(0, 0, bmp, dmSet);
935 temp.PutImage(0, 1, bmp, dmSet);
936 Result := FineResampleLarger(temp, newWidth, 2, ResampleFilter);
937 temp.Free;
938 temp := Result;
939 Result := SimpleStretch(temp, temp.Width,newHeight);
940 temp.Free;
941 exit;
942 end;
943
944 Result := bmp.NewBitmap(NewWidth, NewHeight);
945 yfactor := (bmp.Height - 1) / (newHeight - 1);
946 xfactor := (bmp.Width - 1) / (newWidth - 1);
947
948 setlength(yTab, newHeight);
949 for yb := 0 to newHeight - 1 do
950 begin
951 ysrc := yb * yfactor;
952 factVert := frac(ysrc);
953 yTab[yb].isrc1 := floor(ysrc);
954 yTab[yb].isrc2 := min(bmp.Height-1, ceil(ysrc));
955 yTab[yb].factCorr := round(FineInterpolation(factVert,ResampleFilter)*256);
956 end;
957 setlength(xTab, newWidth);
958 for xb := 0 to newWidth - 1 do
959 begin
960 xsrc := xb * xfactor;
961 factHoriz := frac(xsrc);
962 xTab[xb].isrc1 := floor(xsrc);
963 xTab[xb].isrc2 := min(bmp.Width-1,ceil(xsrc));
964 xTab[xb].factCorr := round(FineInterpolation(factHoriz,ResampleFilter)*256);
965 end;
966
967 for yb := 0 to newHeight - 1 do
968 begin
969 pdest := Result.Scanline[yb];
970 yInfo := yTab[yb];
971 psrc1 := bmp.scanline[yInfo.isrc1];
972 psrc2 := bmp.scanline[yInfo.isrc2];
973 for xb := 0 to newWidth - 1 do
974 begin
975 xInfo := xTab[xb];
976
977 cUpLeft := (psrc1 + xInfo.isrc1)^;
978 cUpRight := (psrc1 + xInfo.isrc2)^;
979 cLowLeft := (psrc2 + xInfo.isrc1)^;
980 cLowRight := (psrc2 + xInfo.isrc2)^;
981
982 fLowRight := (xInfo.factCorr * yInfo.factCorr + 128) shr 8;
983 fLowLeft := yInfo.factCorr - fLowRight;
984 fUpRight := xInfo.factCorr - fLowRight;
985 fUpLeft := (256 - xInfo.factCorr) - fLowLeft;
986
987 faUpLeft := fUpLeft * cUpLeft.alpha;
988 faUpRight := fUpRight * cUpRight.alpha;
989 faLowLeft := fLowLeft * cLowLeft.alpha;
990 faLowRight := fLowRight * cLowRight.alpha;
991
992 rSum := cUpLeft.red * faUpLeft + cUpRight.red * faUpRight +
993 cLowLeft.red * faLowLeft + cLowRight.red * faLowRight;
994 gSum := cUpLeft.green * faUpLeft + cUpRight.green * faUpRight +
995 cLowLeft.green * faLowLeft + cLowRight.green * faLowRight;
996 bSum := cUpLeft.blue * faUpLeft + cUpRight.blue * faUpRight +
997 cLowLeft.blue * faLowLeft + cLowRight.blue * faLowRight;
998 aSum := cUpLeft.alpha * fUpLeft + cUpRight.alpha * fUpRight +
999 cLowLeft.alpha * fLowLeft + cLowRight.alpha * fLowRight;
1000
1001 if aSum = 0 then
1002 pdest^ := BGRAPixelTransparent
1003 else
1004 pdest^ := BGRA((rSum + aSum shr 1) div aSum, (gSum + aSum shr 1) div aSum,
1005 (bSum + aSum shr 1) div aSum, (aSum + 128) shr 8);
1006 Inc(pdest);
1007
1008 end;
1009 end;
1010end;
1011
1012function FineResampleSmaller(bmp: TBGRACustomBitmap;
1013 newWidth, newHeight: integer): TBGRACustomBitmap;
1014var
1015 yb, xb, yb2, xb2: integer;
1016 pdest, psrc: PBGRAPixel;
1017 lineDelta, delta: integer;
1018 xsrc1, ysrc1, xsrc2, ysrc2, xfactor, yfactor: double;
1019 ixsrc1, ixsrc2, iysrc1, iysrc2, ixsrc1p1, ixsrc2m1, iysrc1p1, iysrc2m1: integer;
1020 cBorder, cFull, cUpLeft, cUpRight, cLowLeft, cLowRight: TBGRAPixel;
1021 factHoriz1, factHoriz2, factVert1, factVert2, Sum, fUpLeft, fUpRight,
1022 fLowLeft, fLowRight, faUpLeft, faUpRight, faLowLeft, faLowRight: single;
1023 rSum, gSum, bSum, aSum: double;
1024begin
1025 if (newWidth > bmp.Width) or (newHeight > bmp.Height) then
1026 raise ERangeError.Create('FineResampleSmaller: New dimensions must be smaller or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')');
1027 Result := bmp.NewBitmap(NewWidth, NewHeight);
1028 if (newWidth = 0) or (newHeight = 0) or (bmp.Width = 0) or (bmp.Height = 0) then
1029 exit;
1030
1031 bmp.LoadFromBitmapIfNeeded;
1032
1033 if bmp.lineOrder = riloTopToBottom then
1034 lineDelta := bmp.Width
1035 else
1036 lineDelta := -bmp.Width;
1037
1038 yfactor := bmp.Height / newHeight;
1039 xfactor := bmp.Width / newWidth;
1040 for yb := 0 to newHeight - 1 do
1041 begin
1042 pdest := Result.Scanline[yb];
1043 ysrc1 := yb * yfactor;
1044 ysrc2 := (yb + 1) * yfactor;
1045 iysrc1 := trunc(ysrc1);
1046 if (int(ysrc2) = int(ysrc1)) or (ysrc2 = iysrc1 + 1) then
1047 begin
1048 iysrc2 := iysrc1;
1049 factVert1 := 1;
1050 factVert2 := 0;
1051 end
1052 else
1053 begin
1054 iysrc2 := trunc(ysrc2);
1055 factVert1 := 1 - frac(ysrc1);
1056 factVert2 := frac(ysrc2);
1057 end;
1058 for xb := 0 to newWidth - 1 do
1059 begin
1060 xsrc1 := xb * xfactor;
1061 xsrc2 := (xb + 1) * xfactor;
1062 ixsrc1 := trunc(xsrc1);
1063 if (int(xsrc2) = int(xsrc1)) or (xsrc2 = ixsrc1 + 1) then
1064 begin
1065 ixsrc2 := ixsrc1;
1066 factHoriz1 := 1;
1067 factHoriz2 := 0;
1068 end
1069 else
1070 begin
1071 ixsrc2 := trunc(xsrc2);
1072 factHoriz1 := 1 - frac(xsrc1);
1073 factHoriz2 := frac(xsrc2);
1074 end;
1075
1076 cUpLeft := bmp.GetPixel(ixsrc1, iysrc1);
1077 cUpRight := bmp.GetPixel(ixsrc2, iysrc1);
1078 cLowLeft := bmp.GetPixel(ixsrc1, iysrc2);
1079 cLowRight := bmp.GetPixel(ixsrc2, iysrc2);
1080
1081 fUpLeft := factHoriz1 * factVert1;
1082 fUpRight := factHoriz2 * factVert1;
1083 fLowLeft := factHoriz1 * factVert2;
1084 fLowRight := factHoriz2 * factVert2;
1085
1086 faUpLeft := fUpLeft * cUpLeft.alpha;
1087 faUpRight := fUpRight * cUpRight.alpha;
1088 faLowLeft := fLowLeft * cLowLeft.alpha;
1089 faLowRight := fLowRight * cLowRight.alpha;
1090
1091 Sum := fUpLeft + fUpRight + fLowLeft + fLowRight;
1092 rSum := cUpLeft.red * faUpLeft + cUpRight.red * faUpRight +
1093 cLowLeft.red * faLowLeft + cLowRight.red * faLowRight;
1094 gSum := cUpLeft.green * faUpLeft + cUpRight.green * faUpRight +
1095 cLowLeft.green * faLowLeft + cLowRight.green * faLowRight;
1096 bSum := cUpLeft.blue * faUpLeft + cUpRight.blue * faUpRight +
1097 cLowLeft.blue * faLowLeft + cLowRight.blue * faLowRight;
1098 aSum := cUpLeft.alpha * fUpLeft + cUpRight.alpha * fUpRight +
1099 cLowLeft.alpha * fLowLeft + cLowRight.alpha * fLowRight;
1100
1101 ixsrc1p1 := ixsrc1 + 1;
1102 ixsrc2m1 := ixsrc2 - 1;
1103 iysrc1p1 := iysrc1 + 1;
1104 iysrc2m1 := iysrc2 - 1;
1105
1106 if ixsrc2m1 >= ixsrc1p1 then
1107 begin
1108 psrc := bmp.scanline[iysrc1] + ixsrc1p1;
1109 for xb2 := ixsrc1p1 to ixsrc2m1 do
1110 begin
1111 cBorder := psrc^;
1112 Inc(psrc);
1113 rSum += cBorder.red * cBorder.alpha * factVert1;
1114 gSum += cBorder.green * cBorder.alpha * factVert1;
1115 bSum += cBorder.blue * cBorder.alpha * factVert1;
1116 aSum += cBorder.alpha * factVert1;
1117 Sum += factVert1;
1118 end;
1119
1120 if (factVert2 <> 0) and (iysrc2 < bmp.Height) then
1121 begin
1122 psrc := bmp.scanline[iysrc2] + ixsrc1p1;
1123 for xb2 := ixsrc1p1 to ixsrc2m1 do
1124 begin
1125 cBorder := psrc^;
1126 Inc(psrc);
1127 rSum += cBorder.red * cBorder.alpha * factVert2;
1128 gSum += cBorder.green * cBorder.alpha * factVert2;
1129 bSum += cBorder.blue * cBorder.alpha * factVert2;
1130 aSum += cBorder.alpha * factVert2;
1131 Sum += factVert2;
1132 end;
1133 end;
1134 end;
1135
1136 if iysrc2m1 >= iysrc1p1 then
1137 begin
1138 psrc := bmp.scanline[iysrc1p1] + ixsrc1;
1139 for yb2 := iysrc1p1 to iysrc2m1 do
1140 begin
1141 cBorder := psrc^;
1142 Inc(psrc, lineDelta);
1143 rSum += cBorder.red * cBorder.alpha * factHoriz1;
1144 gSum += cBorder.green * cBorder.alpha * factHoriz1;
1145 bSum += cBorder.blue * cBorder.alpha * factHoriz1;
1146 aSum += cBorder.alpha * factHoriz1;
1147 Sum += factHoriz1;
1148 end;
1149
1150 if (factHoriz2 <> 0) and (ixsrc2 < bmp.Width) then
1151 begin
1152 psrc := bmp.scanline[iysrc1p1] + ixsrc2;
1153 for yb2 := iysrc1p1 to iysrc2m1 do
1154 begin
1155 cBorder := psrc^;
1156 Inc(psrc, lineDelta);
1157 rSum += cBorder.red * cBorder.alpha * factHoriz2;
1158 gSum += cBorder.green * cBorder.alpha * factHoriz2;
1159 bSum += cBorder.blue * cBorder.alpha * factHoriz2;
1160 aSum += cBorder.alpha * factHoriz2;
1161 Sum += factHoriz2;
1162 end;
1163 end;
1164 end;
1165
1166 if (ixsrc2m1 >= ixsrc1p1) and (iysrc2m1 >= iysrc1p1) then
1167 begin
1168 delta := lineDelta - (ixsrc2m1 - ixsrc1p1 + 1);
1169 psrc := bmp.scanline[iysrc1p1] + ixsrc1p1;
1170 for yb2 := iysrc1p1 to iysrc2m1 do
1171 begin
1172 for xb2 := ixsrc1p1 to ixsrc2m1 do
1173 begin
1174 cFull := psrc^;
1175 rSum += cFull.red * cFull.alpha;
1176 gSum += cFull.green * cFull.alpha;
1177 bSum += cFull.blue * cFull.alpha;
1178 aSum += cFull.alpha;
1179 Sum += 1;
1180 Inc(psrc);
1181 end;
1182 Inc(psrc, delta);
1183 end;
1184 end;
1185
1186 if aSum = 0 then
1187 pdest^ := BGRAPixelTransparent
1188 else
1189 pdest^ := BGRA(round(rSum / aSum), round(gSum / aSum),
1190 round(bSum / aSum), round(aSum / Sum));
1191 Inc(pdest);
1192
1193 end;
1194 end;
1195end;
1196
1197function CreateInterpolator(style: TSplineStyle): TWideKernelFilter;
1198begin
1199 case Style of
1200 ssInside, ssInsideWithEnds: result := TCubicKernel.Create;
1201 ssCrossing, ssCrossingWithEnds: result := TMitchellKernel.Create;
1202 ssOutside: result := TSplineKernel.Create(0.5);
1203 ssRoundOutside: result := TSplineKernel.Create(0.75);
1204 ssVertexToSide: result := TSplineKernel.Create(1);
1205 ssEasyBezier: raise Exception.Create('EasyBezier does not have an interpolator');
1206 else
1207 raise Exception.Create('Unknown spline style');
1208 end;
1209end;
1210
1211function FineResample(bmp: TBGRACustomBitmap;
1212 NewWidth, NewHeight: integer; ResampleFilter: TResampleFilter): TBGRACustomBitmap;
1213var
1214 temp, newtemp: TBGRACustomBitmap;
1215 tempFilter1,tempFilter2: TWideKernelFilter;
1216begin
1217 if (NewWidth = bmp.Width) and (NewHeight = bmp.Height) then
1218 begin
1219 Result := bmp.Duplicate;
1220 exit;
1221 end;
1222 case ResampleFilter of
1223 rfBicubic: //blur
1224 begin
1225 tempFilter1 := TCubicKernel.Create;
1226 result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1);
1227 tempFilter1.Free;
1228 exit;
1229 end;
1230 rfMitchell:
1231 begin
1232 tempFilter1 := TMitchellKernel.Create;
1233 result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1);
1234 tempFilter1.Free;
1235 exit;
1236 end;
1237 rfSpline:
1238 begin
1239 tempFilter1 := TSplineKernel.Create;
1240 result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1);
1241 tempFilter1.Free;
1242 exit;
1243 end;
1244 rfLanczos2,rfLanczos3,rfLanczos4:
1245 begin
1246 tempFilter1 := TLanczosKernel.Create(ord(ResampleFilter)-ord(rfLanczos2)+2);
1247 result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1);
1248 tempFilter1.Free;
1249 exit;
1250 end;
1251 rfBestQuality:
1252 begin
1253 tempFilter1 := TSplineKernel.Create;
1254 tempFilter2 := TMitchellKernel.Create;
1255 result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter2,tempFilter1);
1256 tempFilter1.Free;
1257 tempFilter2.Free;
1258 exit;
1259 end;
1260 end;
1261
1262 if (NewWidth >= bmp.Width) and (NewHeight >= bmp.Height) then
1263 Result := FineResampleLarger(bmp, NewWidth, NewHeight, ResampleFilter)
1264 else
1265 if (NewWidth <= bmp.Width) and (NewHeight <= bmp.Height) then
1266 Result := FineResampleSmaller(bmp, NewWidth, NewHeight)
1267 else
1268 begin
1269 temp := bmp;
1270
1271 if NewWidth < bmp.Width then
1272 begin
1273 newtemp := FineResampleSmaller(temp, NewWidth, temp.Height);
1274 if (temp <> bmp) then
1275 temp.Free;
1276 temp := newtemp;
1277 end;
1278
1279 if NewHeight < bmp.Height then
1280 begin
1281 newtemp := FineResampleSmaller(temp, temp.Width, NewHeight);
1282 if (temp <> bmp) then
1283 temp.Free;
1284 temp := newtemp;
1285 end;
1286
1287 if NewWidth > bmp.Width then
1288 begin
1289 newtemp := FineResampleLarger(temp, NewWidth, temp.Height, ResampleFilter);
1290 if (temp <> bmp) then
1291 temp.Free;
1292 temp := newtemp;
1293 end;
1294
1295 if NewHeight > bmp.Height then
1296 begin
1297 newtemp := FineResampleLarger(temp, temp.Width, NewHeight, ResampleFilter);
1298 if (temp <> bmp) then
1299 temp.Free;
1300 temp := newtemp;
1301 end;
1302
1303 if temp <> bmp then
1304 Result := temp
1305 else
1306 Result := bmp.Duplicate;
1307 end;
1308end;
1309
1310{------------------------ Wide kernel filtering adapted from Graphics32 ---------------------------}
1311
1312function Constrain(const Value, Lo, Hi: Integer): Integer;
1313begin
1314 if Value < Lo then
1315 Result := Lo
1316 else if Value > Hi then
1317 Result := Hi
1318 else
1319 Result := Value;
1320end;
1321
1322type
1323 TPointRec = record
1324 Pos: Integer;
1325 Weight: Single;
1326 end;
1327
1328 TCluster = array of TPointRec;
1329 TMappingTable = array of TCluster;
1330
1331{$warnings off}
1332function BuildMappingTable(
1333 DstLo, DstHi: Integer;
1334 ClipLo, ClipHi: Integer;
1335 SrcLo, SrcHi: Integer;
1336 KernelSmaller,KernelLarger: TWideKernelFilter): TMappingTable;
1337Const FullEdge = false;
1338var
1339 SrcW, DstW, ClipW: Integer;
1340 FilterWidth: Single;
1341 Scale, OldScale: Single;
1342 Center: Single;
1343 Left, Right: Integer;
1344 I, J, K: Integer;
1345 Weight: Single;
1346begin
1347 SrcW := SrcHi - SrcLo;
1348 DstW := DstHi - DstLo;
1349 ClipW := ClipHi - ClipLo;
1350 if SrcW = 0 then
1351 begin
1352 Result := nil;
1353 Exit;
1354 end
1355 else if SrcW = 1 then
1356 begin
1357 SetLength(Result, ClipW);
1358 for I := 0 to ClipW - 1 do
1359 begin
1360 SetLength(Result[I], 1);
1361 Result[I][0].Pos := 0;
1362 Result[I][0].Weight := 1;
1363 end;
1364 Exit;
1365 end;
1366 SetLength(Result, ClipW);
1367 if ClipW = 0 then Exit;
1368
1369 if FullEdge then Scale := DstW / SrcW
1370 else Scale := (DstW - 1) / (SrcW - 1);
1371
1372 K := 0;
1373
1374 if Scale = 0 then
1375 begin
1376 SetLength(Result[0], 1);
1377 Result[0][0].Pos := (SrcLo + SrcHi) div 2;
1378 Result[0][0].Weight := 1;
1379 end
1380 else if Scale < 1 then
1381 begin
1382 FilterWidth := KernelSmaller.KernelWidth;
1383 OldScale := Scale;
1384 Scale := 1 / Scale;
1385 FilterWidth := FilterWidth * Scale;
1386 for I := 0 to ClipW - 1 do
1387 begin
1388 if FullEdge then
1389 Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale
1390 else
1391 Center := SrcLo + (I - DstLo + ClipLo) * Scale;
1392 Left := Floor(Center - FilterWidth);
1393 Right := Ceil(Center + FilterWidth);
1394 for J := Left to Right do
1395 begin
1396 Weight := KernelSmaller.Interpolation((Center - J) * OldScale) * OldScale;
1397 if Weight <> 0 then
1398 begin
1399 K := Length(Result[I]);
1400 SetLength(Result[I], K + 1);
1401 Result[I][K].Pos := Constrain(J, SrcLo, SrcHi - 1);
1402 Result[I][K].Weight := Weight;
1403 end;
1404 end;
1405 if Length(Result[I]) = 0 then
1406 begin
1407 SetLength(Result[I], 1);
1408 Result[I][0].Pos := Floor(Center);
1409 Result[I][0].Weight := 1;
1410 end;
1411 end;
1412 end
1413 else // scale > 1
1414 begin
1415 FilterWidth := KernelLarger.KernelWidth;
1416 Scale := 1 / Scale;
1417 for I := 0 to ClipW - 1 do
1418 begin
1419 if FullEdge then
1420 Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale
1421 else
1422 Center := SrcLo + (I - DstLo + ClipLo) * Scale;
1423 Left := Floor(Center - FilterWidth);
1424 Right := Ceil(Center + FilterWidth);
1425 for J := Left to Right do
1426 begin
1427 Weight := KernelLarger.Interpolation(Center - j);
1428 if Weight <> 0 then
1429 begin
1430 K := Length(Result[I]);
1431 SetLength(Result[I], k + 1);
1432 Result[I][K].Pos := Constrain(j, SrcLo, SrcHi - 1);
1433 Result[I][K].Weight := Weight;
1434 end;
1435 end;
1436 end;
1437 end;
1438end;
1439{$warnings on}
1440
1441function WideKernelResample(bmp: TBGRACustomBitmap;
1442 NewWidth, NewHeight: integer; ResampleFilterSmaller, ResampleFilterLarger: TWideKernelFilter): TBGRACustomBitmap;
1443type
1444 TSum = record
1445 sumR,sumG,sumB,sumA: single;
1446 end;
1447
1448var
1449 mapX,mapY: TMappingTable;
1450 xb,yb,xc,yc,MapXLoPos,MapXHiPos: integer;
1451 clusterX,clusterY: TCluster;
1452 verticalSum: array of TSum;
1453 scanlinesSrc: array of PBGRAPixel;
1454 sum: TSum;
1455 c: TBGRAPixel;
1456 w,wa: single;
1457 pdest: PBGRAPixel;
1458begin
1459 result := bmp.NewBitmap(NewWidth,NewHeight);
1460 if (NewWidth=0) or (NewHeight=0) then exit;
1461 mapX := BuildMappingTable(0,NewWidth,0,NewWidth,0,bmp.Width,ResampleFilterSmaller,ResampleFilterLarger);
1462 mapY := BuildMappingTable(0,NewHeight,0,NewHeight,0,bmp.Height,ResampleFilterSmaller,ResampleFilterLarger);
1463
1464 MapXLoPos := MapX[0][0].Pos;
1465 MapXHiPos := MapX[NewWidth - 1][High(MapX[NewWidth - 1])].Pos;
1466
1467 setlength(verticalSum, MapXHiPos-MapXLoPos+1);
1468
1469 setlength(scanlinesSrc, bmp.Height);
1470 for yb := 0 to bmp.Height-1 do
1471 scanlinesSrc[yb] := bmp.ScanLine[yb];
1472
1473 for yb := 0 to NewHeight-1 do
1474 begin
1475 clusterY := mapY[yb];
1476
1477 for xb := MapXLoPos to MapXHiPos do
1478 begin
1479 fillchar(verticalSum[xb - MapXLoPos],sizeof(verticalSum[xb - MapXLoPos]),0);
1480 for yc := 0 to high(clusterY) do
1481 with verticalSum[xb - MapXLoPos] do
1482 begin
1483 c := (scanlinesSrc[clusterY[yc].Pos]+xb)^;
1484 w := clusterY[yc].Weight;
1485 wa := w * c.alpha;
1486 sumA += wa;
1487 sumR += c.red * wa;
1488 sumG += c.green * wa;
1489 sumB += c.blue * wa;
1490 end;
1491 end;
1492
1493 pdest := result.Scanline[yb];
1494
1495 for xb := 0 to NewWidth-1 do
1496 begin
1497 clusterX := mapX[xb];
1498 {$hints off}
1499 fillchar(sum,sizeof(sum),0);
1500 {$hints on}
1501 for xc := 0 to high(clusterX) do
1502 begin
1503 w := clusterX[xc].Weight;
1504 with verticalSum[ClusterX[xc].Pos - MapXLoPos] do
1505 begin
1506 sum.sumA += sumA*w;
1507 sum.sumR += sumR*w;
1508 sum.sumG += sumG*w;
1509 sum.sumB += sumB*w;
1510 end;
1511 end;
1512
1513 if sum.sumA < 0.5 then
1514 pdest^ := BGRAPixelTransparent else
1515 begin
1516 c.red := constrain(round(sum.sumR/sum.sumA),0,255);
1517 c.green := constrain(round(sum.sumG/sum.sumA),0,255);
1518 c.blue := constrain(round(sum.sumB/sum.sumA),0,255);
1519 if sum.sumA > 255 then
1520 c.alpha := 255 else
1521 c.alpha := round(sum.sumA);
1522 pdest^ := c;
1523 end;
1524 inc(pdest);
1525 end;
1526 end;
1527
1528end;
1529
1530end.
1531
Note: See TracBrowser for help on using the repository browser.