// SPDX-License-Identifier: LGPL-3.0-linking-exception
unit BGRADithering;

{$mode objfpc}{$H+}

interface

uses
  BGRAClasses, SysUtils, BGRAFilterType, BGRAPalette, BGRABitmapTypes;

type
  TOutputPixelProc = procedure(X,Y: Int32or64; AColorIndex: Int32or64; AColor: TBGRAPixel) of object;

  { TDitheringTask }

  TDitheringTask = class(TFilterTask)
  protected
    FBounds: TRect;
    FIgnoreAlpha: boolean;
    FPalette: TBGRACustomApproxPalette;
    FCurrentOutputScanline: PBGRAPixel;
    FCurrentOutputY: Int32or64;
    FOutputPixel : TOutputPixelProc;
    FDrawMode: TDrawMode;
    procedure UpdateCurrentLine(Y: Int32or64); inline;
    procedure OutputPixel(X,Y: Int32or64; {%H-}AColorIndex: Int32or64; AColor: TBGRAPixel); virtual;
    procedure OutputPixelSet(X,Y: Int32or64; {%H-}AColorIndex: Int32or64; AColor: TBGRAPixel); virtual;
    procedure OutputPixelSetExceptTransparent(X,Y: Int32or64; {%H-}AColorIndex: Int32or64; AColor: TBGRAPixel); virtual;
    procedure OutputPixelLinearBlend(X,Y: Int32or64; {%H-}AColorIndex: Int32or64; AColor: TBGRAPixel); virtual;
    procedure OutputPixelDraw(X,Y: Int32or64; {%H-}AColorIndex: Int32or64; AColor: TBGRAPixel); virtual;
    procedure OutputPixelXor(X,Y: Int32or64; {%H-}AColorIndex: Int32or64; AColor: TBGRAPixel); virtual;
    procedure ApproximateColor(const AColor: TBGRAPixel; out AApproxColor: TBGRAPixel; out AIndex: integer);
    procedure SetDrawMode(AValue: TDrawMode);
    procedure UpdateOutputPixel;
  public
    constructor Create(ASource: IBGRAScanner; APalette: TBGRACustomApproxPalette; ADestination: TBGRACustomBitmap; AIgnoreAlpha: boolean; ABounds: TRect); overload;
    constructor Create(bmp: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette; AInPlace: boolean; AIgnoreAlpha: boolean; ABounds: TRect); overload;
    constructor Create(bmp: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette; AInPlace: boolean; AIgnoreAlpha: boolean); overload;
    property OnOutputPixel: TOutputPixelProc read FOutputPixel write FOutputPixel;
    property DrawMode: TDrawMode read FDrawMode write SetDrawMode;
  end;

  { TNearestColorTask }

  TNearestColorTask = class(TDitheringTask)
  protected
    procedure DoExecute; override;
  end;

  { TFloydSteinbergDitheringTask }

  TFloydSteinbergDitheringTask = class(TDitheringTask)
  protected
    procedure DoExecute; override;
  end;

  { TDitheringToIndexedImage }

  TDitheringToIndexedImage = class
  protected
    FBitOrder: TRawImageBitOrder;
    FByteOrder: TRawImageByteOrder;
    FBitsPerPixel: integer;
    FLineOrder: TRawImageLineOrder;
    FPalette: TBGRACustomApproxPalette;
    FIgnoreAlpha: boolean;
    FTransparentColorIndex: Int32or64;

    //following variables are used during dithering
    FCurrentScanlineSize: PtrInt;
    FCurrentData: PByte;
    FCurrentOutputY: Int32or64;
    FCurrentOutputScanline: PByte;
    FCurrentBitOrderMask: Int32or64;
    FCurrentMaxY: Int32or64;

    procedure SetPalette(AValue: TBGRACustomApproxPalette);
    procedure SetIgnoreAlpha(AValue: boolean);
    procedure SetLineOrder(AValue: TRawImageLineOrder);
    procedure SetBitOrder(AValue: TRawImageBitOrder); virtual;
    procedure SetBitsPerPixel(AValue: integer); virtual;
    procedure SetByteOrder(AValue: TRawImageByteOrder); virtual;
    procedure OutputPixelSubByte(X,Y: Int32or64; AColorIndex: Int32or64; {%H-}AColor: TBGRAPixel); virtual;
    procedure OutputPixelFullByte(X,Y: Int32or64; AColorIndex: Int32or64; {%H-}AColor: TBGRAPixel); virtual;
    function GetScanline(Y: Int32or64): Pointer; virtual;
    function GetTransparentColorIndex: integer;
    procedure SetTransparentColorIndex(AValue: integer);
  public
    constructor Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer); overload; //use platform byte order
    constructor Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer; AByteOrder: TRawImageByteOrder); overload; //maybe necessary if larger than 8 bits per pixel

    function DitherImage(AAlgorithm: TDitheringAlgorithm; AImage: TBGRACustomBitmap): Pointer; overload; //use minimum scanline size
    function DitherImage(AAlgorithm: TDitheringAlgorithm; AImage: TBGRACustomBitmap; AScanlineSize: PtrInt): Pointer; overload;
    procedure DitherImageTo(AAlgorithm: TDitheringAlgorithm; AImage: TBGRACustomBitmap; AData: Pointer); overload; //use minimum scanline size
    procedure DitherImageTo(AAlgorithm: TDitheringAlgorithm; AImage: TBGRACustomBitmap; AData: Pointer; AScanlineSize: PtrInt); overload;
    function ComputeMinimumScanlineSize(AWidthInPixels: integer): PtrInt;
    function AllocateSpaceForIndexedData(AImage: TBGRACustomBitmap; AScanlineSize: PtrInt): pointer;

    //optional customization of format
    property BitsPerPixel: integer read FBitsPerPixel write SetBitsPerPixel;
    property BitOrder: TRawImageBitOrder read FBitOrder write SetBitOrder;
    property ByteOrder: TRawImageByteOrder read FByteOrder write SetByteOrder;
    property LineOrder: TRawImageLineOrder read FLineOrder write SetLineOrder;

    property Palette: TBGRACustomApproxPalette read FPalette write SetPalette;
    property IgnoreAlpha: boolean read FIgnoreAlpha write SetIgnoreAlpha;

    //when there is no transparent color in the palette, or that IgnoreAlpha is set to True,
    //this allows to define the index for the fully transparent color
    property DefaultTransparentColorIndex: integer read GetTransparentColorIndex write SetTransparentColorIndex;
  end;

function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette;
  AIgnoreAlpha: boolean): TDitheringTask; overload;
function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette;
  AIgnoreAlpha: boolean; ABounds: TRect): TDitheringTask; overload;
function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm; ASource: IBGRAScanner; ADestination: TBGRACustomBitmap; ABounds: TRect): TDitheringTask; overload;
function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm; ASource: IBGRAScanner; ADestination: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette;
    AIgnoreAlpha: boolean; ABounds: TRect): TDitheringTask; overload;

function DitherImageTo16Bit(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap): TBGRACustomBitmap;

implementation

uses BGRABlend;

function AbsRGBADiff(const c1, c2: TExpandedPixel): Int32or64;
begin
  result := abs(c1.alpha-c2.alpha);
  inc(result, abs(c1.red-c2.red) );
  inc(result, abs(c1.green-c2.green) );
  inc(result, abs(c1.blue-c2.blue) );
end;

function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette;
  AIgnoreAlpha: boolean): TDitheringTask;
begin
  result := CreateDitheringTask(AAlgorithm, ABitmap, APalette, AIgnoreAlpha, rect(0,0,ABitmap.width, ABitmap.Height));
end;

function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; APalette: TBGRACustomApproxPalette;
  AIgnoreAlpha: boolean; ABounds: TRect): TDitheringTask;
begin
  result := nil;
  case AAlgorithm of
    daNearestNeighbor: result := TNearestColorTask.Create(ABitmap, APalette, False, AIgnoreAlpha, ABounds);
    daFloydSteinberg: result := TFloydSteinbergDitheringTask.Create(ABitmap, APalette, False, AIgnoreAlpha, ABounds);
    else raise exception.Create('Unknown algorithm');
  end;
end;

function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm;
  ASource: IBGRAScanner; ADestination: TBGRACustomBitmap; ABounds: TRect
  ): TDitheringTask;
begin
  result := CreateDitheringTask(AAlgorithm, ASource, ADestination, nil, true, ABounds);
end;

function CreateDitheringTask(AAlgorithm: TDitheringAlgorithm;
  ASource: IBGRAScanner; ADestination: TBGRACustomBitmap;
  APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABounds: TRect
  ): TDitheringTask;
begin
  result := nil;
  case AAlgorithm of
    daNearestNeighbor: result := TNearestColorTask.Create(ASource, APalette, ADestination, AIgnoreAlpha, ABounds);
    daFloydSteinberg: result := TFloydSteinbergDitheringTask.Create(ASource, APalette, ADestination, AIgnoreAlpha, ABounds);
    else raise exception.Create('Unknown algorithm');
  end;
end;

function DitherImageTo16Bit(AAlgorithm: TDitheringAlgorithm;
  ABitmap: TBGRACustomBitmap): TBGRACustomBitmap;
var
  palette16bit: TBGRA16BitPalette;
  dither: TDitheringTask;
begin
  palette16bit := TBGRA16BitPalette.Create;
  dither := CreateDitheringTask(AAlgorithm, ABitmap, palette16bit, false);
  result := dither.Execute;
  dither.Free;
  palette16bit.Free;
end;

{ TDitheringToIndexedImage }

procedure TDitheringToIndexedImage.SetBitsPerPixel(AValue: integer);
begin
  if not (AValue in [1,2,4,8,16,32]) then
    raise exception.Create('Invalid value for bits per pixel. Allowed values: 1,2,4,8,16,32.');
  if FBitsPerPixel=AValue then Exit;
  FBitsPerPixel:=AValue;
end;

procedure TDitheringToIndexedImage.SetByteOrder(AValue: TRawImageByteOrder);
begin
  if FByteOrder=AValue then Exit;
  FByteOrder:=AValue;
end;

procedure TDitheringToIndexedImage.OutputPixelSubByte(X, Y: Int32or64;
  AColorIndex: Int32or64; AColor: TBGRAPixel);
var p: PByte;
begin
  if y <> FCurrentOutputY then
  begin
    FCurrentOutputY := y;
    FCurrentOutputScanline := GetScanline(Y);
  end;
  if AColorIndex = -1 then AColorIndex := FTransparentColorIndex;
  case FBitsPerPixel of
    1: begin
         p := FCurrentOutputScanline+(x shr 3);
         p^ := p^ or ((AColorIndex and 1) shl ((x xor FCurrentBitOrderMask) and 7));
       end;
    2: begin
         p := FCurrentOutputScanline+(x shr 2);
         p^ := p^ or ((AColorIndex and 1) shl (((x xor FCurrentBitOrderMask) and 3) shl 1));
       end;
    4: begin
         p := FCurrentOutputScanline+(x shr 1);
         p^ := p^ or ((AColorIndex and 1) shl (((x xor FCurrentBitOrderMask) and 1) shl 2));
       end;
  end;
end;

procedure TDitheringToIndexedImage.OutputPixelFullByte(X, Y: Int32or64;
  AColorIndex: Int32or64; AColor: TBGRAPixel);
begin
  if y <> FCurrentOutputY then
  begin
    FCurrentOutputY := y;
    FCurrentOutputScanline := GetScanline(Y);
  end;
  if AColorIndex = -1 then AColorIndex := FTransparentColorIndex;
  case FBitsPerPixel of
    8: (FCurrentOutputScanline+x)^ := AColorIndex;
    16: (PWord(FCurrentOutputScanline)+x)^ := AColorIndex;
    32: (PLongWord(FCurrentOutputScanline)+x)^ := AColorIndex;
  end;
end;

function TDitheringToIndexedImage.GetScanline(Y: Int32or64): Pointer;
begin
  if FLineOrder = riloTopToBottom then
    result := FCurrentData + Y*FCurrentScanlineSize
  else
    result := FCurrentData + (FCurrentMaxY-Y)*FCurrentScanlineSize
end;

procedure TDitheringToIndexedImage.SetIgnoreAlpha(AValue: boolean);
begin
  if FIgnoreAlpha=AValue then Exit;
  FIgnoreAlpha:=AValue;
end;

procedure TDitheringToIndexedImage.SetTransparentColorIndex(AValue: integer);
begin
  if FTransparentColorIndex=AValue then Exit;
  FTransparentColorIndex:=AValue;
end;

function TDitheringToIndexedImage.GetTransparentColorIndex: integer;
begin
  result := FTransparentColorIndex;
end;

procedure TDitheringToIndexedImage.SetPalette(AValue: TBGRACustomApproxPalette);
begin
  if FPalette=AValue then Exit;
  FPalette:=AValue;
end;

procedure TDitheringToIndexedImage.SetLineOrder(AValue: TRawImageLineOrder);
begin
  if FLineOrder=AValue then Exit;
  FLineOrder:=AValue;
end;

procedure TDitheringToIndexedImage.SetBitOrder(AValue: TRawImageBitOrder);
begin
  if FBitOrder=AValue then Exit;
  FBitOrder:=AValue;
end;

constructor TDitheringToIndexedImage.Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer);
begin
  BitsPerPixel:= ABitsPerPixelForIndices;
  BitOrder := riboReversedBits; //convention in BMP format
  {$IFDEF ENDIAN_LITTLE}
  ByteOrder:= riboLSBFirst;
  {$ELSE}
  ByteOrder:= riboMSBFirst;
  {$ENDIF}
  Palette := APalette;
  IgnoreAlpha:= AIgnoreAlpha;
end;

constructor TDitheringToIndexedImage.Create(APalette: TBGRACustomApproxPalette; AIgnoreAlpha: boolean; ABitsPerPixelForIndices: integer;
  AByteOrder: TRawImageByteOrder);
begin
  BitsPerPixel:= ABitsPerPixelForIndices;
  BitOrder := riboReversedBits; //convention in BMP format
  ByteOrder:= AByteOrder;
  Palette := APalette;
  IgnoreAlpha:= AIgnoreAlpha;
end;

function TDitheringToIndexedImage.ComputeMinimumScanlineSize(
  AWidthInPixels: integer): PtrInt;
begin
  result := (AWidthInPixels*FBitsPerPixel+7) shr 3;
end;

function TDitheringToIndexedImage.AllocateSpaceForIndexedData(AImage: TBGRACustomBitmap;
  AScanlineSize: PtrInt): pointer;
var size: integer;
begin
  size := AScanlineSize * AImage.Height;
  GetMem(result, size);
  Fillchar(result^, size, 0);
end;

function TDitheringToIndexedImage.DitherImage(AAlgorithm: TDitheringAlgorithm;
  AImage: TBGRACustomBitmap): Pointer;
begin
  result := DitherImage(AAlgorithm, AImage, ComputeMinimumScanlineSize(AImage.Width));
end;

procedure TDitheringToIndexedImage.DitherImageTo(AAlgorithm: TDitheringAlgorithm;
  AImage: TBGRACustomBitmap; AData: Pointer);
begin
  DitherImageTo(AAlgorithm, AImage, AData, ComputeMinimumScanlineSize(AImage.Width));
end;

function TDitheringToIndexedImage.DitherImage(AAlgorithm: TDitheringAlgorithm;
  AImage: TBGRACustomBitmap; AScanlineSize: PtrInt): Pointer;
begin
  result := AllocateSpaceForIndexedData(AImage, AScanlineSize);
  DitherImageTo(AAlgorithm, AImage, result, AScanlineSize);
end;

procedure TDitheringToIndexedImage.DitherImageTo(AAlgorithm: TDitheringAlgorithm;
  AImage: TBGRACustomBitmap; AData: Pointer; AScanlineSize: PtrInt);
var ditherTask: TDitheringTask;
begin
  FCurrentOutputY := -1;
  FCurrentOutputScanline := nil;
  FCurrentData := AData;
  FCurrentMaxY:= AImage.Height-1;
  FCurrentScanlineSize:= AScanlineSize;

  ditherTask := CreateDitheringTask(AAlgorithm, AImage, FPalette, FIgnoreAlpha);
  try
    ditherTask.Inplace := True; //do not allocate destination
    if BitsPerPixel >= 8 then
      ditherTask.OnOutputPixel := @OutputPixelFullByte
    else
    begin
      ditherTask.OnOutputPixel:= @OutputPixelSubByte;
      if BitOrder = riboBitsInOrder then
        FCurrentBitOrderMask := 0
      else
        FCurrentBitOrderMask := $ff;
    end;
    ditherTask.Execute;
  finally
    ditherTask.Free;
  end;
end;

{ TDitheringTask }

procedure TDitheringTask.SetDrawMode(AValue: TDrawMode);
begin
  if FDrawMode=AValue then Exit;
  FDrawMode:=AValue;
  UpdateOutputPixel;
end;

procedure TDitheringTask.UpdateOutputPixel;
begin
  case FDrawMode of
    dmSet: FOutputPixel := @OutputPixelSet;
    dmSetExceptTransparent: FOutputPixel := @OutputPixelSetExceptTransparent;
    dmLinearBlend: FOutputPixel := @OutputPixelLinearBlend;
    dmXor: FOutputPixel := @OutputPixelXor;
  else
    {dmDrawWithTransparency} FOutputPixel := @OutputPixelDraw;
  end;
end;

procedure TDitheringTask.UpdateCurrentLine(Y: Int32or64);
begin
  if Y <> FCurrentOutputY then
  begin
    FCurrentOutputY := Y;
    FCurrentOutputScanline := Destination.ScanLine[y];
  end;
end;

procedure TDitheringTask.OutputPixel(X, Y: Int32or64; AColorIndex: Int32or64;
  AColor: TBGRAPixel);
begin
  UpdateCurrentLine(y);
  PutPixels(FCurrentOutputScanline+x, @AColor, 1, FDrawMode, 255);
end;

procedure TDitheringTask.OutputPixelSet(X, Y: Int32or64;
  AColorIndex: Int32or64; AColor: TBGRAPixel);
begin
  UpdateCurrentLine(y);
  (FCurrentOutputScanline+x)^ := AColor;
end;

procedure TDitheringTask.OutputPixelSetExceptTransparent(X, Y: Int32or64;
  AColorIndex: Int32or64; AColor: TBGRAPixel);
begin
  UpdateCurrentLine(y);
  if AColor.alpha = 255 then (FCurrentOutputScanline+x)^ := AColor;
end;

procedure TDitheringTask.OutputPixelLinearBlend(X, Y: Int32or64;
  AColorIndex: Int32or64; AColor: TBGRAPixel);
begin
  UpdateCurrentLine(y);
  FastBlendPixelInline(FCurrentOutputScanline+x, AColor);
end;

procedure TDitheringTask.OutputPixelDraw(X, Y: Int32or64;
  AColorIndex: Int32or64; AColor: TBGRAPixel);
begin
  UpdateCurrentLine(y);
  DrawPixelInlineWithAlphaCheck(FCurrentOutputScanline+x, AColor);
end;

procedure TDitheringTask.OutputPixelXor(X, Y: Int32or64;
  AColorIndex: Int32or64; AColor: TBGRAPixel);
begin
  UpdateCurrentLine(y);
  PLongWord(FCurrentOutputScanline+x)^ := PLongWord(FCurrentOutputScanline+x)^ xor PLongWord(@AColor)^;
end;

procedure TDitheringTask.ApproximateColor(const AColor: TBGRAPixel;
  out AApproxColor: TBGRAPixel; out AIndex: integer);
begin
  if FPalette <> nil then
  begin
    AIndex := FPalette.FindNearestColorIndex(AColor, FIgnoreAlpha);
    if AIndex = -1 then
      AApproxColor := BGRAPixelTransparent
    else
      AApproxColor := FPalette.Color[AIndex];
  end else
  begin
    if AColor.alpha = 0 then
    begin
      AApproxColor := BGRAPixelTransparent;
      AIndex := -1;
    end else
    begin
      AApproxColor := AColor;
      AIndex := 0;
    end;
  end;
end;

constructor TDitheringTask.Create(ASource: IBGRAScanner;
  APalette: TBGRACustomApproxPalette; ADestination: TBGRACustomBitmap;
  AIgnoreAlpha: boolean; ABounds: TRect);
begin
  FPalette := APalette;
  SetSource(ASource);
  FBounds := ABounds;
  FIgnoreAlpha:= AIgnoreAlpha;
  FCurrentOutputY := -1;
  FCurrentOutputScanline:= nil;
  Destination := ADestination;
  FDrawMode:= dmSet;
  UpdateOutputPixel;
end;

constructor TDitheringTask.Create(bmp: TBGRACustomBitmap;
  APalette: TBGRACustomApproxPalette; AInPlace: boolean; AIgnoreAlpha: boolean;
  ABounds: TRect);
begin
  FPalette := APalette;
  SetSource(bmp);
  FBounds := ABounds;
  FIgnoreAlpha:= AIgnoreAlpha;
  FCurrentOutputY := -1;
  FCurrentOutputScanline:= nil;
  InPlace := AInPlace;
  FDrawMode:= dmSet;
  UpdateOutputPixel;
end;

constructor TDitheringTask.Create(bmp: TBGRACustomBitmap;
  APalette: TBGRACustomApproxPalette; AInPlace: boolean; AIgnoreAlpha: boolean);
begin
  FPalette := APalette;
  SetSource(bmp);
  FBounds := rect(0,0,bmp.Width,bmp.Height);
  FIgnoreAlpha:= AIgnoreAlpha;
  FCurrentOutputY := -1;
  FCurrentOutputScanline:= nil;
  InPlace := AInPlace;
  FDrawMode:= dmSet;
  UpdateOutputPixel;
end;

{ TFloydSteinbergDitheringTask }

procedure TFloydSteinbergDitheringTask.DoExecute;
const
  ErrorPrecisionShift = 4;
  MaxColorDiffForDiffusion = 4096;
type
  TAccPixel = record
    red,green,blue,alpha: Int32or64;
  end;
  TLine = array of TAccPixel;

  procedure AddError(var dest: TAccPixel; const src: TAccPixel; factor: Int32or64); inline;
  const maxError = 65536 shl ErrorPrecisionShift;
    minError = -(65536 shl ErrorPrecisionShift);
  begin
    inc(dest.alpha, src.alpha * factor);
    if dest.alpha > maxError then dest.alpha := maxError;
    if dest.alpha < minError then dest.alpha := minError;
    inc(dest.red, src.red * factor);
    if dest.red > maxError then dest.red := maxError;
    if dest.red < minError then dest.red := minError;
    inc(dest.green, src.green * factor);
    if dest.green > maxError then dest.green := maxError;
    if dest.green < minError then dest.green := minError;
    inc(dest.blue, src.blue * factor);
    if dest.blue > maxError then dest.blue := maxError;
    if dest.blue < minError then dest.blue := minError;
  end;

var
  w,h: Int32or64;

var
  p,pNext: PExpandedPixel;
  destX,destY: Int32or64;
  orig,cur,approxExp: TExpandedPixel;
  approx: TBGRAPixel;
  approxIndex: integer;
  curPix,diff: TAccPixel;
  i: Int32or64;
  yWrite: Int32or64;
  tempLine, currentLine, nextLine: TLine;

  nextScan,curScan: PExpandedPixel;

  function ClampWordDiv(AValue: Int32or64): Word; inline;
  begin
    if AValue < 0 then AValue := -((-AValue) shr ErrorPrecisionShift) else AValue := AValue shr ErrorPrecisionShift;
    if AValue < 0 then
      result := 0
    else if AValue > 65535 then
      result := 65535
    else
      result := AValue;
  end;

  function Div16(AValue: Int32or64): Int32or64; inline;
  begin
    if AValue < 0 then
      result := -((-AValue) shr 4)
    else
      result := AValue shr 4;
  end;

begin
  w := FBounds.Right-FBounds.Left;
  h := FBounds.Bottom-FBounds.Top;
  if (w <= 0) or (h <= 0) then exit;
  setlength(currentLine,w);
  setlength(nextLine,w);
  curScan := nil;
  nextScan := RequestSourceExpandedScanLine(FBounds.Left, FBounds.Top, FBounds.Right-FBounds.Left);
  for yWrite := 0 to h-1 do
  begin
    if GetShouldStop(yWrite) then break;
    ReleaseSourceExpandedScanLine(curScan);
    curScan := nextScan;
    nextScan := nil;
    p := curScan;
    destX := FBounds.Left;
    destY := yWrite+FBounds.Top;
    if yWrite < h-1 then
      nextScan := RequestSourceExpandedScanLine(FBounds.Left,yWrite+FBounds.Top+1, FBounds.Right-FBounds.Left);
    pNext := nextScan;
    if odd(yWrite) then
    begin
      inc(p, w);
      inc(destX, w);
      if pNext<>nil then inc(pNext, w);
      for i := w-1 downto 0 do
      begin
        dec(p);
        dec(destX);
        if pNext<>nil then dec(pNext);
        if p^.alpha <> 0 then
        begin
          orig := p^;
          with currentLine[i] do
          begin
            curPix.alpha := alpha+Int32or64(orig.alpha shl ErrorPrecisionShift);
            curPix.red := red+Int32or64(orig.red shl ErrorPrecisionShift);
            curPix.green := green+Int32or64(orig.green shl ErrorPrecisionShift);
            curPix.blue := blue+Int32or64(orig.blue shl ErrorPrecisionShift);
            cur.alpha := ClampWordDiv(curPix.alpha);
            cur.red := ClampWordDiv(curPix.red);
            cur.green := ClampWordDiv(curPix.green);
            cur.blue := ClampWordDiv(curPix.blue);
          end;
          ApproximateColor(GammaCompression(cur), approx, approxIndex);
          approxExp := GammaExpansion(approx);
          diff.alpha := Div16(curPix.alpha - (approxExp.alpha shl ErrorPrecisionShift));
          if (approxExp.alpha = 0) or (cur.alpha = 0) then
          begin
            diff.red := 0;
            diff.green := 0;
            diff.blue := 0;
          end else
          begin
            diff.red := Div16(curPix.red - (approxExp.red shl ErrorPrecisionShift));
            diff.green := Div16(curPix.green - (approxExp.green shl ErrorPrecisionShift));
            diff.blue := Div16(curPix.blue - (approxExp.blue shl ErrorPrecisionShift));
          end;
          if i > 0 then
          begin
            if AbsRGBADiff((p-1)^,orig) < MaxColorDiffForDiffusion then
              AddError(currentLine[i-1], diff, 7);
          end;
          if nextLine <> nil then
          begin
            if i > 0 then
            begin
              if AbsRGBADiff((pNext-1)^,orig) < MaxColorDiffForDiffusion then
                AddError(nextLine[i-1], diff, 1);
            end;
            if AbsRGBADiff(pNext^,orig) < MaxColorDiffForDiffusion then
              AddError(nextLine[i], diff, 5);
            if i < w-1 then
            begin
              if AbsRGBADiff((pNext+1)^,orig) < MaxColorDiffForDiffusion then
                AddError(nextLine[i+1], diff, 3);
            end;
          end;
          OnOutputPixel(destX,destY,approxIndex,approx);
        end else
        begin
          ApproximateColor(BGRAPixelTransparent, approx, approxIndex);
          OnOutputPixel(destX,destY,approxIndex,approx);
        end;
      end
    end
    else
    for i := 0 to w-1 do
    begin
      if p^.alpha <> 0 then
      begin
        orig := p^;
        with currentLine[i] do
        begin
          curPix.alpha := alpha+Int32or64(orig.alpha shl ErrorPrecisionShift);
          curPix.red := red+Int32or64(orig.red shl ErrorPrecisionShift);
          curPix.green := green+Int32or64(orig.green shl ErrorPrecisionShift);
          curPix.blue := blue+Int32or64(orig.blue shl ErrorPrecisionShift);
          cur.alpha := ClampWordDiv(curPix.alpha);
          cur.red := ClampWordDiv(curPix.red);
          cur.green := ClampWordDiv(curPix.green);
          cur.blue := ClampWordDiv(curPix.blue);
        end;
        ApproximateColor(GammaCompression(cur), approx, approxIndex);
        approxExp := GammaExpansion(approx);
        diff.alpha := Div16(curPix.alpha - (approxExp.alpha shl ErrorPrecisionShift));
        if (approxExp.alpha = 0) or (cur.alpha = 0) then
        begin
          diff.red := 0;
          diff.green := 0;
          diff.blue := 0;
        end else
        begin
          diff.red := Div16(curPix.red - (approxExp.red shl ErrorPrecisionShift));
          diff.green := Div16(curPix.green - (approxExp.green shl ErrorPrecisionShift));
          diff.blue := Div16(curPix.blue - (approxExp.blue shl ErrorPrecisionShift));
        end;
        if i < w-1 then
        begin
          if AbsRGBADiff((p+1)^,orig) < MaxColorDiffForDiffusion then
            AddError(currentLine[i+1], diff, 7);
        end;
        if pNext <> nil then
        begin
          if i > 0 then
          begin
            if AbsRGBADiff((pNext-1)^,orig) < MaxColorDiffForDiffusion then
              AddError(nextLine[i-1], diff, 3);
          end;
          if AbsRGBADiff(pNext^,orig) < MaxColorDiffForDiffusion then
            AddError(nextLine[i], diff, 5);
          if i < w-1 then
          begin
            if AbsRGBADiff((pNext+1)^,orig) < MaxColorDiffForDiffusion then
              AddError(nextLine[i+1], diff, 1);
          end;
        end;
        OnOutputPixel(destX,destY,approxIndex,approx);
      end else
      begin
        ApproximateColor(BGRAPixelTransparent, approx, approxIndex);
        OnOutputPixel(destX,destY,approxIndex,approx);
      end;
      inc(p);
      inc(destX);
      if pNext<>nil then inc(pNext);
    end;
    tempLine := currentLine;
    currentLine := nextLine;
    nextLine := tempLine;
    if yWrite = h-2 then
      nextLine := nil
      else fillchar(nextLine[0], sizeof(nextLine[0])*w, 0);
  end;
  ReleaseSourceExpandedScanLine(curScan);
  ReleaseSourceExpandedScanLine(nextScan);
  Destination.InvalidateBitmap;
end;

{ TNearestColorTask }

procedure TNearestColorTask.DoExecute;
var yb,xb: Int32or64;
  curScan,psrc: PBGRAPixel;
  colorIndex: LongInt;
  colorValue: TBGRAPixel;
begin
  for yb := FBounds.Top to FBounds.Bottom - 1 do
  begin
    if GetShouldStop(yb) then break;
    curScan := RequestSourceScanLine(FBounds.Left,yb,FBounds.Right-FBounds.Left);
    psrc := curScan;
    for xb := FBounds.Left to FBounds.Right-1 do
    begin
      ApproximateColor(psrc^, colorValue, colorIndex);
      OnOutputPixel(xb,yb,colorIndex,colorValue);
      inc(psrc);
    end;
    ReleaseSourceScanLine(curScan);
  end;
  Destination.InvalidateBitmap;
end;

end.