unit SVColorMap;

interface

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

type
  TSVColorMap = class(TCustomControl)
  private
    FHue, FSat, FVal: Double;
    FMarkerColor: TColor;
    FOnChange: TNotifyEvent;
    FBackground: TBitmap;
    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);
    procedure DrawBackground;
  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;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Color: THSV read GetColor write SetColor;
  published
    property Align;
    property Anchors;
    property Cursor default crCross;
    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', [TSVColorMap]);
end;

{ TSVColorMap }

constructor TSVColorMap.Create(AOwner: TComponent);
begin
  inherited;
  Cursor := crCross;
  FHue := 0;
  FVal := 1;
  FSat := 1;
  FBackground := TBitmap.Create;
end;

destructor TSVColorMap.Destroy;
begin
  FBackground.Free;
  inherited;
end;

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

procedure TSVColorMap.DrawBackground;
type
  PRGBTripleArray = ^TRGBTripleArray;
  TRGBTripleArray = array[word] of TRGBTriple;
var
  sstep, vstep: double;
  y: Integer;
  x: Integer;
  SL: PRGBTripleArray;
begin

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

  FBackground.SetSize(ClientWidth, ClientHeight);
  FBackground.PixelFormat := pf24bit;

  sstep := 1 / (ClientWidth - 1);
  vstep := 1 / (ClientHeight - 1);

  for y := 0 to ClientHeight - 1 do
  begin
    SL := FBackground.ScanLine[y];
    for x := 0 to ClientWidth - 1 do
      SL[x] := RGBToRGBTriple(HSVToRGB(HSV(FHue, x * sstep, y * vstep)));
  end;

end;

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

procedure TSVColorMap.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;

  FSat := X / (ClientWidth - 1);
  FVal := Y / (ClientHeight - 1);
  Invalidate;
  Update;
  DoChange;

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

  ClipCursor(@R);

end;

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

  inherited;

  if not (csLButtonDown in ControlState) then
    Exit;

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

  FSat := EnsureRange(X / (ClientWidth - 1), 0, 1);
  FVal := EnsureRange(Y / (ClientHeight - 1), 0, 1);
  Invalidate;
  Update;
  DoChange;

end;

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

procedure TSVColorMap.Paint;
begin

  inherited;

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

  if (FBackground.Width <> ClientWidth) or (FBackground.Height <> ClientHeight) then
    DrawBackground;

  UpdateMarkerColor;

  var bm := TBitmap.Create;
  try
    bm.SetSize(ClientWidth, ClientHeight);
    BitBlt(bm.Canvas.Handle, 0, 0, ClientWidth, ClientHeight,
      FBackground.Canvas.Handle, 0, 0, SRCCOPY);
    var x := Round((ClientWidth-1) * FSat);
    var y := Round((ClientHeight-1) * FVal);
    bm.Canvas.Pen.Color := FMarkerColor;
    bm.Canvas.MoveTo(0, y);
    bm.Canvas.LineTo(ClientWidth, y);
    bm.Canvas.MoveTo(x, 0);
    bm.Canvas.LineTo(x, ClientHeight);
    BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight,
      bm.Canvas.Handle, 0, 0, SRCCOPY);
  finally
    bm.Free;
  end;

end;

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

procedure TSVColorMap.SetHue(const Value: Double);
begin
  if FHue <> Value then
  begin
    FHue := Value;
    DrawBackground;
    Invalidate;
  end;
end;

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

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

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

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

procedure TSVColorMap.WMSize(var Message: TWMSize);
begin
  DrawBackground;
  Invalidate;
end;

end.
