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

interface

{$I TMSDEFS.INC}

uses
  FMX.Types, FMX.Objects, Classes, Types,
  SysUtils, UITypes, FMX.TMSBasecontrol, Math;

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.4.2 : Reorganized packages
  // v1.0.5.0 : New : support for update 4
  // v1.0.5.1 : Improved : TMSIOS define
  //          : Fixed : Issue with initial state when State is ssOn
  // v1.0.5.2 : New : support for update 4 hotfix 1
  // v1.0.5.3 : Fixed : Issue with state changing with mouse out of bounds
  // v1.5.0.0 : New : support for XE4

type
  TTMSFMXSliderState = (ssOn, ssOff);

  [ComponentPlatformsAttribute(TMSPlatforms)]
  TTMSFMXSlider = class(TTMSFMXBaseControl)
  private
    FTimer: TTimer;
    FCurrentPos, FPosTo: Single;
    FDoAnimation: Boolean;
    FCx: Single;
    FMouseDown, FMouseDownButton: Boolean;
    FState: TTMSFMXSliderState;
    FAnimationFactor: integer;
    FOnStateChanged: TNotifyEvent;
    procedure SetState(const Value: TTMSFMXSliderState);
    procedure SetAnimationFactor(const Value: integer);
    function GetVersion: String;
    function GetVersionNr: Integer;
  protected
    function GetInstance: NativeUInt; override;
    procedure DoSlide(Sender: TObject);
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
    function GetButtonRect: TRectF;
    function GetButtonSize: Single;
    procedure ApplyStyle; override;
  public
    function GetOnElement: TRoundRect;
    function GetOffElement: TRoundRect;
    function GetSliderElement: TRoundRect;
    function GetContainerElement: TRoundRect;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure UpdateSlider;
    procedure Toggle;
    procedure Update; override;
  published
    property Version: String read GetVersion;
    property AnimationFactor: integer read FAnimationFactor write SetAnimationFactor default 5;
    property State: TTMSFMXSliderState read FState write SetState default ssOff;
    property OnStateChanged: TNotifyEvent read FOnStateChanged write FOnStateChanged;
  end;

implementation

{$R FMX.TMSSlider.res}

{ TTMSFMXSlider }

procedure TTMSFMXSlider.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
  inherited;
  if (Button <> TMouseButton.mbLeft) then
    Exit;

  Capture;

  FMouseDown := True;
  FMouseDownButton := PointInRect(PointF(X, Y), GetButtonRect);
  FCx := X;
end;

procedure TTMSFMXSlider.MouseMove(Shift: TShiftState; X, Y: Single);
var
  bs: Single;
begin
  inherited;
  if FMouseDown and not FDoAnimation then
  begin
    bs := GetButtonSize;
    case FState of
      ssOn: FCurrentPos := Min(Max(X - FCx + Width - bs, 0), Width - bs);
      ssOff: FCurrentPos := Min(Max(X - FCx, 0), Width - bs);
    end;
    UpdateSlider;
  end;
end;

procedure TTMSFMXSlider.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Single);
var
  r: TRectF;
  bs: Single;
begin
  inherited;
  if (Button <> TMouseButton.mbLeft) or (FMouseDown = False) then
    Exit;

  ReleaseCapture;

  bs := GetButtonSize;
  R := GetButtonRect;

  if FMouseDownButton then
  begin
    if r.Left + (R.Width / 2) > Width / 2 then
    begin
      FPosTo := Width - bs;
      FState := ssOn;
      if Assigned(OnStateChanged) then
        OnStateChanged(Self);
    end
    else
    begin
      FPosTo := 0;
      FState := ssOff;
      if Assigned(OnStateChanged) then
        OnStateChanged(Self);
    end;
  end
  else
  begin
    if X < r.Left then
    begin
      FPosTo := 0;
      FState := ssOff;
      if Assigned(OnStateChanged) then
        OnStateChanged(Self);
    end
    else if x > R.Left then
    begin
      FPosTo := Width - bs;
      FState := ssOn;
      if Assigned(OnStateChanged) then
        OnStateChanged(Self);
    end;
  end;

  FDoAnimation := true;
  FMouseDown := false;
  FMouseDownButton := False;
end;

procedure TTMSFMXSlider.ApplyStyle;
var
  onel, offel: TRoundRect;
  elementc: TRoundRect;
begin
  inherited;
  onel := GetOnElement;
  offel := GetOffElement;

  elementc := FindStyleResource('elementcontainer') as TRoundRect;

  if Assigned(onel) and Assigned(offel) and Assigned(elementc) then
  begin

    elementc.AddObject(onel);
    elementc.AddObject(offel);

    offel.Margins.Left := 1;
    offel.Margins.Top := 1;
    offel.Margins.Right := 1;
    offel.Margins.Bottom := 1;
    onel.Margins.Left := 1;
    onel.Margins.Top := 1;
    onel.Margins.Right := 1;
    onel.Margins.Bottom := 1;

    {$IFDEF DELPHIXE6_LVL}
    onel.Align := TAlignLayout.Scale;
    offel.Align := TAlignLayout.Scale;
    {$ELSE}
    onel.Align := TAlignLayout.alScale;
    offel.Align := TAlignLayout.alScale;
    {$ENDIF}
    onel.Width := elementc.Width - 3;
    onel.Height := elementc.Height - 3;
    offel.Width := elementc.Width - 3;
    offel.Height := elementc.Height - 3;
    onel.Position.X := 1.5;
    onel.Position.Y := 1.5;
    offel.Position.X := 1.5;
    offel.Position.Y := 1.5;

    onel.Visible := True;
    offel.Visible := True;
    onel.SendToBack;
    offel.SendToBack;
  end;

  case FState of
    ssOn: FPosTo := Width - GetButtonSize;
    ssOff: FPosTo := 0;
  end;
  FCurrentPos := FPosTo;

  UpdateSlider;
end;

constructor TTMSFMXSlider.Create(AOwner: TComponent);
begin
  inherited;
  FAnimationFactor := 5;
  Width := 75;
  Height := 30;
  FState := ssOff;

  FTimer := TTimer.Create(Self);
  FTimer.Interval := 10;
  FTimer.Enabled := true;
  FTimer.OnTimer := DoSlide;
end;

destructor TTMSFMXSlider.Destroy;
begin
  FTimer.Free;
  inherited;
end;

function AnimateDouble(var Start: Single; Stop, Delta, Margin: Single): Boolean;
begin
  Result := true;
  if (Start > Stop - Margin) and (Start < Stop + Margin) then
  begin
    Start := Stop;
    Result := false;
  end
  else
  begin
    Delta := Max(1, Delta);
    if Start < Stop then
      Start := Round(Start + Delta)
    else
      Start := Round(Start - Delta);
  end;
end;

procedure TTMSFMXSlider.DoSlide(Sender: TObject);
var
  d, pos: Single;
  doanim: Boolean;
begin
  if FDoAnimation then
  begin
    d := Abs(FCurrentPos - FPosTo) / AnimationFactor;
    pos := FCurrentPos;
    doanim := AnimateDouble(pos, FposTo, d, 1);
    if doanim then
    begin
      FCurrentPos := pos;
      UpdateSlider;
    end
    else
    begin
      FDoAnimation := false;
      FCurrentPos := FPosTo;
      UpdateSlider;
    end;
  end;
end;

function TTMSFMXSlider.GetButtonRect: TRectF;
var
  sliderbutton: TRoundRect;
begin
  sliderbutton := GetSliderElement;
  if Assigned(sliderbutton) then
    Result := RectF(sliderbutton.Position.X, sliderbutton.Position.Y, sliderbutton.Position.X + sliderbutton.Width, sliderbutton.Position.Y +  sliderbutton.Height)
end;

function TTMSFMXSlider.GetButtonSize: Single;
var
  sliderbutton: TRoundRect;
begin
  Result := 0;
  sliderbutton := GetSliderElement;
  if Assigned(sliderbutton) then
    Result := sliderbutton.Width;
end;

function TTMSFMXSlider.GetContainerElement: TRoundRect;
begin
  Result := FindStyleResource('elementcontainer') as TRoundRect;
end;

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

function TTMSFMXSlider.GetOffElement: TRoundRect;
begin
  Result := FindStyleResource('offelement') as TRoundRect;
end;

function TTMSFMXSlider.GetOnElement: TRoundRect;
begin
  Result := FindStyleResource('onelement') as TRoundRect;
end;

function TTMSFMXSlider.GetSliderElement: TRoundRect;
begin
  Result := FindStyleResource('sliderbuttonelement') as TRoundRect;
end;

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

procedure TTMSFMXSlider.SetAnimationFactor(const Value: integer);
begin
  FAnimationFactor := Value;
end;

procedure TTMSFMXSlider.SetState(const Value: TTMSFMXSliderState);
begin
  if FState <> Value then
  begin
    FState := Value;
    case Value of
      ssOn: FPosTo := Width - GetButtonSize;
      ssOff: FPosTo := 0;
    end;
    FCurrentPos := FPosTo;
    UpdateSlider;
    if Assigned(OnStateChanged) then
      OnStateChanged(Self);
  end;
end;

procedure TTMSFMXSlider.Toggle;
begin
  State := TTMSFMXSliderState(Abs(1 - integer(State)));
end;

procedure TTMSFMXSlider.Update;
begin
  inherited;
end;

procedure TTMSFMXSlider.UpdateSlider;
var
  onel, offel: TRoundRect;
  elementc, sliderbutton: TRoundRect;
begin
  onel := GetOnElement;
  offel := GetOffElement;

  elementc := GetContainerElement;
  sliderbutton := GetSliderElement;

  if Assigned(onel) and Assigned(offel) and Assigned(sliderbutton) and Assigned(elementc) then
  begin
    sliderbutton.Position.X := FCurrentPos;
    onel.Position.X := 1.5;
    onel.Width := FCurrentPos + sliderbutton.Width - 3;
    offel.Position.X := FCurrentPos + 1.5;
    offel.Width := elementc.Width - FcurrentPos - 3;
  end;
end;

Initialization
  RegisterFmxClasses([TTMSFMXSlider]);

end.
