fe87aadcd8
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5579 8e941d3f-bd1b-0410-a28a-d453659cc2b4
580 lines
14 KiB
ObjectPascal
580 lines
14 KiB
ObjectPascal
unit HSVColorPicker;
|
|
|
|
{$IFDEF FPC}
|
|
{$MODE DELPHI}
|
|
{$ENDIF}
|
|
|
|
interface
|
|
|
|
uses
|
|
LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics, Math, Forms, Themes,
|
|
RGBHSVUtils, Scanlines, HTMLColors, mbColorPickerControl;
|
|
|
|
type
|
|
THSVColorPicker = class(TmbColorPickerControl)
|
|
private
|
|
FHue, FSat, FValue: Double;
|
|
FMaxHue, FMaxSat, FMaxValue: Integer;
|
|
FSatCircColor, FHueLineColor: TColor;
|
|
FSelectedColor: TColor;
|
|
FShowSatCirc: boolean;
|
|
FShowHueLine: boolean;
|
|
FShowSelCirc: boolean;
|
|
function RadHue(New: integer): integer;
|
|
function GetHue: Integer;
|
|
function GetSat: Integer;
|
|
function GetValue: Integer;
|
|
function GetRed: Integer;
|
|
function GetGreen: Integer;
|
|
function GetBlue: Integer;
|
|
procedure SetMaxHue(h: Integer);
|
|
procedure SetMaxSat(s: Integer);
|
|
procedure SetMaxValue(v: Integer);
|
|
procedure SetHue(h: integer);
|
|
procedure SetSat(s: integer);
|
|
procedure SetValue(V: integer);
|
|
procedure SetRed(r: Integer);
|
|
procedure SetGreen(g: Integer);
|
|
procedure SetBlue(b: Integer);
|
|
procedure SetSatCircColor(c: TColor);
|
|
procedure SetHueLineColor(c: TColor);
|
|
procedure DrawSatCirc;
|
|
procedure DrawHueLine;
|
|
procedure DrawMarker(x, y: integer);
|
|
procedure SetShowSatCirc(s: boolean);
|
|
procedure SetShowSelCirc(s: boolean);
|
|
procedure SetShowHueLine(s: boolean);
|
|
procedure UpdateCoords;
|
|
protected
|
|
procedure CreateGradient; override;
|
|
procedure CreateWnd; override;
|
|
function GetGradientColor2D(X, Y: Integer): TColor; override;
|
|
function GetSelectedColor: TColor; override;
|
|
procedure Paint; override;
|
|
procedure Resize; override;
|
|
procedure KeyDown(var Key: Word; Shift: TShiftState); 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 SelectColor(x, y: integer);
|
|
procedure SetSelectedColor(c: TColor); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
function GetColorAtPoint(x, y: integer): TColor; override;
|
|
property Red: Integer read GetRed write SetRed;
|
|
property Green: Integer read GetGreen write SetGreen;
|
|
property Blue: Integer read GetBlue write SetBlue;
|
|
published
|
|
property SelectedColor default clRed;
|
|
property Hue: integer read GetHue write SetHue default 0;
|
|
property Saturation: integer read GetSat write SetSat default 255;
|
|
property Value: integer read GetValue write SetValue default 255;
|
|
property MaxHue: Integer read FMaxHue write SetMaxHue default 359;
|
|
property MaxSaturation: Integer read FMaxSat write SetMaxSat default 255;
|
|
property MaxValue: Integer read FMaxValue write SetMaxValue default 255;
|
|
property SaturationCircleColor: TColor read FSatCircColor write SetSatCircColor default clSilver;
|
|
property HueLineColor: TColor read FHueLineColor write SetHueLineColor default clGray;
|
|
property ShowSaturationCircle: boolean read FShowSatCirc write SetShowSatCirc default true;
|
|
property ShowHueLine: boolean read FShowHueLine write SetShowHueLine default true;
|
|
property ShowSelectionCircle: boolean read FShowSelCirc write SetShowSelCirc default true;
|
|
property MarkerStyle default msCrossCirc;
|
|
property OnChange;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
mbUtils;
|
|
|
|
{ THSVColorPicker }
|
|
|
|
constructor THSVColorPicker.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
SetInitialBounds(0, 0, 204, 204);
|
|
FMaxHue := 359;
|
|
FMaxSat := 255;
|
|
FMaxValue := 255;
|
|
FHue := 0;
|
|
FSat := 1.0;
|
|
FValue := 1.0;
|
|
FSatCircColor := clSilver;
|
|
FHueLineColor := clGray;
|
|
FSelectedColor := clRed;
|
|
FManual := false;
|
|
FShowSatCirc := true;
|
|
FShowHueLine := true;
|
|
FShowSelCirc := true;
|
|
MarkerStyle := msCrossCirc;
|
|
end;
|
|
|
|
procedure THSVColorPicker.CreateGradient;
|
|
begin
|
|
FGradientWidth := Min(Width, Height);
|
|
FGradientHeight := FGradientWidth;
|
|
inherited;
|
|
end;
|
|
|
|
procedure THSVColorPicker.CreateWnd;
|
|
begin
|
|
inherited;
|
|
CreateGradient;
|
|
UpdateCoords;
|
|
end;
|
|
|
|
procedure THSVColorPicker.DrawSatCirc;
|
|
var
|
|
delta: integer;
|
|
radius: integer;
|
|
begin
|
|
if not FShowSatCirc then
|
|
exit;
|
|
if (FSat > 0) and (FSat < 1.0) then
|
|
begin
|
|
radius := Min(Width, Height) div 2;
|
|
Canvas.Pen.Color := FSatCircColor;
|
|
Canvas.Brush.Style := bsClear;
|
|
delta := round(radius * FSat);
|
|
Canvas.Ellipse(radius - delta, radius - delta, radius + delta, radius + delta);
|
|
end;
|
|
end;
|
|
|
|
procedure THSVColorPicker.DrawHueLine;
|
|
var
|
|
angle: double;
|
|
sinAngle, cosAngle: Double;
|
|
radius: integer;
|
|
begin
|
|
if not FShowHueLine then
|
|
exit;
|
|
radius := Min(Width, Height) div 2;
|
|
if (FHue >= 0) and (FHue <= 1.0) then
|
|
begin
|
|
angle := -FHue * 2 * pi;
|
|
SinCos(angle, sinAngle, cosAngle);
|
|
Canvas.Pen.Color := FHueLineColor;
|
|
Canvas.MoveTo(radius, radius);
|
|
Canvas.LineTo(radius + round(radius*cosAngle), radius + round(radius*sinAngle));
|
|
end;
|
|
end;
|
|
|
|
procedure THSVColorPicker.DrawMarker(x, y: integer);
|
|
var
|
|
c: TColor;
|
|
begin
|
|
if not FShowSelCirc then
|
|
exit;
|
|
if Focused or (csDesigning in ComponentState) then
|
|
c := clBlack
|
|
else
|
|
c := clGray;
|
|
InternalDrawMarker(x, y, c);
|
|
end;
|
|
|
|
function THSVColorPicker.GetBlue: Integer;
|
|
begin
|
|
Result := GetBValue(FSelectedColor);
|
|
end;
|
|
|
|
function THSVColorPicker.GetColorAtPoint(x, y: integer): TColor;
|
|
var
|
|
angle: Double;
|
|
dx, dy, r, radius: integer;
|
|
h, s: double;
|
|
begin
|
|
radius := Min(Width, Height) div 2;
|
|
dx := x - Radius;
|
|
dy := y - Radius;
|
|
|
|
r := round(sqrt(sqr(dx) + sqr(dy)));
|
|
if r <= radius then
|
|
begin
|
|
angle := 360 + 180 * arctan2(-dy, dx) / pi;
|
|
if angle < 0 then
|
|
angle := angle + 360
|
|
else if angle > 360 then
|
|
angle := angle - 360;
|
|
h := angle / 360;
|
|
s := r / radius;
|
|
Result := HSVtoColor(h, s, FValue);
|
|
if WebSafe then
|
|
Result := GetWebSafe(Result);
|
|
end else
|
|
Result := clNone;
|
|
end;
|
|
|
|
{ Outer loop: Y, Inner loop: X }
|
|
function THSVColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
|
|
var
|
|
dx, dy: Integer;
|
|
dSq, radiusSq: Integer;
|
|
radius, size: Integer;
|
|
S, H, V: Double;
|
|
q: TRGBQuad;
|
|
begin
|
|
size := FGradientWidth; // or Height, they are the same...
|
|
radius := size div 2;
|
|
radiusSq := sqr(radius);
|
|
dx := X - radius;
|
|
dy := Y - radius;
|
|
dSq := sqr(dx) + sqr(dy);
|
|
if dSq <= radiusSq then
|
|
begin
|
|
if radius <> 0 then
|
|
S := sqrt(dSq) / radius
|
|
else
|
|
S := 0;
|
|
H := 180 * (1 + arctan2(dx, dy) / pi); // wp: order (x,y) is correct!
|
|
H := H + 90;
|
|
if H > 360 then H := H - 360;
|
|
Result := HSVtoColor(H/360, S, FValue);
|
|
if WebSafe then
|
|
Result := GetWebSafe(Result);
|
|
end else
|
|
Result := GetDefaultColor(dctBrush);
|
|
end;
|
|
|
|
function THSVColorPicker.GetGreen: Integer;
|
|
begin
|
|
Result := GetGValue(FSelectedColor);
|
|
end;
|
|
|
|
function THSVColorPicker.GetHue: Integer;
|
|
begin
|
|
Result := round(FHue * FMaxHue);
|
|
end;
|
|
|
|
function THSVColorPicker.GetRed: Integer;
|
|
begin
|
|
Result := GetRValue(FSelectedColor);
|
|
end;
|
|
|
|
function THSVColorPicker.GetSat: Integer;
|
|
begin
|
|
Result := round(FSat * FMaxSat);
|
|
end;
|
|
|
|
function THSVColorPicker.GetSelectedColor: TColor;
|
|
begin
|
|
if FSelectedColor <> clNone then
|
|
begin
|
|
Result := HSVtoColor(FHue, FSat, FValue);
|
|
if WebSafe then
|
|
Result := GetWebSafe(Result);
|
|
end
|
|
else
|
|
Result := clNone;
|
|
end;
|
|
|
|
function THSVColorPicker.GetValue: Integer;
|
|
begin
|
|
Result := round(FValue * FMaxValue);
|
|
end;
|
|
|
|
procedure THSVColorPicker.KeyDown(var Key: Word; Shift: TShiftState);
|
|
var
|
|
eraseKey: Boolean;
|
|
delta: Integer;
|
|
begin
|
|
eraseKey := true;
|
|
delta := IfThen(ssCtrl in shift, 10, 1);
|
|
|
|
case Key of
|
|
VK_LEFT : SetHue(RadHue(GetHue() + delta));
|
|
VK_RIGHT : SetHue(RadHue(GetHue() - delta));
|
|
VK_UP : SetSat(GetSat() + delta);
|
|
VK_DOWN : SetSat(GetSat() - delta);
|
|
else eraseKey := false;
|
|
end;
|
|
|
|
if eraseKey then
|
|
Key := 0;
|
|
|
|
inherited;
|
|
end;
|
|
|
|
procedure THSVColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
begin
|
|
inherited;
|
|
if csDesigning in ComponentState then
|
|
exit;
|
|
if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then
|
|
SelectColor(X, Y);
|
|
SetFocus;
|
|
end;
|
|
|
|
procedure THSVColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
|
|
begin
|
|
inherited;
|
|
if csDesigning in ComponentState then
|
|
exit;
|
|
if (ssLeft in Shift) and PointInCircle(Point(x, y), Min(Width, Height)) then
|
|
SelectColor(X, Y);
|
|
end;
|
|
|
|
procedure THSVColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
begin
|
|
inherited;
|
|
if csDesigning in ComponentState then
|
|
exit;
|
|
if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then
|
|
SelectColor(X, Y);
|
|
end;
|
|
|
|
procedure THSVColorPicker.Paint;
|
|
var
|
|
rgn: HRGN;
|
|
R: TRect;
|
|
begin
|
|
PaintParentBack(Canvas);
|
|
R := ClientRect;
|
|
R.Right := R.Left + Min(Width, Height);
|
|
R.Bottom := R.Top + Min(Width, Height);
|
|
InflateRect(R, -1, -1); // Avoid spurious black pixels at the border
|
|
rgn := CreateEllipticRgnIndirect(R);
|
|
SelectClipRgn(Canvas.Handle, rgn);
|
|
Canvas.Draw(0, 0, FBufferBmp);
|
|
DeleteObject(rgn);
|
|
DrawSatCirc;
|
|
DrawHueLine;
|
|
DrawMarker(mx, my);
|
|
end;
|
|
|
|
function THSVColorPicker.RadHue(New: integer): integer;
|
|
begin
|
|
if New < 0 then New := New + (FMaxHue + 1);
|
|
if New > (FMaxHue + 1) then New := New - (FMaxHue + 1);
|
|
Result := New;
|
|
end;
|
|
|
|
procedure THSVColorPicker.Resize;
|
|
begin
|
|
inherited;
|
|
CreateGradient;
|
|
UpdateCoords;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SelectColor(x, y: integer);
|
|
var
|
|
angle: Double;
|
|
dx, dy, r, radius: integer;
|
|
H, S: Double;
|
|
begin
|
|
mx := x;
|
|
my := y;
|
|
|
|
radius := Min(Width, Height) div 2;
|
|
dx := x - radius;
|
|
dy := y - radius;
|
|
r := round(sqrt(sqr(dx) + sqr(dy)));
|
|
|
|
if r > radius then // point outside circle
|
|
begin
|
|
SetSelectedColor(clNone);
|
|
exit;
|
|
end;
|
|
|
|
//FSelectedColor := clWhite; // ????
|
|
angle := 360 + 180*arctan2(-dy, dx) / pi; // wp: "-y, x" correct? The others have "x, y"
|
|
if angle < 0 then
|
|
angle := angle + 360
|
|
else if angle > 360 then
|
|
angle := angle - 360;
|
|
H := angle / 360;
|
|
if r > radius then
|
|
S := 1.0
|
|
else
|
|
S := r / radius;
|
|
|
|
if (H = FHue) and (S = FSat) then
|
|
exit;
|
|
|
|
FHue := H;
|
|
FSat := S;
|
|
FSelectedColor := HSVToColor(FHue, FSat, FValue);
|
|
UpdateCoords;
|
|
Invalidate;
|
|
DoChange;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetBlue(b: Integer);
|
|
var
|
|
c: TColor;
|
|
begin
|
|
Clamp(b, 0, 255);
|
|
if b = GetBValue(FSelectedColor) then
|
|
exit;
|
|
c := RgbToColor(GetRValue(FSelectedColor), GetGValue(FSelectedColor), b);
|
|
SetSelectedColor(c);
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetGreen(g: Integer);
|
|
var
|
|
c: TColor;
|
|
begin
|
|
Clamp(g, 0, 255);
|
|
if g = GetGValue(FSelectedColor) then
|
|
exit;
|
|
c := RgbToColor(GetRValue(FSelectedColor), g, GetBValue(FSelectedColor));
|
|
SetSelectedColor(c);
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetHue(h: integer);
|
|
begin
|
|
if h > FMaxHue then h := h - (FMaxHue + 1);
|
|
if h < 0 then h := h + (FMaxHue + 1);
|
|
if GetHue() <> h then
|
|
begin
|
|
FHue := h / FMaxHue;
|
|
FSelectedColor := HSVToColor(FHue, FSat, FValue);
|
|
UpdateCoords;
|
|
Invalidate;
|
|
DoChange;
|
|
end;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetHueLineColor(c: TColor);
|
|
begin
|
|
if FHueLineColor <> c then
|
|
begin
|
|
FHueLineColor := c;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetMaxHue(h: Integer);
|
|
begin
|
|
if h = FMaxHue then
|
|
exit;
|
|
FMaxHue := h;
|
|
CreateGradient;
|
|
//if FChange and Assigned(OnChange) then OnChange(Self);
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetMaxSat(s: Integer);
|
|
begin
|
|
if s = FMaxSat then
|
|
exit;
|
|
FMaxSat := s;
|
|
CreateGradient;
|
|
//if FChange and Assigned(OnChange) then OnChange(Self);
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetMaxValue(v: Integer);
|
|
begin
|
|
if v = FMaxValue then
|
|
exit;
|
|
FMaxValue := v;
|
|
CreateGradient;
|
|
//if FChange and Assigned(OnChange) then OnChange(Self);
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetRed(r: Integer);
|
|
var
|
|
c: TColor;
|
|
begin
|
|
Clamp(r, 0, 255);
|
|
if r = GetRValue(FSelectedColor) then
|
|
exit;
|
|
c := RgbToColor(r, GetGValue(FSelectedColor), GetBValue(FSelectedColor));
|
|
SetSelectedColor(c);
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetSat(s: integer);
|
|
begin
|
|
Clamp(s, 0, FMaxSat);
|
|
if GetSat() <> s then
|
|
begin
|
|
FSat := s / FMaxSat;
|
|
FSelectedColor := HSVToColor(FHue, FSat, FValue);
|
|
UpdateCoords;
|
|
Invalidate;
|
|
DoChange;
|
|
end;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetSatCircColor(c: TColor);
|
|
begin
|
|
if FSatCircColor <> c then
|
|
begin
|
|
FSatCircColor := c;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetSelectedColor(c: TColor);
|
|
var
|
|
h, s, v: Double;
|
|
begin
|
|
if WebSafe then
|
|
c := GetWebSafe(c);
|
|
if c = FSelectedColor then
|
|
exit;
|
|
RGBtoHSV(GetRValue(c), GetGValue(c), GetBValue(c), FHue, FSat, FValue);
|
|
FSelectedColor := c;
|
|
UpdateCoords;
|
|
Invalidate;
|
|
DoChange;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetShowHueLine(s: boolean);
|
|
begin
|
|
if FShowHueLine <> s then
|
|
begin
|
|
FShowHueLine := s;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetShowSatCirc(s: boolean);
|
|
begin
|
|
if FShowSatCirc <> s then
|
|
begin
|
|
FShowSatCirc := s;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetShowSelCirc(s: boolean);
|
|
begin
|
|
if FShowSelCirc <> s then
|
|
begin
|
|
FShowSelCirc := s;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure THSVColorPicker.SetValue(V: integer);
|
|
begin
|
|
Clamp(V, 0, FMaxValue);
|
|
if GetValue() <> V then
|
|
begin
|
|
FValue := V / FMaxValue;
|
|
FSelectedColor := HSVToColor(FHue, FSat, FValue);
|
|
CreateGradient;
|
|
Invalidate;
|
|
DoChange;
|
|
end;
|
|
end;
|
|
|
|
procedure THSVColorPicker.UpdateCoords;
|
|
var
|
|
r, angle: double;
|
|
sinAngle, cosAngle: Double;
|
|
radius: integer;
|
|
begin
|
|
radius := Min(Width, Height) div 2;
|
|
r := -FSat * radius;
|
|
angle := -(FHue * 2 + 1) * pi;
|
|
SinCos(angle, sinAngle, cosAngle);
|
|
mx := round(cosAngle * r) + radius;
|
|
my := round(sinAngle * r) + radius;
|
|
end;
|
|
|
|
end.
|