{

   This program is free software; you can redistribute it and/or
  modify it under the terms of the GNU General Public License
  as published by the Free Software Foundation; either
  version 2 of the License, or (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
unit im_Basic;

{*********************************************}
{  This unit is a part of ImageE              }
{  Copyright © 2003-2004 R.Geurts             }
{  See Readme.txt for licence information     }
{*********************************************}

interface

uses
  sysutils, classes, graphics, GR32, GR32_Filters,gr32_transforms,math,
    GR32_Blend;

type
  TColorBGRA = record // color splitting type
    b: Byte;
    g: Byte;
    r: Byte;
    a: Byte;
  end;
  PColorBGRA = ^TColorBGRA;

procedure FillLut(var Lut: TLUT8; x1, y1, x2, y2: Byte);
procedure ApplyLUTRGB(Dst, Src: TBitmap32; const LUT_R, LUT_G, LUT_B: TLUT8);
procedure BuildLUT(var LUT: TLUT8);
procedure brightness(src:tbitmap32; brightness:real);
procedure contrast(src:tbitmap32; contrast:real);
procedure gamma(src:tbitmap32; gamma:real);
procedure StretchIntensity(src: TBitmap32; const LowVal, HighVal: Integer);
procedure imagerotate(src:TBitmap32; alpha:extended; backcolor:tcolor);
procedure imagerotate2(Src: TBitmap32; const Angle: Single;const FillColor: tcolor);
procedure ImageFlipHoriz(src: TBitmap32);
procedure ImageFlipVert(src: TBitmap32);
function  CountColors32(const bm32: TBitmap32): Integer;
function  ColorAddKeepAlpha(C1, C2: TColor32): TColor32;
procedure Bitmap32FloydSteinbergDither(bm32: TBitmap32; shift: Integer);
procedure Bitmap32FloydSteinbergDitherBW(bm32: TBitmap32);
procedure AutoContrast(Bitmap: TBitmap32);

implementation

procedure Contrast(src: TBitmap32;contrast:real);
//scale from -1..1
var
 F: Single;
 I, V: Integer;
 LUT: TLUT8;
 dst:tbitmap32;
 w,h:integer;
begin
  dst:=tbitmap32.create;
  w:=src.width;
  h:=src.height;
  dst.width:=w;
  dst.height:=h;
 for I := 0 to 255 do
 begin
 F := I / 255; // Scale to 0..1 range

// F := Power(F, GAMMA); // Gamma
 F := (F - 0.5) * (1 + CONTRAST) + 0.5; // Contrast
// F := (F-0.5) * (3 + CONTRAST*3) + 0.5; // Contrast
// F := F + BRIGHTNESS; // Brightness

 V := Round(F * 255); // Scale to 0..255 range

 if V < 0 then V := 0
 else if V > 255 then V := 255; // Clip to 0..255 range

 LUT[I] := V;
 end;
 ApplyLut(dst, src, LUT);
 src.assign(dst);
 src.changed;
 dst.free;
end;

procedure Brightness(src: TBitmap32; brightness:real);
//scale from -1..1
var
 F: Single;
 I, V: Integer;
 LUT: TLUT8;
  dst:tbitmap32;
 w,h:integer;
 begin
  dst:=tbitmap32.create;
  w:=src.width;
  h:=src.height;
  dst.width:=w;
  dst.height:=h;
 for I := 0 to 255 do
 begin
 F := I / 255; // Scale to 0..1 range

// F := Power(F, GAMMA); // Gamma
// F := (F - 0.5) * (1 + CONTRAST) + 0.5; // Contrast
 F := F + BRIGHTNESS; // Brightness

 V := Round(F * 255); // Scale to 0..255 range

 if V < 0 then V := 0
 else if V > 255 then V := 255; // Clip to 0..255 range

 LUT[I] := V;
 end;
 ApplyLut(dst, src, LUT);
   src.assign(dst);
   src.changed;
 dst.free;
end;

procedure Gamma(Src: TBitmap32; gamma:real);
//scale from -1..1
var
 F: Single;
 I, V: Integer;
 LUT: TLUT8;
  dst:tbitmap32;
 w,h:integer;
 begin
  dst:=tbitmap32.create;
  w:=src.width;
  h:=src.height;
  dst.width:=w;
  dst.height:=h;
 for I := 0 to 255 do
 begin
 Gamma:=ensurerange(gamma,0,5);
 F:= EnsureRange(I/255, 0,1); //0..1 range
 F := Power(F, GAMMA); // Gamma
// F := (F - 0.5) * (1 + CONTRAST) + 0.5; // Contrast
// F := F + BRIGHTNESS; // Brightness

 V := Round(F * 255); // Scale to 0..255 range

 if V < 0 then V := 0
 else if V > 255 then V := 255; // Clip to 0..255 range

 LUT[I] := V;
 end;
 ApplyLut(dst, src, LUT);
   src.assign(dst);
   src.changed;
   dst.free;
end;

procedure StretchIntensity(src: TBitmap32; const LowVal, HighVal: Integer);
 var
 i: Integer;
 LUT: TLUT8;
  dst:tbitmap32;
 w,h:integer;
 begin
  dst:=tbitmap32.create;
  w:=src.width;
  h:=src.height;
  dst.width:=w;
  dst.height:=h;
 // validation
 if LowVal + 1 > HighVal - 1 then Exit;

 // set values 0 to LowVal to black...
 for i := 0 to LowVal do
 LUT[i] := 0;

 // 'stretch' 0 - 255 values between LowVal and HighVal
 for i := LowVal + 1 to HighVal - 1 do
 LUT[i] := (i - LowVal) * 255 div (HighVal - LowVal);

 // set values HighVal to 255 to white...
 for i := HighVal to 255 do
 LUT[i] := 255;

 ApplyLUT(dst, src, LUT);
   src.assign(dst);
   src.changed;
   dst.free;
end;

procedure BuildLUT(var LUT: TLUT8);
 var
 L, M, H, Lo, Hi: Single;
 I: Integer;
 in_lo,in_mid,in_hi,out_lo,out_hi:integer;  //tobemodified <-

 function F(X: Single): Integer;
 var
 R: Single;
 begin
 in_lo:=0;
 in_mid:=0;
 in_hi:=0;

 if X < L then R := 0
 else if X < M then R := (X - L) / 2 / (M - L)
 else if X < H then R := (X - M) / 2 / (H - M) + 0.5
 else R := 1;
 R := Lo + R * (Hi - Lo);
 Result := Round(R);
 if Result < 0 then Result := 0
 else if Result > 255 then Result := 255;
 end;

 begin
 //init
 Out_Lo:=0;
 Out_Hi:=0;
 //rest
 L := IN_LO / 255;
 M := IN_MID / 255;
 H := IN_HI / 255;
 Lo := OUT_LO;
 Hi := OUT_HI;
 for I := 0 to 255 do LUT[I] := F(I / 255);
 end;

procedure FillLut(var Lut: TLUT8; x1, y1, x2, y2: Byte);
var
  x, n, i, ii: Integer;
begin
  n := x2 - x1;
  if n <> 0 then
  begin
    i := y1 shl 16;
    ii := ((y2 - y1 + 1) shl 16) div n;
    for x := x1 to x2 - 1 do
    begin
      Lut[x] := i shr 16;
        // this may create overflow of byte when i shr 16 evaluates to > 255...
      Inc(i, ii);
    end;
    // .. so we are going to force set the last cell:
    Lut[x2] := y2;
  end;
end;

procedure imagerotate2(Src: TBitmap32; const Angle: Single;const FillColor: tcolor);
var
  SrcR: Integer;
  SrcB: Integer;
  Trans: TAffineTransformation;
  Rad, Sx, Sy: Single;
  Dst:tbitmap32;
begin
Dst:=tbitmap32.Create;
try
  if (Angle = 0) then
  else if (Angle = 90) then Src.Rotate90()
  else if (Angle = 180) or (Angle = -180) then Src.Rotate180()
  else if (Angle = -90) or (Angle = 270) then Src.Rotate270()
  else begin
   Rad := - Angle * Pi / 180;
   with Src do begin
   SrcR := Width - 1;
   SrcB := Height - 1;
   end;
   // width, height of rotated image (without scaling)
   Sx := Abs(SrcR * Cos(Rad)) + Abs(SrcB * Sin(Rad));
   Sy := Abs(SrcR * Sin(Rad)) + Abs(SrcB * Cos(Rad));
   with Dst do begin
    SetSize(Round(Sx), Round(Sy));
    Clear(color32(FillColor));
   end;
   Trans := TAffineTransformation.Create;
   try
     Trans.Clear;
     with Src do begin
      SetBorderTransparent(Src, Rect(0, 0, Width - 1, Height - 1));
      Trans.SrcRect := FloatRect(0, 0, Width, Height);
     end;
     // rotate around center
     with Trans do begin
      Translate(-SrcR / 2, -SrcB / 2);
      Rotate(0, 0, - Angle);
      // move the origin back
      Translate(Sx / 2, Sy / 2);
     end;
     // perform transform
     src.DrawMode:=dmblend;
     Transform(Dst, Src, Trans);
     src.DrawMode:=dmOpaque;
    finally
     Trans.Free;
    end;
    src.Assign(Dst);
  end;
  src.Changed;
finally
  Dst.Free;
end;
end;

procedure imagerotate(src:TBitmap32; alpha:extended; backcolor:tcolor);
var
  tmp:tbitmap32;
  SrcR: Integer;
  SrcB: Integer;
  T: TAffineTransformation;
//  Sx, Sy: Single;
  w,h:integer;
begin
  alpha:=alpha*(-1); //½Ã°è¹æÇâÀ¸·Î º¯°æ
  w:=src.width;
  h:=src.height;
  tmp:=TBitmap32.Create;
  tmp.Assign(src);

  SrcR := src.Width - 1;
  SrcB := src.Height - 1;
  T := TAffineTransformation.Create;
  T.SrcRect := FloatRect(0, 0, SrcR + 1, SrcB + 1);
  try
    T.Clear;
    // move the origin to a center for scaling and rotation
    T.Translate(-SrcR / 2, -SrcB / 2);
    T.Rotate(0, 0, Alpha);
//    Alpha := Alpha * 3.14159265358979 / 180;

    // get the width and height of rotated image (without scaling)
//    Sx := Abs(SrcR * Cos(Alpha)) + Abs(SrcB * Sin(Alpha));
//    Sy := Abs(SrcR * Sin(Alpha)) + Abs(SrcB * Cos(Alpha));

    // calculate a new scale so that the image fits in original boundaries

    // move the origin back
    T.Translate(SrcR / 2, SrcB / 2);

    // transform the bitmap
    tmp.BeginUpdate;
    tmp.Clear(Color32(backcolor));
    src.DrawMode:=dmblend;
    Transform(tmp, src, T);
    src.DrawMode:=dmOpaque;
    tmp.EndUpdate;
  finally
    T.Free;
  end;
  src.Assign(tmp);
  tmp.free;
end;

procedure ImageFlipHoriz(src: TBitmap32);
var
  i, j: Integer;
  P1, P2: PColor32;
  tmp: TColor32;
  W,h, W2: Integer;
  dst:tbitmap32;
begin
  dst:=tbitmap32.create;
  w:=src.width;
  h:=src.height;
  dst.width:=w;
  dst.height:=h;
//  if (Dst = nil) or (Dst = Self) then
  begin
    { In-place flipping }
    P1 := @src.Bits[0];
    P2 := P1;
    Inc(P2, w - 1);
    W2 := w shr 1;
    for J := 0 to h - 1 do
    begin
      for I := 0 to W2 - 1 do
      begin
        tmp := P1^;
        P1^ := P2^;
        P2^ := tmp;
        Inc(P1);
        Dec(P2);
      end;
      Inc(P1, W - W2);
      Inc(P2, W + W2);
    end;
    src.Changed;
end;
end;


procedure imageflipvert(src: Tbitmap32);
var
   dest:tbitmap32;
   w,h,x,y:integer;
   pd,ps:Pcolor32array;
begin
  w:=src.width;
  h:=src.height;
  dest:=tbitmap32.create;
  dest.width:=w;
  dest.height:=h;
  for y:=0 to h-1 do begin
   pd:=dest.scanline[y];
   ps:=src.scanline[h-1-y];
   for x:=0 to w-1 do begin
     pd[x]:=ps[x];
   end;
   end;
   src.assign(dest);
   src.changed;
  dest.free;
end;

procedure AutoContrast(Bitmap: TBitmap32);
var
  hr, hg, hb, lr, lg, lb: Byte;
  r, g, b: TLUT8;
  pc: PColorBGRA;
  x, y, w, h: Integer;
begin
  hr := 0;
  hg := 0;
  hb := 0;
  lr := 255;
  lg := 255;
  lb := 255;
  pc := PColorBGRA(@Bitmap.Bits[0]);
  w := Bitmap.Width;
  h := Bitmap.Height;

  for y := 0 to h - 1 do
  begin
    for x := 0 to w - 1 do
    begin
      if pc.b > hb then
        hb := pc.b;
      if pc.b < lb then
        lb := pc.b;
      if pc.g > hg then
        hg := pc.g;
      if pc.g < lg then
        lg := pc.g;
      if pc.r > hr then
        hr := pc.r;
      if pc.r < lr then
        lr := pc.r;
      Inc(pc);
    end;
  end;
  if ((lr or lg or lb) <> 0) or ((hr and hg and hb) <> 255) then
  begin
    FillLut(r, lr, 0, hr, 255);
    FillLut(g, lg, 0, hg, 255);
    FillLut(b, lb, 0, hb, 255);
    ApplyLutRGB(Bitmap, Bitmap, r, g, b);
  end;
end;

procedure ApplyLUTRGB(Dst, Src: TBitmap32; const LUT_R, LUT_G, LUT_B: TLUT8);
var
  I: Integer;
  D, S: PColor32;
  r, g, b: TColor32;
  C: TColor32;
begin
 // CheckParams(Src, Dst);
  D := @Dst.Bits[0];
  S := @Src.Bits[0];

  for I := 0 to Src.Width * Src.Height - 1 do
  begin
    C := S^;
    r := C and $00FF0000;
    g := C and $0000FF00;
    r := r shr 16;
    b := C and $000000FF;
    g := g shr 8;
    r := LUT_R[r];
    g := LUT_G[g];
    b := LUT_B[b];
    D^ := $FF000000 or r shl 16 or g shl 8 or b;
    Inc(S);
    Inc(D);
  end;
  Dst.Changed;
end;

function CountColors32(const bm32: TBitmap32): Integer;
var
  cols: array[0..65535] of array of Byte;
  i, j, k: Integer;
  row: PColor32Array;
  pix, wl: Cardinal;
begin
  result := 0;
  wl := bm32.Width - 1;
  for j := 0 to bm32.Height - 1 do begin
    row := bm32.Scanline[j];
    for i := 0 to wl do begin
      pix := row[i] and $FFFFFF;
      k := pix shr 8;
      if cols[k] = nil then SetLength(cols[k], 256);
      cols[k][pix and $FF] := 1;
    end;
  end;
  for j := 0 to 65535 do
      if cols[j] <> nil then begin
        for k := 0 to 255 do if cols[j][k] > 0 then Inc(result);
        SetLength(cols[j], 0);
      end;
end;


function ColorAddKeepAlpha(C1, C2: TColor32): TColor32;
var
  r, g, b: Integer;
begin
  r := C1 and $00FF00FF + C2 and $00FF00FF;
  g := C1 and $0000FF00 + C2 and $0000FF00;
  b := r and $000001FF;
  r := r and $01FF0000;
  if r > $FF0000 then r := $FF0000;
  if g > $00FF00 then g := $00FF00;
  if b > $0000FF then b := $0000FF;
  result := Integer(C1 and $FF000000) or r or g or b;
end;

procedure Bitmap32FloydSteinbergDither(bm32: TBitmap32; shift: Integer);
var
  j, jl, k, kl, ki, ks, ke, kn: Integer;
  rowIn, rowNx: PColor32Array;
  delta, m, n: Cardinal;
  r, g, b: Cardinal;
  lutby1, lutby3, lutby5, lutby7: TLUT8;
begin
  m := $FF shr shift shl shift;
  n := not m and $FF;
  m := $FF000000 or m shl 16 or m shl 8 or m;
  for j := 0 to 255 do begin
    lutby1[j] := j shr 4;
    lutby3[j] := (j * 3) shr 4;
    lutby5[j] := (j * 5) shr 4;
    lutby7[j] := (j * 7) shr 4;
  end;
  kl := bm32.Width - 1;
  jl := bm32.Height - 1;
  ki := 1;
  rowNx := bm32.Scanline[0];
  for j := 0 to jl do begin
    rowIn := rowNx;
    if j < jl then rowNx := bm32.Scanline[j + 1];
    ki := -ki;
    if ki = -1 then begin // right to left -> odd row
      ks := kl;
      ke := 0;
    end
    else begin // left to right -> even row
      ks := 0;
      ke := kl;
    end;
    kn := ks;
    repeat
      k := kn;
      kn := k + ki;
      delta := rowIn[k];
      r := delta shr 16 and n;
      g := delta shr 8 and n;
      b := delta and n;
      rowIn[k] := TColor32(rowIn[k] and m);
      if k <> ke then begin
        rowIn[kn] := ColorAddKeepAlpha(rowIn[kn], lutby7[r] shl 16 or lutby7[g] shl 8 or lutby7[b]);
        if j < jl then rowNx[kn] := ColorAddKeepAlpha(rowNx[kn], lutby1[r] shl 16 or lutby1[g] shl 8 or lutby1[b]);
      end;
      if j < jl then begin
        rowNx[k] := ColorAddKeepAlpha(rowNx[k], lutby5[r] shl 16 or lutby5[g] shl 8 or lutby5[b]);
        if k <> ks then rowNx[k - ki] := ColorAddKeepAlpha(rowNx[k - ki], lutby3[r] shl 16 or lutby3[g] shl 8 or lutby3[b]);
      end;
    until k = ke;
  end;
end;

function ByteConstrain(i: Integer): Integer;
asm
//  MOV  EAX,i
  CMP  EAX,0    // EAX = i
  JL   @MOV00
  CMP  EAX,$FF
  JG   @MOVFF
  RET
@MOV00:
  MOV  EAX,0
  RET
@MOVFF:
  MOV  EAX,$FF
end;

procedure ColorCorrectKeepAlpha(var c: TColor32; r_d, g_d, b_d: Integer);
var
  r, g, b: Integer;
begin
  r := (c shr 16) and $FF;
  g := (c shr 8) and $FF;
  b := c and $FF;
  c := (c and $FF000000) or
    (Byte(ByteConstrain(r + r_d)) shl 16) or
    (Byte(ByteConstrain(g + g_d)) shl 8) or
    Byte(ByteConstrain(b + b_d));
end;

type
  TLUT8S = array[-255..255] of Shortint;

// Valentim Batista, March 2003.

procedure Bitmap32FloydSteinbergDitherBW(bm32: TBitmap32);
var
  j, jl, k, kl, ki, ks, ke, kn: Integer;
  rowIn, rowNx: PColor32Array;
  pixel: Cardinal;
  intens, re, ge, be: Integer;
  lutsby1, lutsby3, lutsby5, lutsby7: TLUT8S;
begin
  for j := -255 to 255 do begin
    lutsby1[j] := Round(j / 8);
    lutsby3[j] := Round(j * 3 / 8);
    lutsby5[j] := Round(j * 5 / 8);
    lutsby7[j] := Round(j * 7 / 8);
  end;
  kl := bm32.Width - 1;
  jl := bm32.Height - 1;
  ki := 1;
  rowNx := bm32.Scanline[0];
  for j := 0 to jl do begin
    rowIn := rowNx;
    if j < jl then rowNx := bm32.Scanline[j + 1];
    ki := -ki;
    if ki = -1 then begin // right to left -> odd row
      ks := kl;
      ke := 0;
    end
    else begin // left to right -> even row
      ks := 0;
      ke := kl;
    end;
    kn := ks;
    repeat
      k := kn;
      kn := k + ki;

      pixel := rowIn[k];
      intens := Intensity(pixel);
      if intens < 128 then intens := 0
      else intens := 255;
      re := Integer((pixel shr 16) and $FF) - intens;
      ge := Integer((pixel shr 8) and $FF) - intens;
      be := Integer(pixel and $FF) - intens;

      rowIn[k] := Gray32(intens, pixel shr 24);
      if k <> ke then begin
        ColorCorrectKeepAlpha(rowIn[kn], lutsby7[re], lutsby7[ge], lutsby7[be]);
        if j < jl then ColorCorrectKeepAlpha(rowNx[kn], lutsby1[re], lutsby1[ge], lutsby1[be]);
      end;
      if j < jl then begin
        ColorCorrectKeepAlpha(rowNx[k], lutsby5[re], lutsby5[ge], lutsby5[be]);
        if k <> ks then ColorCorrectKeepAlpha(rowNx[k - ki], lutsby3[re], lutsby3[ge], lutsby3[be]);
      end;
    until k = ke;
  end;
end;

///--------------------------------------------------------



end.
