unit resize;
interface
uses VenomGFX;

Function SmoothResize(Src:VirtualWindow;breite,hoehe:longint):VirtualWindow;


implementation
const
  StretchOffs = False;

Type
  PFColor =^TFColor;
  TFColor = packed record
    b,g,r: Byte;
  end;

  TLine8    = array[Word]of Byte;     PLine8    =^TLine8;

  PLut16 = ^TLut16;
  TLut16 = array [0..65535] of TFColor;

  PBackLut16 = ^TBackLut16;
  TBackLut16 = record
    ri, gi, bi: array [0..65535] of Word;
  end;

Var Lut16 : PLut16;
    BackLut16 : TBackLut16;


function GenLut16(Src : VirtualWindow; Lut8 : PLine8): PLut16;
Var n : Integer;
    c : TFColor;
    pc : PFColor;
    rs : PLut16;
begin
If (Lut16 = nil) then GetMem(Lut16, SizeOf(TLut16));
Rs := Lut16;
pc := @Rs[0];
For n:=0 to 65535 do begin
  c.b := n shl Src.BShr;
  c.g := n shr Src.GShl shl Src.GShr;
  c.r := n shr Src.RShl shl Src.RShr;
  If (Lut8 <> nil) then begin
    pc.b := Lut8[c.b]; pc.g := Lut8[c.g]; pc.r := Lut8[c.r];
  end else
    pc^ := c;
  Inc(pc);
end;
end;

function GenBackLut16(Dst : TFastDIB): PBackLut16;
{NECHAT}
Var n : Integer;
begin
Result := @BackLut16;
For n:=0 to 255 do With Result^ do begin
  ri[n] := n shr Dst.RShr shl Dst.RShl;
  gi[n] := n shr Dst.GShr shl Dst.GShl;
  bi[n] := n shr Dst.BShr;
end;
end;


Function SmoothResize(Src:VirtualWindow;breite,hoehe:longint):VirtualWindow;
Const
  FilterRads : array [ TResizeFilter ] of Double =
    ( 0, 0.5, 1, 1, 1, 1, 1.5, 2, 2, 2, 2, 2, 3, 3, 3, 3 );
  ForceOneCont = True;
    // force sum of all contributors to be 1 (65536)
    // to use 'shr' instead of 'div'
//  ForceOneCont = False;

  MaxVal = $10000 * $FF;

Type

  TContributor = record
    pos : Integer;
    Case Integer of
      0 : (w : Integer);
      1 : (InvFW : real);
  end;
  PContributor = ^TContributor;

Var
  Lut16 : PLut16;
  BLut16 : PBackLut16;

  function SinC(x: Double): Double;
  begin
    if x=0 then Result:=1
    else begin
      x:=Pi*x;
      SinC:=Sin(x)/x;
    end;
  end;

  function f(x, Rad: Double): Double;
  begin
  if x<0 then x:=-x;
  if x<Rad then f:=SinC(x)*SinC(x/Rad) else f:=0;
  end;

  function Ceil(x: Double): Integer;
  begin
    Result:=Trunc(x);
    if Frac(x)>0 then Inc(Result);
  end;

  function PreCalcEx(Var Cont : PContributor; Count, MaxCnt : Integer; s, Rad : real): Integer;
  Var n, x1, x2, t, i, x, c : Integer;
      r, m, v, tv, sm : real;
      pw : PContributor;
      arr : array of real;
  begin
  If s < 1 then sm := s else sm := 1;
  r := Rad / sm;
  n := 2 * Trunc(r) + 1;
  SetLength(arr, n);
  ReAllocMem(Cont, Count * (n + 1) * SizeOf(TContributor));
  pw := Cont;
  for x := 0 to Count-1 do begin
//    If x > Count div 2 then asm int 3; end;
    m := x/s - 0.5 * (1 - 1 / s);
    if n > 1 then x1 := Ceil(m - r) else x1 := Round(m);
    x2 := x1 + n - 1;
    t := 0; tv := 0; c := 0;
    For i := x1 to x2 do
      If (i >= 0) and (i < MaxCnt) then begin
        v := f( (m - i) * sm, Rad, Filter) * sm;
        arr[i - x1] := v; tv := tv + v;
        Inc(c);
      end;

    If (c <> 0) and (ForceOneCont) then
      If (tv <> 1) then begin
        v := (1 - tv) / c; tv := 0;
        For i := x1 to x2 do If (i >= 0) and (i < MaxCnt) then begin
          arr[i - x1] := arr[i - x1] + v; tv := tv + arr[i - x1];
        end;
      end;

    t := 0;
    For i := x1 to x2 do begin
      If (i >= 0) and (i < MaxCnt) then begin
        pw.pos := i; pw.w := Round(arr[i - x1] * $10000);
        Inc(t, pw.w);
      end else
        pw.w := 0;
      Inc(pw);
    end;

    If t > 0 then pw.w := t else pw.w := 1;
{
    If tv > 0 then begin
      pw.w := Round(tv * $10000);
//      pw.InvFW := 1 / (tv * $10000);
    end else begin
      pw.w := 1;
//      pw.InvFW := 1;
    end;
}
    Inc(pw);
  end;
  Result := n;
  end;


  procedure DoFilter(Src, Dst : VirtualWindow; FilterLen : Integer;
                     Cont : PContributor; Horisontal : Boolean);
  Var
    i, x, y, zr, zg, zb, za, w, sx, sy, sBytesPP, dBytesPP : Integer;
    v : real;
    pc: PFColor;
    c: PFColorA;
    pw, ph : PContributor;
  begin
  ph := Cont;
  sBytesPP := Src.Bpp div 8;
  dBytesPP := Dst.Bpp div 8;

  For y:=0 to Dst.Hoeheminus1 do
      begin
      pw := Cont;
      pc := Dst.Scanlines[y];
      For x := 0 to Dst.Breiteminus1 do
          begin
          zr := 0; zg := 0; zb := 0;
          If Horisontal then
             For i := 0 to FilterLen - 1 do
                 begin
                 w := pw.w;
                 If w <> 0 then
                    begin
                    c := @Lut16[ Src.Pixels16[y, pw.pos] ];
                    Inc(zr, w * c.r); Inc(zg, w * c.g); Inc(zb, w * c.b);
                    end;
                 Inc(pw);
                 end;

             else begin
             pw := ph;
             For i := 0 to FilterLen - 1 do
                 begin
                 w := pw.w;
                 If w <> 0 then
                    begin
                    c := @Lut16[ Src.Pixels16[pw.pos, x] ];
                    Inc(zr, w * c.r); Inc(zg, w * c.g); Inc(zb, w * c.b);
                    end;
                 Inc(pw);
                 end;


          end;
      end;

  w := pw.w;
  If ForceOneCont then
     begin
     Inc(zr, w shr 1); Inc(zg, w shr 1); Inc(zb, w shr 1);
          // really needed?
     If zr < 0 then zr := 0 else If zr > MaxVal then zr := MaxVal;
     If zg < 0 then zg := 0 else If zg > MaxVal then zg := MaxVal;
     If zb < 0 then zb := 0 else If zb > MaxVal then zb := MaxVal;
//        zb := zb shr 16; zg := zg shr 16; zr := zr shr 16;

     With BLut16^ do
          PWord(pc)^ := ri[zr shr 16] or gi[zg shr 16] or bi[zb shr 16];

     end;
     end
     else begin
     zr := (zr + (w shr 1)) div w;
     zg := (zg + (w shr 1)) div w;
     zb := (zb + (w shr 1)) div w;

     If zr < 0 then zr := 0 else If zr > $FF then zr := $FF;
     If zg < 0 then zg := 0 else If zg > $FF then zg := $FF;
     If zb < 0 then zb := 0 else If zb > $FF then zb := $FF;



     With BLut16^ do PWord(pc)^ := ri[zr] or gi[zg] or bi[zb];
     end;

      Inc(pw);
      Inc(PByte(pc), dBytesPP);
    end;
    Inc(ph, FilterLen + 1);
  end;
  end;




var
  Bmp : TFastDIB;
  sx, sy : real;
  w : PContributor;
  c, bpp : Integer;
  All24Bpp : Boolean;
  dst,bmp:VirtualWindow;

begin
Lut16 := GenLut16(Src,nil);
BLut16 := GenBackLut16(Dst);

All24Bpp := false;

Init_VW(dst,breite,hoehe,false);
sx := Dst.Width / Src.Width;
sy := Dst.Height / Src.Height;
w := nil;
{!! IF SRC.bpp = 16 then bpp:=24 !!}

c := PreCalcEx(w, Dst.Width, Src.Width, sx, FilterRads[Filter]);
DoFilter(Src, dst, c, w, True);

FreeMem(w);
end;


initialization
finalization
If (Lut16 <> nil) then FreeMem(Lut16);

end.
