unit GR32_ColorPicker; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are subject to the Mozilla Public License Version * 1.1 (the "License"); you may not use this file except in compliance with * the License. You may obtain a copy of the License at * http://www.mozilla.org/MPL/ * * Software distributed under the License is distributed on an "AS IS" basis, * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License * for the specific language governing rights and limitations under the * License. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Graphics32 * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * ***** END LICENSE BLOCK ***** *) interface {$include GR32.inc} {-$define GR32_FRAME3D} uses {$IFDEF FPC} LCLIntf, LCLType, LMessages, Types, {$IFDEF MSWINDOWS} Windows, {$ENDIF} {$ELSE} Windows, Messages, Types, {$ENDIF} Classes, Controls, Forms, GR32, GR32_Polygons, GR32_Containers, GR32_ColorGradients; type TScreenColorPickerForm = class(TCustomForm) private FSelectedColor: TColor32; FOnColorSelected: TNotifyEvent; protected procedure CreateParams(var Params: TCreateParams); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; {$IFDEF FPC} procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND; {$ELSE} procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; {$ENDIF} public constructor Create(AOwner: TComponent); override; function Execute: boolean; property SelectedColor: TColor32 read FSelectedColor write FSelectedColor; property OnColorSelected: TNotifyEvent read FOnColorSelected write FOnColorSelected; published property OnKeyUp; property OnKeyPress; property OnKeyDown; property OnMouseMove; property OnMouseUp; property OnMouseDown; end; THueCirclePolygonFiller = class(TCustomPolygonFiller) private FCenter: TFloatPoint; FWebSafe: Boolean; protected function GetFillLine: TFillLineEvent; override; procedure FillLine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); virtual; procedure FillLineWebSafe(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); virtual; public constructor Create(Center: TFloatPoint; WebSafe: Boolean = False); property Center: TFloatPoint read FCenter write FCenter; property WebSafe: Boolean read FWebSafe write FWebSafe; end; THueSaturationCirclePolygonFiller = class(THueCirclePolygonFiller) private FRadius: Single; FInvRadius: Single; FValue: Single; procedure SetRadius(const Value: Single); protected procedure FillLine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); override; procedure FillLineWebSafe(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); override; public constructor Create(Center: TFloatPoint; Radius, Value: Single; WebSafe: Boolean = False); property Radius: Single read FRadius write SetRadius; property Value: Single read FValue write FValue; end; TBarycentricGradientPolygonFillerEx = class(TBarycentricGradientPolygonFiller) private FWebSafe: Boolean; protected function GetFillLine: TFillLineEvent; override; procedure FillLineWebSafe(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); public property WebSafe: Boolean read FWebSafe write FWebSafe; end; TVisualAid = set of (vaHueLine, vaSaturationCircle, vaSelection); TVisualAidRenderType = (vatSolid, vatInvert, vatBW); TAdjustCalc = procedure (X, Y: Single) of object; TVisualAidOptions = class(TPersistent) private FOwner: TPersistent; FRenderType: TVisualAidRenderType; FColor: TColor32; FLineWidth: Single; procedure SetRenderType(const Value: TVisualAidRenderType); procedure SetColor(const Value: TColor32); procedure SetLineWidth(const Value: Single); protected function GetOwner: TPersistent; override; procedure Changed; virtual; public constructor Create(AOwner: TPersistent); virtual; procedure Assign(Source: TPersistent); override; property Owner: TPersistent read FOwner; published property RenderType: TVisualAidRenderType read FRenderType write SetRenderType default vatInvert; property Color: TColor32 read FColor write SetColor; property LineWidth: Single read FLineWidth write SetLineWidth; end; TCustomColorPicker = class(TCustomControl) private FBuffer: TBitmap32; FAdjustCalc: TAdjustCalc; FSelectedColor: TColor32; FBufferValid: Boolean; FVisualAidOptions: TVisualAidOptions; FWebSafe: Boolean; FBorder: Boolean; FOnChanged: TNotifyEvent; procedure SetBorder(const Value: Boolean); procedure SetWebSafe(const Value: Boolean); procedure SetSelectedColor(const Value: TColor32); {$IFDEF FPC} procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND; procedure WMGetDlgCode(var Msg: TLMessage); message LM_GETDLGCODE; {$ELSE} procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND; procedure WMGetDlgCode(var Msg: TWmGetDlgCode); message WM_GETDLGCODE; {$ENDIF} protected procedure Paint; override; procedure PaintBackground; virtual; procedure PaintColorPicker; virtual; abstract; procedure SelectedColorChanged; virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure Invalidate; override; procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; property Border: Boolean read FBorder write SetBorder default False; property VisualAidOptions: TVisualAidOptions read FVisualAidOptions; property SelectedColor: TColor32 read FSelectedColor write SetSelectedColor; property WebSafe: Boolean read FWebSafe write SetWebSafe; property OnChanged: TNotifyEvent read FOnChanged write FOnChanged; end; TColorComponent = (ccRed, ccGreen, ccBlue, ccAlpha); TCustomColorPickerComponent = class(TCustomColorPicker) private FMouseDown: Boolean; FColorComponent: TColorComponent; procedure SetColorComponent(const Value: TColorComponent); protected procedure PaintColorPicker; override; 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; procedure Assign(Source: TPersistent); override; property ColorComponent: TColorComponent read FColorComponent write SetColorComponent; end; TCustomColorPickerRGBA = class(TCustomColorPicker) private FBarHeight: Integer; FSpaceHeight: Integer; procedure SetBarHeight(const Value: Integer); procedure SetSpaceHeight(const Value: Integer); procedure PickAlpha(X, Y: Single); procedure PickBlue(X, Y: Single); procedure PickGreen(X, Y: Single); procedure PickRed(X, Y: Single); protected procedure PaintColorPicker; override; 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; procedure Assign(Source: TPersistent); override; property BarHeight: Integer read FBarHeight write SetBarHeight default 24; property SpaceHeight: Integer read FSpaceHeight write SetSpaceHeight default 8; end; TMarkerType = (mtCross, mtCircle); TCustomColorPickerHS = class(TCustomColorPicker) private FHue: Single; FSaturation: Single; FLockValues: integer; FMarkerType: TMarkerType; procedure PickHue(X, Y: Single); procedure SetHue(const Value: Single); procedure SetSaturation(const Value: Single); procedure SetMarkerType(const Value: TMarkerType); procedure ApplyHS; protected procedure PaintColorPicker; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; procedure SelectedColorChanged; override; public constructor Create(AOwner: TComponent); override; procedure Assign(Source: TPersistent); override; property MarkerType: TMarkerType read FMarkerType write SetMarkerType; property Hue: Single read FHue write SetHue; property Saturation: Single read FSaturation write SetSaturation; end; TCustomColorPickerHSV = class(TCustomColorPicker) private FHue: Single; FSaturation: Single; FValue: Single; FLockValues: integer; FCenter: TFloatPoint; FRadius: TFloat; FCircleSteps: Integer; FVisualAid: TVisualAid; procedure PickHue(X, Y: Single); procedure PickValue(X, Y: Single); procedure SetHue(const Value: Single); procedure SetSaturation(const Value: Single); procedure SetValue(const Value: Single); procedure SetVisualAid(const Value: TVisualAid); procedure ApplyHSV; protected procedure PaintColorPicker; override; 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 SelectedColorChanged; override; public constructor Create(AOwner: TComponent); override; procedure Assign(Source: TPersistent); override; procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; property Hue: Single read FHue write SetHue; property Saturation: Single read FSaturation write SetSaturation; property Value: Single read FValue write SetValue; property VisualAid: TVisualAid read FVisualAid write SetVisualAid; end; TVisualAidGTK = set of (vagHueLine, vagSelection); TCustomColorPickerGTK = class(TCustomColorPicker) private FHue: Single; FSaturation: Single; FValue: Single; FLockValues: integer; FCenter: TFloatPoint; FRadius: TFloat; FInnerRadius: TFloat; FCircleSteps: Integer; FVisualAid: TVisualAidGTK; procedure PickHue(X, Y: Single); procedure PickSaturationValue(X, Y: Single); procedure SetHue(const Value: Single); procedure SetSaturation(const Value: Single); procedure SetValue(const Value: Single); procedure SetVisualAid(const Value: TVisualAidGTK); procedure SetRadius(const Value: TFloat); procedure ApplyHSV; protected procedure PaintColorPicker; override; 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 SelectedColorChanged; override; property Radius: TFloat read FRadius write SetRadius; property Center: TFloatPoint read FCenter write FCenter; public constructor Create(AOwner: TComponent); override; procedure Assign(Source: TPersistent); override; procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; property Hue: Single read FHue write SetHue; property Saturation: Single read FSaturation write SetSaturation; property Value: Single read FValue write SetValue; property VisualAid: TVisualAidGTK read FVisualAid write SetVisualAid; end; TColorPickerComponent = class(TCustomColorPickerComponent) published property Border; property ColorComponent; property SelectedColor; property VisualAidOptions; property WebSafe default False; property OnChanged; property Align; property Anchors; property DragCursor; property DragKind; property Enabled; {$IFDEF HasParentBackground} // property ParentBackground; {$ENDIF} property Color; // Background color property ParentColor; property ParentShowHint; property PopupMenu; property TabOrder; property TabStop; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnMouseEnter; property OnMouseLeave; property OnResize; property OnStartDrag; end; TColorPickerRGBA = class(TCustomColorPickerRGBA) published property BarHeight; property Border; property SelectedColor; property SpaceHeight; property VisualAidOptions; property WebSafe default False; property OnChanged; property Align; property Anchors; property DragCursor; property DragKind; property Enabled; {$IFDEF HasParentBackground} // property ParentBackground; {$ENDIF} property Color; // Background color property ParentColor; property ParentShowHint; property PopupMenu; property TabOrder; property TabStop; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnMouseEnter; property OnMouseLeave; property OnResize; property OnStartDrag; end; TColorPickerHS = class(TCustomColorPickerHS) published property Hue; property MarkerType; property Saturation; property SelectedColor; property WebSafe default False; property OnChanged; property Align; property Anchors; property DragCursor; property DragKind; property Enabled; property ParentShowHint; property PopupMenu; property TabOrder; property TabStop; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnMouseEnter; property OnMouseLeave; property OnResize; property OnStartDrag; end; TColorPickerHSV = class(TCustomColorPickerHSV) published property Border; property Hue; property Saturation; property SelectedColor; property Value; property VisualAid default [vaHueLine, vaSaturationCircle, vaSelection]; property VisualAidOptions; property WebSafe default False; property OnChanged; property Align; property Anchors; property DragCursor; property DragKind; property Enabled; {$IFDEF HasParentBackground} // property ParentBackground; {$ENDIF} property Color; // Background color property ParentColor; property ParentShowHint; property PopupMenu; property TabOrder; property TabStop; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnMouseEnter; property OnMouseLeave; property OnResize; property OnStartDrag; end; TColorPickerGTK = class(TCustomColorPickerGTK) published property Border; property Hue; property Saturation; property SelectedColor; property Value; property VisualAid default [vagHueLine, vagSelection]; property VisualAidOptions; property WebSafe default False; property OnChanged; property Align; property Anchors; property DragCursor; property DragKind; property Enabled; {$IFDEF HasParentBackground} // property ParentBackground; {$ENDIF} property Color; // Background color property ParentColor; property ParentShowHint; property PopupMenu; property TabOrder; property TabStop; {$IFNDEF PLATFORM_INDEPENDENT} property OnCanResize; {$ENDIF} property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnMouseEnter; property OnMouseLeave; property OnResize; property OnStartDrag; end; implementation uses Math, Graphics, GR32_Backends, GR32_Math, GR32_Blend, GR32_VectorUtils; procedure RoundToWebSafe(var Color: TColor32); begin with TColor32Entry(Color) do begin R := ((R + $19) div $33) * $33; G := ((G + $19) div $33) * $33; B := ((B + $19) div $33) * $33; end; end; {$IFDEF MSWINDOWS} function GetDesktopColor(const x, y: Integer): TColor32; var DC: HDC; begin DC := GetWindowDC(GetDesktopWindow); try Result := Color32(GetPixel(DC, x, y)); finally ReleaseDC(GetDesktopWindow, DC); end; end; {$ENDIF} { TVisualAidOptions } constructor TVisualAidOptions.Create(AOwner: TPersistent); begin inherited Create; FOwner := AOwner; FColor := $AF000000; FRenderType := vatInvert; FLineWidth := 2; end; procedure TVisualAidOptions.Assign(Source: TPersistent); begin if (Source is TVisualAidOptions) then begin FRenderType := TVisualAidOptions(Source).RenderType; FColor := TVisualAidOptions(Source).Color; FLineWidth := TVisualAidOptions(Source).LineWidth; Changed; end else inherited; end; procedure TVisualAidOptions.Changed; begin if FOwner is TCustomColorPicker then TCustomColorPicker(Owner).Invalidate; end; function TVisualAidOptions.GetOwner: TPersistent; begin if FOwner is TPersistent then Result := TPersistent(FOwner) else Result := nil; end; procedure TVisualAidOptions.SetColor(const Value: TColor32); begin if FColor <> Value then begin FColor := Value; if FRenderType = vatSolid then Changed; end; end; procedure TVisualAidOptions.SetLineWidth(const Value: Single); begin if FLineWidth <> Value then begin FLineWidth := Value; Changed; end; end; procedure TVisualAidOptions.SetRenderType(const Value: TVisualAidRenderType); begin if FRenderType <> Value then begin FRenderType := Value; Changed; end; end; { TScreenColorPickerForm } constructor TScreenColorPickerForm.Create(AOwner: TComponent); begin inherited CreateNew(AOwner); ControlStyle := ControlStyle + [csOpaque]; BorderIcons := []; BorderStyle := bsNone; Caption := 'Pick a color...'; FormStyle := fsStayOnTop; Position := poDesigned; WindowState := wsMaximized; Cursor := crHandPoint; FSelectedColor := 0; end; procedure TScreenColorPickerForm.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); Params.ExStyle := WS_EX_TRANSPARENT or WS_EX_TOPMOST; // Theoretically this should make Windows use a null brush when clearing the // background (i.e. do nothing), but unfortunately it doesn't seem to work. Params.WindowClass.hbrBackground := NULL_BRUSH; end; function TScreenColorPickerForm.Execute: boolean; begin Result := (ShowModal = mrOK); end; procedure TScreenColorPickerForm.KeyDown(var Key: Word; Shift: TShiftState); begin case Key of VK_ESCAPE: begin ModalResult := mrCancel; Key := 0; end; VK_RETURN: begin ModalResult := mrOK; Key := 0; end; else inherited; end; end; procedure TScreenColorPickerForm.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then begin {$IFDEF MSWINDOWS} FSelectedColor := GetDesktopColor(X, Y); if Assigned(FOnColorSelected) then FOnColorSelected(Self); {$ENDIF} ModalResult := mrOk end else inherited; end; procedure TScreenColorPickerForm.MouseMove(Shift: TShiftState; X, Y: Integer); begin {$IFDEF MSWINDOWS} FSelectedColor := GetDesktopColor(X, Y); {$ENDIF} inherited; end; {$IFDEF FPC} procedure TScreenColorPickerForm.WMEraseBkgnd(var Message: TLMEraseBkgnd); {$ELSE} procedure TScreenColorPickerForm.WMEraseBkgnd(var Message: TWMEraseBkgnd); {$ENDIF} begin // Do not erase window background Message.Result := 1; // Note: Does not work with FPC. The message is processed but the background is still cleared. end; { THueCirclePolygonFiller } constructor THueCirclePolygonFiller.Create(Center: TFloatPoint; WebSafe: Boolean = False); begin FCenter := Center; FWebSafe := WebSafe; inherited Create; end; procedure THueCirclePolygonFiller.FillLine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); var X: Integer; H: Single; const CTwoPiInv = 1 / (2 * Pi); begin for X := DstX to DstX + Length - 1 do begin // calculate squared distance H := 0.5 + ArcTan2(DstY - FCenter.Y, X - FCenter.X) * CTwoPiInv; CombineMem(HSVtoRGB(H, 1, 1), Dst^, AlphaValues^); Inc(Dst); Inc(AlphaValues); end; end; procedure THueCirclePolygonFiller.FillLineWebSafe(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); var X: Integer; H: Single; Color: TColor32; const CTwoPiInv = 1 / (2 * Pi); begin for X := DstX to DstX + Length - 1 do begin // calculate squared distance H := 0.5 + ArcTan2(DstY - FCenter.Y, X - FCenter.X) * CTwoPiInv; Color := HSVtoRGB(H, 1, 1); RoundToWebSafe(Color); CombineMem(Color, Dst^, AlphaValues^); Inc(Dst); Inc(AlphaValues); end; end; function THueCirclePolygonFiller.GetFillLine: TFillLineEvent; begin if FWebSafe then Result := FillLineWebSafe else Result := FillLine; end; { THueSaturationCirclePolygonFiller } constructor THueSaturationCirclePolygonFiller.Create(Center: TFloatPoint; Radius, Value: Single; WebSafe: Boolean = False); begin FRadius := Max(1, Radius); FInvRadius := 1 / FRadius; FValue := Value; inherited Create(Center, WebSafe); end; procedure THueSaturationCirclePolygonFiller.FillLine(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); var X: Integer; SqrYDist, H, S: Single; const CTwoPiInv = 1 / (2 * Pi); begin SqrYDist := Sqr(DstY - FCenter.Y); for X := DstX to DstX + Length - 1 do begin // calculate squared distance H := 0.5 + ArcTan2(DstY - FCenter.Y, X - FCenter.X) * CTwoPiInv; S := Sqrt(Sqr(X - Center.X) + SqrYDist) * FInvRadius; if S > 1 then S := 1; CombineMem(HSVtoRGB(H, S, Value), Dst^, AlphaValues^); Inc(Dst); Inc(AlphaValues); end; end; procedure THueSaturationCirclePolygonFiller.FillLineWebSafe(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); var X: Integer; SqrYDist, H, S: Single; Color: TColor32; const CTwoPiInv = 1 / (2 * Pi); begin SqrYDist := Sqr(DstY - FCenter.Y); for X := DstX to DstX + Length - 1 do begin // calculate squared distance H := 0.5 + ArcTan2(DstY - FCenter.Y, X - FCenter.X) * CTwoPiInv; S := Sqrt(Sqr(X - Center.X) + SqrYDist) * FInvRadius; if S > 1 then S := 1; Color := HSVtoRGB(H, S, Value); RoundToWebSafe(Color); CombineMem(Color, Dst^, AlphaValues^); Inc(Dst); Inc(AlphaValues); end; end; procedure THueSaturationCirclePolygonFiller.SetRadius(const Value: Single); begin if FRadius <> Value then begin FRadius := Value; FInvRadius := 1 / FRadius; end; end; { TBarycentricGradientPolygonFillerEx } procedure TBarycentricGradientPolygonFillerEx.FillLineWebSafe(Dst: PColor32; DstX, DstY, Length: Integer; AlphaValues: PColor32; CombineMode: TCombineMode); var X: Integer; Color32: TColor32; Temp, DotY1, DotY2: TFloat; Barycentric: array [0..1] of TFloat; BlendMemEx: TBlendMemEx; begin BlendMemEx := BLEND_MEM_EX[CombineMode]^; Temp := DstY - FColorPoints[2].Point.Y; DotY1 := FDists[0].X * Temp; DotY2 := FDists[1].X * Temp; for X := DstX to DstX + Length - 1 do begin Temp := (X - FColorPoints[2].Point.X); Barycentric[0] := FDists[0].Y * Temp + DotY1; Barycentric[1] := FDists[1].Y * Temp + DotY2; Color32 := Linear3PointInterpolation(FColorPoints[0].Color32, FColorPoints[1].Color32, FColorPoints[2].Color32, Barycentric[0], Barycentric[1], 1 - Barycentric[1] - Barycentric[0]); RoundToWebSafe(Color32); BlendMemEx(Color32, Dst^, AlphaValues^); Inc(Dst); Inc(AlphaValues); end; end; function TBarycentricGradientPolygonFillerEx.GetFillLine: TFillLineEvent; begin if FWebSafe then Result := FillLineWebSafe else Result := inherited GetFillLine; end; { TCustomColorPicker } constructor TCustomColorPicker.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls]; FBuffer := TBitmap32.Create; FSelectedColor := clSalmon32; FVisualAidOptions := TVisualAidOptions.Create(Self); end; destructor TCustomColorPicker.Destroy; begin FVisualAidOptions.Free; FBuffer.Free; inherited; end; procedure TCustomColorPicker.Assign(Source: TPersistent); begin inherited; if (Source is TCustomColorPicker) then begin FBorder := TCustomColorPicker(Source).Border; FVisualAidOptions.Assign(TCustomColorPicker(Source).VisualAidOptions); FSelectedColor := TCustomColorPicker(Source).SelectedColor; FWebSafe := TCustomColorPicker(Source).WebSafe; FOnChanged := TCustomColorPicker(Source).OnChanged; Invalidate; end; end; procedure TCustomColorPicker.Invalidate; begin FBufferValid := False; inherited; end; procedure TCustomColorPicker.Paint; begin if (Parent = nil) then Exit; if not FBufferValid then begin (FBuffer.Backend as IPaintSupport).ImageNeeded; PaintColorPicker; (FBuffer.Backend as IPaintSupport).CheckPixmap; FBufferValid := True; end; FBuffer.Lock; try (FBuffer.Backend as IDeviceContextSupport).DrawTo(Canvas.Handle, 0, 0); finally FBuffer.Unlock; end; end; procedure TCustomColorPicker.PaintBackground; var BackgroundColor: TColor; begin BackgroundColor := Color; {$ifdef FPC} if (BackgroundColor = clDefault) then BackgroundColor := GetDefaultColor(dctBrush); {$endif} FBuffer.Clear(Color32(BackgroundColor)); end; procedure TCustomColorPicker.SelectedColorChanged; begin if Assigned(FOnChanged) then FOnChanged(Self); Invalidate; end; procedure TCustomColorPicker.SetBorder(const Value: Boolean); begin if FBorder <> Value then begin FBorder := Value; Invalidate; end; end; procedure TCustomColorPicker.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); begin inherited; if (FBuffer <> nil) then FBuffer.SetSize(Width, Height); FBufferValid := False; end; procedure TCustomColorPicker.SetSelectedColor(const Value: TColor32); begin if FSelectedColor <> Value then begin FSelectedColor := Value; SelectedColorChanged; end; end; procedure TCustomColorPicker.SetWebSafe(const Value: Boolean); begin if FWebSafe <> Value then begin FWebSafe := Value; Invalidate; end; end; procedure TCustomColorPicker.WMEraseBkgnd(var Message: {$IFDEF FPC}TLmEraseBkgnd{$ELSE}TWmEraseBkgnd{$ENDIF}); begin Message.Result := 1; end; procedure TCustomColorPicker.WMGetDlgCode(var Msg: {$IFDEF FPC}TLMessage{$ELSE}TWmGetDlgCode{$ENDIF}); begin with Msg do Result := Result or DLGC_WANTARROWS; end; { TCustomColorPickerComponent } constructor TCustomColorPickerComponent.Create(AOwner: TComponent); begin inherited; FVisualAidOptions.Color := clBlack32; FVisualAidOptions.LineWidth := 1.5; end; procedure TCustomColorPickerComponent.Assign(Source: TPersistent); begin inherited; if (Source is TCustomColorPickerComponent) then begin FColorComponent := TCustomColorPickerComponent(Source).ColorComponent; end; end; procedure TCustomColorPickerComponent.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FMouseDown := (Button = mbLeft); inherited; end; procedure TCustomColorPickerComponent.MouseMove(Shift: TShiftState; X, Y: Integer); var Value: Single; Color: TColor32Entry; begin if FMouseDown then begin Value := EnsureRange((X - 3) / (Width - 3), 0, 1); Color := TColor32Entry(SelectedColor); case FColorComponent of ccRed: Color.R := Round(Value * 255); ccGreen: Color.G := Round(Value * 255); ccBlue: Color.B := Round(Value * 255); ccAlpha: Color.A := Round(Value * 255); end; SelectedColor := Color.ARGB; end; inherited; end; procedure TCustomColorPickerComponent.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (Button = mbLeft) then FMouseDown := False; inherited; end; procedure TCustomColorPickerComponent.PaintColorPicker; var Polygon: TArrayOfFloatPoint; InvertFiller: TInvertPolygonFiller; procedure RenderPolygon; begin case FVisualAidOptions.RenderType of vatInvert: PolygonFS(FBuffer, Polygon, InvertFiller); vatBW: if Intensity(FSelectedColor) < 127 then PolygonFS(FBuffer, Polygon, clWhite32) else PolygonFS(FBuffer, Polygon, clBlack32); else PolygonFS(FBuffer, Polygon, FVisualAidOptions.Color); end; end; var X, Y: Integer; ScanLine: PColor32Array; Value: Single; LeftColor, RightColor: TColor32Entry; OddY: Boolean; BorderOffset: Integer; GradientFiller: TLinearGradientPolygonFiller; const CByteScale = 1 / 255; CCheckerBoardColor: array [Boolean] of TColor32 = ($FFA0A0A0, $FF5F5F5F); // Size of indicator triangles IndicatorWidth = 3; IndicatorHeight = 5; begin PaintBackground; BorderOffset := Integer(FBorder); InvertFiller := TInvertPolygonFiller.Create; try LeftColor := TColor32Entry(FSelectedColor); RightColor := TColor32Entry(FSelectedColor); case FColorComponent of ccRed: begin Value := LeftColor.R * CByteScale; LeftColor.R := 0; RightColor.R := 255; LeftColor.A := 255; RightColor.A := 255; end; ccGreen: begin Value := LeftColor.G * CByteScale; LeftColor.G := 0; RightColor.G := 255; LeftColor.A := 255; RightColor.A := 255; end; ccBlue: begin Value := LeftColor.B * CByteScale; LeftColor.B := 0; RightColor.B := 255; LeftColor.A := 255; RightColor.A := 255; end; ccAlpha: begin Value := LeftColor.A * CByteScale; LeftColor.A := 0; RightColor.A := 255; for Y := 0 to Height - 1 do begin OddY := Odd(Y div 8); ScanLine := FBuffer.ScanLine[Y]; for X := IndicatorWidth to Width - IndicatorWidth - 1 do ScanLine^[X] := CCheckerBoardColor[Odd(X shr 3) = OddY]; end; end else Exit; end; GradientFiller := TLinearGradientPolygonFiller.Create; try GradientFiller.SimpleGradientX(IndicatorWidth, LeftColor.ARGB, Width - IndicatorWidth, RightColor.ARGB); PolygonFS(FBuffer, Rectangle(FloatRect(IndicatorWidth, 0, Width - IndicatorWidth, Height)), GradientFiller); finally GradientFiller.Free; end; if FBorder then begin FBuffer.FrameRectTS(IndicatorWidth, 0, Width - IndicatorWidth, Height, $DF000000); {$ifdef GR32_FRAME3D} FBuffer.RaiseRectTS(IndicatorWidth+1, 0, Width - IndicatorWidth - 1, Height - 1, 20); {$endif} end; SetLength(Polygon, 3); Polygon[0] := FloatPoint(IndicatorWidth + Value * (Width - 2*IndicatorWidth), Height - BorderOffset - IndicatorHeight); Polygon[1] := FloatPoint(Polygon[0].X - IndicatorWidth, Polygon[0].Y + IndicatorHeight); Polygon[2] := FloatPoint(Polygon[0].X + IndicatorWidth, Polygon[0].Y + IndicatorHeight); RenderPolygon; Polygon[0].Y := BorderOffset + IndicatorHeight; Polygon[1].Y := BorderOffset; Polygon[2].Y := BorderOffset; RenderPolygon; finally InvertFiller.Free; end; inherited; end; procedure TCustomColorPickerComponent.SetColorComponent( const Value: TColorComponent); begin if FColorComponent <> Value then begin FColorComponent := Value; Invalidate; end; end; { TCustomColorPickerRGBA } constructor TCustomColorPickerRGBA.Create(AOwner: TComponent); begin inherited; FBarHeight := 24; FSpaceHeight := 8; FVisualAidOptions.Color := clBlack32; FVisualAidOptions.LineWidth := 1.5; Height := 4*FBarHeight + 3*FSpaceHeight; Width := 3*Height; end; procedure TCustomColorPickerRGBA.Assign(Source: TPersistent); begin inherited; if (Source is TCustomColorPickerRGBA) then begin FBarHeight := TCustomColorPickerRGBA(Source).BarHeight; FSpaceHeight := TCustomColorPickerRGBA(Source).SpaceHeight; end; end; procedure TCustomColorPickerRGBA.PickRed(X, Y: Single); var Value: Single; Color: TColor32Entry; begin Value := EnsureRange((X - 3) / (Width - 3), 0, 1); Color := TColor32Entry(SelectedColor); Color.R := Round(Value * 255); SelectedColor := Color.ARGB; end; procedure TCustomColorPickerRGBA.PickGreen(X, Y: Single); var Value: Single; Color: TColor32Entry; begin Value := EnsureRange((X - 3) / (Width - 3), 0, 1); Color := TColor32Entry(SelectedColor); Color.G := Round(Value * 255); SelectedColor := Color.ARGB; end; procedure TCustomColorPickerRGBA.PickBlue(X, Y: Single); var Value: Single; Color: TColor32Entry; begin Value := EnsureRange((X - 3) / (Width - 3), 0, 1); Color := TColor32Entry(SelectedColor); Color.B := Round(Value * 255); SelectedColor := Color.ARGB; end; procedure TCustomColorPickerRGBA.PickAlpha(X, Y: Single); var Value: Single; Color: TColor32Entry; begin Value := EnsureRange((X - 3) / (Width - 3), 0, 1); Color := TColor32Entry(SelectedColor); Color.A := Round(Value * 255); SelectedColor := Color.ARGB; end; procedure TCustomColorPickerRGBA.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var Index: Integer; begin if (Button = mbLeft) and (X >= 3) or (X <= Width - 3) then begin Index := Y div (FBarHeight + FSpaceHeight); case Index of 0: FAdjustCalc := PickRed; 1: FAdjustCalc := PickGreen; 2: FAdjustCalc := PickBlue; 3: FAdjustCalc := PickAlpha; end; end; if Assigned(FAdjustCalc) then FAdjustCalc(X, Y); inherited; end; procedure TCustomColorPickerRGBA.MouseMove(Shift: TShiftState; X, Y: Integer); begin if (ssLeft in Shift) and Assigned(FAdjustCalc) then FAdjustCalc(X, Y); inherited; end; procedure TCustomColorPickerRGBA.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FAdjustCalc := nil; inherited; end; procedure TCustomColorPickerRGBA.PaintColorPicker; var Polygon: TArrayOfFloatPoint; InvertFiller: TInvertPolygonFiller; procedure RenderPolygon; begin case FVisualAidOptions.RenderType of vatInvert: PolygonFS(FBuffer, Polygon, InvertFiller); vatBW: if Intensity(FSelectedColor) < 127 then PolygonFS(FBuffer, Polygon, clWhite32) else PolygonFS(FBuffer, Polygon, clBlack32); else PolygonFS(FBuffer, Polygon, FVisualAidOptions.Color); end; end; var X, Y, Index: Integer; ScanLine: PColor32Array; Value: Single; LeftColor, RightColor: TColor32Entry; ValueRect: TRect; OddY: Boolean; BorderOffset: Integer; GradientFiller: TLinearGradientPolygonFiller; const CByteScale = 1 / 255; CCheckerBoardColor: array [Boolean] of TColor32 = ($FFA0A0A0, $FF5F5F5F); // Size of indicator triangles IndicatorWidth = 3; IndicatorHeight = 5; begin PaintBackground; BorderOffset := Integer(FBorder); SetLength(Polygon, 3); InvertFiller := TInvertPolygonFiller.Create; try for Index := 0 to 3 do begin ValueRect := Rect(IndicatorWidth, Index * (FBarHeight + FSpaceHeight), Width - IndicatorWidth, Index * (FBarHeight + FSpaceHeight) + FBarHeight); LeftColor := TColor32Entry(FSelectedColor); RightColor := TColor32Entry(FSelectedColor); case Index of 0: begin Value := LeftColor.R * CByteScale; LeftColor.R := 0; RightColor.R := 255; LeftColor.A := 255; RightColor.A := 255; end; 1: begin Value := LeftColor.G * CByteScale; LeftColor.G := 0; RightColor.G := 255; LeftColor.A := 255; RightColor.A := 255; end; 2: begin Value := LeftColor.B * CByteScale; LeftColor.B := 0; RightColor.B := 255; LeftColor.A := 255; RightColor.A := 255; end; 3: begin Value := LeftColor.A * CByteScale; LeftColor.A := 0; RightColor.A := 255; for Y := ValueRect.Top to Min(ValueRect.Bottom, Height) - 1 do begin OddY := Odd(Y div 8); ScanLine := FBuffer.ScanLine[Y]; for X := ValueRect.Left to ValueRect.Right - 1 do ScanLine^[X] := CCheckerBoardColor[Odd(X shr 3) = OddY]; end; end; else Exit; end; GradientFiller := TLinearGradientPolygonFiller.Create; try GradientFiller.SimpleGradientX(ValueRect.Left, LeftColor.ARGB, ValueRect.Right, RightColor.ARGB); PolygonFS(FBuffer, Rectangle(FloatRect(ValueRect)), GradientFiller); finally GradientFiller.Free; end; if FBorder then begin FBuffer.FrameRectTS(ValueRect, $DF000000); {$ifdef GR32_FRAME3D} FBuffer.RaiseRectTS(ValueRect.Left + 1, ValueRect.Top + 1, ValueRect.Right - 1, ValueRect.Bottom - 1, 20); {$endif} end; Polygon[0] := FloatPoint(IndicatorWidth + Value * (Width - 2*IndicatorWidth), ValueRect.Bottom - BorderOffset - IndicatorHeight); Polygon[1] := FloatPoint(Polygon[0].X - IndicatorWidth, Polygon[0].Y + IndicatorHeight); Polygon[2] := FloatPoint(Polygon[0].X + IndicatorWidth, Polygon[0].Y + IndicatorHeight); RenderPolygon; Polygon[0].Y := ValueRect.Top + BorderOffset + IndicatorHeight; Polygon[1].Y := ValueRect.Top + BorderOffset; Polygon[2].Y := ValueRect.Top + BorderOffset; RenderPolygon; end; finally InvertFiller.Free; end; inherited; end; procedure TCustomColorPickerRGBA.SetBarHeight(const Value: Integer); begin if FBarHeight <> Value then begin FBarHeight := Value; Invalidate; end; end; procedure TCustomColorPickerRGBA.SetSpaceHeight(const Value: Integer); begin if FSpaceHeight <> Value then begin FSpaceHeight := Value; Invalidate; end; end; { TCustomColorPickerHS } constructor TCustomColorPickerHS.Create(AOwner: TComponent); var Luminance: Single; begin inherited; FVisualAidOptions.Color := clBlack32; FVisualAidOptions.LineWidth := 1.5; RGBtoHSL(FSelectedColor, FHue, FSaturation, Luminance); end; procedure TCustomColorPickerHS.Assign(Source: TPersistent); begin inherited; if (Source is TCustomColorPickerHS) then begin FMarkerType := TCustomColorPickerHS(Source).MarkerType; FHue := TCustomColorPickerHS(Source).Hue; FSaturation := TCustomColorPickerHS(Source).Saturation; end; end; procedure TCustomColorPickerHS.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then PickHue(X, Y); inherited; end; procedure TCustomColorPickerHS.MouseMove(Shift: TShiftState; X, Y: Integer); begin if (ssLeft in Shift) then PickHue(X, Y); inherited; end; procedure TCustomColorPickerHS.PaintColorPicker; var X, Y: Integer; Saturation, InvWidth, InvHeight: Single; Line: PColor32Array; Pos: TFloatPoint; VectorData: TArrayOfArrayOfFloatPoint; InvertFiller: TInvertPolygonFiller; begin InvWidth := 1 / FBuffer.Width; InvHeight := 1 / FBuffer.Height; if FWebSafe then for Y := 0 to FBuffer.Height - 1 do begin Line := FBuffer.ScanLine[Y]; Saturation := 1 - Y * InvHeight; for X := 0 to FBuffer.Width - 1 do begin Line^[X] := HSLtoRGB(X * InvWidth, Saturation, 0.5); RoundToWebSafe(Line^[X]); end; end else for Y := 0 to FBuffer.Height - 1 do begin Line := FBuffer.ScanLine[Y]; Saturation := 1 - Y * InvHeight; for X := 0 to FBuffer.Width - 1 do Line^[X] := HSLtoRGB(X * InvWidth, Saturation, 0.5); end; Pos.X := Round(FHue * FBuffer.Width); Pos.Y := Round((1 - FSaturation) * FBuffer.Height); case FMarkerType of mtCross: begin SetLength(VectorData, 4); VectorData[0] := HorzLine(Pos.X - 5, Pos.Y, Pos.X - 2); VectorData[1] := HorzLine(Pos.X + 2, Pos.Y, Pos.X + 5); VectorData[2] := VertLine(Pos.X, Pos.Y - 5, Pos.Y - 2); VectorData[3] := VertLine(Pos.X, Pos.Y + 2, Pos.Y + 5); case FVisualAidOptions.RenderType of vatSolid: PolyPolylineFS(FBuffer, VectorData, FVisualAidOptions.Color, False, FVisualAidOptions.LineWidth); vatInvert: begin InvertFiller := TInvertPolygonFiller.Create; try PolyPolylineFS(FBuffer, VectorData, InvertFiller, False, FVisualAidOptions.LineWidth) finally InvertFiller.Free; end; end; vatBW: PolyPolylineFS(FBuffer, VectorData, FVisualAidOptions.Color, False, FVisualAidOptions.LineWidth); end; end; mtCircle: begin SetLength(VectorData, 1); VectorData[0] := Circle(Pos, 4, 12); PolygonFS(FBuffer, VectorData[0], FSelectedColor); case FVisualAidOptions.RenderType of vatSolid: PolylineFS(FBuffer, VectorData[0], FVisualAidOptions.Color, True, FVisualAidOptions.LineWidth); vatInvert: begin InvertFiller := TInvertPolygonFiller.Create; try PolylineFS(FBuffer, VectorData[0], InvertFiller, True, 1.5) finally InvertFiller.Free; end; end; vatBW: PolylineFS(FBuffer, VectorData[0], FVisualAidOptions.Color, True, 1.5); end; end; end; end; procedure TCustomColorPickerHS.ApplyHS; var H, S, L: Single; begin RGBtoHSL(FSelectedColor, H, S, L); Inc(FLockValues); try SelectedColor := HSLtoRGB(FHue, FSaturation, L, SelectedColor shr 24); finally Dec(FLockValues); end; end; procedure TCustomColorPickerHS.PickHue(X, Y: Single); begin FHue := EnsureRange(X / FBuffer.Width, 0, 1); FSaturation := EnsureRange(1 - Y / FBuffer.Height, 0, 1); ApplyHS; end; procedure TCustomColorPickerHS.SelectedColorChanged; var H, S, L: Single; begin if (FLockValues = 0) then begin RGBtoHSL(FSelectedColor, H, S, L); FHue := H; FSaturation := S; end; inherited; end; procedure TCustomColorPickerHS.SetHue(const Value: Single); begin if FHue <> Value then begin FHue := Value; ApplyHS; end; end; procedure TCustomColorPickerHS.SetSaturation(const Value: Single); begin if FSaturation <> Value then begin FSaturation := Value; ApplyHS; end; end; procedure TCustomColorPickerHS.SetMarkerType(const Value: TMarkerType); begin if FMarkerType <> Value then begin FMarkerType := Value; Invalidate; end; end; { TCustomColorPickerHSV } constructor TCustomColorPickerHSV.Create(AOwner: TComponent); begin inherited Create(AOwner); FVisualAid := [vaHueLine, vaSaturationCircle, vaSelection]; FVisualAidOptions.LineWidth := 1.5; RGBToHSV(FSelectedColor, FHue, FSaturation, FValue); { Setting a initial size here will cause the control to crash under LCL } {$IFNDEF FPC} Height := 192; Width := 256; {$ENDIF} end; procedure TCustomColorPickerHSV.Assign(Source: TPersistent); begin inherited; if (Source is TCustomColorPickerHSV) then begin FHue := TCustomColorPickerHSV(Source).Hue; FSaturation := TCustomColorPickerHSV(Source).Saturation; FValue := TCustomColorPickerHSV(Source).Value; FVisualAid := TCustomColorPickerHSV(Source).VisualAid; end; end; procedure TCustomColorPickerHSV.PaintColorPicker; var Polygon: TArrayOfFloatPoint; ValueRect: TRect; GradientFiller: TLinearGradientPolygonFiller; HueSaturationFiller: THueSaturationCirclePolygonFiller; InvertFiller: TInvertPolygonFiller; LineWidth: Single; begin PaintBackground; Polygon := Circle(FCenter, FRadius, FCircleSteps); HueSaturationFiller := THueSaturationCirclePolygonFiller.Create(FCenter, FRadius, FValue, FWebSafe); try PolygonFS(FBuffer, Polygon, HueSaturationFiller); finally HueSaturationFiller.Free; end; if FBorder then PolylineFS(FBuffer, Polygon, clBlack32, True, 1); LineWidth := FVisualAidOptions.LineWidth; InvertFiller := TInvertPolygonFiller.Create; try if vaSaturationCircle in FVisualAid then begin Polygon := Circle(FCenter, FSaturation * FRadius, -1); case FVisualAidOptions.RenderType of vatInvert: PolylineFS(FBuffer, Polygon, InvertFiller, True, LineWidth); vatBW: if Intensity(FSelectedColor) < 127 then PolylineFS(FBuffer, Polygon, clWhite32, True, LineWidth) else PolylineFS(FBuffer, Polygon, clBlack32, True, LineWidth); else PolylineFS(FBuffer, Polygon, FVisualAidOptions.Color, True, LineWidth); end; end; if vaHueLine in FVisualAid then begin SetLength(Polygon, 2); Polygon[0] := FCenter; Polygon[1] := FloatPoint( FCenter.X - FRadius * Cos(2 * Pi * FHue), FCenter.Y - FRadius * Sin(2 * Pi * FHue)); case FVisualAidOptions.RenderType of vatInvert: PolylineFS(FBuffer, Polygon, InvertFiller, False, LineWidth); vatBW: if Intensity(FSelectedColor) < 127 then PolylineFS(FBuffer, Polygon, clWhite32, False, LineWidth) else PolylineFS(FBuffer, Polygon, clBlack32, False, LineWidth); else PolylineFS(FBuffer, Polygon, FVisualAidOptions.Color, False, LineWidth); end; end; if vaSelection in FVisualAid then begin Polygon := Circle( FCenter.X - FSaturation * FRadius * Cos(2 * Pi * FHue), FCenter.Y - FSaturation * FRadius * Sin(2 * Pi * FHue), 4, 8); PolygonFS(FBuffer, Polygon, FSelectedColor); case FVisualAidOptions.RenderType of vatInvert: PolylineFS(FBuffer, Polygon, InvertFiller, True, LineWidth); vatBW: if Intensity(FSelectedColor) < 127 then PolylineFS(FBuffer, Polygon, clWhite32, True, LineWidth) else PolylineFS(FBuffer, Polygon, clBlack32, True, LineWidth); else PolylineFS(FBuffer, Polygon, FVisualAidOptions.Color, True, LineWidth); end; end; ValueRect := Rect(Width - 24, 8, Width - 8, Height - 8); Polygon := Rectangle(FloatRect(ValueRect)); GradientFiller := TLinearGradientPolygonFiller.Create; try GradientFiller.SimpleGradientY(ValueRect.Top, clWhite32, ValueRect.Bottom, clBlack32); PolygonFS(FBuffer, Polygon, GradientFiller); finally GradientFiller.Free; end; SetLength(Polygon, 3); Polygon[0] := FloatPoint(Width - 8, 8 + (1 - FValue) * (Height - 16)); Polygon[1] := FloatPoint(Polygon[0].X + 7, Polygon[0].Y - 4); Polygon[2] := FloatPoint(Polygon[0].X + 7, Polygon[0].Y + 4); case FVisualAidOptions.RenderType of vatInvert: PolygonFS(FBuffer, Polygon, InvertFiller); vatBW: if Intensity(FSelectedColor) < 127 then PolygonFS(FBuffer, Polygon, clWhite32) else PolygonFS(FBuffer, Polygon, clBlack32); else PolygonFS(FBuffer, Polygon, FVisualAidOptions.Color); end; if FBorder then begin FBuffer.FrameRectTS(ValueRect, $DF000000); {$ifdef GR32_FRAME3D} FBuffer.RaiseRectTS(ValueRect.Left + 1, ValueRect.Top + 1, ValueRect.Right - 1, ValueRect.Bottom - 1, 20); {$endif} end; finally InvertFiller.Free; end; inherited; end; procedure TCustomColorPickerHSV.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then begin if X > Width - 28 then FAdjustCalc := PickValue else FAdjustCalc := PickHue; end; if Assigned(FAdjustCalc) then FAdjustCalc(X, Y); inherited; end; procedure TCustomColorPickerHSV.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FAdjustCalc := nil; inherited; end; procedure TCustomColorPickerHSV.MouseMove(Shift: TShiftState; X, Y: Integer); begin if (ssLeft in Shift) and Assigned(FAdjustCalc) then FAdjustCalc(X, Y); inherited; end; procedure TCustomColorPickerHSV.ApplyHSV; begin Inc(FLockValues); try SelectedColor := HSVtoRGB(FHue, FSaturation, FValue, SelectedColor shr 24); finally Dec(FLockValues); end; end; procedure TCustomColorPickerHSV.PickHue(X, Y: Single); const CTwoPiInv = 1 / (2 * Pi); begin FHue := 0.5 + ArcTan2(Y - FCenter.Y, X - FCenter.X) * CTwoPiInv; FSaturation := Sqrt(Sqr(Y - FCenter.Y) + Sqr(X - FCenter.X)) / FRadius; if FSaturation > 1 then FSaturation := 1; ApplyHSV; end; procedure TCustomColorPickerHSV.PickValue(X, Y: Single); begin Value := 1 - EnsureRange((Y - 8) / (Height - 16), 0, 1); end; procedure TCustomColorPickerHSV.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); begin inherited; if Height < Width then begin FRadius := Min(0.5 * Width - 1 - 16, 0.5 * Height - 1); FCircleSteps := CalculateCircleSteps(FRadius); FCenter := FloatPoint(0.5 * Width - 16, 0.5 * Height); end else begin FRadius := Min(0.5 * Width - 1, 0.5 * Height - 1 - 16); FCircleSteps := CalculateCircleSteps(FRadius); FCenter := FloatPoint(0.5 * Width, 0.5 * Height - 16); end; end; procedure TCustomColorPickerHSV.SetHue(const Value: Single); begin if FHue <> Value then begin FHue := Value; ApplyHSV; end; end; procedure TCustomColorPickerHSV.SetSaturation(const Value: Single); begin if FSaturation <> Value then begin FSaturation := Value; ApplyHSV; end; end; procedure TCustomColorPickerHSV.SelectedColorChanged; var H, S, V: Single; begin if (FLockValues = 0) then begin RGBtoHSV(FSelectedColor, H, S, V); FHue := H; FSaturation := S; FValue := V; end; inherited; end; procedure TCustomColorPickerHSV.SetValue(const Value: Single); begin if FValue <> Value then begin FValue := Value; ApplyHSV; end; end; procedure TCustomColorPickerHSV.SetVisualAid(const Value: TVisualAid); begin if FVisualAid <> Value then begin FVisualAid := Value; Invalidate; end; end; { TCustomColorPickerGTK } constructor TCustomColorPickerGTK.Create(AOwner: TComponent); begin inherited Create(AOwner); FVisualAid := [vagHueLine, vagSelection]; FVisualAidOptions.RenderType := vatBW; FVisualAidOptions.LineWidth := 2; RGBToHSV(FSelectedColor, FHue, FSaturation, FValue); { Setting a initial size here will cause the control to crash under LCL } {$IFNDEF FPC} Height := 192; Width := 192; {$ENDIF} end; procedure TCustomColorPickerGTK.Assign(Source: TPersistent); begin inherited; if (Source is TCustomColorPickerGTK) then begin FHue := TCustomColorPickerGTK(Source).Hue; FSaturation := TCustomColorPickerGTK(Source).Saturation; FValue := TCustomColorPickerGTK(Source).Value; FVisualAid := TCustomColorPickerGTK(Source).VisualAid; end; end; procedure TCustomColorPickerGTK.PaintColorPicker; var Polygon: TArrayOfFloatPoint; HueBand: TArrayOfArrayOfFloatPoint; GradientFiller: TBarycentricGradientPolygonFillerEx; HueFiller: THueCirclePolygonFiller; InvertFiller: TInvertPolygonFiller; Pos: TFloatPoint; HalfInnerRadius: Single; LineWidth: Single; const CY = 1.7320508075688772935274463415059; begin PaintBackground; // Don't use BuildPolyPolyline to build HueBand; We need both inner and outer // polygons to be free of self-intersections as we use them to draw the border. HueBand := [ Circle(FCenter, FRadius, FCircleSteps), ReversePolygon(Circle(FCenter, FInnerRadius, FCircleSteps)) ]; HueFiller := THueCirclePolygonFiller.Create(FCenter, FWebSafe); try PolyPolygonFS(FBuffer, HueBand, HueFiller); finally HueFiller.Free; end; LineWidth := FVisualAidOptions.LineWidth; if vagHueLine in FVisualAid then begin SetLength(Polygon, 2); Polygon[0] := FloatPoint( FCenter.X - FInnerRadius * Cos(2 * Pi * FHue), FCenter.Y - FInnerRadius * Sin(2 * Pi * FHue)); Polygon[1] := FloatPoint( FCenter.X - FRadius * Cos(2 * Pi * FHue), FCenter.Y - FRadius * Sin(2 * Pi * FHue)); case FVisualAidOptions.RenderType of vatSolid: PolylineFS(FBuffer, Polygon, FVisualAidOptions.Color, False, LineWidth); vatInvert: begin InvertFiller := TInvertPolygonFiller.Create; try PolylineFS(FBuffer, Polygon, InvertFiller, False, LineWidth); finally InvertFiller.Free; end; end; vatBW: if Intensity(HSVtoRGB(FHue, 1, 1)) < 127 then PolylineFS(FBuffer, Polygon, $F0FFFFFF, True, LineWidth) else PolylineFS(FBuffer, Polygon, $F0000000, True, LineWidth) end; end; SetLength(Polygon, 3); GR32_Math.SinCos(2 * Pi * FHue, Pos.Y, Pos.X); Polygon[0] := FloatPoint( FCenter.X - FInnerRadius * Pos.X, FCenter.Y - FInnerRadius * Pos.Y); HalfInnerRadius := 0.5 * FInnerRadius; Pos := FloatPoint(Pos.X + CY * Pos.Y, Pos.X * CY - Pos.Y); Polygon[1] := FloatPoint( FCenter.X + HalfInnerRadius * Pos.X, FCenter.Y - HalfInnerRadius * Pos.Y); HalfInnerRadius := 0.5 * HalfInnerRadius; Pos := FloatPoint(Pos.X - CY * Pos.Y, Pos.Y + Pos.X * CY); Polygon[2] := FloatPoint( FCenter.X - HalfInnerRadius * Pos.X, FCenter.Y + HalfInnerRadius * Pos.Y); GradientFiller := TBarycentricGradientPolygonFillerEx.Create; try GradientFiller.SetPoints(Polygon); GradientFiller.Color[0] := HSVtoRGB(Hue, 1, 1); GradientFiller.Color[1] := clWhite32; GradientFiller.Color[2] := clBlack32; GradientFiller.WebSafe := FWebSafe; PolygonFS(FBuffer, Polygon, GradientFiller); finally GradientFiller.Free; end; if FBorder then begin PolyPolygonFS(FBuffer, BuildPolyPolyline(HueBand, True, 1), clBlack32); PolylineFS(FBuffer, Polygon, clBlack32, True, 1); end; if vagSelection in FVisualAid then begin Polygon := Circle( Polygon[2].X + FValue * (Polygon[1].X + FSaturation * (Polygon[0].X - Polygon[1].X) - Polygon[2].X), Polygon[2].Y + FValue * (Polygon[1].Y + FSaturation * (Polygon[0].Y - Polygon[1].Y) - Polygon[2].Y), 4, 12); PolygonFS(FBuffer, Polygon, FSelectedColor); case FVisualAidOptions.RenderType of vatSolid: PolylineFS(FBuffer, Polygon, FVisualAidOptions.Color, True, LineWidth); vatInvert: begin InvertFiller := TInvertPolygonFiller.Create; try PolylineFS(FBuffer, Polygon, InvertFiller, True, LineWidth); finally InvertFiller.Free; end; end; vatBW: if Intensity(FSelectedColor) < 127 then PolylineFS(FBuffer, Polygon, clWhite32, True, LineWidth) else PolylineFS(FBuffer, Polygon, clBlack32, True, LineWidth) end end; inherited; end; procedure TCustomColorPickerGTK.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then begin if Sqrt(Sqr(X - FCenter.X) + Sqr(Y - FCenter.Y)) > FInnerRadius then FAdjustCalc := PickHue else FAdjustCalc := PickSaturationValue; end; if Assigned(FAdjustCalc) then FAdjustCalc(X, Y); inherited; end; procedure TCustomColorPickerGTK.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FAdjustCalc := nil; inherited; end; procedure TCustomColorPickerGTK.MouseMove(Shift: TShiftState; X, Y: Integer); begin if (ssLeft in Shift) and Assigned(FAdjustCalc) then FAdjustCalc(X, Y); inherited; end; procedure TCustomColorPickerGTK.ApplyHSV; begin Inc(FLockValues); try SelectedColor := HSVtoRGB(FHue, FSaturation, FValue, SelectedColor shr 24); finally Dec(FLockValues); end; end; procedure TCustomColorPickerGTK.PickHue(X, Y: Single); const CTwoPiInv = 1 / (2 * Pi); begin Hue := 0.5 + ArcTan2(Y - FCenter.Y, X - FCenter.X) * CTwoPiInv; end; procedure TCustomColorPickerGTK.PickSaturationValue(X, Y: Single); var Sampler: TBarycentricGradientSampler; Pos: TFloatPoint; Color: TColor32; H: Single; const CY = 1.7320508075688772935274463415059; begin Sampler := TBarycentricGradientSampler.Create; try GR32_Math.SinCos(2 * Pi * FHue, Pos.Y, Pos.X); Sampler.Point[0] := FloatPoint( FCenter.X - FInnerRadius * Pos.X, FCenter.Y - FInnerRadius * Pos.Y); Pos := FloatPoint(-0.5 * (Pos.X + CY * Pos.Y), 0.5 * (Pos.X * CY - Pos.Y)); Sampler.Point[1] := FloatPoint( FCenter.X - FInnerRadius * Pos.X, FCenter.Y - FInnerRadius * Pos.Y); Pos := FloatPoint(-0.5 * (Pos.X + CY * Pos.Y), 0.5 * (Pos.X * CY - Pos.Y)); Sampler.Point[2] := FloatPoint( FCenter.X - FInnerRadius * Pos.X, FCenter.Y - FInnerRadius * Pos.Y); Sampler.Color[0] := HSVtoRGB(FHue, 1, 1); Sampler.Color[1] := clWhite32; Sampler.Color[2] := clBlack32; Sampler.PrepareSampling; Color := Sampler.GetSampleFloatInTriangle(X, Y); finally Sampler.Free; end; RGBtoHSV(Color, H, FSaturation, FValue); ApplyHSV; end; procedure TCustomColorPickerGTK.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); begin inherited; Radius := Min(0.5 * Width - 1, 0.5 * Height - 1); Center := FloatPoint(0.5 * Width, 0.5 * Height); end; procedure TCustomColorPickerGTK.SetHue(const Value: Single); begin if FHue <> Value then begin FHue := Value; ApplyHSV; end; end; procedure TCustomColorPickerGTK.SetRadius(const Value: TFloat); begin if FRadius <> Value then begin FRadius := Value; FInnerRadius := 0.8 * FRadius; FCircleSteps := CalculateCircleSteps(FRadius); end; end; procedure TCustomColorPickerGTK.SetSaturation(const Value: Single); begin if FSaturation <> Value then begin FSaturation := Value; ApplyHSV; end; end; procedure TCustomColorPickerGTK.SelectedColorChanged; var H, S, V: Single; begin if (FLockValues = 0) then begin RGBtoHSV(FSelectedColor, H, S, V); FHue := H; FSaturation := S; FValue := V; end; inherited; end; procedure TCustomColorPickerGTK.SetValue(const Value: Single); begin if FValue <> Value then begin FValue := Value; ApplyHSV; end; end; procedure TCustomColorPickerGTK.SetVisualAid(const Value: TVisualAidGTK); begin if FVisualAid <> Value then begin FVisualAid := Value; Invalidate; end; end; end.