unit SaturationSelector;

interface

uses
  Windows, Messages, SysUtils, Types, Classes, Controls, Menus, Graphics,
  RColors, UITypes;

type
  TSaturationSelector = class(TCustomControl)
  private
    FSat, FVal: double;
    FHue: double;
    FMarkerColor: TColor;
    FOnChange: TNotifyEvent;
    procedure SetSat(const Value: double);
    procedure SetVal(const Value: double);
    procedure SetHue(const Value: double);
    procedure UpdateMarkerColor;
    procedure DoChange;
    function GetColor: THSV;
    procedure SetColor(const Value: THSV);
  protected
    procedure Paint; override;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
    property Color: THSV read GetColor write SetColor;
  published
    property Align;
    property Anchors;
    property Cursor;
    property Enabled;
    property PopupMenu;
    property Saturation: double read FSat write SetSat;
    property Value: double read FVal write SetVal;
    property Hue: double read FHue write SetHue;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

procedure Register;

implementation

uses Math;

procedure Register;
begin
  RegisterComponents('Rejbrand 2015', [TSaturationSelector]);
end;

{ TSaturationSelector }

constructor TSaturationSelector.Create(AOwner: TComponent);
begin
  inherited;
  FHue := 0;
  FSat := 1;
  FVal := 1;
  UpdateMarkerColor;
end;

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

function TSaturationSelector.GetColor: THSV;
begin
  result := HSV(FHue, FSat, FVal);
end;

procedure TSaturationSelector.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
var
  SatStep: double;
  R: TRect;
begin

  inherited;

  if Button <> mbLeft then Exit;

  if (ClientWidth < 4) or (ClientHeight < 4) then
    Exit;

  SatStep := 1 / (ClientWidth - 1);
  Saturation := SatStep * X;

  DoChange;

  with ClientToScreen(Point(0, 0)) do
    R := Rect(X, Y, X + ClientWidth, Y + ClientHeight);

  ClipCursor(@R);

end;

procedure TSaturationSelector.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  SatStep: double;
begin

  inherited;

  if not (csLButtonDown in ControlState) then
    Exit;

  if (ClientWidth < 4) or (ClientHeight < 4) then
    Exit;

  SatStep := 1 / (ClientWidth - 1);
  Saturation := EnsureRange(SatStep * X, 0, 1);
  DoChange;

end;

procedure TSaturationSelector.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  ClipCursor(nil);
end;

procedure TSaturationSelector.Paint;
var
  SatStep: double;
  clr: THSV;
  BM: TBitmap;
  x: Integer;
begin

  inherited;

  if (ClientWidth < 4) or (ClientHeight < 4) then
    Exit;

  SatStep := 1 / (ClientWidth - 1);
  clr := HSV(FHue, 0, FVal);

  BM := TBitmap.Create;
  try
    BM.SetSize(ClientWidth, ClientHeight);
    BM.Canvas.Pen.Width := 1;
    BM.Canvas.Pen.Mode := pmCopy;
    for x := 0 to ClientWidth - 1 do
    begin
      BM.Canvas.Pen.Color := GetPascalColor(clr);
      BM.Canvas.MoveTo(x, 0);
      BM.Canvas.LineTo(x, ClientHeight);
      clr.hsvSaturation := clr.hsvSaturation + SatStep;
    end;
    BM.Canvas.Pen.Color := FMarkerColor;
    BM.Canvas.MoveTo(round(FSat / SatStep), 0);
    BM.Canvas.LineTo(BM.Canvas.PenPos.X, ClientHeight);
    BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight,
      BM.Canvas.Handle, 0, 0, SRCCOPY);
  finally
    BM.Free;
  end;

end;

procedure TSaturationSelector.UpdateMarkerColor;
begin
  if FVal > 0.5 then
    FMarkerColor := clBlack
  else
    FMarkerColor := clWhite;
end;

procedure TSaturationSelector.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  message.Result := 1;
end;

procedure TSaturationSelector.SetColor(const Value: THSV);
begin
  if not SameHSV(Color, Value) then
    with Value do
    begin
      FHue := hsvHue;
      FSat := hsvSaturation;
      FVal := hsvValue;
      UpdateMarkerColor;
      Invalidate;
    end;
end;

procedure TSaturationSelector.SetHue(const Value: double);
begin
  if FHue <> Value then
  begin
    FHue := Value;
    Invalidate;
  end;
end;

procedure TSaturationSelector.SetSat(const Value: double);
var
  clr: THSV;
  SatStep: double;
begin

  if (ClientWidth < 4) or (ClientHeight < 4) then
    Exit;

  if FSat <> Value then
  begin
    SatStep := 1 / (ClientWidth - 1);
    clr := HSV(FHue, FSat, FVal);
    Canvas.Pen.Color := GetPascalColor(clr);
    Canvas.MoveTo(round(FSat / SatStep), 0);
    Canvas.LineTo(Canvas.PenPos.X, ClientHeight);
    FSat := Value;
    Canvas.Pen.Color := FMarkerColor;
    Canvas.MoveTo(round(FSat / SatStep), 0);
    Canvas.LineTo(Canvas.PenPos.X, ClientHeight);
  end;

end;

procedure TSaturationSelector.SetVal(const Value: double);
begin
  if FVal <> Value then
  begin
    FVal := Value;
    Invalidate;
  end;
end;

end.
