ewsdr/FlatFloatSpinEdit.pas

unit FlatFloatSpinEdit;

{ Custom floating-point spin edit with canvas rendering.
  Use instead of TFloatSpinEdit where native widgetset styling is undesirable. }

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Controls, Graphics, Forms, LCLType, LMessages, Types,
  Clipbrd, Math, AppTheme, DpiUtils;

type
  TFlatFloatSpinPart = (ffspNone, ffspEdit, ffspUp, ffspDown);

  TFlatFloatSpinEdit = class(TCustomControl)
  private
    FValue: Double;
    FMinValue: Double;
    FMaxValue: Double;
    FIncrement: Double;
    FDecimalPlaces: Integer;
    FText: string;
    FCaretPos: Integer;
    FSelStart: Integer;
    FSelLen: Integer;
    FHot: Boolean;
    FEditing: Boolean;
    FDragging: Boolean;
    FHotPart: TFlatFloatSpinPart;
    FDownPart: TFlatFloatSpinPart;
    FOnChange: TNotifyEvent;
    FClrOuterBG: TColor;
    FClrBG: TColor;
    FClrBGHot: TColor;
    FClrBorder: TColor;
    FClrText: TColor;
    FClrTextDim: TColor;
    FClrSelBG: TColor;
    FClrSelText: TColor;
    FClrBtnHot: TColor;
    FClrBtnDown: TColor;
    FClrBtnText: TColor;
    function ButtonWidth: Integer;
    function EditRect: TRect;
    function UpRect: TRect;
    function DownRect: TRect;
    function PartAt(X, Y: Integer): TFlatFloatSpinPart;
    function HasSelection: Boolean;
    function SelFirst: Integer;
    function SelAfter: Integer;
    function CaretPosAtX(X: Integer): Integer;
    function FormatValue(V: Double): string;
    function TryTextToValue(const S: string; out V: Double): Boolean;
    procedure SetValue(V: Double);
    procedure SetMinValue(V: Double);
    procedure SetMaxValue(V: Double);
    procedure SetIncrement(V: Double);
    procedure SetDecimalPlaces(V: Integer);
    procedure SetTextInternal(const S: string);
    procedure DeleteSelection;
    procedure InsertText(const S: string);
    procedure UpdateValueFromText;
    procedure CommitText;
    procedure StepValue(Dir: Integer);
    procedure DoChange;
    procedure AppUserInput(Sender: TObject; Msg: Cardinal);
  protected
    procedure Paint; override;
    procedure MouseEnter; override;
    procedure MouseLeave; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure DblClick; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: char); override;
    procedure DoEnter; override;
    procedure DoExit; override;
    function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
    function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetAppTheme(const T: TAppTheme);
    procedure SelectAll;

    property Value: Double read FValue write SetValue;
    property MinValue: Double read FMinValue write SetMinValue;
    property MaxValue: Double read FMaxValue write SetMaxValue;
    property Increment: Double read FIncrement write SetIncrement;
    property DecimalPlaces: Integer read FDecimalPlaces write SetDecimalPlaces;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Align;
    property Anchors;
    property Enabled;
    property Font;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Tag;
    property Visible;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
  end;

implementation

const
  BASE_PAD_X = 8;
  BASE_BTN_W = 22;
  VALUE_EPS = 1.0e-12;

constructor TFlatFloatSpinEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque, csCaptureMouse, csClickEvents];
  Width := 96;
  Height := DpiScale(26);
  TabStop := True;
  Cursor := crIBeam;

  Font.Name := 'Courier New';
  Font.Size := 9;

  FMinValue := 0.0;
  FMaxValue := 100.0;
  FIncrement := 1.0;
  FDecimalPlaces := 2;
  FValue := 0.0;
  FText := FormatValue(FValue);
  FCaretPos := Length(FText);
  FSelStart := FCaretPos;

  FClrOuterBG := TColor($00181818);
  FClrBG := TColor($001A1A1A);
  FClrBGHot := TColor($00202020);
  FClrBorder := TColor($00444444);
  FClrText := TColor($00E0E0E0);
  FClrTextDim := TColor($00666666);
  FClrSelBG := TColor($000C3010);
  FClrSelText := TColor($0000FF88);
  FClrBtnHot := TColor($000C3010);
  FClrBtnDown := TColor($00183618);
  FClrBtnText := TColor($0000FF88);
  Application.AddOnUserInputHandler(@AppUserInput);
end;

destructor TFlatFloatSpinEdit.Destroy;
begin
  Application.RemoveOnUserInputHandler(@AppUserInput);
  inherited Destroy;
end;

function TFlatFloatSpinEdit.ButtonWidth: Integer;
begin
  Result := DpiScale(BASE_BTN_W);
  if Result > Width div 2 then
    Result := Width div 2;
end;

function TFlatFloatSpinEdit.EditRect: TRect;
begin
  Result := Rect(0, 0, Width - ButtonWidth, Height);
end;

function TFlatFloatSpinEdit.UpRect: TRect;
begin
  Result := Rect(Width - ButtonWidth, 0, Width, Height div 2);
end;

function TFlatFloatSpinEdit.DownRect: TRect;
begin
  Result := Rect(Width - ButtonWidth, Height div 2, Width, Height);
end;

function TFlatFloatSpinEdit.PartAt(X, Y: Integer): TFlatFloatSpinPart;
begin
  if not PtInRect(ClientRect, Point(X, Y)) then
    Exit(ffspNone);
  if PtInRect(UpRect, Point(X, Y)) then
    Exit(ffspUp);
  if PtInRect(DownRect, Point(X, Y)) then
    Exit(ffspDown);
  Result := ffspEdit;
end;

procedure TFlatFloatSpinEdit.SetAppTheme(const T: TAppTheme);
begin
  FClrOuterBG := T.Panel;
  FClrBG := T.BtnNorm;
  FClrBGHot := T.BtnHot;
  FClrBorder := T.Border;
  FClrText := T.Text;
  FClrTextDim := T.TextDim;
  FClrSelBG := T.BtnActive;
  FClrSelText := T.BtnTextActive;
  FClrBtnHot := T.BtnActive;
  FClrBtnDown := T.SliderTrackFill;
  FClrBtnText := T.BtnTextActive;
  Font.Color := T.Text;
  Invalidate;
end;

function TFlatFloatSpinEdit.HasSelection: Boolean;
begin
  Result := FSelLen <> 0;
end;

function TFlatFloatSpinEdit.SelFirst: Integer;
begin
  if FSelLen >= 0 then
    Result := FSelStart
  else
    Result := FSelStart + FSelLen;
end;

function TFlatFloatSpinEdit.SelAfter: Integer;
begin
  if FSelLen >= 0 then
    Result := FSelStart + FSelLen
  else
    Result := FSelStart;
end;

function TFlatFloatSpinEdit.CaretPosAtX(X: Integer): Integer;
var
  I, Pad, RelX, BestDist, Dist: Integer;
begin
  Pad := DpiScale(BASE_PAD_X);
  RelX := X - Pad;
  Result := 0;
  BestDist := Abs(RelX);
  for I := 1 to Length(FText) do
  begin
    Dist := Abs(RelX - Canvas.TextWidth(Copy(FText, 1, I)));
    if Dist < BestDist then
    begin
      BestDist := Dist;
      Result := I;
    end;
  end;
end;

function TFlatFloatSpinEdit.FormatValue(V: Double): string;
var
  FS: TFormatSettings;
begin
  FS := DefaultFormatSettings;
  FS.DecimalSeparator := '.';
  if FDecimalPlaces <= 0 then
    Result := FormatFloat('0', V, FS)
  else
    Result := FormatFloat('0.' + StringOfChar('0', FDecimalPlaces), V, FS);
end;

function TFlatFloatSpinEdit.TryTextToValue(const S: string; out V: Double): Boolean;
var
  FS: TFormatSettings;
  T: string;
begin
  T := Trim(S);
  if (T = '') or (T = '-') or (T = '.') or (T = '-.') then
    Exit(False);
  T := StringReplace(T, ',', '.', [rfReplaceAll]);
  FS := DefaultFormatSettings;
  FS.DecimalSeparator := '.';
  Result := TryStrToFloat(T, V, FS);
end;

procedure TFlatFloatSpinEdit.SetTextInternal(const S: string);
begin
  FText := S;
  FCaretPos := EnsureRange(FCaretPos, 0, Length(FText));
  FSelStart := FCaretPos;
  FSelLen := 0;
  Invalidate;
end;

procedure TFlatFloatSpinEdit.SetValue(V: Double);
var
  NewText: string;
begin
  V := EnsureRange(V, FMinValue, FMaxValue);
  NewText := FormatValue(V);
  if (Abs(FValue - V) <= VALUE_EPS) and (FText = NewText) then Exit;
  FValue := V;
  FText := NewText;
  FCaretPos := Length(FText);
  FSelStart := FCaretPos;
  FSelLen := 0;
  Invalidate;
  DoChange;
end;

procedure TFlatFloatSpinEdit.SetMinValue(V: Double);
begin
  FMinValue := V;
  if FMaxValue < FMinValue then
    FMaxValue := FMinValue;
  SetValue(FValue);
end;

procedure TFlatFloatSpinEdit.SetMaxValue(V: Double);
begin
  FMaxValue := V;
  if FMinValue > FMaxValue then
    FMinValue := FMaxValue;
  SetValue(FValue);
end;

procedure TFlatFloatSpinEdit.SetIncrement(V: Double);
begin
  FIncrement := Abs(V);
  if FIncrement <= 0.0 then
    FIncrement := 1.0;
end;

procedure TFlatFloatSpinEdit.SetDecimalPlaces(V: Integer);
begin
  FDecimalPlaces := EnsureRange(V, 0, 8);
  SetTextInternal(FormatValue(FValue));
end;

procedure TFlatFloatSpinEdit.DeleteSelection;
var
  A, B: Integer;
begin
  if not HasSelection then Exit;
  A := SelFirst;
  B := SelAfter;
  Delete(FText, A + 1, B - A);
  FCaretPos := A;
  FSelStart := FCaretPos;
  FSelLen := 0;
end;

procedure TFlatFloatSpinEdit.InsertText(const S: string);
begin
  if S = '' then Exit;
  DeleteSelection;
  Insert(S, FText, FCaretPos + 1);
  Inc(FCaretPos, Length(S));
  FSelStart := FCaretPos;
  FSelLen := 0;
  UpdateValueFromText;
  Invalidate;
end;

procedure TFlatFloatSpinEdit.UpdateValueFromText;
var
  V: Double;
begin
  if not TryTextToValue(FText, V) then Exit;
  if (V < FMinValue) or (V > FMaxValue) then Exit;
  if Abs(FValue - V) <= VALUE_EPS then Exit;
  FValue := V;
  DoChange;
end;

procedure TFlatFloatSpinEdit.CommitText;
var
  V: Double;
begin
  if not TryTextToValue(FText, V) then
  begin
    SetValue(FValue);
    Exit;
  end;
  SetValue(V);
end;

procedure TFlatFloatSpinEdit.StepValue(Dir: Integer);
begin
  CommitText;
  SetValue(FValue + Dir * FIncrement);
end;

procedure TFlatFloatSpinEdit.DoChange;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TFlatFloatSpinEdit.AppUserInput(Sender: TObject; Msg: Cardinal);
var
  P: TPoint;
begin
  if not FEditing then Exit;
  case Msg of
    LM_LBUTTONDOWN, LM_RBUTTONDOWN, LM_MBUTTONDOWN: ;
  else
    Exit;
  end;

  P := ScreenToClient(Mouse.CursorPos);
  if PtInRect(ClientRect, P) then Exit;

  CommitText;
  FDragging := False;
  MouseCapture := False;
  FEditing := False;
  FHot := False;
  FHotPart := ffspNone;
  FDownPart := ffspNone;
  FSelLen := 0;
  Invalidate;
end;

procedure TFlatFloatSpinEdit.Paint;
var
  R, ER, UR, DR, TextR, SelR: TRect;
  Pad, TextY, CaretX, A, B, MidX, MidY, S: Integer;
  BeforeSel, SelText: string;

  procedure FillPart(const AR: TRect; Part: TFlatFloatSpinPart);
  begin
    if not Enabled then
      Canvas.Brush.Color := FClrBG
    else if FDownPart = Part then
      Canvas.Brush.Color := FClrBtnDown
    else if FHotPart = Part then
      Canvas.Brush.Color := FClrBtnHot
    else if FHot or FEditing or Focused then
      Canvas.Brush.Color := FClrBGHot
    else
      Canvas.Brush.Color := FClrBG;
    Canvas.Pen.Style := psClear;
    Canvas.Brush.Style := bsSolid;
    Canvas.FillRect(AR);
  end;

  procedure DrawArrow(const AR: TRect; Up: Boolean);
  var
    P: array[0..2] of TPoint;
    Size: Integer;
  begin
    Size := Max(3, DpiScale(4));
    MidX := (AR.Left + AR.Right) div 2;
    MidY := (AR.Top + AR.Bottom) div 2;
    if Up then
    begin
      P[0] := Point(MidX, MidY - Size div 2);
      P[1] := Point(MidX - Size, MidY + Size div 2);
      P[2] := Point(MidX + Size, MidY + Size div 2);
    end
    else
    begin
      P[0] := Point(MidX - Size, MidY - Size div 2);
      P[1] := Point(MidX + Size, MidY - Size div 2);
      P[2] := Point(MidX, MidY + Size div 2);
    end;
    if Enabled then
      Canvas.Brush.Color := FClrBtnText
    else
      Canvas.Brush.Color := FClrTextDim;
    Canvas.Pen.Style := psClear;
    Canvas.Polygon(P);
  end;
begin
  R := ClientRect;
  ER := EditRect;
  UR := UpRect;
  DR := DownRect;

  Canvas.Brush.Color := FClrOuterBG;
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Style := psClear;
  Canvas.FillRect(R);

  if FHot or FEditing or Focused then
    Canvas.Brush.Color := FClrBGHot
  else
    Canvas.Brush.Color := FClrBG;
  Canvas.Pen.Color := FClrBorder;
  Canvas.Pen.Style := psSolid;
  Canvas.Pen.Width := 1;
  Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);

  FillPart(UR, ffspUp);
  FillPart(DR, ffspDown);
  Canvas.Pen.Color := FClrBorder;
  Canvas.Pen.Style := psSolid;
  Canvas.Line(UR.Left, 1, UR.Left, Height - 1);
  Canvas.Line(UR.Left, DR.Top, Width - 1, DR.Top);
  DrawArrow(UR, True);
  DrawArrow(DR, False);

  Canvas.Font.Assign(Font);
  if Enabled then
    Canvas.Font.Color := FClrText
  else
    Canvas.Font.Color := FClrTextDim;
  Pad := DpiScale(BASE_PAD_X);
  TextR := Rect(ER.Left + Pad, ER.Top, ER.Right - DpiScale(3), ER.Bottom);
  TextY := (Height - Canvas.TextHeight('Ag')) div 2;

  if HasSelection then
  begin
    A := SelFirst;
    B := SelAfter;
    BeforeSel := Copy(FText, 1, A);
    SelText := Copy(FText, A + 1, B - A);
    SelR := Rect(TextR.Left + Canvas.TextWidth(BeforeSel), TextY,
      TextR.Left + Canvas.TextWidth(BeforeSel + SelText), TextY + Canvas.TextHeight('Ag'));
    Canvas.Brush.Color := FClrSelBG;
    Canvas.Pen.Style := psClear;
    Canvas.FillRect(SelR);
  end;

  Canvas.Brush.Style := bsClear;
  Canvas.TextRect(TextR, TextR.Left, TextY, FText);

  if HasSelection then
  begin
    A := SelFirst;
    B := SelAfter;
    BeforeSel := Copy(FText, 1, A);
    SelText := Copy(FText, A + 1, B - A);
    Canvas.Font.Color := FClrSelText;
    Canvas.TextOut(TextR.Left + Canvas.TextWidth(BeforeSel), TextY, SelText);
  end;

  if FEditing and not HasSelection then
  begin
    S := EnsureRange(FCaretPos, 0, Length(FText));
    CaretX := TextR.Left + Canvas.TextWidth(Copy(FText, 1, S));
    Canvas.Pen.Color := FClrText;
    Canvas.Pen.Style := psSolid;
    Canvas.Pen.Width := 1;
    Canvas.Line(CaretX, TextY, CaretX, TextY + Canvas.TextHeight('Ag'));
  end;
end;

procedure TFlatFloatSpinEdit.MouseEnter;
begin
  inherited;
  FHot := True;
  Invalidate;
end;

procedure TFlatFloatSpinEdit.MouseLeave;
begin
  inherited;
  FHot := False;
  FHotPart := ffspNone;
  Invalidate;
end;

procedure TFlatFloatSpinEdit.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  Pos: Integer;
begin
  inherited;
  if (Button <> mbLeft) or not Enabled then Exit;
  SetFocus;
  FEditing := True;
  FDownPart := PartAt(X, Y);
  FHotPart := FDownPart;
  if FDownPart in [ffspUp, ffspDown] then
  begin
    FDragging := False;
    MouseCapture := True;
    if FDownPart = ffspUp then
      StepValue(1)
    else
      StepValue(-1);
  end
  else
  begin
    FDragging := True;
    MouseCapture := True;
    Pos := CaretPosAtX(X);
    FCaretPos := Pos;
    FSelStart := Pos;
    FSelLen := 0;
  end;
  Invalidate;
end;

procedure TFlatFloatSpinEdit.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  Pos: Integer;
  Part: TFlatFloatSpinPart;
begin
  inherited;
  Part := PartAt(X, Y);
  if FHotPart <> Part then
  begin
    FHotPart := Part;
    if Part = ffspEdit then
      Cursor := crIBeam
    else
      Cursor := crDefault;
    Invalidate;
  end;

  if not FDragging then Exit;
  Pos := CaretPosAtX(X);
  FCaretPos := Pos;
  FSelLen := Pos - FSelStart;
  Invalidate;
end;

procedure TFlatFloatSpinEdit.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  if Button <> mbLeft then Exit;
  FDragging := False;
  FDownPart := ffspNone;
  MouseCapture := False;
  Invalidate;
end;

procedure TFlatFloatSpinEdit.DblClick;
begin
  inherited;
  if FHotPart <> ffspEdit then Exit;
  FEditing := True;
  SelectAll;
end;

procedure TFlatFloatSpinEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  if not Enabled then Exit;
  FEditing := True;
  case Key of
    VK_LEFT:
      begin
        FCaretPos := EnsureRange(FCaretPos - 1, 0, Length(FText));
        FSelStart := FCaretPos;
        FSelLen := 0;
        Invalidate;
        Key := 0;
      end;
    VK_RIGHT:
      begin
        FCaretPos := EnsureRange(FCaretPos + 1, 0, Length(FText));
        FSelStart := FCaretPos;
        FSelLen := 0;
        Invalidate;
        Key := 0;
      end;
    VK_HOME:
      begin
        FCaretPos := 0;
        FSelStart := FCaretPos;
        FSelLen := 0;
        Invalidate;
        Key := 0;
      end;
    VK_END:
      begin
        FCaretPos := Length(FText);
        FSelStart := FCaretPos;
        FSelLen := 0;
        Invalidate;
        Key := 0;
      end;
    VK_UP:
      begin
        StepValue(1);
        Key := 0;
      end;
    VK_DOWN:
      begin
        StepValue(-1);
        Key := 0;
      end;
    VK_RETURN:
      begin
        CommitText;
        SelectAll;
        Key := 0;
      end;
    VK_ESCAPE:
      begin
        SetTextInternal(FormatValue(FValue));
        Key := 0;
      end;
    VK_BACK:
      begin
        if HasSelection then
          DeleteSelection
        else if FCaretPos > 0 then
        begin
          Delete(FText, FCaretPos, 1);
          Dec(FCaretPos);
        end;
        FSelStart := FCaretPos;
        FSelLen := 0;
        UpdateValueFromText;
        Invalidate;
        Key := 0;
      end;
    VK_DELETE:
      begin
        if HasSelection then
          DeleteSelection
        else if FCaretPos < Length(FText) then
          Delete(FText, FCaretPos + 1, 1);
        FSelStart := FCaretPos;
        FSelLen := 0;
        UpdateValueFromText;
        Invalidate;
        Key := 0;
      end;
    Ord('A'):
      if ssCtrl in Shift then
      begin
        SelectAll;
        Key := 0;
      end;
    Ord('C'):
      if (ssCtrl in Shift) and HasSelection then
      begin
        Clipboard.AsText := Copy(FText, SelFirst + 1, SelAfter - SelFirst);
        Key := 0;
      end;
    Ord('X'):
      if (ssCtrl in Shift) and HasSelection then
      begin
        Clipboard.AsText := Copy(FText, SelFirst + 1, SelAfter - SelFirst);
        DeleteSelection;
        UpdateValueFromText;
        Invalidate;
        Key := 0;
      end;
    Ord('V'):
      if ssCtrl in Shift then
      begin
        InsertText(Clipboard.AsText);
        Key := 0;
      end;
  end;
end;

procedure TFlatFloatSpinEdit.KeyPress(var Key: char);
begin
  inherited;
  if not Enabled then Exit;
  FEditing := True;
  if Key in ['0'..'9'] then
  begin
    InsertText(Key);
    Key := #0;
  end
  else if (Key in ['.', ',']) and (Pos('.', FText) = 0) and (Pos(',', FText) = 0) then
  begin
    InsertText('.');
    Key := #0;
  end
  else if (Key = '-') and (FMinValue < 0.0) and (FCaretPos = 0) and (Pos('-', FText) = 0) then
  begin
    InsertText(Key);
    Key := #0;
  end
  else if Key >= #32 then
    Key := #0;
end;

procedure TFlatFloatSpinEdit.DoEnter;
begin
  inherited;
  FEditing := True;
  Invalidate;
end;

procedure TFlatFloatSpinEdit.DoExit;
begin
  inherited;
  CommitText;
  FEditing := False;
  FHot := False;
  FHotPart := ffspNone;
  FDownPart := ffspNone;
  FSelLen := 0;
  Invalidate;
end;

function TFlatFloatSpinEdit.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
  if Enabled then
    StepValue(1);
  Result := True;
end;

function TFlatFloatSpinEdit.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
  if Enabled then
    StepValue(-1);
  Result := True;
end;

procedure TFlatFloatSpinEdit.SelectAll;
begin
  FSelStart := 0;
  FSelLen := Length(FText);
  FCaretPos := Length(FText);
  Invalidate;
end;

end.