unit Unit1;

{$mode objfpc}{$H+}

interface

uses

Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, Math;

type

TResampleFilter = function(Value: Single): Single;

{ TForm1 }

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

public

end;

var

Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

function Sinc(Value: Single): Single;

begin

if Value <> 0.0 then begin

Value := Value * Pi;

Result := Sin(Value) / Value;

end

else Result := 1.0;

end;

function Lanczos3Filter(Value: Single): Single;

begin

if Value < 0.0 then Value := -Value;

if Value < 3.0 then

Result := SinC(Value) * SinC(Value / 3.0)

else

Result := 0.0;

end;

function Limit(Min, Max, Val: Integer): Integer;

begin

if Val < Min then Exit(Min);

if Val > Max then Exit(Max);

Exit(Val);

end;

function Clip(Val: Extended): Byte;

begin

if Val > 255 then Exit(255);

if Val < 0 then Exit(0);

Result := Round(Val);

end;

function Resample(Bmp: TBitmap; AWidth, AHeight: Integer; Filter: TResampleFilter): TBitmap;

var x,y: Integer;

P: TColor;

PP: array[0..3] of Byte absolute P;

i,j: Integer;

ratioX,ratioY: Extended;

SumR, SumG, SumB: Extended;

xx,yy: Extended;

xxx,yyy: Integer;

xxxx,yyyy: Integer;

Tmp: Single;

RadX, RadY: Single;

begin

Result := TBitmap.Create;

Result.PixelFormat := pf32bit;

Result.SetSize(AWidth, AHeight);

ratioX := AWidth/ Bmp.Width;

ratioY := AHeight/ Bmp.Height;

for y:=0 to AHeight-1 do begin

for x:=0 to AWidth-1 do begin

xx := x / ratioX;

yy := y / ratioY;

xxx := Floor(xx);

yyy := Floor(yy);

SumR := 0;

SumG := 0;

SumB := 0;

for j:=-3 to 3 do

for i:=-3 to 3 do begin

RadX := xx - (xxx + i);

RadY := yy - (yyy + j);

Tmp := Filter(RadX) * Filter(RadY);

xxxx := Limit(0, Bmp.Width-1, xxx+i);

yyyy := Limit(0, Bmp.Height-1, yyy+j);

P := Bmp.Canvas.Pixels[xxxx, yyyy];

SumR := SumR + PP[0]*Tmp ;

SumG := SumG + PP[1]*Tmp ;

SumB := SumB + PP[2]*Tmp ;

end;

Result.Canvas.Pixels[x,y] := RGBToColor( Clip(SumR), Clip(SumG), Clip(SumB) );

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var InB, OutB: TBitmap;

begin

InB := TBitmap.Create;

InB.LoadFromFile('1.bmp'); //should be 32bpp

OutB := Resample(InB, 50, 50, @Lanczos3Filter);

OutB.SaveToFile('2.bmp');

OutB.Free;

InB.Free;

end;

end.