source: trunk/Packages/bgrabitmap/bgradithering.pas

Last change on this file was 2, checked in by chronos, 6 years ago
File size: 23.3 KB
Line 
1unit BGRADithering;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, BGRAFilterType, BGRAPalette, BGRABitmapTypes;
9
10type
11 TOutputPixelProc = procedure(X,Y: NativeInt; AColorIndex: NativeInt; AColor: TBGRAPixel) of object;
12
13 { TDitheringTask }
14
15 TDitheringTask = class(TFilterTask)
16 protected
17 FBounds: TRect;
18 FIgnoreAlpha: boolean;
19 FPalette: TBGRACustomApproxPalette;
20 FCurrentOutputScanline: PBGRAPixel;
21 FCurrentOutputY: NativeInt;
22 FOutputPixel : TOutputPixelProc;
23 FDrawMode: TDrawMode;
24 procedure OutputPixel(X,Y: NativeInt; {%H-}AColorIndex: NativeInt; AColor: TBGRAPixel); virtual;
25 procedure ApproximateColor(const AColor: TBGRAPixel; out AApproxColor: TBGRAPixel; out AIndex: integer);
26 public
27 constructor Create(ASource: IBGRAScanner; APalette: TBGRACustomApproxPalette; ADestination: TBGRACustomBitmap; AIgnoreAlpha: boolean; ABounds: TRect); overload;
28 constructor Create(bmp: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette; AInPlace: boolean; AIgnoreAlpha: boolean; ABounds: TRect); overload;
29 constructor Create(bmp: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette; AInPlace: boolean; AIgnoreAlpha: boolean); overload;
30 property OnOutputPixel: TOutputPixelProc read FOutputPixel write FOutputPixel;
31 property DrawMode: TDrawMode read FDrawMode write FDrawMode;
32 end;
33
34 { TNearestColorTask }
35
36 TNearestColorTask = class(TDitheringTask)
37 protected
38 procedure DoExecute; override;
39 end;
40
41 { TFloydSteinbergDitheringTask }
42
43 TFloydSteinbergDitheringTask = class(TDitheringTask)
44 protected
45 procedure DoExecute; override;
46 end;
47
48 { TDitheringToIndexedImage }
49
50 TDitheringToIndexedImage = class
51 protected
52 FBitOrder: TRawImageBitOrder;
53 FByteOrder: TRawImageByteOrder;
54 FBitsPerPixel: integer;
55 FLineOrder: TRawImageLineOrder;
56 FPalette: TBGRACustomApproxPalette;
57 FIgnoreAlpha: boolean;
58 FTransparentColorIndex: NativeInt;
59
60 //following variables are used during dithering
61 FCurrentScanlineSize: PtrInt;
62 FCurrentData: PByte;
63 FCurrentOutputY: NativeInt;
64 FCurrentOutputScanline: PByte;
65 FCurrentBitOrderMask: NativeInt;
66 FCurrentMaxY: NativeInt;
67
68 procedure SetPalette(AValue: TBGRACustomApproxPalette);
69 procedure SetIgnoreAlpha(AValue: boolean);
70 procedure SetLineOrder(AValue: TRawImageLineOrder);
71 procedure SetBitOrder(AValue: TRawImageBitOrder); virtual;
72 procedure SetBitsPerPixel(AValue: integer); virtual;
73 procedure SetByteOrder(AValue: TRawImageByteOrder); virtual;
74 procedure OutputPixelSubByte(X,Y: NativeInt; AColorIndex: NativeInt; {%H-}AColor: TBGRAPixel); virtual;
75 procedure OutputPixelFullByte(X,Y: NativeInt; AColorIndex: NativeInt; {%H-}AColor: TBGRAPixel); virtual;
76 function GetScanline(Y: NativeInt): Pointer; virtual;
77 function GetTransparentColorIndex: integer;
78 procedure SetTransparentColorIndex(AValue: integer);
79 public
80 constructor Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer); overload; //use platform byte order
81 constructor Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer; AByteOrder: TRawImageByteOrder); overload; //maybe necessary if larger than 8 bits per pixel
82
83 function DitherImage(AAlgorithm: TDitheringAlgorithm; AImage: TBGRACustomBitmap): Pointer; overload; //use minimum scanline size
84 function DitherImage(AAlgorithm: TDitheringAlgorithm; AImage: TBGRACustomBitmap; AScanlineSize: PtrInt): Pointer; overload;
85 procedure DitherImageTo(AAlgorithm: TDitheringAlgorithm; AImage: TBGRACustomBitmap; AData: Pointer); overload; //use minimum scanline size
86 procedure DitherImageTo(AAlgorithm: TDitheringAlgorithm; AImage: TBGRACustomBitmap; AData: Pointer; AScanlineSize: PtrInt); overload;
87 function ComputeMinimumScanlineSize(AWidthInPixels: integer): PtrInt;
88 function AllocateSpaceForIndexedData(AImage: TBGRACustomBitmap; AScanlineSize: PtrInt): pointer;
89
90 //optional customization of format
91 property BitsPerPixel: integer read FBitsPerPixel write SetBitsPerPixel;
92 property BitOrder: TRawImageBitOrder read FBitOrder write SetBitOrder;
93 property ByteOrder: TRawImageByteOrder read FByteOrder write SetByteOrder;
94 property LineOrder: TRawImageLineOrder read FLineOrder write SetLineOrder;
95
96 property Palette: TBGRACustomApproxPalette read FPalette write SetPalette;
97 property IgnoreAlpha: boolean read FIgnoreAlpha write SetIgnoreAlpha;
98
99 //when there is no transparent color in the palette, or that IgnoreAlpha is set to True,
100 //this allows to define the index for the fully transparent color
101 property DefaultTransparentColorIndex: integer read GetTransparentColorIndex write SetTransparentColorIndex;
102 end;
103
104function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette;
105 AIgnoreAlpha: boolean): TDitheringTask; overload;
106function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette;
107 AIgnoreAlpha: boolean; ABounds: TRect): TDitheringTask; overload;
108function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm; ASource: IBGRAScanner; ADestination: TBGRACustomBitmap; ABounds: TRect): TDitheringTask; overload;
109function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm; ASource: IBGRAScanner; ADestination: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette;
110 AIgnoreAlpha: boolean; ABounds: TRect): TDitheringTask; overload;
111
112function DitherImageTo16Bit(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap): TBGRACustomBitmap;
113
114implementation
115
116uses BGRABlend;
117
118function AbsRGBADiff(const c1, c2: TExpandedPixel): NativeInt;
119begin
120 result := abs(c1.alpha-c2.alpha);
121 result += abs(c1.red-c2.red);
122 result += abs(c1.green-c2.green);
123 result += abs(c1.blue-c2.blue);
124end;
125
126function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette;
127 AIgnoreAlpha: boolean): TDitheringTask;
128begin
129 result := CreateDitheringTask(AAlgorithm, ABitmap, APalette, AIgnoreAlpha, rect(0,0,ABitmap.width, ABitmap.Height));
130end;
131
132function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette;
133 AIgnoreAlpha: boolean; ABounds: TRect): TDitheringTask;
134begin
135 result := nil;
136 case AAlgorithm of
137 daNearestNeighbor: result := TNearestColorTask.Create(ABitmap, APalette, False, AIgnoreAlpha, ABounds);
138 daFloydSteinberg: result := TFloydSteinbergDitheringTask.Create(ABitmap, APalette, False, AIgnoreAlpha, ABounds);
139 else raise exception.Create('Unknown algorithm');
140 end;
141end;
142
143function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm;
144 ASource: IBGRAScanner; ADestination: TBGRACustomBitmap; ABounds: TRect
145 ): TDitheringTask;
146begin
147 result := CreateDitheringTask(AAlgorithm, ASource, ADestination, nil, true, ABounds);
148end;
149
150function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm;
151 ASource: IBGRAScanner; ADestination: TBGRACustomBitmap;
152 APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABounds: TRect
153 ): TDitheringTask;
154begin
155 result := nil;
156 case AAlgorithm of
157 daNearestNeighbor: result := TNearestColorTask.Create(ASource, APalette, ADestination, AIgnoreAlpha, ABounds);
158 daFloydSteinberg: result := TFloydSteinbergDitheringTask.Create(ASource, APalette, ADestination, AIgnoreAlpha, ABounds);
159 else raise exception.Create('Unknown algorithm');
160 end;
161end;
162
163function DitherImageTo16Bit(AAlgorithm: TDitheringAlgorithm;
164 ABitmap: TBGRACustomBitmap): TBGRACustomBitmap;
165var
166 palette16bit: TBGRA16BitPalette;
167 dither: TDitheringTask;
168begin
169 palette16bit := TBGRA16BitPalette.Create;
170 dither := CreateDitheringTask(AAlgorithm, ABitmap, palette16bit, false);
171 result := dither.Execute;
172 dither.Free;
173 palette16bit.Free;
174end;
175
176{ TDitheringToIndexedImage }
177
178procedure TDitheringToIndexedImage.SetBitsPerPixel(AValue: integer);
179begin
180 if not (AValue in [1,2,4,8,16,32]) then
181 raise exception.Create('Invalid value for bits per pixel. Allowed values: 1,2,4,8,16,32.');
182 if FBitsPerPixel=AValue then Exit;
183 FBitsPerPixel:=AValue;
184end;
185
186procedure TDitheringToIndexedImage.SetByteOrder(AValue: TRawImageByteOrder);
187begin
188 if FByteOrder=AValue then Exit;
189 FByteOrder:=AValue;
190end;
191
192procedure TDitheringToIndexedImage.OutputPixelSubByte(X, Y: NativeInt;
193 AColorIndex: NativeInt; AColor: TBGRAPixel);
194var p: PByte;
195begin
196 if y <> FCurrentOutputY then
197 begin
198 FCurrentOutputY := y;
199 FCurrentOutputScanline := GetScanline(Y);
200 end;
201 if AColorIndex = -1 then AColorIndex := FTransparentColorIndex;
202 case FBitsPerPixel of
203 1: begin
204 p := FCurrentOutputScanline+(x shr 3);
205 p^ := p^ or ((AColorIndex and 1) shl ((x xor FCurrentBitOrderMask) and 7));
206 end;
207 2: begin
208 p := FCurrentOutputScanline+(x shr 2);
209 p^ := p^ or ((AColorIndex and 1) shl (((x xor FCurrentBitOrderMask) and 3) shl 1));
210 end;
211 4: begin
212 p := FCurrentOutputScanline+(x shr 1);
213 p^ := p^ or ((AColorIndex and 1) shl (((x xor FCurrentBitOrderMask) and 1) shl 2));
214 end;
215 end;
216end;
217
218procedure TDitheringToIndexedImage.OutputPixelFullByte(X, Y: NativeInt;
219 AColorIndex: NativeInt; AColor: TBGRAPixel);
220begin
221 if y <> FCurrentOutputY then
222 begin
223 FCurrentOutputY := y;
224 FCurrentOutputScanline := GetScanline(Y);
225 end;
226 if AColorIndex = -1 then AColorIndex := FTransparentColorIndex;
227 case FBitsPerPixel of
228 8: (FCurrentOutputScanline+x)^ := AColorIndex;
229 16: (PWord(FCurrentOutputScanline)+x)^ := AColorIndex;
230 32: (PDWord(FCurrentOutputScanline)+x)^ := AColorIndex;
231 end;
232end;
233
234function TDitheringToIndexedImage.GetScanline(Y: NativeInt): Pointer;
235begin
236 if FLineOrder = riloTopToBottom then
237 result := FCurrentData + Y*FCurrentScanlineSize
238 else
239 result := FCurrentData + (FCurrentMaxY-Y)*FCurrentScanlineSize
240end;
241
242procedure TDitheringToIndexedImage.SetIgnoreAlpha(AValue: boolean);
243begin
244 if FIgnoreAlpha=AValue then Exit;
245 FIgnoreAlpha:=AValue;
246end;
247
248procedure TDitheringToIndexedImage.SetTransparentColorIndex(AValue: integer);
249begin
250 if FTransparentColorIndex=AValue then Exit;
251 FTransparentColorIndex:=AValue;
252end;
253
254function TDitheringToIndexedImage.GetTransparentColorIndex: integer;
255begin
256 result := FTransparentColorIndex;
257end;
258
259procedure TDitheringToIndexedImage.SetPalette(AValue: TBGRACustomApproxPalette);
260begin
261 if FPalette=AValue then Exit;
262 FPalette:=AValue;
263end;
264
265procedure TDitheringToIndexedImage.SetLineOrder(AValue: TRawImageLineOrder);
266begin
267 if FLineOrder=AValue then Exit;
268 FLineOrder:=AValue;
269end;
270
271procedure TDitheringToIndexedImage.SetBitOrder(AValue: TRawImageBitOrder);
272begin
273 if FBitOrder=AValue then Exit;
274 FBitOrder:=AValue;
275end;
276
277constructor TDitheringToIndexedImage.Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer);
278begin
279 BitsPerPixel:= ABitsPerPixelForIndices;
280 BitOrder := riboReversedBits; //convention in BMP format
281 {$IFDEF ENDIAN_LITTLE}
282 ByteOrder:= riboLSBFirst;
283 {$ELSE}
284 ByteOrder:= riboMSBFirst;
285 {$ENDIF}
286 Palette := APalette;
287 IgnoreAlpha:= AIgnoreAlpha;
288end;
289
290constructor TDitheringToIndexedImage.Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer;
291 AByteOrder: TRawImageByteOrder);
292begin
293 BitsPerPixel:= ABitsPerPixelForIndices;
294 BitOrder := riboReversedBits; //convention in BMP format
295 ByteOrder:= AByteOrder;
296 Palette := APalette;
297 IgnoreAlpha:= AIgnoreAlpha;
298end;
299
300function TDitheringToIndexedImage.ComputeMinimumScanlineSize(
301 AWidthInPixels: integer): PtrInt;
302begin
303 result := (AWidthInPixels*FBitsPerPixel+7) shr 3;
304end;
305
306function TDitheringToIndexedImage.AllocateSpaceForIndexedData(AImage: TBGRACustomBitmap;
307 AScanlineSize: PtrInt): pointer;
308var size: integer;
309begin
310 size := AScanlineSize * AImage.Height;
311 GetMem(result, size);
312 Fillchar(result^, size, 0);
313end;
314
315function TDitheringToIndexedImage.DitherImage(AAlgorithm: TDitheringAlgorithm;
316 AImage: TBGRACustomBitmap): Pointer;
317begin
318 result := DitherImage(AAlgorithm, AImage, ComputeMinimumScanlineSize(AImage.Width));
319end;
320
321procedure TDitheringToIndexedImage.DitherImageTo(AAlgorithm: TDitheringAlgorithm;
322 AImage: TBGRACustomBitmap; AData: Pointer);
323begin
324 DitherImageTo(AAlgorithm, AImage, AData, ComputeMinimumScanlineSize(AImage.Width));
325end;
326
327function TDitheringToIndexedImage.DitherImage(AAlgorithm: TDitheringAlgorithm;
328 AImage: TBGRACustomBitmap; AScanlineSize: PtrInt): Pointer;
329begin
330 result := AllocateSpaceForIndexedData(AImage, AScanlineSize);
331 DitherImageTo(AAlgorithm, AImage, result, AScanlineSize);
332end;
333
334procedure TDitheringToIndexedImage.DitherImageTo(AAlgorithm: TDitheringAlgorithm;
335 AImage: TBGRACustomBitmap; AData: Pointer; AScanlineSize: PtrInt);
336var ditherTask: TDitheringTask;
337begin
338 FCurrentOutputY := -1;
339 FCurrentOutputScanline := nil;
340 FCurrentData := AData;
341 FCurrentMaxY:= AImage.Height-1;
342 FCurrentScanlineSize:= AScanlineSize;
343
344 ditherTask := CreateDitheringTask(AAlgorithm, AImage, FPalette, FIgnoreAlpha);
345 try
346 ditherTask.Inplace := True; //do not allocate destination
347 if BitsPerPixel >= 8 then
348 ditherTask.OnOutputPixel := @OutputPixelFullByte
349 else
350 begin
351 ditherTask.OnOutputPixel:= @OutputPixelSubByte;
352 if BitOrder = riboBitsInOrder then
353 FCurrentBitOrderMask := 0
354 else
355 FCurrentBitOrderMask := $ff;
356 end;
357 ditherTask.Execute;
358 finally
359 ditherTask.Free;
360 end;
361end;
362
363{ TDitheringTask }
364
365procedure TDitheringTask.OutputPixel(X, Y: NativeInt; AColorIndex: NativeInt;
366 AColor: TBGRAPixel);
367begin
368 if Y <> FCurrentOutputY then
369 begin
370 FCurrentOutputY := Y;
371 FCurrentOutputScanline := Destination.ScanLine[y];
372 end;
373 PutPixels(FCurrentOutputScanline+x, @AColor, 1, FDrawMode, 255);
374end;
375
376procedure TDitheringTask.ApproximateColor(const AColor: TBGRAPixel;
377 out AApproxColor: TBGRAPixel; out AIndex: integer);
378begin
379 if FPalette <> nil then
380 begin
381 AIndex := FPalette.FindNearestColorIndex(AColor, FIgnoreAlpha);
382 if AIndex = -1 then
383 AApproxColor := BGRAPixelTransparent
384 else
385 AApproxColor := FPalette.Color[AIndex];
386 end else
387 begin
388 if AColor.alpha = 0 then
389 begin
390 AApproxColor := BGRAPixelTransparent;
391 AIndex := -1;
392 end else
393 begin
394 AApproxColor := AColor;
395 AIndex := 0;
396 end;
397 end;
398end;
399
400constructor TDitheringTask.Create(ASource: IBGRAScanner;
401 APalette: TBGRACustomApproxPalette; ADestination: TBGRACustomBitmap;
402 AIgnoreAlpha: boolean; ABounds: TRect);
403begin
404 FPalette := APalette;
405 SetSource(ASource);
406 FBounds := ABounds;
407 FIgnoreAlpha:= AIgnoreAlpha;
408 FCurrentOutputY := -1;
409 FCurrentOutputScanline:= nil;
410 OnOutputPixel:= @OutputPixel;
411 Destination := ADestination;
412 FDrawMode:= dmSet;
413end;
414
415constructor TDitheringTask.Create(bmp: TBGRACustomBitmap;
416 APalette: TBGRACustomApproxPalette; AInPlace: boolean; AIgnoreAlpha: boolean;
417 ABounds: TRect);
418begin
419 FPalette := APalette;
420 SetSource(bmp);
421 FBounds := ABounds;
422 FIgnoreAlpha:= AIgnoreAlpha;
423 FCurrentOutputY := -1;
424 FCurrentOutputScanline:= nil;
425 OnOutputPixel:= @OutputPixel;
426 InPlace := AInPlace;
427 FDrawMode:= dmSet;
428end;
429
430constructor TDitheringTask.Create(bmp: TBGRACustomBitmap;
431 APalette: TBGRACustomApproxPalette; AInPlace: boolean; AIgnoreAlpha: boolean);
432begin
433 FPalette := APalette;
434 SetSource(bmp);
435 FBounds := rect(0,0,bmp.Width,bmp.Height);
436 FIgnoreAlpha:= AIgnoreAlpha;
437 FCurrentOutputY := -1;
438 FCurrentOutputScanline:= nil;
439 OnOutputPixel:= @OutputPixel;
440 InPlace := AInPlace;
441 FDrawMode:= dmSet;
442end;
443
444{ TFloydSteinbergDitheringTask }
445
446procedure TFloydSteinbergDitheringTask.DoExecute;
447const
448 ErrorPrecisionShift = 4;
449 MaxColorDiffForDiffusion = 4096;
450type
451 TAccPixel = record
452 red,green,blue,alpha: NativeInt;
453 end;
454 TLine = array of TAccPixel;
455
456 procedure AddError(var dest: TAccPixel; const src: TAccPixel; factor: NativeInt);
457 const maxError = 65536 shl ErrorPrecisionShift;
458 minError = -(65536 shl ErrorPrecisionShift);
459 begin
460 dest.alpha += src.alpha * factor;
461 if dest.alpha > maxError then dest.alpha := maxError;
462 if dest.alpha < minError then dest.alpha := minError;
463 dest.red += src.red * factor;
464 if dest.red > maxError then dest.red := maxError;
465 if dest.red < minError then dest.red := minError;
466 dest.green += src.green * factor;
467 if dest.green > maxError then dest.green := maxError;
468 if dest.green < minError then dest.green := minError;
469 dest.blue += src.blue * factor;
470 if dest.blue > maxError then dest.blue := maxError;
471 if dest.blue < minError then dest.blue := minError;
472 end;
473
474var
475 w,h: NativeInt;
476
477var
478 p,pNext: PExpandedPixel;
479 destX,destY: NativeInt;
480 orig,cur,approxExp: TExpandedPixel;
481 approx: TBGRAPixel;
482 approxIndex: integer;
483 curPix,diff: TAccPixel;
484 i: NativeInt;
485 yWrite: NativeInt;
486 tempLine, currentLine, nextLine: TLine;
487
488 nextScan,curScan: PExpandedPixel;
489
490 function ClampWordDiv(AValue: NativeInt): Word; inline;
491 begin
492 if AValue < 0 then AValue := -((-AValue) shr ErrorPrecisionShift) else AValue := AValue shr ErrorPrecisionShift;
493 if AValue < 0 then
494 result := 0
495 else if AValue > 65535 then
496 result := 65535
497 else
498 result := AValue;
499 end;
500
501 function Div16(AValue: NativeInt): NativeInt; inline;
502 begin
503 if AValue < 0 then
504 result := -((-AValue) shr 4)
505 else
506 result := AValue shr 4;
507 end;
508
509begin
510 w := FBounds.Right-FBounds.Left;
511 h := FBounds.Bottom-FBounds.Top;
512 if (w <= 0) or (h <= 0) then exit;
513 setlength(currentLine,w);
514 setlength(nextLine,w);
515 curScan := nil;
516 nextScan := RequestSourceExpandedScanLine(FBounds.Left, FBounds.Top, FBounds.Right-FBounds.Left);
517 for yWrite := 0 to h-1 do
518 begin
519 if GetShouldStop(yWrite) then break;
520 ReleaseSourceExpandedScanLine(curScan);
521 curScan := nextScan;
522 nextScan := nil;
523 p := curScan;
524 destX := FBounds.Left;
525 destY := yWrite+FBounds.Top;
526 if yWrite < h-1 then
527 nextScan := RequestSourceExpandedScanLine(FBounds.Left,yWrite+FBounds.Top+1, FBounds.Right-FBounds.Left);
528 pNext := nextScan;
529 if odd(yWrite) then
530 begin
531 inc(p, w);
532 inc(destX, w);
533 if pNext<>nil then inc(pNext, w);
534 for i := w-1 downto 0 do
535 begin
536 dec(p);
537 dec(destX);
538 if pNext<>nil then dec(pNext);
539 if p^.alpha <> 0 then
540 begin
541 orig := p^;
542 with currentLine[i] do
543 begin
544 curPix.alpha := alpha+NativeInt(orig.alpha shl ErrorPrecisionShift);
545 curPix.red := red+NativeInt(orig.red shl ErrorPrecisionShift);
546 curPix.green := green+NativeInt(orig.green shl ErrorPrecisionShift);
547 curPix.blue := blue+NativeInt(orig.blue shl ErrorPrecisionShift);
548 cur.alpha := ClampWordDiv(curPix.alpha);
549 cur.red := ClampWordDiv(curPix.red);
550 cur.green := ClampWordDiv(curPix.green);
551 cur.blue := ClampWordDiv(curPix.blue);
552 end;
553 ApproximateColor(GammaCompression(cur), approx, approxIndex);
554 approxExp := GammaExpansion(approx);
555 diff.alpha := Div16(curPix.alpha - (approxExp.alpha shl ErrorPrecisionShift));
556 if (approxExp.alpha = 0) or (cur.alpha = 0) then
557 begin
558 diff.red := 0;
559 diff.green := 0;
560 diff.blue := 0;
561 end else
562 begin
563 diff.red := Div16(curPix.red - (approxExp.red shl ErrorPrecisionShift));
564 diff.green := Div16(curPix.green - (approxExp.green shl ErrorPrecisionShift));
565 diff.blue := Div16(curPix.blue - (approxExp.blue shl ErrorPrecisionShift));
566 end;
567 if i > 0 then
568 begin
569 if AbsRGBADiff((p-1)^,orig) < MaxColorDiffForDiffusion then
570 AddError(currentLine[i-1], diff, 7);
571 end;
572 if nextLine <> nil then
573 begin
574 if i > 0 then
575 begin
576 if AbsRGBADiff((pNext-1)^,orig) < MaxColorDiffForDiffusion then
577 AddError(nextLine[i-1], diff, 1);
578 end;
579 if AbsRGBADiff(pNext^,orig) < MaxColorDiffForDiffusion then
580 AddError(nextLine[i], diff, 5);
581 if i < w-1 then
582 begin
583 if AbsRGBADiff((pNext+1)^,orig) < MaxColorDiffForDiffusion then
584 AddError(nextLine[i+1], diff, 3);
585 end;
586 end;
587 OnOutputPixel(destX,destY,approxIndex,approx);
588 end;
589 end
590 end
591 else
592 for i := 0 to w-1 do
593 begin
594 if p^.alpha <> 0 then
595 begin
596 orig := p^;
597 with currentLine[i] do
598 begin
599 curPix.alpha := alpha+NativeInt(orig.alpha shl ErrorPrecisionShift);
600 curPix.red := red+NativeInt(orig.red shl ErrorPrecisionShift);
601 curPix.green := green+NativeInt(orig.green shl ErrorPrecisionShift);
602 curPix.blue := blue+NativeInt(orig.blue shl ErrorPrecisionShift);
603 cur.alpha := ClampWordDiv(curPix.alpha);
604 cur.red := ClampWordDiv(curPix.red);
605 cur.green := ClampWordDiv(curPix.green);
606 cur.blue := ClampWordDiv(curPix.blue);
607 end;
608 ApproximateColor(GammaCompression(cur), approx, approxIndex);
609 approxExp := GammaExpansion(approx);
610 diff.alpha := Div16(curPix.alpha - (approxExp.alpha shl ErrorPrecisionShift));
611 if (approxExp.alpha = 0) or (cur.alpha = 0) then
612 begin
613 diff.red := 0;
614 diff.green := 0;
615 diff.blue := 0;
616 end else
617 begin
618 diff.red := Div16(curPix.red - (approxExp.red shl ErrorPrecisionShift));
619 diff.green := Div16(curPix.green - (approxExp.green shl ErrorPrecisionShift));
620 diff.blue := Div16(curPix.blue - (approxExp.blue shl ErrorPrecisionShift));
621 end;
622 if i < w-1 then
623 begin
624 if AbsRGBADiff((p+1)^,orig) < MaxColorDiffForDiffusion then
625 AddError(currentLine[i+1], diff, 7);
626 end;
627 if pNext <> nil then
628 begin
629 if i > 0 then
630 begin
631 if AbsRGBADiff((pNext-1)^,orig) < MaxColorDiffForDiffusion then
632 AddError(nextLine[i-1], diff, 3);
633 end;
634 if AbsRGBADiff(pNext^,orig) < MaxColorDiffForDiffusion then
635 AddError(nextLine[i], diff, 5);
636 if i < w-1 then
637 begin
638 if AbsRGBADiff((pNext+1)^,orig) < MaxColorDiffForDiffusion then
639 AddError(nextLine[i+1], diff, 1);
640 end;
641 end;
642 OnOutputPixel(destX,destY,approxIndex,approx);
643 end;
644 inc(p);
645 inc(destX);
646 if pNext<>nil then inc(pNext);
647 end;
648 tempLine := currentLine;
649 currentLine := nextLine;
650 nextLine := tempLine;
651 if yWrite = h-2 then
652 nextLine := nil
653 else
654 for i := 0 to w-1 do
655 begin
656 nextLine[i].red := 0;
657 nextLine[i].green := 0;
658 nextLine[i].blue := 0;
659 nextLine[i].alpha := 0;
660 end;
661 end;
662 ReleaseSourceExpandedScanLine(curScan);
663 ReleaseSourceExpandedScanLine(nextScan);
664 Destination.InvalidateBitmap;
665end;
666
667{ TNearestColorTask }
668
669procedure TNearestColorTask.DoExecute;
670var yb,xb: NativeInt;
671 curScan,psrc: PBGRAPixel;
672 colorIndex: LongInt;
673 colorValue: TBGRAPixel;
674begin
675 for yb := FBounds.Top to FBounds.Bottom - 1 do
676 begin
677 if GetShouldStop(yb) then break;
678 curScan := RequestSourceScanLine(FBounds.Left,yb,FBounds.Right-FBounds.Left);
679 psrc := curScan;
680 for xb := FBounds.Left to FBounds.Right-1 do
681 begin
682 ApproximateColor(psrc^, colorValue, colorIndex);
683 OnOutputPixel(xb,yb,colorIndex,colorValue);
684 inc(psrc);
685 end;
686 ReleaseSourceScanLine(curScan);
687 end;
688 Destination.InvalidateBitmap;
689end;
690
691end.
692
Note: See TracBrowser for help on using the repository browser.