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);
  var
    FMenuItem: TMenuItem;
  begin
    FMenuItem := TMenuItem.Create(FPopupMenu);
    FMenuItem.Caption := ACaption;
    FMenuItem.Tag := AHue;
    FMenuItem.OnClick := PopupMenuClick;
    FPopupMenu.Items.Add(FMenuItem);
  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
  HueStep: double;
  R: TRect;
begin

  inherited;

  if Button <> mbLeft then Exit;

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

  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);
var
  HueStep: double;
begin

  inherited;

  if not (csLButtonDown in ControlState) then
    Exit;

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

  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
  HueStep: double;
  clr: THSV;
  BM: TBitmap;
  x: Integer;
begin

  inherited;

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

  HueStep := 360 / (ClientWidth - 1);

  if FImmune then
    clr := HSV(0, 1, 1)
  else
    clr := HSV(0, FSat, 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.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
  inherited;
  if Message.Result = 1 then Exit;

  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;
  HueStep: real;
begin

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

  if FHue <> Value then
  begin
    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.
