{********************************************************************}
{                                                                    }
{ 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.TMSRating;

interface

{$I TMSDEFS.INC}

uses
  Classes, SysUtils, Types, UITypes,
  FMX.Objects, FMX.Types, Math, FMX.TMSBaseControl, FMX.Controls
  {$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.0.0.1 : Improved : TMSIOS define
  // v1.5.0.0 : New : support for XE4

type

  TTMSFMXRatingShapeBeforeDrawEvent = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRectF; var DefaultDraw: Boolean) of object;

  TTMSFMXRatingShapeAfterDrawEvent = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRectF) of object;

  TTMSFMXRatingShapeKind = (skRectangle, skEllipse, skStar, skDiamond, skTriangle, skNone);

  TTMSFMXRatingShape = class(TRoundRect)
  private
    FOnAfterDraw: TTMSFMXRatingShapeAfterDrawEvent;
    FOnBeforeDraw: TTMSFMXRatingShapeBeforeDrawEvent;
    FIndex: Integer;
    FTransparent: Boolean;
    FKind: TTMSFMXRatingShapeKind;
    procedure SetTransparent(const Value: Boolean);
    procedure SetKind(const Value: TTMSFMXRatingShapeKind);
  public
    constructor Create(AOwner: TComponent); override;
    procedure Paint; override;
    property Index: Integer read FIndex write FIndex;
  published
    property Transparent: Boolean read FTransparent write SetTransparent default False;
    property OnBeforeDraw: TTMSFMXRatingShapeBeforeDrawEvent read FOnBeforeDraw write FOnBeforeDraw;
    property OnAfterDraw: TTMSFMXRatingShapeAfterDrawEvent read FOnAfterDraw write FOnAfterDraw;
    property Kind: TTMSFMXRatingShapeKind read FKind write SetKind default skStar;
  end;

  TTMSFMXRatingCustomizeEvent = procedure(Sender: TObject; AShape: TControl; AShapeIndex: Integer) of object;

  TTMSFMXRatingBeforeDrawEvent = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRectF; AShapeIndex: Integer; var DefaultDraw: Boolean) of object;

  TTMSFMXRatingAfterDrawEvent = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRectF; AShapeIndex: Integer) of object;

  TTMSFMXRatingValueClickEvent = procedure(Sender: TObject; AValue: Single) of object;

  [ComponentPlatformsAttribute(TMSPlatforms)]
  TTMSFMXRating = class(TTMSFMXBaseControl)
  private
    FMouseDown: Boolean;
    FCount: Integer;
    FMaximum: Single;
    FValue: Single;
    FOnActiveCustomize: TTMSFMXRatingCustomizeEvent;
    FOnInActiveCustomize: TTMSFMXRatingCustomizeEvent;
    FOnActiveAfterdraw: TTMSFMXRatingAfterDrawEvent;
    FOnInActiveAfterdraw: TTMSFMXRatingAfterDrawEvent;
    FOnActiveBeforedraw: TTMSFMXRatingBeforeDrawEvent;
    FOnInActiveBeforedraw: TTMSFMXRatingBeforeDrawEvent;
    FOnValueClick: TTMSFMXRatingValueClickEvent;
    procedure SetCount(const Value: Integer);
    procedure SetMaximum(const Value: Single);
    procedure SetValue(const Value: Single);
    function GetVersion: String;
    function GetVersionNr: Integer;
    procedure SetVersion(const Value: String);
  protected
    function GetInActiveDefaultShape: TControl;
    function GetActiveDefaultShape: TControl;
    procedure ApplyStyle; override;
    procedure UpdateShapes;
    procedure AssignEvents;
    procedure CleanInActiveShapes;
    procedure CleanActiveShapes;
    procedure Resize; override;
    function GetInactiveShape(sn: String): TControl;
    function GetActiveShape(sn: String): TControl;
    function GetActiveHolder: TControl;
    function GetInActiveHolder: TControl;
    function GetInstance: NativeUInt; override;
    procedure DoBeforeInActiveDraw(Sender: TObject; ACanvas: TCanvas; ARect: TRectF; var DefaultDraw: Boolean);
    procedure DoAfterInActiveDraw(Sender: TObject; ACanvas: TCanvas; ARect: TRectF);
    procedure DoBeforeActiveDraw(Sender: TObject; ACanvas: TCanvas; ARect: TRectF; var DefaultDraw: Boolean);
    procedure DoAfterActiveDraw(Sender: TObject; ACanvas: TCanvas; ARect: TRectF);

    procedure DoMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    procedure DoMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Single);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Count: Integer read FCount write SetCount default 5;
    property Value: Single read FValue write SetValue;
    property Maximum: Single read FMaximum write SetMaximum;
    property OnInActiveCustomize: TTMSFMXRatingCustomizeEvent read FOnInActiveCustomize write FOnInActiveCustomize;
    property OnActiveCustomize: TTMSFMXRatingCustomizeEvent read FOnActiveCustomize write FOnActiveCustomize;
    property OnInActiveBeforeDraw: TTMSFMXRatingBeforeDrawEvent read FOnInActiveBeforedraw write FOnInActiveBeforeDraw;
    property OnInActiveAfterDraw: TTMSFMXRatingAfterDrawEvent read FOnInActiveAfterdraw write FOnInActiveAfterDraw;
    property OnActiveBeforeDraw: TTMSFMXRatingBeforeDrawEvent read FOnActiveBeforedraw write FOnActiveBeforeDraw;
    property OnActiveAfterDraw: TTMSFMXRatingAfterDrawEvent read FOnActiveAfterdraw write FOnActiveAfterDraw;
    property OnValueClick: TTMSFMXRatingValueClickEvent read FOnValueClick write FOnValueClick;
    property Version: String read GetVersion write SetVersion;
  end;

implementation

{$R FMX.TMSRating.res}

{ TTMSFMXRatingShape }

constructor TTMSFMXRatingShape.Create(AOwner: TComponent);
begin
  inherited;
  FTransparent := False;
  FKind := skStar;
end;

procedure TTMSFMXRatingShape.Paint;
var
  DefaultDraw: Boolean;
  pth: TPathData;
  poly: TPolygon;
  an1, an2, sin1, sin2, cos1, cos2, inr, outr: Single;
  I: Integer;
begin
  DefaultDraw := True;
  if Assigned(OnBeforeDraw) then
    OnBeforeDraw(Self, Canvas, BoundsRect, DefaultDraw);

  if DefaultDraw and not Transparent then
  begin
    case Kind of
      skRectangle: inherited;
      skStar:
      begin
        pth := TPathData.Create;


        an1 := PI / 5.0;
        an2 := 2.0 * an1;

        sin1 := Sin(an1);
        sin2 := Sin(an2);
        cos1 := Cos(an1);
        cos2 := Cos(an2);

        if Width > Height then
        begin
          outr := Height / 2;
          inr := Height / 4;
        end
        else
        begin
          outr := Width / 2;
          inr := Width / 4;
        end;

        SetLength(poly, 11);

        for I := 0 to length(poly) - 1 do
        begin
          poly[i] := PointF(Width / 2, Height / 2);
        end;

        poly[0].Y := poly[0].Y - outr;
        poly[1].X := poly[1].X + inr * sin1;
        poly[1].Y := poly[1].Y - inr * cos1;
        poly[2].X := poly[2].X + outr * Sin2;
        poly[2].Y := poly[2].Y - outr * cos2;
        poly[3].X := poly[3].X + inr * sin2;
        poly[3].Y := poly[3].Y + inr * cos2;
        poly[4].X := poly[4].X + outr * sin1;
        poly[4].Y := poly[4].Y + outr * cos1;
        poly[5].Y := poly[5].Y + inr;
        poly[6].X := poly[6].X + poly[6].X - poly[4].X;
        poly[6].Y := poly[4].Y;
        poly[7].X := poly[7].X + poly[7].X - poly[3].X;
        poly[7].Y := poly[3].Y;
        poly[8].X := poly[8].X + poly[8].X - poly[2].X;
        poly[8].Y := poly[2].Y;
        poly[9].X := poly[9].X + poly[9].X - poly[1].X;
        poly[9].Y := poly[1].Y;
        poly[10] := poly[0];

        Canvas.Fill.Assign(Fill);
        Canvas.Stroke.Assign(Stroke);
        Canvas.FillPolygon(poly, Opacity);
        Canvas.DrawPolygon(poly, Opacity);
        pth.Free;
      end;
      skTriangle:
      begin
        pth := TPathData.Create;
        pth.MoveTo(PointF(Width / 2, 0));
        pth.LineTo(PointF(Width, Height));
        pth.LineTo(PointF(0, Height));
        pth.ClosePath;
        canvas.FillPath(pth, Opacity, Fill);
        canvas.DrawPath(pth, Opacity, Stroke);
        pth.Free;
      end;
      skDiamond:
      begin
        pth := TPathData.Create;
        pth.MoveTo(PointF(Width / 2, 0));
        pth.LineTo(PointF(Width, Height / 2));
        pth.LineTo(PointF(Width / 2, Height));
        pth.LineTo(PointF(0, Height / 2));
        pth.ClosePath;
        canvas.FillPath(pth, Opacity, Fill);
        canvas.DrawPath(pth, Opacity, Stroke);
        pth.Free;
      end;
      skEllipse:
      begin
        Canvas.FillEllipse(Boundsrect, Opacity, Fill);
        Canvas.DrawEllipse(Boundsrect, Opacity, Stroke);
      end;
    end;
  end;

  if Assigned(OnAfterDraw) then
    OnAfterDraw(Self, Canvas, BoundsRect);
end;

procedure TTMSFMXRatingShape.SetKind(const Value: TTMSFMXRatingShapeKind);
begin
  if FKind <> Value then
  begin
    FKind := Value;
    Repaint;
  end;
end;

procedure TTMSFMXRatingShape.SetTransparent(const Value: Boolean);
begin
  if FTransparent <> Value then
  begin
    FTransparent := Value;
    Repaint;
  end;
end;

{ TTMSFMXRating }

procedure TTMSFMXRating.ApplyStyle;
begin
  inherited;
  AssignEvents;
  UpdateShapes;
end;

procedure TTMSFMXRating.AssignEvents;
var
  shp: TControl;
begin
  shp := GetInActiveHolder;
  if Assigned(shp) then
  begin
    shp.OnMouseUp := DoMouseUp;
    shp.OnMouseMove := DoMouseMove;
    shp.OnMouseDown := DoMouseDown;
  end;
end;

procedure TTMSFMXRating.CleanActiveShapes;
var
  str: TStringList;
  lName: String;
  i: integer;
  ctrl: TFMXObject;
  l: TControl;
  hldactive: TControl;
begin
  hldactive := GetActiveHolder;
  if Assigned(hldactive) then
  begin
    str := TStringList.Create;
    for i := 0 to Count - 1 do
    begin
      lName := 'FMXRatingShapeActive'+inttostr(i);
      str.Add(UpperCase(lName+'Name'));
    end;

    for I := hldactive.ChildrenCount - 1 downto 0 do
    begin
      ctrl := hldactive.Children[i];
      if ctrl is TControl then
      begin
        l := ctrl as TControl;
        if str.IndexOf(UpperCase(l.Name)) = -1 then
        begin
          {$IFDEF DELPHI_LLVM}
          l.Release;
          {$ELSE}
          l.Free;
          {$ENDIF}
        end;
      end;
    end;

    str.Free;
  end;
end;

procedure TTMSFMXRating.CleanInactiveShapes;
var
  str: TStringList;
  lName: String;
  i: integer;
  ctrl: TFMXObject;
  l: TControl;
  inactiveholder: TControl;
begin
  inactiveholder := GetInActiveHolder;
  if Assigned(inactiveholder) then
  begin
    str := TStringList.Create;
    for i := 0 to Count - 1 do
    begin
      lName := 'FMXRatingShapeInActive'+inttostr(i);
      str.Add(UpperCase(lName+'Name'));
    end;

    for I := inactiveholder.ChildrenCount - 1 downto 0 do
    begin
      ctrl := inactiveholder.Children[i];
      if ctrl is TControl then
      begin
        l := ctrl as TControl;
        if str.IndexOf(UpperCase(l.Name)) = -1 then
        begin
          {$IFDEF DELPHI_LLVM}
          l.Release;
          {$ELSE}
          l.Free;
          {$ENDIF}
        end;
      end;
    end;

    str.Free;
  end;
end;

constructor TTMSFMXRating.Create(AOwner: TComponent);
begin
  inherited;
  Width := 145;
  Height := 25;
  FCount := 5;
  FMaximum := 5;
  FValue := 0;
end;

destructor TTMSFMXRating.Destroy;
begin
  inherited;
end;

procedure TTMSFMXRating.DoAfterActiveDraw(Sender: TObject; ACanvas: TCanvas;
  ARect: TRectF);
var
  i: integer;
begin
  if Assigned(OnActiveAfterDraw) then
  begin
    i := -1;
    if (Sender is TTMSFMXRatingShape) then
      i := (Sender as TTMSFMXRatingShape).Index;
    OnActiveAfterDraw(Sender, ACanvas, ARect, i);
  end;
end;

procedure TTMSFMXRating.DoAfterInActiveDraw(Sender: TObject; ACanvas: TCanvas;
  ARect: TRectF);
var
  i: integer;
begin
  if Assigned(OnInActiveAfterDraw) then
  begin
    i := -1;
    if (Sender is TTMSFMXRatingShape) then
      i := (Sender as TTMSFMXRatingShape).Index;
    OnInActiveAfterDraw(Sender, ACanvas, ARect, i);
  end;
end;

procedure TTMSFMXRating.DoBeforeActiveDraw(Sender: TObject; ACanvas: TCanvas;
  ARect: TRectF; var DefaultDraw: Boolean);
var
  i: integer;
begin
  if Assigned(OnActiveBeforeDraw) then
  begin
    i := -1;
    if (Sender is TTMSFMXRatingShape) then
      i := (Sender as TTMSFMXRatingShape).Index;
    OnActiveBeforeDraw(Sender, ACanvas, ARect, i, DefaultDraw);
  end;
end;

procedure TTMSFMXRating.DoBeforeInActiveDraw(Sender: TObject; ACanvas: TCanvas;
  ARect: TRectF; var DefaultDraw: Boolean);
var
  i: integer;
begin
  if Assigned(OnInActiveBeforeDraw) then
  begin
    i := -1;
    if (Sender is TTMSFMXRatingShape) then
      i := (Sender as TTMSFMXRatingShape).Index;
    OnInActiveBeforeDraw(Sender, ACanvas, ARect, i, DefaultDraw);
  end;
end;

function TTMSFMXRating.GetActiveDefaultShape: TControl;
begin
  Result := FindStyleResource('activedefaultshape') as TControl;
end;

function TTMSFMXRating.GetActiveHolder: TControl;
begin
  Result := FindStyleResource('activeholder') as TControl;
end;

function TTMSFMXRating.GetActiveShape(sn: String): TControl;
var
  i: integer;
  ctrl: TFMXObject;
  l: TControl;
  activeholder: TControl;
begin
  Result := nil;
  activeholder := GetActiveHolder;
  if Assigned(activeholder) then
  begin
    for I := 0 to activeholder.ChildrenCount - 1 do
    begin
      ctrl := activeholder.Children[i];
      if ctrl is TControl then
      begin
        l := ctrl as TControl;
        if UpperCase(l.StyleName) = UpperCase(sn) then
        begin
          Result := l;
          Break;
        end;
      end;
    end;
  end;
end;

function TTMSFMXRating.GetInActiveDefaultShape: TControl;
begin
  Result := FindStyleResource('inactivedefaultshape') as TControl;
end;

function TTMSFMXRating.GetInActiveHolder: TControl;
begin
  Result := FindStyleResource('inactiveholder') as TControl;
end;

function TTMSFMXRating.GetInactiveShape(sn: String): TControl;
var
  i: integer;
  ctrl: TFMXObject;
  l: TTMSFMXRatingShape;
  inactiveholder: TControl;
begin
  Result := nil;
  inactiveholder := GetInActiveHolder;
  if Assigned(inactiveholder) then
  begin
    for I := 0 to inactiveholder.ChildrenCount - 1 do
    begin
      ctrl := inactiveholder.Children[i];
      if ctrl is TTMSFMXRatingShape then
      begin
        l := ctrl as TTMSFMXRatingShape;
        if UpperCase(l.StyleName) = UpperCase(sn) then
        begin
          Result := l;
          Break;
        end;
      end;
    end;
  end;
end;

function TTMSFMXRating.GetInstance: NativeUInt;
begin
  Result := HInstance;
end;

function TTMSFMXRating.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 TTMSFMXRating.GetVersionNr: integer;
begin
  Result := MakeLong(MakeWord(BLD_VER,REL_VER),MakeWord(MIN_VER,MAJ_VER));
end;


procedure TTMSFMXRating.DoMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
begin
  FMouseDown := True;
end;

procedure TTMSFMXRating.DoMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Single);
var
  val, valres: Single;
begin
  if not FMouseDown then
    Exit;

  if Width > 0 then
  begin
    val := Maximum / Count / 2;
    valres := Round((Maximum / Width) * X / val) * val;
    Value := valres;
  end;
end;

procedure TTMSFMXRating.DoMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X,
  Y: Single);
var
  val, valres: Single;
begin
  FMouseDown := False;
  if Width > 0 then
  begin
    val := Maximum / Count / 2;
    valres := Round((Maximum / Width) * X / val) * val;
    Value := valres;
    if Assigned(OnValueClick) then
      OnValueClick(Self, Value);
  end;
end;

procedure TTMSFMXRating.Resize;
begin
  inherited;
  UpdateShapes;
end;

procedure TTMSFMXRating.SetCount(const Value: Integer);
begin
  if FCount <> Value then
  begin
    FCount := Value;
    UpdateShapes;
  end;
end;

procedure TTMSFMXRating.SetMaximum(const Value: Single);
begin
  if FMaximum <> Value then
  begin
    FMaximum := Value;
    UpdateShapes;
  end;
end;

procedure TTMSFMXRating.SetValue(const Value: Single);
begin
  if FValue <> Value then
  begin
    FValue := Value;
    UpdateShapes;
  end;
end;

procedure TTMSFMXRating.SetVersion(const Value: String);
begin

end;

procedure TTMSFMXRating.UpdateShapes;
var
  I: Integer;
  s: TControl;
  w: Single;
  sn: String;
  inactiveshape, activeshape: TControl;
  inactiveholder, activeholder: TControl;
begin
  inactiveholder := GetInActiveHolder;
  activeholder := GetActiveHolder;
  if Assigned(inactiveholder) and Assigned(activeholder) then
  begin
    inactiveshape := GetInActiveDefaultShape;
    activeshape := GetActiveDefaultShape;

    inactiveholder.Position.X := 0;
    inactiveholder.Position.Y := 0;
    inactiveholder.Width := Width;
    inactiveholder.Height := Height;

    activeholder.Position.X := 0;
    activeholder.Position.Y := 0;
    activeholder.Width := Width / Maximum * Value;
    activeholder.Height := Height;

    if Assigned(inactiveshape) and Assigned(activeshape) and (Count > 0) and (Maximum > 0) then
    begin
      BeginUpdate;
      for I := 0 to Count - 1 do
      begin
        //inactive shapes
        sn := 'FMXRatingShapeInActive'+inttostr(i)+'Name';
        s := GetInactiveShape(sn);
        if not Assigned(s) then
        begin
          s := inactiveshape.Clone(inactiveholder) as TControl;
          CloneChildrenBase(inactiveshape, s);
          s.Name := sn;
          s.StyleName := sn;
          {$IFDEF DELPHIXE6_LVL}
          s.Align := TAlignLayout.Left;
          {$ELSE}
          s.Align := TAlignLayout.alLeft;
          {$ENDIF}
          s.Visible := True;
          inactiveholder.AddObject(s);
        end;

        if s is TTMSFMXRatingShape then
        begin
          (s as TTMSFMXRatingShape).OnBeforeDraw := DoBeforeInActiveDraw;
          (s as TTMSFMXRatingShape).OnAfterDraw := DoAfterInActiveDraw;
        end;

        w := (Width - s.Margins.Right - (Count * (s.Margins.Left + s.Margins.Right))) / Count;
        s.Width :=  w;

        if Assigned(OnInActiveCustomize) then
          OnInActiveCustomize(Self, s, I);

        //active shapes

        sn := 'FMXRatingShapeActive'+inttostr(i)+'Name';
        s := GetActiveShape(sn);
        if not Assigned(s) then
        begin
          s := activeshape.Clone(activeholder) as TControl;
          CloneChildrenBase(activeshape, s);
          s.Name := sn;
          s.StyleName := sn;
          s.Visible := True;
          {$IFDEF DELPHIXE6_LVL}
          s.Align := TAlignLayout.Left;
          {$ELSE}
          s.Align := TAlignLayout.alLeft;
          {$ENDIF}
          activeholder.AddObject(s);
        end;

        w := (Width - s.Margins.Right - (Count * (s.Margins.Left + s.Margins.Right))) / Count;
        s.Width :=  w;

        if s is TTMSFMXRatingShape then
        begin
          (s as TTMSFMXRatingShape).OnBeforeDraw := DoBeforeActiveDraw;
          (s as TTMSFMXRatingShape).OnAfterDraw := DoAfterActiveDraw;
        end;

        if Assigned(OnActiveCustomize) then
          OnActiveCustomize(Self, s, I);

      end;
      EndUpdate;
    end;

    CleanInActiveShapes;
    CleanActiveShapes;
  end;

  Repaint;
end;

initialization
  RegisterFmxClasses([TTMSFMXRating, TTMSFMXRatingShape]);

end.
