{********************************************************************}
{                                                                    }
{ written by TMS Software                                            }
{            copyright © 2013                                        }
{            Email : info@tmssoftware.com                            }
{            Web : http://www.tmssoftware.com                        }
{                                                                    }
{ The source code is given as is. The author is not responsible      }
{ for any possible damage done due to the use of this code.          }
{ The complete source code remains property of the author and may    }
{ not be distributed, published, given or sold in any form as such.  }
{ No parts of the source code can be included in any other component }
{ or application without written authorization of the author.        }
{********************************************************************}

unit FMX.TMSBitmap;

interface

{$I TMSDEFS.INC}

uses
  Classes, Types, SysUtils, UITypes, FMX.Types, FMX.TMSBaseControl,
  FMX.Objects, FMX.TMSBitmapContainer, FMX.Controls
  , UIConsts, FMX.Styles
  {$IFDEF DELPHIXE5_LVL}
  , FMX.Graphics
  {$ENDIF}
  {$IFDEF DELPHIXE6_LVL}
  , System.Math.Vectors
  {$ENDIF}
  ;

const
  MAJ_VER = 1; // Major version nr.
  MIN_VER = 5; // Minor version nr.
  REL_VER = 0; // Release nr.
  BLD_VER = 0; // Build nr.

  // version history
  // v1.0.0.0 : First Release
  // v1.1.0.3 : Reorganized packages
  // v1.1.1.0 : New : support for update 4
  // v1.1.1.1 : Improved : TMSIOS define
  // v1.1.1.2 : New : support for update 4 hotfix 1
  // v1.1.1.3 : Fixed : Issue with absolute opacity
  // v1.5.0.0 : New : support for XE4

type

  TBool2DArray = array of array of boolean;

  TTMSFMXCustomBitmap = class(TTMSFMXBaseShape)
  private
    FBitmapContainer: TTMSFMXBitmapContainer;
    FBitmapName: String;
    FStretch: Boolean;
    FBitmap: TBitmap;
    FLinkedImage: TImage;
    FCropping: Boolean;
    FCenter: Boolean;
    FAutoSize: Boolean;
    FAspectRatio: Boolean;
    FHighSpeed: Boolean;
    FShiftState: TShiftState;
    function GetVersion: string;
    function GetVersionNr: Integer;
    procedure SetVersion(const Value: string);
    procedure SetBitmapName(const Value: String);
    procedure SetBitmapContainer(const Value: TTMSFMXBitmapContainer);
    procedure SetStretch(const Value: Boolean);
    procedure SetBitmap(const Value: TBitmap);
    procedure SetLinkedImage(const Value: TImage);
    procedure SetCropping(const Value: Boolean);
    procedure SetCenter(const Value: Boolean);
    procedure SetAutoSize(const Value: Boolean);
    procedure SetAspectRatio(const Value: Boolean);
    procedure SetHighSpeed(const Value: Boolean);
  protected
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure BitmapChanged(Sender: TObject);
    property AspectRatio: Boolean read FAspectRatio write SetAspectRatio default True;
    property Version: String read GetVersion write SetVersion;
    property LinkedImage: TImage read FLinkedImage write SetLinkedImage;
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property BitmapName: String read FBitmapName write SetBitmapName;
    property BitmapContainer: TTMSFMXBitmapContainer read FBitmapContainer write SetBitmapContainer;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property Cropping: Boolean read FCropping write SetCropping default False;
    property Center: Boolean read FCenter write SetCenter default True;
    property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
    property HighSpeed: Boolean read FHighSpeed write SetHighSpeed default True;
  public
    property ShiftState: TShiftState read FShiftState write FShiftState;
    function GetPaintBitmap: TBitmap;
    function GetPaintRectangle: TRectF;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    function GetBitmap: TBitmap;
    procedure GetAspectSize(var x, y, w, h: Single; ow, oh, nw, nh: Single);
    function MagicWand(X, Y: Single; Tolerance: Single = 0.1; DensityValue: Single = 50; DensityMax: Single = 50): TPolygon;
  end;

  [ComponentPlatformsAttribute(TMSPlatforms)]
  TTMSFMXBitmap = class(TTMSFMXCustomBitmap)
  published
    property AspectRatio;
    property Version;
    property LinkedImage;
    property Bitmap;
    property BitmapName;
    property BitmapContainer;
    property Stretch;
    property Cropping;
    property Center;
    property AutoSize;
    property HighSpeed;
    property Position;
    property Width;
    property Height;
    property Visible;
    property ClipChildren;
  end;

function GetMagicWandPolygon(ABitmap: TBitmap; X, Y: Single; Tolerance: Single = 0.1; DensityValue: Single = 50; DensityMax: Single = 50): TPolygon;

implementation

function CalcWandPoly(var d: TBitmapData; bmp: TBitmap; var mask: TBool2DArray; DensityValue, DensityMax: Single): TPolyGon;
var
  i,j,xi,yi,xc,yc,nx,ny: Integer;
  modified: Boolean;
  nPoints: Integer;
  tt,modifiable: array of boolean;
  a,c,Distance: Real;
  odir,dir: Integer;

//------------------------------------------------------------------------------
  function newx(x,dir:Integer):Integer;//calculate new x in the direction specified
  begin
    case (dir mod 8) of
    0:Result := x;                    //N
    1:Result := x + 1;                //NE
    2:Result := x + 1;                //E
    3:Result := x + 1;                //SE
    4:Result := x;                    //S
    5:Result := x - 1;                //SW
    6:Result := x - 1;                //W
    7:Result := x - 1;                //NW
    else
      Result := 0; //to stop compiler warnings
    end;
  end;

//------------------------------------------------------------------------------
  function newy(y,dir:Integer):Integer;
  begin
    case (dir mod 8) of
    0:Result := y - 1;                //N
    1:Result := y - 1;		      //NE
    2:Result := y;		      //E
    3:Result := y + 1;		      //SE
    4:Result := y + 1;		      //S
    5:Result := y + 1;		      //SW
    6:Result := y;		      //W
    7:Result := y - 1;		      //NW
    else
      Result := 0; //to stop compiler warnings
    end;
  end;

//------------------------------------------------------------------------------
begin
  nPoints := 0;
  Result := nil;
  SetLength(Result,20);//grow 20 points at a time
  SetLength(modifiable,20);

  xi := -1;
  yi := -1;

  //find the first point of the region
  for j := 0 to bmp.Height - 1 do
  begin
    for i := 0 to bmp.Width - 1 do
      if mask[i,j] then
      begin
        xi := i;
        yi := j;
        Break;
      end;
    if mask[i,j] then Break;
  end;

  //if there is no point then Exit
  if (xi < 0) or (yi < 0) then
  begin
    Result := nil;
    Exit;
  end;

  xc := xi;
  yc := yi;
  dir := 8; //the first direction is North, orthogonal with current direction
            //(which is East since we were scanning left to right)

  odir := -1;
  j := 0; //"fire escape" variable

  repeat
    inc(j);
    for i := 0 to 7 do //for all 8 directions
    begin
      nx := newx(xc,dir);
      ny := newy(yc,dir);
      try
        if (nx >= bmp.Width) or (ny >= bmp.Height) or (nx < 0) or (ny < 0) then
          Continue;
        if mask[nx,ny] then //if it found a point then add it
        begin
          //if the direction changed (if not, it is useless to add another point)
          if (odir mod 8) <> (dir mod 8) then
          begin
            if nPoints >= Length(Result) then
            begin
              SetLength(Result,nPoints + 20);
              SetLength(modifiable,nPoints + 20);
            end;
            Result[nPoints].x := xc;
            Result[nPoints].y := yc;

            D.SetPixel(xc, yc, claBlue);

            modifiable[nPoints] := True;
            inc(nPoints);
          end;
          //if it is a corner, mark it as non eraseable
          if ((8 + dir - odir) mod 8) > 1 then
            modifiable[nPoints-1] := False;
          xc := nx;
          yc := ny;
          odir := dir;
          //new direction is orthogonal on current direction (dir := dir - 3 + 1 -from finally)
          dir := ((dir + 5) mod 8) + 8;
          Break;
        end;
      finally
        inc(dir);
      end;
    end;
    if j > 1000000 then
      Break;  //in case of fire break window
  until (xc = xi) and (yc = yi);

  //simple algorithm to reduce the number of points:
  //repeat
  // for all points
  //  if the distance between i+1 and (i,i+3) line is smaller than Distance
  //  then delete i+1
  //until no point was deleted

  // for high accuracy, do not reduce points
  Setlength(Result,nPoints);
  Setlength(tt,nPoints);

  Distance := 3 * ((DensityMax - DensityValue + 5) / DensityMax);

  repeat
    Setlength(Result,nPoints);
    Setlength(tt,nPoints);
    Modified := False;

    for i := 0 to High(Result) do
      tt[i] := True;

    for i := 0 to High(Result)-2 do
    begin
      if (not tt[i])or(not modifiable[i+1]) then
        Continue;

      if Abs(Result[i+2].x - Result[i].x) < 0.0000001 then
      begin
        if Abs(Result[i+1].x-Result[i].x) < Distance then
        begin
          tt[i+1] := False;
          modified := True;
        end;
      end
      else
      begin
        a := -(Result[i+2].y-Result[i].y)/(Result[i+2].x-Result[i].x);
        c := -Result[i].y-a*Result[i].x;
        if((abs(a*Result[i+1].x+Result[i+1].y+c)/sqrt(a*a+1))<Distance) then
        begin
          tt[i+1] := False;
          modified := True;
        end;
      end;
    end;

    nPoints := 0;
    for i := 0 to High(Result) do
    begin
      if tt[i] then
      begin
        if nPoints <> i then
          Result[nPoints] := Result[i];
        inc(nPoints);
      end;
    end;
  until modified = False;
end;

function GetMagicWandPolygon(ABitmap: TBitmap; X, Y: Single; Tolerance: Single = 0.1; DensityValue: Single = 50; DensityMax: Single = 50): TPolygon;
var
  nf: Integer;
  i,j,ir: Integer;
  xf,yf: Single;
  mask: TBool2DArray;
  outermask: TBool2DArray;
  oldcolor: TAlphaColor;
  fillx:array[0..80000]of Single;
  filly:array[0..80000]of Single;
  d: TBitmapData;
  bmp: TBitmap;

  procedure grow_region;
  var
    pixr,pixg,pixb,oldr,oldg,oldb: Byte;
    pix: TAlphaColor;
    jj: Byte;
    xr,yr: Longint;
  begin
    oldr := Byte(oldcolor);
    oldg := Byte(oldcolor shr 8);
    oldb := Byte(oldcolor shr 16);

    xr := Round(xf + 1);
    yr := Round(yf);

    for jj := 1 to 4 do
    begin
      //Growing the Region
      if jj = 1 then
      begin
        xr := Round(xf + 1);
        yr := Round(yf);
      end;
      if jj = 2 then
      begin
        xr := Round(xf - 1);
        yr := Round(yf);
      end;
      if jj = 3 then
      begin
        xr := Round(xf);
        yr := Round(yf + 1);
      end;
      if jj = 4 then
      begin
        xr := Round(xf);
        yr := Round(yf - 1);
      end;

      //if it's not outside the bitmap
      if ((xr < ABitmap.Width) and (jj = 1)) or ((xr >= 0) and (jj = 2))
        or ((yr < ABitmap.Height) and (jj = 3)) or ((yr >= 0)and (jj = 4)) then
      begin
        pix := d.GetPixel(xr, yr);
        pixr := Byte(pix);
        pixg := Byte(pix shr 8);
        pixb := Byte(pix shr 16);
        // if the current pixel should be part of the region then add it to it
        if (not Mask[xr,yr]) and (Abs(pixr - oldr) <= Tolerance * 150) and (Abs(pixg-oldg) <= Tolerance * 150) and (Abs(pixb-oldb) <= tolerance*150)then
        begin
          mask[xr,yr] := true;

          nf := nf + 1;
          //add to queue
          fillx[nf] := xr;
          filly[nf] := yr;
        end;
      end;
    end;
  end;

//------------------------------------------------------------------------------
begin
  Result := nil;
  //Image initialization
  if (x > ABitmap.Width) or (x < 0) or
   (y < 0) or (y > ABitmap.Height) then
    Exit;

  bmp := TBitmap.Create(ABitmap.Width, ABitmap.Height);
  bmp.Assign(ABitmap);
  {$IFDEF DELPHIXE6_LVL}
  bmp.Map(TMapAccess.Read, d);
  {$ELSE}
  bmp.Map(TMapAccess.maRead, d);
  {$ENDIF}

  try
    // initialize boolean array
    SetLength(mask,ABitmap.Width + 5,ABitmap.Height + 5);
    SetLength(outermask,ABitmap.Width + 5,ABitmap.Height + 5);

    // start color
    if Integer(d.PixelFormat) <> 0 then
    begin
      oldcolor := d.GetPixel(Round(x), Round(y));

      nf := 1;
      ir := 1;
      fillx[nf] := x;
      filly[nf] := y;
      xf := x;
      yf := y;
      grow_region;

      while (nf > ir) do
      begin
        //extract point & grow_region(point)
        ir := ir + 1;
        xf := fillx[ir];
        yf := filly[ir];
        grow_region;
        if (nf > 75000)  then
        begin
          for i := 1 to nf-ir do
          begin
            fillx[i] := fillx[ir + i];
            filly[i] := filly[ir + i];
          end;
          nf := nf - ir ;
          ir := 0;
        end;
      end;

     for i := 0 to bmp.Width - 1 do
     begin
       for j := 0 to bmp.Height - 1 do
       begin
         if mask[i,j] then
         begin
           outermask[i,j] := mask[i,j];

           if (i > 0) then
             outermask[i - 1, j] := true;

           if (j > 0) then
             outermask[i, j - 1] := true;

           if (i < bmp.Width) then
             outermask[i + 1, j] := true;

           if (j < bmp.Height) then
             outermask[i, j + 1] := true;
         end;

       end;
     end;

      Result := CalcWandPoly(d, bmp, outermask, DensityValue, DensityMax);
    end;
  finally
    bmp.Unmap(d);
    bmp.Free;
  end;
end;

procedure TTMSFMXCustomBitmap.BitmapChanged(Sender: TObject);
begin
  Repaint;
end;

constructor TTMSFMXCustomBitmap.Create(AOwner: TComponent);
begin
  inherited;
  ClipChildren := True;
  FHighSpeed := True;
  FCenter := True;
  FStretch := False;
  FAspectRatio := True;
  FCropping := False;
  FBitmap := TBitmap.Create(0, 0);
  FBitmap.OnChange := BitmapChanged;
end;

destructor TTMSFMXCustomBitmap.Destroy;
begin
  FBitmap.Free;
  inherited;
end;

function TTMSFMXCustomBitmap.GetBitmap: TBitmap;
begin
  Result := nil;
  if Assigned(LinkedImage) and not LinkedImage.Bitmap.IsEmpty then
    Result := LinkedImage.Bitmap
  else if Assigned(Bitmap) and not Bitmap.IsEmpty then
    Result := Bitmap
  else if Assigned(BitmapContainer) and (BitmapName <> '') then
    Result := BitmapContainer.FindBitmap(BitmapName);
end;

function TTMSFMXCustomBitmap.GetPaintBitmap: TBitmap;
var
  bmp: TBitmap;
begin
  bmp := TBitmap.Create(Round(Width), Round(Height));
  try
    bmp.Canvas.BeginScene;
    PaintTo(bmp.Canvas, BoundsRect);
    bmp.Canvas.EndScene;
  finally
    Result := bmp;
  end;
end;

function TTMSFMXCustomBitmap.GetPaintRectangle: TRectF;
var
  bmp: TBitmap;
  rsrc, rdest: TRectF;
  w, h: Single;
  x, y: Single;
begin
  Result := RectF(0, 0, 0, 0);
  bmp := GetBitmap;
  if Assigned(bmp) then
  begin
    GetAspectSize(x, y, w, h, bmp.Width, bmp.Height, Width, Height);
    rsrc := RectF(0, 0, bmp.Width, bmp.Height);
    if Center or Cropping then
    begin
      x := (width - w) / 2;
      y := (height - h) / 2;
    end;

    rdest := RectF(x, y, x + w, y + h);
    Result := rdest;
  end;
end;

function TTMSFMXCustomBitmap.GetVersion: string;
var
  vn: Integer;
begin
  vn := GetVersionNr;
  Result := IntToStr(Hi(Hiword(vn)))+'.'+IntToStr(Lo(Hiword(vn)))+'.'+IntToStr(Hi(Loword(vn)))+'.'+IntToStr(Lo(Loword(vn)));
end;

function TTMSFMXCustomBitmap.GetVersionNr: integer;
begin
  Result := MakeLong(MakeWord(BLD_VER,REL_VER),MakeWord(MIN_VER,MAJ_VER));
end;

function TTMSFMXCustomBitmap.MagicWand(X, Y, Tolerance, DensityValue,
  DensityMax: Single): TPolygon;
var
  bmp: TBitmap;
begin
  bmp := GetPaintBitmap;
  if Assigned(bmp) then
  begin
    try
      Result := GetMagicWandPolyGon(bmp, X, Y, Tolerance, DensityValue, DensityMax);
    finally
      bmp.Free;
    end;
  end;
end;

procedure TTMSFMXCustomBitmap.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Single);
begin
  ShiftState := Shift;
  inherited;
  ShiftState := [];
end;

procedure TTMSFMXCustomBitmap.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if (Operation = opRemove) and (AComponent = FBitmapContainer) then
    FBitmapContainer := nil;
end;

procedure TTMSFMXCustomBitmap.GetAspectSize(var x, y, w, h: Single; ow, oh, nw, nh: Single);
var
  arc, ar: Single;
begin
  if AspectRatio then
  begin
    if (ow > 0) and (oh > 0) and (nw > 0) and (nh > 0) then
    begin
      if (ow < nw) and (oh < nh) and (not Stretch) then
      begin
        w := ow;
        h := oh;
      end
      else
      begin
        if ow / oh < nw / nh then
        begin
          h := nh;
          w := nh * ow / oh;
        end
        else
        begin
          w := nw;
          h := nw * oh / ow;
        end;
      end;
    end
    else
    begin
      w := 0;
      h := 0;
    end;
  end
  else
  begin
    if Stretch then
    begin
      w := nw;
      h := nh;
    end
    else
    begin
      w := ow;
      h := oh;

      if Cropping then
      begin
        if (w >= h) and (w > 0) then
        begin
          h := Width / w * h;
          w := Width;
        end
        else
        if (h >= w) and (h > 0) then
        begin
          w := Height / h * w;
          h := Height;
        end;

        if h = 0 then
          ar := 1
        else
          ar := w / h;

        if Height = 0 then
          arc := 1
        else
          arc := Width / Height;

        if (ar < 1) or (arc > ar) then
        begin
          h := Width / ar;
          w := Width;
        end
        else
        begin
          w := ar * Height;
          h := Height;
        end;
      end;
    end;
  end;
end;

procedure TTMSFMXCustomBitmap.Paint;
var
  bmp: TBitmap;
  rsrc, rdest: TRectF;
  w, h: Single;
  x, y: Single;
begin
  bmp := GetBitmap;
  if Assigned(bmp) then
  begin
    GetAspectSize(x, y, w, h, bmp.Width, bmp.Height, Width, Height);
    rsrc := RectF(0, 0, bmp.Width, bmp.Height);
    if Center or Cropping then
    begin
      x := (width - w) / 2;
      y := (height - h) / 2;
    end;

    rdest := RectF(x, y, x + w, y + h);
    Canvas.DrawBitmap(bmp, rsrc, rdest, AbsoluteOpacity, HighSpeed);
  end;
end;

procedure TTMSFMXCustomBitmap.SetAspectRatio(const Value: Boolean);
begin
  FAspectRatio := Value;
  Repaint;
end;

procedure TTMSFMXCustomBitmap.SetAutoSize(const Value: Boolean);
var
  bmp: TBitmap;
begin
  FAutoSize := Value;
  bmp := GetBitmap;
  if Assigned(bmp) then
  begin
    if FAutoSize and not bmp.IsEmpty then
    begin
      Self.Width := bmp.Width;
      Self.Height := bmp.Height;
    end;
  end;
end;

procedure TTMSFMXCustomBitmap.SetBitmap(const Value: TBitmap);
begin
  FBitmap.Assign(Value);
  Repaint;
end;

procedure TTMSFMXCustomBitmap.SetBitmapContainer(
  const Value: TTMSFMXBitmapContainer);
begin
  FBitmapContainer := Value;
  Repaint;
end;

procedure TTMSFMXCustomBitmap.SetBitmapName(const Value: String);
begin
  FBitmapName := Value;
  Repaint;
end;

procedure TTMSFMXCustomBitmap.SetCenter(const Value: Boolean);
begin
  FCenter := Value;
  Repaint;
end;

procedure TTMSFMXCustomBitmap.SetCropping(const Value: Boolean);
begin
  FCropping := Value;
  Repaint;
end;

procedure TTMSFMXCustomBitmap.SetHighSpeed(const Value: Boolean);
begin
  FHighSpeed := Value;
  Repaint;
end;

procedure TTMSFMXCustomBitmap.SetLinkedImage(const Value: TImage);
begin
  FLinkedImage := Value;
  Repaint;
end;

procedure TTMSFMXCustomBitmap.SetStretch(const Value: Boolean);
begin
  FStretch := Value;
  Repaint;
end;

procedure TTMSFMXCustomBitmap.SetVersion(const Value: string);
begin

end;

initialization
  RegisterFmxClasses([TTMSFMXBitmap]);

end.
