//Some procs from ImageTransform unit
//Copyright(c) Rivarez(rivarez@list.ru)
unit RVColorTransform;

interface

uses Windows, Graphics;

procedure SaturationBitmap(Const  Bmp :TBitmap; Const  Amount :Integer);
procedure SaturationColors(Var  Colors :Array of TColor; Const  Amount :Integer);
procedure ColorizeBitmapAlter(Const  Bmp :TBitmap; Const  CColor :TColor);
procedure ColorizeColorsAlter(Var  Colors :Array of TColor; Const  CColor :TColor);

implementation

Type  TRGBArray   = Array[0..32768] of TRGBTriple;
      TGraysArray = Array[0..767]   of Integer;
      TAlphaArray = Array[0..255]   of Word;
      TTableArray = Array[0..255]   of TRGBTriple;

Function IntToByte(Const i :Integer) :Byte;
Begin
  If i>255 then     Result:=255
  Else  If i<0 then Result:=0
  Else              Result:=i;
end;

Procedure PrepareGraysAndAlpha(Var  Grays :TGraysArray; Var  Alpha :TAlphaArray; Const  Amount :Integer);
Var  Gray, x, i :Integer;
Begin
  x:=0;
  For i:=0 to 255 do
    begin
      Alpha[i]:=(i*Amount) shr 8;
      Gray:=i-Alpha[i];
      Grays[x]:=Gray; Inc(x);
      Grays[x]:=Gray; Inc(x);
      Grays[x]:=Gray; Inc(x);
    end;
end;

//Note: use only pf24bit PixelFormat bitmaps
Procedure SaturationBitmap(Const  Bmp :TBitmap; Const  Amount :Integer);
Var
  pY :^TRGBArray;
  Gray, x, y :Integer;
  Grays :TGraysArray;
  Alpha :TAlphaArray;
Begin
  PrepareGraysAndAlpha(Grays,Alpha,Amount);
  With Bmp do
    For y:=0 to Height-1 do
      begin
        pY:=ScanLine[y];
        For x:=0 to Width-1 do
          With pY^[x] do
            begin
              Gray:=Grays[rgbtRed+rgbtGreen+rgbtBlue];
              rgbtRed:=IntToByte(Gray+Alpha[rgbtRed]);
              rgbtGreen:=IntToByte(Gray+Alpha[rgbtGreen]);
              rgbtBlue:=IntToByte(Gray+Alpha[rgbtBlue]);
            end;
      end;
end;

Procedure SaturationColors(Var  Colors :Array of TColor; Const  Amount :Integer);
Var
  Gray, i :Integer;
  r, g, b :TColor;
  Grays :TGraysArray;
  Alpha :TAlphaArray;
Begin
  PrepareGraysAndAlpha(Grays,Alpha,Amount);
  For i:=0 to High(Colors) do
    begin
      r:=Lo(Colors[i]); g:=Lo(Colors[i] shr 8 ); b:=Lo(Colors[i] shr 16);
      Gray:=Grays[r+g+b];
      r:=IntToByte(Gray+Alpha[r]);
      g:=IntToByte(Gray+Alpha[g]);
      b:=IntToByte(Gray+Alpha[b]);
      Colors[i]:=r or (g shl 8) or (b shl 16);
    end;
end;

Procedure PrepareTable(Var  Table :TTableArray; CColor :TColor);
Var  i, j :Integer;
     r, g, b :TColor;
Begin
  CColor:=ColorToRGB(CColor);
  r:=Lo(CColor); g:=Lo(CColor shr 8); b:=Lo(CColor shr 16);
  r:=r shr 2; g:=g shr 2; b:=b shr 2;
  For i:=0 to 255 do  With Table[i] do
    begin
      j:=i-(i shr 3);
      rgbtRed:=IntToByte(j+r);
      rgbtGreen:=IntToByte(j+g);
      rgbtBlue:=IntToByte(j+b);
    end;
end;

//Alternate way to Colorize - lighter colors in CColor param gives the better result than standard Colorize method
//but processing with darker colors in CColor gives the lighter result. Therefore processing with some colors need
//the saturation increase.
//Notes:
//    - to take a "clean" colorize effect(like in graphics editors) with a coloured bitmap, you must set the bitmap
//      Saturation to null before(to convert a colour bitmap to greyscale);
//    - use only pf24bit PixelFormat bitmaps
Procedure ColorizeBitmapAlter(Const  Bmp :TBitmap; Const  CColor :TColor);
Var
  x, y :Integer;
  pY :^TRGBArray;
  TransR, TransG, TransB :TColor;
  Table :TTableArray;
Begin
  PrepareTable(Table,CColor);
  TransR:=-1; TransG:=-1; TransB:=-1;
  With Bmp do
    begin
      If Transparent then
        begin
          TransR:=Lo(TransparentColor); TransG:=Lo(TransparentColor shr 8); TransB:=Lo(TransparentColor shr 16);
        end;
      For y:=0 to Height-1 do
        begin
          pY:=ScanLine[y];
          For x:=0 to Width-1 do
            With pY^[x] do
              If (rgbtRed<>TransR) or (rgbtGreen<>TransG) or (rgbtBlue<>TransB) then
                begin
                  rgbtRed:=Table[rgbtRed].rgbtRed;
                  rgbtGreen:=Table[rgbtGreen].rgbtGreen;
                  rgbtBlue:=Table[rgbtBlue].rgbtBlue;
                  //avoiding getting transparent color from non transparent
                  If (rgbtRed=TransR) and (rgbtGreen=TransG) and (rgbtBlue=TransB) then
                    begin
                      If rgbtBlue<>0 then  rgbtBlue:=rgbtBlue-1
                      Else                 rgbtBlue:=rgbtBlue+1;
                    end;
                end;
        end;
    end;
end;

Procedure ColorizeColorsAlter(Var  Colors :Array of TColor; Const  CColor :TColor);
Var  i :Integer;
     r, g, b :TColor;
     Table :TTableArray;
Begin
  PrepareTable(Table,CColor);
  For i:=0 to High(Colors) do
    begin
      r:=Lo(Colors[i]); g:=Lo(Colors[i] shr 8 ); b:=Lo(Colors[i] shr 16);
      r:=Table[r].rgbtRed; g:=Table[g].rgbtGreen; b:=Table[b].rgbtBlue;
      Colors[i]:=r or (g shl 8) or (b shl 16);
    end;
end;

end.