unit HueSelector;

interface

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

type
  THueSelector = class(TCustomControl)
  private
    FSat, FVal: Double;
    FHue: Double;
    FMarkerColor: TColor;
    FPopupMenu: TPopupMenu;
    FOnChange: TNotifyEvent;
    FImmune: Boolean;
    procedure SetSat(const Value: Double);
    procedure SetVal(const Value: Double);
    procedure SetHue(const Value: Double);
    procedure UpdateMarkerColor;
    procedure PopupMenuClick(Sender: TObject);
    procedure DoChange;
    function GetColor: THSV;
    procedure SetColor(const Value: THSV);
    procedure SetImmune(const Value: Boolean);
  protected
    procedure Paint; override;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMContextMenu(var Message: TWMContextMenu);
      message WM_CONTEXTMENU;
    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 Immune: Boolean read FImmune write SetImmune default false;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

procedure Register;

implementation

uses
  Math;

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

{ THueSelector }

constructor THueSelector.Create(AOwner: TComponent);

  procedure AddMenuItem(const ACaption: string; const AHue: Integer);
  begin
    var LMenuItem := TMenuItem.Create(FPopupMenu);
    LMenuItem.Caption := ACaption;
    LMenuItem.Tag := AHue;
    LMenuItem.OnClick := PopupMenuClick;
    FPopupMenu.Items.Add(LMenuItem);
  end;

begin

  inherited;

  FImmune := False;
  FHue := 0;
  FSat := 1;
  FVal := 1;
  UpdateMarkerColor;

  FPopupMenu := TPopupMenu.Create(Self);
  AddMenuItem('Red', 0);
  AddMenuItem('Yellow', 60);
  AddMenuItem('Green', 120);
  AddMenuItem('Aqua', 180);
  AddMenuItem('Blue', 240);
  AddMenuItem('Fuchsia', 300);
  AddMenuItem('Red', 360);

end;

procedure THueSelector.PopupMenuClick(Sender: TObject);
begin
  if Sender is TMenuItem then
  begin
    SetHue(TMenuItem(Sender).Tag);
    DoChange;
  end;
end;

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

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

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

  inherited;

  if Assigned(Parent) and Parent.Visible and Visible and Enabled and CanFocus then
    SetFocus;

  if Button <> mbLeft then
    Exit;

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

  const HueStep = 360 / (ClientWidth - 1);
  Hue := HueStep * X;

  DoChange;

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

  ClipCursor(@R);

end;

procedure THueSelector.MouseMove(Shift: TShiftState; X, Y: Integer);
begin

  inherited;

  if not (csLButtonDown in ControlState) then
    Exit;

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

  const HueStep = 360 / (ClientWidth - 1);
  Hue := EnsureRange(HueStep * X, 0, 360);
  DoChange;

end;

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

procedure THueSelector.Paint;
var
  clr: THSV;
begin

  inherited;

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

  const HueStep = 360 / (ClientWidth - 1);

  if FImmune then
    clr := HSV(0, 1, 1)
  else
    clr := HSV(0, FSat, FVal);

  var BM := TBitmap.Create;
  try
    BM.SetSize(ClientWidth, ClientHeight);
    BM.Canvas.Pen.Width := 1;
    BM.Canvas.Pen.Mode := pmCopy;
    for var x := 0 to ClientWidth - 1 do
    begin
      BM.Canvas.Pen.Color := GetPascalColor(clr);
      BM.Canvas.MoveTo(x, 0);
      BM.Canvas.LineTo(x, ClientHeight);
      clr.hsvHue := clr.hsvHue + HueStep;
    end;
    BM.Canvas.Pen.Color := FMarkerColor;
    BM.Canvas.MoveTo(round(FHue / HueStep), 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 THueSelector.UpdateMarkerColor;
begin
  if FImmune or (FVal > 0.5) then
    FMarkerColor := clBlack
  else
    FMarkerColor := clWhite;
end;

procedure THueSelector.WMContextMenu(var Message: TWMContextMenu);
begin

  if Assigned(PopupMenu) then
  begin
    inherited;
    Exit;
  end;

  if (Message.XPos = -1) and (Message.YPos = -1) then
    with ClientToScreen(Point(0, ClientHeight)) do
      FPopupMenu.Popup(X, Y)
  else
    with SmallPointToPoint(Message.Pos) do
      FPopupMenu.Popup(X, Y);

end;

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

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

procedure THueSelector.SetHue(const Value: Double);
var
  clr: THSV;
begin

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

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

end;

procedure THueSelector.SetImmune(const Value: Boolean);
begin
  if FImmune <> Value then
  begin
    FImmune := Value;
    Invalidate;
  end;
end;

procedure THueSelector.SetSat(const Value: Double);
begin
  if FSat <> Value then
  begin
    FSat := Value;
    UpdateMarkerColor;
    Invalidate;
  end;
end;

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

end.
