// SPDX-License-Identifier: LGPL-3.0-linking-exception

{ This unit provides resampling functions, i.e. resizing of bitmaps with or
  without interpolation filters. }
unit BGRAResample;

{$mode objfpc}{$H+}

interface

uses
  SysUtils, BGRABitmapTypes;

{------------------------------- Simple stretch ------------------------------------}

{ Computes a resampled image with pixels are boxes, with antialising between boxes.
  For example, a 2x2 image will be stretched as four boxes, one for each pixel }
function SimpleStretch(bmp: TBGRACustomBitmap; NewWidth, NewHeight: integer): TBGRACustomBitmap;
{ Puts a resampled image on the destination. Pixels are boxes, with antialising between boxes. }
procedure StretchPutImage(bmp: TBGRACustomBitmap; NewWidth, NewHeight: integer;
  dest: TBGRACustomBitmap; OffsetX,OffsetY: Integer; ADrawMode: TDrawMode;
  AOpacity: byte; ANoTransition: boolean = false);

{ Puts a resampled image on the destination, downsampling by the provided _factorX_ and _factorY_ }
procedure DownSamplePutImage(source: TBGRACustomBitmap; factorX,factorY: integer; dest: TBGRACustomBitmap; OffsetX,OffsetY: Integer; ADrawMode: TDrawMode);
{ Computes a resampled image, downsampling by the provided _factorX_ and _factorY_ }
function DownSample(source: TBGRACustomBitmap; factorX,factorY: integer): TBGRACustomBitmap;

{---------------------------- Interpolation filters --------------------------------}

{ Computes fine interpolation between 0 and 1 for rfBox, rfLinear, rfHalfCosine and rfCosine filters.  }
function FineInterpolation(t: single; ResampleFilter: TResampleFilter): single;
{ Computes fine interpolation between 0 and 256 for rfBox, rfLinear, rfHalfCosine and rfCosine filters.  }
function FineInterpolation256(t256: integer; ResampleFilter: TResampleFilter): integer;

type
  { @abstract(Abstract class to define a wide kernel.)

    A wide kernel is an interpolation method that can use more than the adjacent pixels. }
  TWideKernelFilter = class
    function Interpolation(t: single): single; virtual; abstract;
    function ShouldCheckRange: boolean; virtual; abstract;
    function KernelWidth: single; virtual; abstract;
  end;

  { Filter that provides smooth interpolation but less blurry than TCubicKernel }
  TMitchellKernel = class(TWideKernelFilter)
    function Interpolation(t: single): single; override;
    function ShouldCheckRange: boolean; override;
    function KernelWidth: single; override;
  end;

  { Spline kernel provides customizable wide interpolation filter using Coeff property }
  TSplineKernel = class(TWideKernelFilter)
  public
    Coeff: single;
    constructor Create; overload;
    constructor Create(ACoeff: single); overload;
    function Interpolation(t: single): single; override;
    function ShouldCheckRange: boolean; override;
    function KernelWidth: single; override;
  end;

  { Cubic interpolation is very smooth but can be a bit blurry }
  TCubicKernel = class(TWideKernelFilter)
    function pow3(x: single): single; inline;
    function Interpolation(t: single): single; override;
    function ShouldCheckRange: boolean; override;
    function KernelWidth: single; override;
  end;

  { Lanczos kernel provides smooth but contrasted interpolation }
  TLanczosKernel = class(TWideKernelFilter)
  private
    FNumberOfLobes: integer;
    FFactor: ValReal;
    procedure SetNumberOfLobes(AValue: integer);
  public
    constructor Create(ANumberOfLobes: integer);
    function Interpolation(t: single): single; override;
    function ShouldCheckRange: boolean; override;
    function KernelWidth: single; override;

    property NumberOfLobes : integer read FNumberOfLobes write SetNumberOfLobes;
  end;

{ Create an instance of a predefined kernel matching spline style }
function CreateInterpolator(style: TSplineStyle): TWideKernelFilter;

{-------------------------------- Fine resample ------------------------------------}

{ @abstract(Uses floating point coordinates to get an antialiased resample.)

  It can use minimal interpolation (4 pixels when upsizing) for simple interpolation
  filters (linear and cosine-like) or wide kernel resample for complex interpolation.
  In this cas, it calls WideKernelResample. }
function FineResample(bmp: TBGRACustomBitmap;
  NewWidth, NewHeight: integer; ResampleFilter: TResampleFilter): TBGRACustomBitmap;

{ WideKernelResample can be called for custom filter kernel, derived
  from TWideKernelFilter. It is slower of course than simple interpolation. }
function WideKernelResample(bmp: TBGRACustomBitmap;
  NewWidth, NewHeight: integer; ResampleFilterSmaller, ResampleFilterLarger: TWideKernelFilter): TBGRACustomBitmap;

implementation

uses Math, BGRABlend, BGRAClasses;

function SimpleStretch(bmp: TBGRACustomBitmap;
  newWidth, newHeight: integer): TBGRACustomBitmap;
begin
  if (NewWidth = bmp.Width) and (NewHeight = bmp.Height) then
  begin
    Result := bmp.Duplicate;
    exit;
  end;
  Result := bmp.NewBitmap(NewWidth, NewHeight);
  StretchPutImage(bmp, newWidth,newHeight, result, 0,0, dmSet, 255);
end;

procedure StretchPutImage(bmp: TBGRACustomBitmap; NewWidth, NewHeight: integer;
  dest: TBGRACustomBitmap; OffsetX, OffsetY: Integer; ADrawMode: TDrawMode; AOpacity: byte; ANoTransition: boolean);
type
  TTransitionState = (tsNone, tsPlain, tsLeft, tsMiddle, tsRight);
var
  x_src,y_src, y_src2, prev_y_src, prev_y_src2: Int32or64;
  inc_x_src, mod_x_src, acc_x_src, inc_y_src, mod_y_src, acc_y_src,
  acc_x_src2, acc_y_src2: Int32or64;
  x_dest, y_dest: Int32or64;

  PDest, PSrc1, PSrc2: PBGRAPixel;
  vertColors: packed array[1..2] of TBGRAPixel;
  DeltaSrcX: Int32or64;
  targetRect: TRect;
  tempData: PBGRAPixel;
  prevHorizTransition,horizTransition,prevVertTransition,vertTransition: TTransitionState;
  horizSlightlyDifferent,vertSlightlyDifferent: boolean;

  procedure LinearMix(PSrc: PBGRAPixel; DeltaSrc: integer; AccSrcQuarter: boolean;
        PDest: PBGRAPixel; slightlyDifferent: boolean; var transition: TTransitionState);
  var
    asum: Int32or64;
    a1,a2: Int32or64;
    newTransition: TTransitionState;
  begin
    if (DeltaSrc=0) or ANoTransition then
    begin
      PDest^ := PSrc^;
      transition:= tsPlain;
    end
    else
    begin
      if slightlyDifferent then
      begin
        if AccSrcQuarter then newTransition:= tsRight else
          newTransition:= tsLeft;
      end else
        newTransition:= tsMiddle;

      if (newTransition = tsMiddle) or ((newTransition = tsRight) and (transition = tsLeft)) or
        ((newTransition = tsLeft) and (transition = tsRight)) then
      begin
        transition:= tsMiddle;
        if ADrawMode = dmXor then
        begin
          pdest^.alpha := (psrc^.alpha + (psrc+DeltaSrc)^.alpha + 1) shr 1;
          pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red + 1) shr 1;
          pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green + 1) shr 1;
          pdest^.blue := (psrc^.blue + (psrc+DeltaSrc)^.blue + 1) shr 1;
        end else
        begin
          asum := psrc^.alpha + (psrc+DeltaSrc)^.alpha;
          if asum = 0 then
            pdest^ := BGRAPixelTransparent
          else if asum = 510 then
          begin
            pdest^.alpha := 255;
            pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red + 1) shr 1;
            pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green + 1) shr 1;
            pdest^.blue := (psrc^.blue + (psrc+DeltaSrc)^.blue + 1) shr 1;
          end else
          begin
            pdest^.alpha := asum shr 1;
            a1 := psrc^.alpha;
            a2 := (psrc+DeltaSrc)^.alpha;
            pdest^.red := (psrc^.red*a1 + (psrc+DeltaSrc)^.red*a2 + (asum shr 1)) div asum;
            pdest^.green := (psrc^.green*a1 + (psrc+DeltaSrc)^.green*a2 + (asum shr 1)) div asum;
            pdest^.blue := (psrc^.blue*a1 + (psrc+DeltaSrc)^.blue*a2 + (asum shr 1)) div asum;
          end;
        end;
      end else
      if newTransition = tsRight then
      begin
        transition := tsRight;
        if ADrawMode = dmXor then
        begin
          pdest^.alpha := (psrc^.alpha + (psrc+DeltaSrc)^.alpha*3 + 2) shr 2;
          pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red*3 + 2) shr 2;
          pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green*3 + 2) shr 2;
          pdest^.blue := (psrc^.blue + (psrc+DeltaSrc)^.blue*3 + 2) shr 2;
        end else
        begin
          asum := psrc^.alpha + (psrc+DeltaSrc)^.alpha*3;
          if asum = 0 then
            pdest^ := BGRAPixelTransparent
          else if asum = 1020 then
          begin
            pdest^.alpha := 255;
            pdest^.red := (psrc^.red + (psrc+DeltaSrc)^.red*3 + 2) shr 2;
            pdest^.green := (psrc^.green + (psrc+DeltaSrc)^.green*3 + 2) shr 2;
            pdest^.blue := (psrc^.blue + (psrc+DeltaSrc)^.blue*3 + 2) shr 2;
          end else
          begin
            pdest^.alpha := asum shr 2;
            a1 := psrc^.alpha;
            a2 := (psrc+DeltaSrc)^.alpha;
            pdest^.red := (psrc^.red*a1 + (psrc+DeltaSrc)^.red*a2*3 + (asum shr 1)) div asum;
            pdest^.green := (psrc^.green*a1 + (psrc+DeltaSrc)^.green*a2*3 + (asum shr 1)) div asum;
            pdest^.blue := (psrc^.blue*a1 + (psrc+DeltaSrc)^.blue*a2*3 + (asum shr 1)) div asum;
          end;
        end;
      end else
      begin
        transition:= tsLeft;
        if ADrawMode = dmXor then
        begin
          pdest^.alpha := (psrc^.alpha*3 + (psrc+DeltaSrc)^.alpha + 2) shr 2;
          pdest^.red := (psrc^.red*3 + (psrc+DeltaSrc)^.red + 2) shr 2;
          pdest^.green := (psrc^.green*3 + (psrc+DeltaSrc)^.green + 2) shr 2;
          pdest^.blue := (psrc^.blue*3 + (psrc+DeltaSrc)^.blue + 2) shr 2;
        end else
        begin
          asum := psrc^.alpha*3 + (psrc+DeltaSrc)^.alpha;
          if asum = 0 then
            pdest^ := BGRAPixelTransparent
          else if asum = 1020 then
          begin
            pdest^.alpha := 255;
            pdest^.red := (psrc^.red*3 + (psrc+DeltaSrc)^.red + 2) shr 2;
            pdest^.green := (psrc^.green*3 + (psrc+DeltaSrc)^.green + 2) shr 2;
            pdest^.blue := (psrc^.blue*3 + (psrc+DeltaSrc)^.blue + 2) shr 2;
          end else
          begin
            pdest^.alpha := asum shr 2;
            a1 := psrc^.alpha;
            a2 := (psrc+DeltaSrc)^.alpha;
            pdest^.red := (psrc^.red*a1*3 + (psrc+DeltaSrc)^.red*a2 + (asum shr 1)) div asum;
            pdest^.green := (psrc^.green*a1*3 + (psrc+DeltaSrc)^.green*a2 + (asum shr 1)) div asum;
            pdest^.blue := (psrc^.blue*a1*3 + (psrc+DeltaSrc)^.blue*a2 + (asum shr 1)) div asum;
          end;
        end;
      end;
    end;
  end;

begin
  if (newWidth <= 0) or (newHeight <= 0) or (bmp.Width <= 0)
    or (bmp.Height <= 0) then
    exit;

  targetRect := rect(0,0,NewWidth,NewHeight);
  if OffsetX < dest.ClipRect.Left then targetRect.Left:= dest.ClipRect.Left-OffsetX;
  if OffsetY < dest.ClipRect.Top then targetRect.Top:= dest.ClipRect.Top-OffsetY;
  if OffsetX+NewWidth > dest.ClipRect.Right then targetRect.Right := dest.ClipRect.Right-OffsetX;
  if OffsetY+NewHeight > dest.ClipRect.Bottom then targetRect.Bottom := dest.ClipRect.Bottom-OffsetY;
  if (targetRect.Right <= targetRect.Left) or (targetRect.Bottom <= targetRect.Top) then exit;

  bmp.LoadFromBitmapIfNeeded;

  if (ADrawMode <> dmSet) or (AOpacity <> 255) then
     getmem(tempData, (targetRect.Right-targetRect.Left)*sizeof(TBGRAPixel) )
  else
      tempData := nil;

  inc_x_src := bmp.Width div newwidth;
  mod_x_src := bmp.Width mod newwidth;
  inc_y_src := bmp.Height div newheight;
  mod_y_src := bmp.Height mod newheight;

  prev_y_src := -1;
  prev_y_src2 := -1;

  acc_y_src := targetRect.Top*mod_y_src;
  y_src     := targetRect.Top*inc_y_src + (acc_y_src div NewHeight);
  acc_y_src := acc_y_src mod NewHeight;

  y_src     := y_src+ (bmp.Height div 4) div newheight;
  acc_y_src := acc_y_src+ (bmp.Height div 4) mod newheight;

  y_src2     := y_src+ (bmp.Height div 2) div newheight;
  acc_y_src2 := acc_y_src+ (bmp.Height div 2) mod newheight;
  if acc_y_src2 > NewHeight then
  begin
    dec(acc_y_src2, NewHeight);
    inc(y_src2);
  end;
  horizSlightlyDifferent := (NewWidth > bmp.Width*2 div 3) and (NewWidth < bmp.Width*4 div 3);
  prevVertTransition:= tsNone;
  vertSlightlyDifferent := (NewHeight > bmp.Height*2 div 3) and (NewHeight < bmp.Height*4 div 3);
  for y_dest := targetRect.Top to targetRect.Bottom - 1 do
  begin
    if (y_src = prev_y_src) and (y_src2 = prev_y_src2) and not vertSlightlyDifferent then
    begin
      if tempData = nil then
        move((dest.ScanLine[y_dest-1+OffsetY]+OffsetX+targetRect.Left)^,(dest.ScanLine[y_dest+OffsetY]+OffsetX+targetRect.Left)^,(targetRect.Right-targetRect.Left)*sizeof(TBGRAPixel))
      else
        PutPixels(dest.ScanLine[y_dest+OffsetY]+OffsetX+targetRect.Left,tempData,targetRect.right-targetRect.left,ADrawMode,AOpacity);
    end else
    begin
      if tempData = nil then
         PDest := dest.ScanLine[y_dest+OffsetY]+OffsetX+targetRect.Left
      else
        PDest := tempData;
      PSrc1 := bmp.Scanline[y_src];

      acc_x_src := targetRect.Left*mod_x_src;
      x_src     := targetRect.Left*inc_x_src + (acc_x_src div NewWidth);
      acc_x_src := acc_x_src mod NewWidth;

      x_src     := x_src+ (bmp.Width div 4) div NewWidth;
      acc_x_src := acc_x_src+ (bmp.Width div 4) mod NewWidth;

      DeltaSrcX := (bmp.Width div 2) div NewWidth;
      acc_x_src2 := acc_x_src+ (bmp.Width div 2) mod NewWidth;
      if acc_x_src2 > NewWidth then
      begin
        dec(acc_x_src2, NewWidth);
        inc(DeltaSrcX);
      end;
      inc(Psrc1, x_src);
      prevHorizTransition := tsNone;

      if y_src2=y_src then
      begin
        horizTransition:= prevHorizTransition;
        for x_dest := targetRect.left to targetRect.right - 1 do
        begin
          LinearMix(psrc1, DeltaSrcX, acc_x_src2 >= NewWidth shr 2, PDest, horizSlightlyDifferent, horizTransition);

          Inc(PSrc1, inc_x_src);
          Inc(acc_x_src, mod_x_src);
          if acc_x_src >= newWidth then
          begin
            Dec(acc_x_src, newWidth);
            Inc(PSrc1);
            dec(DeltaSrcX);
          end;
          Inc(acc_x_src2, mod_x_src);
          if acc_x_src2 >= newWidth then
          begin
            Dec(acc_x_src2, newWidth);
            Inc(DeltaSrcX);
          end;
          inc(PDest);
        end;
        prevVertTransition:= tsPlain;
      end else
      begin
        PSrc2 := bmp.Scanline[y_src2]+x_src;
        for x_dest := targetRect.left to targetRect.right - 1 do
        begin
          horizTransition:= prevHorizTransition;
          LinearMix(psrc1, DeltaSrcX, acc_x_src2 >= NewWidth shr 2, @vertColors[1], horizSlightlyDifferent, horizTransition);
          horizTransition:= prevHorizTransition;
          LinearMix(psrc2, DeltaSrcX, acc_x_src2 >= NewWidth shr 2, @vertColors[2], horizSlightlyDifferent, horizTransition);
          prevHorizTransition:= horizTransition;
          vertTransition:= prevVertTransition;
          LinearMix(@vertColors[1],1,acc_y_src2 >= NewHeight shr 2,PDest,vertSlightlyDifferent,vertTransition);

          Inc(PSrc1, inc_x_src);
          Inc(PSrc2, inc_x_src);
          Inc(acc_x_src, mod_x_src);
          if acc_x_src >= newWidth then
          begin
            Dec(acc_x_src, newWidth);
            Inc(PSrc1);
            Inc(PSrc2);
            dec(DeltaSrcX);
          end;
          Inc(acc_x_src2, mod_x_src);
          if acc_x_src2 >= newWidth then
          begin
            Dec(acc_x_src2, newWidth);
            Inc(DeltaSrcX);
          end;
          inc(PDest);
        end;
        prevVertTransition:= vertTransition;
      end;

      if tempData <> nil then
         PutPixels(dest.ScanLine[y_dest+OffsetY]+OffsetX+targetRect.Left,tempData,targetRect.right-targetRect.left,ADrawMode,AOpacity);
    end;

    prev_y_src := y_src;
    prev_y_src2 := y_src2;

    Inc(y_src, inc_y_src);
    Inc(acc_y_src, mod_y_src);
    if acc_y_src >= newheight then
    begin
      Dec(acc_y_src, newheight);
      Inc(y_src);
    end;

    Inc(y_src2, inc_y_src);
    Inc(acc_y_src2, mod_y_src);
    if acc_y_src2 >= newheight then
    begin
      Dec(acc_y_src2, newheight);
      Inc(y_src2);
    end;
  end;
  dest.InvalidateBitmap;
  if Assigned(tempData) then FreeMem(tempData);
end;

procedure DownSamplePutImage2(source: TBGRACustomBitmap;
  dest: TBGRACustomBitmap; OffsetX, OffsetY: Integer; ADrawMode: TDrawMode);
const factorX = 2; factorY = 2; nbi= factorX*factorY;
var xb,yb,ys: Int32or64;
    pdest: PBGRAPixel;
    psrc1,psrc2: PBGRAPixel;
    asum,maxsum: UInt32or64;
    newWidth,newHeight: Int32or64;
    r,g,b: UInt32or64;
begin
  if (source.Width mod factorX <> 0) or (source.Height mod factorY <> 0) then
     raise exception.Create('Source size must be a multiple of factorX and factorY');
  newWidth := source.Width div factorX;
  newHeight := source.Height div factorY;
  ys := 0;
  maxsum := 255*Int32or64(factorX)*Int32or64(factorY);
  for yb := 0 to newHeight-1 do
  begin
    pdest := dest.ScanLine[yb+OffsetY]+OffsetX;
    psrc1 := source.Scanline[ys]; inc(ys);
    psrc2 := source.Scanline[ys]; inc(ys);
    for xb := newWidth-1 downto 0 do
    begin
      asum := 0;
      asum := psrc1^.alpha + psrc2^.alpha + (psrc1+1)^.alpha + (psrc2+1)^.alpha;
      if asum = maxsum then
      begin
        pdest^.alpha := 255;
        r := psrc1^.red + psrc2^.red + (psrc1+1)^.red + (psrc2+1)^.red;
        g := psrc1^.green + psrc2^.green + (psrc1+1)^.green + (psrc2+1)^.green;
        b := psrc1^.blue + psrc2^.blue + (psrc1+1)^.blue + (psrc2+1)^.blue;
        inc(psrc1,factorX); inc(psrc2,factorX);
        pdest^.red := (r + (nbi shr 1)) shr 2;
        pdest^.green := (g + (nbi shr 1)) shr 2;
        pdest^.blue := (b + (nbi shr 1)) shr 2;
      end else
      if ADrawMode <> dmSetExceptTransparent then
      begin
        if asum = 0 then
        begin
          if ADrawMode = dmSet then
            pdest^ := BGRAPixelTransparent;
          inc(psrc1,factorX); inc(psrc2,factorX);
        end
        else
        begin
          r := psrc1^.red*psrc1^.alpha + psrc2^.red*psrc2^.alpha + (psrc1+1)^.red*(psrc1+1)^.alpha + (psrc2+1)^.red*(psrc2+1)^.alpha;
          g := psrc1^.green*psrc1^.alpha + psrc2^.green*psrc2^.alpha + (psrc1+1)^.green*(psrc1+1)^.alpha + (psrc2+1)^.green*(psrc2+1)^.alpha;
          b := psrc1^.blue*psrc1^.alpha + psrc2^.blue*psrc2^.alpha + (psrc1+1)^.blue*(psrc1+1)^.alpha + (psrc2+1)^.blue*(psrc2+1)^.alpha;
          inc(psrc1,factorX); inc(psrc2,factorX);
          if ADrawMode = dmSet then
          begin
            pdest^.alpha := (asum + (nbi shr 1)) shr 2;
            pdest^.red := (r + (asum shr 1)) div asum;
            pdest^.green := (g + (asum shr 1)) div asum;
            pdest^.blue := (b + (asum shr 1)) div asum;
          end
          else
          begin
            if ADrawMode = dmDrawWithTransparency then
              DrawPixelInlineWithAlphaCheck(pdest,BGRA((r + (asum shr 1)) div asum,
                 (g + (asum shr 1)) div asum,
                 (b + (asum shr 1)) div asum,
                 (asum + (nbi shr 1)) shr 2)) else
             if ADrawMode = dmFastBlend then
               FastBlendPixelInline(pdest,BGRA((r + (asum shr 1)) div asum,
                  (g + (asum shr 1)) div asum,
                  (b + (asum shr 1)) div asum,
                  (asum + (nbi shr 1)) shr 2));
          end;
        end;
      end;
      inc(pdest);
    end;
  end;
end;

procedure DownSamplePutImage3(source: TBGRACustomBitmap;
  dest: TBGRACustomBitmap; OffsetX, OffsetY: Integer; ADrawMode: TDrawMode);
const factorX = 3; factorY = 3; nbi= factorX*factorY;
var xb,yb,ys: Int32or64;
    pdest: PBGRAPixel;
    psrc1,psrc2,psrc3: PBGRAPixel;
    asum,maxsum: UInt32or64;
    newWidth,newHeight: Int32or64;
    r,g,b: UInt32or64;
begin
  if (source.Width mod factorX <> 0) or (source.Height mod factorY <> 0) then
     raise exception.Create('Source size must be a multiple of factorX and factorY');
  newWidth := source.Width div factorX;
  newHeight := source.Height div factorY;
  ys := 0;
  maxsum := 255*Int32or64(factorX)*Int32or64(factorY);
  for yb := 0 to newHeight-1 do
  begin
    pdest := dest.ScanLine[yb+OffsetY]+OffsetX;
    psrc1 := source.Scanline[ys]; inc(ys);
    psrc2 := source.Scanline[ys]; inc(ys);
    psrc3 := source.Scanline[ys]; inc(ys);
    for xb := newWidth-1 downto 0 do
    begin
      asum := 0;
      asum := psrc1^.alpha + psrc2^.alpha + psrc3^.alpha
           + (psrc1+1)^.alpha + (psrc2+1)^.alpha + (psrc3+1)^.alpha
           + (psrc1+2)^.alpha + (psrc2+2)^.alpha + (psrc3+2)^.alpha;
      if asum = maxsum then
      begin
        pdest^.alpha := 255;
        r := psrc1^.red + psrc2^.red + psrc3^.red
           + (psrc1+1)^.red + (psrc2+1)^.red + (psrc3+1)^.red
           + (psrc1+2)^.red + (psrc2+2)^.red + (psrc3+2)^.red;
        g := psrc1^.green + psrc2^.green + psrc3^.green
           + (psrc1+1)^.green + (psrc2+1)^.green + (psrc3+1)^.green
           + (psrc1+2)^.green + (psrc2+2)^.green + (psrc3+2)^.green;
        b := psrc1^.blue + psrc2^.blue + psrc3^.blue
           + (psrc1+1)^.blue + (psrc2+1)^.blue + (psrc3+1)^.blue
           + (psrc1+2)^.blue + (psrc2+2)^.blue + (psrc3+2)^.blue;
        inc(psrc1,factorX); inc(psrc2,factorX); inc(psrc3,factorX);
        pdest^.red := (r + (nbi shr 1)) div 9;
        pdest^.green := (g + (nbi shr 1)) div 9;
        pdest^.blue := (b + (nbi shr 1)) div 9;
      end else
      if ADrawMode <> dmSetExceptTransparent then
      begin
        if asum = 0 then
        begin
          if ADrawMode = dmSet then
            pdest^ := BGRAPixelTransparent;
          inc(psrc1,factorX); inc(psrc2,factorX); inc(psrc3,factorX);
        end
        else
        begin
          r := psrc1^.red*psrc1^.alpha + psrc2^.red*psrc2^.alpha + psrc3^.red*psrc3^.alpha
            + (psrc1+1)^.red*(psrc1+1)^.alpha + (psrc2+1)^.red*(psrc2+1)^.alpha + (psrc3+1)^.red*(psrc3+1)^.alpha
            + (psrc1+2)^.red*(psrc1+2)^.alpha + (psrc2+2)^.red*(psrc2+2)^.alpha + (psrc3+2)^.red*(psrc3+2)^.alpha;
          g := psrc1^.green*psrc1^.alpha + psrc2^.green*psrc2^.alpha + psrc3^.green*psrc3^.alpha
            + (psrc1+1)^.green*(psrc1+1)^.alpha + (psrc2+1)^.green*(psrc2+1)^.alpha + (psrc3+1)^.green*(psrc3+1)^.alpha
            + (psrc1+2)^.green*(psrc1+2)^.alpha + (psrc2+2)^.green*(psrc2+2)^.alpha + (psrc3+2)^.green*(psrc3+2)^.alpha;
          b := psrc1^.blue*psrc1^.alpha + psrc2^.blue*psrc2^.alpha + psrc3^.blue*psrc3^.alpha
            + (psrc1+1)^.blue*(psrc1+1)^.alpha + (psrc2+1)^.blue*(psrc2+1)^.alpha + (psrc3+1)^.blue*(psrc3+1)^.alpha
            + (psrc1+2)^.blue*(psrc1+2)^.alpha + (psrc2+2)^.blue*(psrc2+2)^.alpha + (psrc3+2)^.blue*(psrc3+2)^.alpha;
          inc(psrc1,factorX); inc(psrc2,factorX); inc(psrc3,factorX);
          if ADrawMode = dmSet then
          begin
            pdest^.alpha := (asum + (nbi shr 1)) div 9;
            pdest^.red := (r + (asum shr 1)) div asum;
            pdest^.green := (g + (asum shr 1)) div asum;
            pdest^.blue := (b + (asum shr 1)) div asum;
          end
          else
          begin
            if ADrawMode = dmDrawWithTransparency then
              DrawPixelInlineWithAlphaCheck(pdest,BGRA((r + (asum shr 1)) div asum,
                 (g + (asum shr 1)) div asum,
                 (b + (asum shr 1)) div asum,
                 (asum + (nbi shr 1)) div 9)) else
             if ADrawMode = dmFastBlend then
               FastBlendPixelInline(pdest,BGRA((r + (asum shr 1)) div asum,
                  (g + (asum shr 1)) div asum,
                  (b + (asum shr 1)) div asum,
                  (asum + (nbi shr 1)) div 9));
          end;
        end;
      end;
      inc(pdest);
    end;
  end;
end;

procedure DownSamplePutImage(source: TBGRACustomBitmap; factorX, factorY: integer;
  dest: TBGRACustomBitmap; OffsetX, OffsetY: Integer; ADrawMode: TDrawMode);
var xb,yb,ys,iy,ix: Int32or64;
    pdest,psrci: PBGRAPixel;
    psrc: array of PBGRAPixel;
    asum,maxsum: UInt32or64;
    newWidth,newHeight: Int32or64;
    r,g,b,nbi: UInt32or64;
begin
  if ADrawMode = dmXor then raise exception.Create('dmXor drawmode not supported');
  if (factorX = 2) and (factorY = 2) then
  begin
     DownSamplePutImage2(source,dest,OffsetX,OffsetY,ADrawMode);
     exit;
  end;
  if (factorX = 3) and (factorY = 3) then
  begin
     DownSamplePutImage3(source,dest,OffsetX,OffsetY,ADrawMode);
     exit;
  end;
  if (source.Width mod factorX <> 0) or (source.Height mod factorY <> 0) then
     raise exception.Create('Source size must be a multiple of factorX and factorY');
  newWidth := source.Width div factorX;
  newHeight := source.Height div factorY;
  ys := 0;
  maxsum := 255*Int32or64(factorX)*Int32or64(factorY);
  nbi := factorX*factorY;
  setlength(psrc, factorY);
  for yb := 0 to newHeight-1 do
  begin
    pdest := dest.ScanLine[yb+OffsetY]+OffsetX;
    for iy := factorY-1 downto 0 do
    begin
      psrc[iy] := source.Scanline[ys];
      inc(ys);
    end;
    for xb := newWidth-1 downto 0 do
    begin
      asum := 0;
      for iy := factorY-1 downto 0 do
      begin
        psrci := psrc[iy];
        for ix := factorX-1 downto 0 do
          inc(asum, (psrci+ix)^.alpha);
      end;
      if asum = maxsum then
      begin
        pdest^.alpha := 255;
        r := 0;
        g := 0;
        b := 0;
        for iy := factorY-1 downto 0 do
          for ix := factorX-1 downto 0 do
          begin
            with psrc[iy]^ do
            begin
              inc(r, red);
              inc(g, green);
              inc(b, blue);
            end;
            inc(psrc[iy]);
          end;
        pdest^.red := (r + (nbi shr 1)) div nbi;
        pdest^.green := (g + (nbi shr 1)) div nbi;
        pdest^.blue := (b + (nbi shr 1)) div nbi;
      end else
      if ADrawMode <> dmSetExceptTransparent then
      begin
        if asum = 0 then
        begin
          if ADrawMode = dmSet then
            pdest^ := BGRAPixelTransparent;
          for iy := factorY-1 downto 0 do
            inc(psrc[iy],factorX);
        end
        else
        begin
          r := 0;
          g := 0;
          b := 0;
          for iy := factorY-1 downto 0 do
            for ix := factorX-1 downto 0 do
            begin
              with psrc[iy]^ do
              begin
                inc(r, red*alpha);
                inc(g, green*alpha);
                inc(b, blue*alpha);
              end;
              inc(psrc[iy]);
            end;
          if ADrawMode = dmSet then
          begin
            pdest^.alpha := (asum + (nbi shr 1)) div nbi;
            pdest^.red := (r + (asum shr 1)) div asum;
            pdest^.green := (g + (asum shr 1)) div asum;
            pdest^.blue := (b + (asum shr 1)) div asum;
          end
          else
          begin
            if ADrawMode = dmDrawWithTransparency then
              DrawPixelInlineWithAlphaCheck(pdest,BGRA((r + (asum shr 1)) div asum,
                 (g + (asum shr 1)) div asum,
                 (b + (asum shr 1)) div asum,
                 (asum + (nbi shr 1)) div nbi)) else
             if ADrawMode = dmFastBlend then
               FastBlendPixelInline(pdest,BGRA((r + (asum shr 1)) div asum,
                  (g + (asum shr 1)) div asum,
                  (b + (asum shr 1)) div asum,
                  (asum + (nbi shr 1)) div nbi));
          end;
        end;
      end;
      inc(pdest);
    end;
  end;
end;

function DownSample(source: TBGRACustomBitmap; factorX, factorY: integer): TBGRACustomBitmap;
begin
  if (source.Width mod factorX <> 0) or (source.Height mod factorY <> 0) then
     raise exception.Create('Source size must be a multiple of factorX and factorY');
  result := source.NewBitmap(source.Width div factorX, source.Height div factorY);
  DownSamplePutImage(source,factorX,factorY,result,0,0,dmSet);
end;

{---------------------------- Interpolation filters ----------------------------------------}

function FineInterpolation(t: single; ResampleFilter: TResampleFilter): single;
begin
  if ResampleFilter <= rfLinear then
  begin
    if ResampleFilter = rfBox then
    begin
       result := round(t);
    end else
      result := t;
  end else
  begin
    if t <= 0.5 then
      result := t*t*2 else
      result := 1-(1-t)*(1-t)*2;
    if ResampleFilter <> rfCosine then result := (result+t)*0.5;
  end;
end;

function FineInterpolation256(t256: integer; ResampleFilter: TResampleFilter): integer;
begin
  if ResampleFilter <= rfLinear then
  begin
    if ResampleFilter = rfBox then
    begin
      if t256 < 128 then
        result := 0
      else
        result := 256;
    end
    else
      result := t256;
  end else
  begin
    if t256 <= 128 then
      result := (t256*t256) shr 7 else
      result := 256 - (((256-t256)*(256-t256)) shr 7);
    if ResampleFilter <> rfCosine then result := (result+t256) shr 1;
  end;
end;

{ TCubicKernel }

function TCubicKernel.pow3(x: single): single;
begin
  if x <= 0.0 then
   result:=0.0
  else
   result:=x * x * x;
end;

function TCubicKernel.Interpolation(t: single): single;
const globalfactor = 1/6;
begin
   if t > 2 then
     result := 0
   else
     result:= globalfactor *
       (pow3(t + 2 ) - 4 * pow3(t + 1 ) + 6 * pow3(t ) - 4 * pow3(t - 1 ) );
end;

function TCubicKernel.ShouldCheckRange: boolean;
begin
  Result:= false;
end;

function TCubicKernel.KernelWidth: single;
begin
  Result:= 2;
end;

{ TMitchellKernel }

function TMitchellKernel.Interpolation(t: single): single;
var
  tt, ttt: single;
const OneEighteenth = 1 / 18;
begin
  t := Abs(t);
  tt := Sqr(t);
  ttt := tt * t;
  if t < 1 then Result := (21 * ttt - 36 * tt + 16 ) * OneEighteenth
  else if t < 2 then Result := (- 7 * ttt + 36 * tt - 60 * t + 32) * OneEighteenth
  else Result := 0;
end;

function TMitchellKernel.ShouldCheckRange: Boolean;
begin
  Result := True;
end;

function TMitchellKernel.KernelWidth: single;
begin
  Result := 2;
end;

{ TSplineKernel }

constructor TSplineKernel.Create;
begin
  coeff := 0.5;
end;

constructor TSplineKernel.Create(ACoeff: single);
begin
  Coeff := ACoeff;
end;

function TSplineKernel.Interpolation(t: single): single;
var
  tt, ttt: single;
begin
  t := Abs(t);
  tt := Sqr(t);
  ttt := tt * t;
  if t < 1 then
    Result := (2 - Coeff) * ttt - (3 - Coeff) * tt + 1
  else if t < 2 then
    Result := -Coeff * (ttt - 5 * tt + 8 * t - 4)
  else
    Result := 0;
end;

function TSplineKernel.ShouldCheckRange: Boolean;
begin
  Result := True;
end;

function TSplineKernel.KernelWidth: single;
begin
  Result := 2;
end;

{ TLanczosKernel }
{ by stab }
procedure TLanczosKernel.SetNumberOfLobes(AValue: integer);
begin
  if AValue < 1 then AValue := 1;
  if FNumberOfLobes=AValue then Exit;
  FNumberOfLobes:=AValue;
  if AValue = 1 then FFactor := 1.5 else FFactor := AValue;
end;

constructor TLanczosKernel.Create(ANumberOfLobes: integer);
begin
  NumberOfLobes:= ANumberOfLobes;
end;

function TLanczosKernel.Interpolation(t: single): single;
var Pi_t: ValReal;
begin
  if t = 0 then
    Result := 1
  else if t < FNumberOfLobes then
  begin
    Pi_t := pi * t;
    Result := FFactor * sin(Pi_t) * sin(Pi_t / FNumberOfLobes) /
      (Pi_t * Pi_t)
  end
  else
    Result := 0;
end;

function TLanczosKernel.ShouldCheckRange: boolean;
begin
  Result := True;
end;

function TLanczosKernel.KernelWidth: single;
begin
  Result := FNumberOfLobes;
end;

{--------------------------------------------- Fine resample ------------------------------------------------}

function FineResampleLarger(bmp: TBGRACustomBitmap;
  newWidth, newHeight: integer; ResampleFilter: TResampleFilter): TBGRACustomBitmap;
type
  TInterpolationEntry = record
    isrc1,isrc2,factCorr: integer;
  end;
var
  yb, xb: integer;
  pdest,psrc1,psrc2:  PBGRAPixel;
  xsrc, ysrc, xfactor, yfactor: double;
  xTab,yTab: array of TInterpolationEntry;
  xInfo,yInfo: TInterpolationEntry;
  cUpLeft, cUpRight, cLowLeft, cLowRight: TBGRAPixel;
  factHoriz, factVert: single;
  fUpLeft, fUpRight, fLowLeft, fLowRight: integer;
  faUpLeft, faUpRight, faLowLeft, faLowRight: integer;
  rSum, gSum, bSum, aSum: integer;
  temp:   TBGRACustomBitmap;
begin
  if (newWidth < bmp.Width) or (newHeight < bmp.Height) then
    raise ERangeError.Create('FineResampleLarger: New dimensions must be greater or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')');

  if (newWidth = 0) or (newHeight = 0) then
  begin
    Result := bmp.NewBitmap(NewWidth, NewHeight);
    exit;
  end;

  bmp.LoadFromBitmapIfNeeded;

  if (bmp.Width = 1) and (bmp.Height = 1) then
  begin
    Result := bmp.NewBitmap(NewWidth, NewHeight);
    Result.Fill(bmp.GetPixel(0, 0));
    exit;
  end
  else
  if bmp.Width = 1 then
  begin
    temp := bmp.NewBitmap(2, bmp.Height);
    temp.PutImage(0, 0, bmp, dmSet);
    temp.PutImage(1, 0, bmp, dmSet);
    Result := FineResampleLarger(temp, 2, newHeight, ResampleFilter);
    temp.Free;
    temp := Result;
    Result := SimpleStretch(temp, newWidth,temp.Height);
    temp.Free;
    exit;
  end
  else
  if bmp.Height = 1 then
  begin
    temp := bmp.NewBitmap(bmp.Width, 2);
    temp.PutImage(0, 0, bmp, dmSet);
    temp.PutImage(0, 1, bmp, dmSet);
    Result := FineResampleLarger(temp, newWidth, 2, ResampleFilter);
    temp.Free;
    temp := Result;
    Result := SimpleStretch(temp, temp.Width,newHeight);
    temp.Free;
    exit;
  end;

  Result := bmp.NewBitmap(NewWidth, NewHeight);
  yfactor := (bmp.Height - 1) / (newHeight - 1);
  xfactor := (bmp.Width - 1) / (newWidth - 1);

  setlength(yTab, newHeight);
  for yb := 0 to newHeight - 1 do
  begin
    ysrc     := yb * yfactor;
    factVert := frac(ysrc);
    yTab[yb].isrc1   := floor(ysrc);
    yTab[yb].isrc2 := min(bmp.Height-1, ceil(ysrc));
    yTab[yb].factCorr := round(FineInterpolation(factVert,ResampleFilter)*256);
  end;
  setlength(xTab, newWidth);
  for xb := 0 to newWidth - 1 do
  begin
    xsrc     := xb * xfactor;
    factHoriz := frac(xsrc);
    xTab[xb].isrc1   := floor(xsrc);
    xTab[xb].isrc2 := min(bmp.Width-1,ceil(xsrc));
    xTab[xb].factCorr := round(FineInterpolation(factHoriz,ResampleFilter)*256);
  end;

  for yb := 0 to newHeight - 1 do
  begin
    pdest    := Result.Scanline[yb];
    yInfo    := yTab[yb];
    psrc1    := bmp.scanline[yInfo.isrc1];
    psrc2    := bmp.scanline[yInfo.isrc2];
    for xb := 0 to newWidth - 1 do
    begin
      xInfo  := xTab[xb];

      cUpLeft   := (psrc1 + xInfo.isrc1)^;
      cUpRight  := (psrc1 + xInfo.isrc2)^;
      cLowLeft  := (psrc2 + xInfo.isrc1)^;
      cLowRight := (psrc2 + xInfo.isrc2)^;

      fLowRight := (xInfo.factCorr * yInfo.factCorr + 128) shr 8;
      fLowLeft := yInfo.factCorr - fLowRight;
      fUpRight := xInfo.factCorr - fLowRight;
      fUpLeft := (256 - xInfo.factCorr) - fLowLeft;

      faUpLeft   := fUpLeft * cUpLeft.alpha;
      faUpRight  := fUpRight * cUpRight.alpha;
      faLowLeft  := fLowLeft * cLowLeft.alpha;
      faLowRight := fLowRight * cLowRight.alpha;

      rSum := cUpLeft.red * faUpLeft + cUpRight.red * faUpRight +
        cLowLeft.red * faLowLeft + cLowRight.red * faLowRight;
      gSum := cUpLeft.green * faUpLeft + cUpRight.green * faUpRight +
        cLowLeft.green * faLowLeft + cLowRight.green * faLowRight;
      bSum := cUpLeft.blue * faUpLeft + cUpRight.blue * faUpRight +
        cLowLeft.blue * faLowLeft + cLowRight.blue * faLowRight;
      aSum := cUpLeft.alpha * fUpLeft + cUpRight.alpha * fUpRight +
        cLowLeft.alpha * fLowLeft + cLowRight.alpha * fLowRight;

      if aSum = 0 then
        pdest^ := BGRAPixelTransparent
      else
        pdest^ := BGRA((rSum + aSum shr 1) div aSum, (gSum + aSum shr 1) div aSum,
          (bSum + aSum shr 1) div aSum, (aSum + 128) shr 8);
      Inc(pdest);

    end;
  end;
end;

function FineResampleSmaller(bmp: TBGRACustomBitmap;
  newWidth, newHeight: integer): TBGRACustomBitmap;
var
  yb, xb, yb2, xb2: integer;
  pdest, psrc:      PBGRAPixel;
  lineDelta, delta: integer;
  xsrc1, ysrc1, xsrc2, ysrc2, xfactor, yfactor: double;
  ixsrc1, ixsrc2, iysrc1, iysrc2, ixsrc1p1, ixsrc2m1, iysrc1p1, iysrc2m1: integer;
  cBorder, cFull, cUpLeft, cUpRight, cLowLeft, cLowRight: TBGRAPixel;
  factHoriz1, factHoriz2, factVert1, factVert2, Sum, fUpLeft, fUpRight,
  fLowLeft, fLowRight, faUpLeft, faUpRight, faLowLeft, faLowRight: single;
  rSum, gSum, bSum, aSum: double;
begin
  if (newWidth > bmp.Width) or (newHeight > bmp.Height) then
    raise ERangeError.Create('FineResampleSmaller: New dimensions must be smaller or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')');
  Result := bmp.NewBitmap(NewWidth, NewHeight);
  if (newWidth = 0) or (newHeight = 0) or (bmp.Width = 0) or (bmp.Height = 0) then
    exit;

  bmp.LoadFromBitmapIfNeeded;

  if bmp.lineOrder = riloTopToBottom then
    lineDelta := bmp.Width
  else
    lineDelta := -bmp.Width;

  yfactor := bmp.Height / newHeight;
  xfactor := bmp.Width / newWidth;
  for yb := 0 to newHeight - 1 do
  begin
    pdest  := Result.Scanline[yb];
    ysrc1  := yb * yfactor;
    ysrc2  := (yb + 1) * yfactor;
    iysrc1 := trunc(ysrc1);
    if (int(ysrc2) = int(ysrc1)) or (ysrc2 = iysrc1 + 1) then
    begin
      iysrc2    := iysrc1;
      factVert1 := 1;
      factVert2 := 0;
    end
    else
    begin
      iysrc2    := trunc(ysrc2);
      factVert1 := 1 - frac(ysrc1);
      factVert2 := frac(ysrc2);
    end;
    for xb := 0 to newWidth - 1 do
    begin
      xsrc1  := xb * xfactor;
      xsrc2  := (xb + 1) * xfactor;
      ixsrc1 := trunc(xsrc1);
      if (int(xsrc2) = int(xsrc1)) or (xsrc2 = ixsrc1 + 1) then
      begin
        ixsrc2     := ixsrc1;
        factHoriz1 := 1;
        factHoriz2 := 0;
      end
      else
      begin
        ixsrc2     := trunc(xsrc2);
        factHoriz1 := 1 - frac(xsrc1);
        factHoriz2 := frac(xsrc2);
      end;

      cUpLeft   := bmp.GetPixel(ixsrc1, iysrc1);
      cUpRight  := bmp.GetPixel(ixsrc2, iysrc1);
      cLowLeft  := bmp.GetPixel(ixsrc1, iysrc2);
      cLowRight := bmp.GetPixel(ixsrc2, iysrc2);

      fUpLeft   := factHoriz1 * factVert1;
      fUpRight  := factHoriz2 * factVert1;
      fLowLeft  := factHoriz1 * factVert2;
      fLowRight := factHoriz2 * factVert2;

      faUpLeft   := fUpLeft * cUpLeft.alpha;
      faUpRight  := fUpRight * cUpRight.alpha;
      faLowLeft  := fLowLeft * cLowLeft.alpha;
      faLowRight := fLowRight * cLowRight.alpha;

      Sum  := fUpLeft + fUpRight + fLowLeft + fLowRight;
      rSum := cUpLeft.red * faUpLeft + cUpRight.red * faUpRight +
        cLowLeft.red * faLowLeft + cLowRight.red * faLowRight;
      gSum := cUpLeft.green * faUpLeft + cUpRight.green * faUpRight +
        cLowLeft.green * faLowLeft + cLowRight.green * faLowRight;
      bSum := cUpLeft.blue * faUpLeft + cUpRight.blue * faUpRight +
        cLowLeft.blue * faLowLeft + cLowRight.blue * faLowRight;
      aSum := cUpLeft.alpha * fUpLeft + cUpRight.alpha * fUpRight +
        cLowLeft.alpha * fLowLeft + cLowRight.alpha * fLowRight;

      ixsrc1p1 := ixsrc1 + 1;
      ixsrc2m1 := ixsrc2 - 1;
      iysrc1p1 := iysrc1 + 1;
      iysrc2m1 := iysrc2 - 1;

      if ixsrc2m1 >= ixsrc1p1 then
      begin
        psrc := bmp.scanline[iysrc1] + ixsrc1p1;
        for xb2 := ixsrc1p1 to ixsrc2m1 do
        begin
          cBorder := psrc^;
          Inc(psrc);
          IncF(rSum, cBorder.red * cBorder.alpha * factVert1);
          IncF(gSum, cBorder.green * cBorder.alpha * factVert1);
          IncF(bSum, cBorder.blue * cBorder.alpha * factVert1);
          IncF(aSum, cBorder.alpha * factVert1);
          IncF(Sum, factVert1);
        end;

        if (factVert2 <> 0) and (iysrc2 < bmp.Height) then
        begin
          psrc := bmp.scanline[iysrc2] + ixsrc1p1;
          for xb2 := ixsrc1p1 to ixsrc2m1 do
          begin
            cBorder := psrc^;
            Inc(psrc);
            IncF(rSum, cBorder.red * cBorder.alpha * factVert2);
            IncF(gSum, cBorder.green * cBorder.alpha * factVert2);
            IncF(bSum, cBorder.blue * cBorder.alpha * factVert2);
            IncF(aSum, cBorder.alpha * factVert2);
            IncF(Sum, factVert2);
          end;
        end;
      end;

      if iysrc2m1 >= iysrc1p1 then
      begin
        psrc := bmp.scanline[iysrc1p1] + ixsrc1;
        for yb2 := iysrc1p1 to iysrc2m1 do
        begin
          cBorder := psrc^;
          Inc(psrc, lineDelta);
          IncF(rSum, cBorder.red * cBorder.alpha * factHoriz1);
          IncF(gSum, cBorder.green * cBorder.alpha * factHoriz1);
          IncF(bSum, cBorder.blue * cBorder.alpha * factHoriz1);
          IncF(aSum, cBorder.alpha * factHoriz1);
          IncF(Sum, factHoriz1);
        end;

        if (factHoriz2 <> 0) and (ixsrc2 < bmp.Width) then
        begin
          psrc := bmp.scanline[iysrc1p1] + ixsrc2;
          for yb2 := iysrc1p1 to iysrc2m1 do
          begin
            cBorder := psrc^;
            Inc(psrc, lineDelta);
            IncF(rSum, cBorder.red * cBorder.alpha * factHoriz2);
            IncF(gSum, cBorder.green * cBorder.alpha * factHoriz2);
            IncF(bSum, cBorder.blue * cBorder.alpha * factHoriz2);
            IncF(aSum, cBorder.alpha * factHoriz2);
            IncF(Sum, factHoriz2);
          end;
        end;
      end;

      if (ixsrc2m1 >= ixsrc1p1) and (iysrc2m1 >= iysrc1p1) then
      begin
        delta := lineDelta - (ixsrc2m1 - ixsrc1p1 + 1);
        psrc  := bmp.scanline[iysrc1p1] + ixsrc1p1;
        for yb2 := iysrc1p1 to iysrc2m1 do
        begin
          for xb2 := ixsrc1p1 to ixsrc2m1 do
          begin
            cFull := psrc^;
            IncF(rSum, cFull.red * cFull.alpha);
            IncF(gSum, cFull.green * cFull.alpha);
            IncF(bSum, cFull.blue * cFull.alpha);
            IncF(aSum, cFull.alpha);
            IncF(Sum, 1);
            Inc(psrc);
          end;
          Inc(psrc, delta);
        end;
      end;

      if aSum = 0 then
        pdest^ := BGRAPixelTransparent
      else
        pdest^ := BGRA(round(rSum / aSum), round(gSum / aSum),
          round(bSum / aSum), round(aSum / Sum));
      Inc(pdest);

    end;
  end;
end;

function CreateInterpolator(style: TSplineStyle): TWideKernelFilter;
begin
  case Style of
    ssInside, ssInsideWithEnds: result := TCubicKernel.Create;
    ssCrossing, ssCrossingWithEnds: result := TMitchellKernel.Create;
    ssOutside: result := TSplineKernel.Create(0.5);
    ssRoundOutside: result := TSplineKernel.Create(0.75);
    ssVertexToSide: result := TSplineKernel.Create(1);
    ssEasyBezier: raise Exception.Create('EasyBezier does not have an interpolator');
  else
    raise Exception.Create('Unknown spline style');
  end;
end;

function FineResample(bmp: TBGRACustomBitmap;
  NewWidth, NewHeight: integer; ResampleFilter: TResampleFilter): TBGRACustomBitmap;
var
  temp, newtemp: TBGRACustomBitmap;
  tempFilter1,tempFilter2: TWideKernelFilter;
begin
  if (NewWidth = bmp.Width) and (NewHeight = bmp.Height) then
  begin
    Result := bmp.Duplicate;
    exit;
  end;
  case ResampleFilter of
    rfBicubic: //blur
    begin
      tempFilter1 := TCubicKernel.Create;
      result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1);
      tempFilter1.Free;
      exit;
    end;
    rfMitchell:
    begin
      tempFilter1 := TMitchellKernel.Create;
      result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1);
      tempFilter1.Free;
      exit;
    end;
    rfSpline:
    begin
      tempFilter1 := TSplineKernel.Create;
      result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1);
      tempFilter1.Free;
      exit;
    end;
    rfLanczos2,rfLanczos3,rfLanczos4:
    begin
      tempFilter1 := TLanczosKernel.Create(ord(ResampleFilter)-ord(rfLanczos2)+2);
      result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1);
      tempFilter1.Free;
      exit;
    end;
    rfBestQuality:
    begin
      tempFilter1 := TSplineKernel.Create;
      tempFilter2 := TMitchellKernel.Create;
      result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter2,tempFilter1);
      tempFilter1.Free;
      tempFilter2.Free;
      exit;
    end;
  end;

  if (NewWidth >= bmp.Width) and (NewHeight >= bmp.Height) then
    Result := FineResampleLarger(bmp, NewWidth, NewHeight, ResampleFilter)
  else
  if (NewWidth <= bmp.Width) and (NewHeight <= bmp.Height) then
    Result := FineResampleSmaller(bmp, NewWidth, NewHeight)
  else
  begin
    temp := bmp;

    if NewWidth < bmp.Width then
    begin
      newtemp := FineResampleSmaller(temp, NewWidth, temp.Height);
      if (temp <> bmp) then
        temp.Free;
      temp := newtemp;
    end;

    if NewHeight < bmp.Height then
    begin
      newtemp := FineResampleSmaller(temp, temp.Width, NewHeight);
      if (temp <> bmp) then
        temp.Free;
      temp := newtemp;
    end;

    if NewWidth > bmp.Width then
    begin
      newtemp := FineResampleLarger(temp, NewWidth, temp.Height, ResampleFilter);
      if (temp <> bmp) then
        temp.Free;
      temp := newtemp;
    end;

    if NewHeight > bmp.Height then
    begin
      newtemp := FineResampleLarger(temp, temp.Width, NewHeight, ResampleFilter);
      if (temp <> bmp) then
        temp.Free;
      temp := newtemp;
    end;

    if temp <> bmp then
      Result := temp
    else
      Result := bmp.Duplicate;
  end;
end;

{------------------------ Wide kernel filtering adapted from Graphics32 ---------------------------}

function Constrain(const Value, Lo, Hi: Integer): Integer;
begin
  if Value < Lo then
  	Result := Lo
  else if Value > Hi then
  	Result := Hi
  else
  	Result := Value;
end;

type
  TPointRec = record
    Pos: Integer;
    Weight: Single;
  end;

  TCluster = array of TPointRec;
  TMappingTable = array of TCluster;

{$warnings off}
function BuildMappingTable(
  DstLo, DstHi: Integer;
  ClipLo, ClipHi: Integer;
  SrcLo, SrcHi: Integer;
  KernelSmaller,KernelLarger: TWideKernelFilter): TMappingTable;
Const FullEdge = false;
var
  SrcW, DstW, ClipW: Integer;
  FilterWidth: Single;
  Scale, OldScale: Single;
  Center: Single;
  Left, Right: Integer;
  I, J, K: Integer;
  Weight: Single;
begin
  SrcW := SrcHi - SrcLo;
  DstW := DstHi - DstLo;
  ClipW := ClipHi - ClipLo;
  if SrcW = 0 then
  begin
    Result := nil;
    Exit;
  end
  else if SrcW = 1 then
  begin
    SetLength(Result, ClipW);
    for I := 0 to ClipW - 1 do
    begin
      SetLength(Result[I], 1);
      Result[I][0].Pos := 0;
      Result[I][0].Weight := 1;
    end;
    Exit;
  end;
  SetLength(Result, ClipW);
  if ClipW = 0 then Exit;

  if FullEdge then Scale := DstW / SrcW
  else Scale := (DstW - 1) / (SrcW - 1);

  K := 0;

  if Scale = 0 then
  begin
    SetLength(Result[0], 1);
    Result[0][0].Pos := (SrcLo + SrcHi) div 2;
    Result[0][0].Weight := 1;
  end
  else if Scale < 1 then
  begin
    FilterWidth := KernelSmaller.KernelWidth;
    OldScale := Scale;
    Scale := 1 / Scale;
    FilterWidth := FilterWidth * Scale;
    for I := 0 to ClipW - 1 do
    begin
      if FullEdge then
        Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale
      else
        Center := SrcLo + (I - DstLo + ClipLo) * Scale;
      Left := Floor(Center - FilterWidth);
      Right := Ceil(Center + FilterWidth);
      for J := Left to Right do
      begin
        Weight := KernelSmaller.Interpolation((Center - J) * OldScale) * OldScale;
        if Weight <> 0 then
        begin
          K := Length(Result[I]);
          SetLength(Result[I], K + 1);
          Result[I][K].Pos := Constrain(J, SrcLo, SrcHi - 1);
          Result[I][K].Weight := Weight;
        end;
      end;
      if Length(Result[I]) = 0 then
      begin
        SetLength(Result[I], 1);
        Result[I][0].Pos := Floor(Center);
        Result[I][0].Weight := 1;
      end;
    end;
  end
  else // scale > 1
  begin
    FilterWidth := KernelLarger.KernelWidth;
    Scale := 1 / Scale;
    for I := 0 to ClipW - 1 do
    begin
      if FullEdge then
        Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale
      else
        Center := SrcLo + (I - DstLo + ClipLo) * Scale;
      Left := Floor(Center - FilterWidth);
      Right := Ceil(Center + FilterWidth);
      for J := Left to Right do
      begin
        Weight := KernelLarger.Interpolation(Center - j);
        if Weight <> 0 then
        begin
          K := Length(Result[I]);
          SetLength(Result[I], k + 1);
          Result[I][K].Pos := Constrain(j, SrcLo, SrcHi - 1);
          Result[I][K].Weight := Weight;
        end;
      end;
    end;
  end;
end;
{$warnings on}

function WideKernelResample(bmp: TBGRACustomBitmap;
  NewWidth, NewHeight: integer; ResampleFilterSmaller, ResampleFilterLarger: TWideKernelFilter): TBGRACustomBitmap;
type
  TSum = record
    sumR,sumG,sumB,sumA: single;
  end;

var
  mapX,mapY: TMappingTable;
  xb,yb,xc,yc,MapXLoPos,MapXHiPos: integer;
  clusterX,clusterY: TCluster;
  verticalSum: array of TSum;
  scanlinesSrc: array of PBGRAPixel;
  sum: TSum;
  c: TBGRAPixel;
  w,wa: single;
  pdest: PBGRAPixel;
begin
  result := bmp.NewBitmap(NewWidth,NewHeight);
  if (NewWidth=0) or (NewHeight=0) then exit;
  mapX := BuildMappingTable(0,NewWidth,0,NewWidth,0,bmp.Width,ResampleFilterSmaller,ResampleFilterLarger);
  mapY := BuildMappingTable(0,NewHeight,0,NewHeight,0,bmp.Height,ResampleFilterSmaller,ResampleFilterLarger);

  MapXLoPos := MapX[0][0].Pos;
  MapXHiPos := MapX[NewWidth - 1][High(MapX[NewWidth - 1])].Pos;

  setlength(verticalSum, MapXHiPos-MapXLoPos+1);

  setlength(scanlinesSrc, bmp.Height);
  for yb := 0 to bmp.Height-1 do
    scanlinesSrc[yb] := bmp.ScanLine[yb];

  for yb := 0 to NewHeight-1 do
  begin
    clusterY := mapY[yb];

    for xb := MapXLoPos to MapXHiPos do
    begin
      fillchar(verticalSum[xb - MapXLoPos],sizeof(verticalSum[xb - MapXLoPos]),0);
      for yc := 0 to high(clusterY) do
      with verticalSum[xb - MapXLoPos] do
      begin
        c := (scanlinesSrc[clusterY[yc].Pos]+xb)^;
        w := clusterY[yc].Weight;
        wa := w * c.alpha;
        IncF(sumA, wa);
        IncF(sumR, c.red * wa);
        IncF(sumG, c.green * wa);
        IncF(sumB, c.blue * wa);
      end;
    end;

    pdest := result.Scanline[yb];

    for xb := 0 to NewWidth-1 do
    begin
      clusterX := mapX[xb];
      {$hints off}
      fillchar(sum,sizeof(sum),0);
      {$hints on}
      for xc := 0 to high(clusterX) do
      begin
        w := clusterX[xc].Weight;
        with verticalSum[ClusterX[xc].Pos - MapXLoPos] do
        begin
          IncF(sum.sumA, sumA*w);
          IncF(sum.sumR, sumR*w);
          IncF(sum.sumG, sumG*w);
          IncF(sum.sumB, sumB*w);
        end;
      end;

      if sum.sumA < 0.5 then
        pdest^ := BGRAPixelTransparent else
      begin
        c.red := constrain(round(sum.sumR/sum.sumA),0,255);
        c.green := constrain(round(sum.sumG/sum.sumA),0,255);
        c.blue := constrain(round(sum.sumB/sum.sumA),0,255);
        if sum.sumA > 255 then
          c.alpha := 255 else
          c.alpha := round(sum.sumA);
        pdest^ := c;
      end;
      inc(pdest);
    end;
  end;

end;

end.

