summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/gui/fpg_colormapping.pas138
-rw-r--r--src/gui/fpg_colorwheel.pas573
2 files changed, 711 insertions, 0 deletions
diff --git a/src/gui/fpg_colormapping.pas b/src/gui/fpg_colormapping.pas
new file mode 100644
index 00000000..9f486bbf
--- /dev/null
+++ b/src/gui/fpg_colormapping.pas
@@ -0,0 +1,138 @@
+{
+ fpGUI - Free Pascal GUI Library
+
+ Copyright (C) 2006 - 2009 See the file AUTHORS.txt, included in this
+ distribution, for details of the copyright.
+
+ See the file COPYING.modifiedLGPL, included in this distribution,
+ for details about redistributing fpGUI.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ Description:
+ This unit contains some color conversion/mapping functions.
+}
+
+unit fpg_ColorMapping;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, fpg_base;
+
+ // IN these functions the following definitions apply:
+ // Hue: 0 - 1535
+ // red = 0 green = 512 blue = 1024
+ // Saturation: 0 - 1
+ // grey (no color) = 0 max color = 1
+ // Value: 0 - 1
+ // black =0 max brightness = 1
+
+procedure RGBToHSV(C: TfpgColor; out Hue: longint; out Saturation, Value: double);
+function HSVToRGB(const H: longint; const S, V: double): TfpgColor;
+
+implementation
+
+uses
+ Math;
+
+procedure RGBToHSV(C: TfpgColor; out Hue: longint; out Saturation, Value: double);
+var
+ r, g, b: longint;
+ hi, lo: longint;
+ d: longint;
+ rgb: TRGBTriple;
+begin
+ rgb := fpgColorToRGBTriple(C);
+ r := rgb.Red;
+ g := rgb.Green;
+ b := rgb.Blue;
+ hi := max(max(r, g), b);
+ lo := min(min(r, g), b);
+ d := hi - lo;
+ Value := hi / 256;
+ if d > 0 then
+ begin
+ if r = hi then
+ Hue := 256 * (g - b) div d
+ else if g = hi then
+ Hue := 512 + 256 * (b - r) div d
+ else
+ Hue := 1024 + 256 * (r - g) div d;
+ if Hue < 0 then
+ Hue := Hue + 1536;
+ end
+ else
+ Hue := 0; // doesn't matter (grey: Sat = 0)
+
+ if hi > 0 then
+ Saturation := d / hi
+ else
+ Saturation := 0; // doesn't matter (black: Val = 0
+end;
+
+function HSVToRGB(const H: longint; const S, V: double): TfpgColor;
+var
+ r, g, b: longint;
+ rgb: TRGBTriple;
+begin
+ if (h < 0) or (h > 1535) or (S < 0) or (S > 1) or (V < 0) or (V > 1) then
+ begin
+ // Invalid value, use black
+ Result := 0;
+ exit;
+ end;
+ case h div 256 of
+ 0:
+ begin
+ r := 255;
+ g := h;
+ b := 0;
+ end;
+ 1:
+ begin
+ r := 511 - h;
+ g := 255;
+ b := 0;
+ end;
+ 2:
+ begin
+ r := 0;
+ g := 255;
+ b := h - 512;
+ end;
+ 3:
+ begin
+ r := 0;
+ g := 1023 - h;
+ b := 255;
+ end;
+ 4:
+ begin
+ r := h - 1024;
+ g := 0;
+ b := 255;
+ end;
+ 5:
+ begin
+ r := 255;
+ g := 0;
+ b := 1535 - h;
+ end;
+ end;
+ r := Trunc(V * (255 - S * (255 - r)));
+ g := Trunc(V * (255 - S * (255 - g)));
+ b := Trunc(V * (255 - S * (255 - b)));
+ rgb.Red := r;
+ rgb.Green := g;
+ rgb.Blue := b;
+ Result := RGBTripleTofpgColor(rgb);
+end;
+
+
+end.
+
diff --git a/src/gui/fpg_colorwheel.pas b/src/gui/fpg_colorwheel.pas
new file mode 100644
index 00000000..103ce35d
--- /dev/null
+++ b/src/gui/fpg_colorwheel.pas
@@ -0,0 +1,573 @@
+{
+ fpGUI - Free Pascal GUI Library
+
+ Copyright (C) 2006 - 2009 See the file AUTHORS.txt, included in this
+ distribution, for details of the copyright.
+
+ See the file COPYING.modifiedLGPL, included in this distribution,
+ for details about redistributing fpGUI.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ Description:
+ This unit implements color selectors using a ColorWheel and
+ a ValueBar. Color results are in HSV format.
+}
+
+unit fpg_ColorWheel;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, fpg_base, fpg_main, fpg_widget;
+
+type
+ // forward declaration
+ TfpgValueBar = class;
+
+ TfpgColorWheel = class(TfpgWidget)
+ protected
+ FValueBar: TfpgValueBar;
+ FHue: longint;
+ FSaturation: double;
+ FMarginWidth: longint;
+ FCursorSize: longint;
+ FWhiteAreaPercent: longint; // 0 to 50 percent of circle radius that is pure white
+ FOnChange: TNotifyEvent;
+ FImage: TfpgImage; // cached colorwheel image
+ procedure HSFromPoint(X, Y: longint; out H: longint; out S: double);
+ procedure DrawCursor;
+ procedure SetMarginWidth(NewWidth: longint);
+ procedure SetCursorSize(NewSize: longint);
+ procedure SetValueBar(AValueBar: TfpgValueBar);
+ procedure SetWhiteAreaPercent(WhiteAreaPercent: longint);
+ procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+ function DrawWidth: longint;
+ function DrawHeight: longint;
+ procedure Change;
+ procedure HandlePaint; override;
+ procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override;
+ procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override;
+ procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+ property Hue: longint Read FHue;
+ property Saturation: double Read FSaturation;
+ procedure SetSelectedColor(const NewColor: TfpgColor);
+ published
+ property BackgroundColor;
+ property ValueBar: TfpgValueBar Read FValueBar Write SetValueBar;
+ property MarginWidth: longint Read FMarginWidth Write SetMarginWidth;
+ property CursorSize: longint Read FCursorSize Write SetCursorSize;
+ property WhiteAreaPercent: longint Read FWhiteAreaPercent Write SetWhiteAreaPercent;
+ property OnChange: TNotifyEvent Read FOnChange Write FOnChange;
+ end;
+
+
+ TfpgValueBar = class(TfpgWidget)
+ protected
+ FColorWheel: TfpgColorWheel;
+ FHue: longint;
+ FSaturation: double;
+ FValue: double;
+ FMarginWidth: longint;
+ FCursorHeight: longint;
+ FOnChange: TNotifyEvent;
+ procedure DrawCursor;
+ procedure SetMarginWidth(NewWidth: longint);
+ procedure SetValue(Value: double);
+ procedure SetCursorHeight(CursorHeight: longint);
+ function GetSelectedColor: TfpgColor;
+ procedure Change;
+ function DrawWidth: longint;
+ function DrawHeight: longint;
+ function ValueFromY(Y: longint): real;
+ procedure DrawLine(Y: longint);
+ procedure HandlePaint; override;
+ procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override;
+ procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override;
+ procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ procedure SetHS(Hue: longint; Sat: double);
+ published
+ property BackgroundColor;
+ property Value: double Read FValue Write SetValue;
+ property SelectedColor: TfpgColor Read GetSelectedColor;
+ property MarginWidth: longint Read FMarginWidth Write SetMarginWidth;
+ property CursorHeight: longint Read FCursorHeight Write SetCursorHeight;
+ property OnChange: TNotifyEvent Read FOnChange Write FOnChange;
+ end;
+
+
+implementation
+
+uses
+ fpg_ColorMapping;
+
+const
+ RadToHue: double = 1536 / (2 * pi);
+
+
+function AngleFrom(x, y: double): double;
+ // Quadrants are laid out as follows:
+ //
+ // 1|0
+ // ---+----
+ // 2|3
+begin
+ if X = 0 then
+ begin
+ if Y > 0 then
+ Result := pi / 2
+ else
+ Result := 3 * pi / 2;
+ end
+ else
+ begin
+ Result := arctan(abs(y) / abs(x));
+ if (x < 0) and (y >= 0) then
+ // quadrant 1
+ Result := pi - Result
+ else if (x < 0) and (y < 0) then
+ // quadrant 2
+ Result := Result + pi
+ else if (x >= 0) and (y < 0) then
+ // quadrant 3
+ Result := 2 * pi - Result;
+ end;
+end;
+
+
+{ TfpgColorWheel }
+
+function TfpgColorWheel.DrawWidth: longint;
+begin
+ Result := Width - FMarginWidth * 2;
+end;
+
+function TfpgColorWheel.DrawHeight: longint;
+begin
+ Result := Height - FMarginWidth * 2;
+end;
+
+procedure TfpgColorWheel.SetSelectedColor(const NewColor: TfpgColor);
+var
+ Value: double;
+begin
+ RGBToHSV(NewColor, FHue, FSaturation, Value);
+ Change;
+ if FValueBar <> nil then
+ FValueBar.Value := Value;
+end;
+
+procedure TfpgColorWheel.Change;
+begin
+ if FValueBar <> nil then
+ FValueBar.SetHS(FHue, FSaturation);
+ if FOnChange <> nil then
+ FOnChange(self);
+ Invalidate;
+end;
+
+procedure TfpgColorWheel.HandlePaint;
+var
+ x, y: longint;
+ lHue: longint;
+ lsaturation: double;
+ c: TfpgColor;
+begin
+ // clear background rectangle
+ Canvas.Clear(BackgroundColor);
+
+ // margins too big
+ if (Width < MarginWidth * 2) or (Height < MarginWidth * 2) then
+ Exit; //==>
+
+ if csDesigning in ComponentState then
+ begin
+ // When designing, don't draw colors
+ // but draw an outline
+ Canvas.SetLineStyle(1, lsDash);
+ Canvas.DrawRectangle(GetClientRect);
+ Canvas.Color := clHilite1;
+ Canvas.DrawArc(Width div 2, Height div 2, DrawWidth div 2 + 1,
+ DrawHeight div 2 + 1, 45, 180);
+ Canvas.Color := clShadow1;
+ Canvas.DrawArc(Width div 2, Height div 2, DrawWidth div 2 + 1,
+ DrawHeight div 2 + 1, 225, 180);
+ Exit; //==>
+ end;
+
+ if FImage = nil then
+ begin
+ // we must only do this once, because it's very slow
+ FImage := TfpgImage.Create;
+ FImage.AllocateImage(32, DrawWidth, DrawHeight);
+ FImage.UpdateImage;
+ for X := 0 to DrawWidth - 1 do
+ begin
+ for Y := 0 to DrawHeight - 1 do
+ begin
+ // work out hue and saturation for point
+ HSFromPoint(X, Y, lHue, lSaturation);
+ if lSaturation <= 1.0 then
+ begin
+ // point is within wheel
+ C := HSVToRGB(lHue, lSaturation, 1.0);
+ // draw the pixel
+ Canvas.Pixels[X + FMarginWidth, Y + FMarginWidth] := C;
+ FImage.Colors[x, y] := c;
+ end
+ else
+ // point is outside wheel. Also incase color is alias, lookup the RGB values.
+ FImage.Colors[x, y] := fpgColorToRGB(BackgroundColor);
+ end;
+ end;
+ end
+ else
+ begin
+ // paint buffer image seeing that we have it
+ Canvas.DrawImage(FMarginWidth, FMarginWidth, FImage);
+ end;
+
+ DrawCursor;
+end;
+
+procedure TfpgColorWheel.HandleLMouseDown(x, y: integer; shiftstate: TShiftState);
+begin
+ inherited HandleLMouseDown(x, y, shiftstate);
+ Dec(X, FMarginWidth);
+ Dec(Y, FMarginWidth);
+ HSFromPoint(X, Y, FHue, FSaturation);
+ if FSaturation > 1.0 then
+ FSaturation := 1.0;
+ Change;
+ CaptureMouse;
+end;
+
+procedure TfpgColorWheel.HandleMouseMove(x, y: integer; btnstate: word;
+ shiftstate: TShiftState);
+begin
+ inherited HandleMouseMove(x, y, btnstate, shiftstate);
+ // is mouse still captured (LButton down)?
+ if ((btnstate and MOUSE_LEFT) = 0) then
+ Exit; //==>
+ Dec(X, FMarginWidth);
+ Dec(Y, FMarginWidth);
+ HSFromPoint(X, Y, FHue, FSaturation);
+ if FSaturation > 1.0 then
+ FSaturation := 1.0;
+ Change;
+end;
+
+procedure TfpgColorWheel.HandleLMouseUp(x, y: integer; shiftstate: TShiftState);
+begin
+ inherited HandleLMouseUp(x, y, shiftstate);
+ ReleaseMouse;
+end;
+
+constructor TfpgColorWheel.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FMarginWidth := 5;
+ FCursorSize := 5;
+ Width := 100;
+ Height := 100;
+ Name := 'ColorWheel';
+ FWhiteAreaPercent := 10;
+end;
+
+destructor TfpgColorWheel.Destroy;
+begin
+ if FImage <> nil then
+ FImage.Free;
+ inherited Destroy;
+end;
+
+// Calculate hue and saturation for a given point in the color wheel
+procedure TfpgColorWheel.HSFromPoint(X, Y: longint; out H: longint; out S: double);
+var
+ xp, yp: double;
+ halfw, halfh: longint;
+begin
+ halfw := DrawWidth div 2;
+ halfh := DrawHeight div 2;
+ xp := (x - halfw) / halfw; // x as -1..1
+ yp := (y - halfh) / halfh; // y as -1..1
+ H := Trunc(RadToHue * AngleFrom(xp, -yp));
+ S := sqrt(xp * xp + yp * yp);
+ // scale saturation and limit to white, for white area
+ S := S * (1 + (FWhiteAreaPercent / 100.0)) - (FWhiteAreaPercent / 100.0);
+ if S < 0 then
+ S := 0;
+end;
+
+procedure TfpgColorWheel.DrawCursor;
+var
+ Angle: Double;
+ X, Y: longint;
+ S: Double;
+ a: Double;
+ len: longint;
+begin
+ Angle := FHue/RadToHue;
+
+ // Scale distance from centre for white area
+ S := FSaturation;
+ if S > 0 then
+ begin
+ a := FWhiteAreaPercent / 100.0;
+ S := (S * (1 - a)) + a;
+ end;
+
+ // work out point for selected hue and saturation
+ X := Trunc(Width div 2+cos(Angle) * S * (DrawWidth div 2));
+ Y := Trunc(Height div 2+sin(Angle) * S * -(DrawHeight div 2));
+
+ // draw a crosshair with centre at mouse cursor position
+ len := FCursorSize*2 + 2; // length of crosshair lines
+ Canvas.XORFillRectangle($FFFFFF, X-FCursorSize, Y, len, 2);
+ Canvas.XORFillRectangle($FFFFFF, X, Y-FCursorSize, 2, len);
+end;
+
+procedure TfpgColorWheel.SetMarginWidth(NewWidth: longint);
+begin
+ FMarginWidth := NewWidth;
+ if WinHandle = 0 then
+ Exit; //==>
+ Invalidate;
+end;
+
+procedure TfpgColorWheel.SetCursorSize(NewSize: longint);
+begin
+ FCursorSize := NewSize;
+ if WinHandle = 0 then
+ Exit; //==>
+ Invalidate;
+end;
+
+procedure TfpgColorWheel.SetValueBar(AValueBar: TfpgValueBar);
+begin
+ if FValueBar <> nil then
+ // tell the old value bar it's no longer controlled by this wheel
+ FValueBar.FColorWheel := nil;
+ FValueBar := AValueBar;
+ if FValueBar <> nil then
+ begin
+ // Tell value bar it is controlled by this component
+ FValueBar.FColorWheel := Self;
+ // request notification when other is freed
+ FValueBar.FreeNotification(Self);
+ end;
+end;
+
+procedure TfpgColorWheel.SetWhiteAreaPercent(WhiteAreaPercent: longint);
+begin
+ if WhiteAreaPercent > 50 then
+ WhiteAreaPercent := 50;
+
+ if WhiteAreaPercent < 0 then
+ WhiteAreaPercent := 0;
+
+ FWhiteAreaPercent := WhiteAreaPercent;
+ Invalidate;
+end;
+
+procedure TfpgColorWheel.Notification(AComponent: TComponent; Operation: TOperation);
+begin
+ inherited Notification(AComponent, Operation);
+ if Operation = opRemove then
+ begin
+ if AComponent = FValueBar then
+ FValueBar := nil;
+ end;
+end;
+
+
+{ TfpgValueBar }
+
+procedure TfpgValueBar.DrawLine(Y: longint);
+var
+ DrawVal: double;
+ c: TfpgColor;
+begin
+ DrawVal := ValueFromY(Y);
+ C := HSVToRGB(FHue, FSaturation, DrawVal);
+ Canvas.Color := c;
+ Canvas.DrawLine(FMarginWidth, Y, Width - FMarginWidth - 1, Y);
+end;
+
+procedure TfpgValueBar.HandlePaint;
+var
+ y: longint;
+ r: TfpgRect;
+begin
+ // inherited HandlePaint;
+ Canvas.Clear(BackgroundColor);
+
+ if csDesigning in ComponentState then
+ begin
+ // when designing just draw
+ // a rectangle to indicate
+ Canvas.SetLineStyle(1, lsDash);
+ Canvas.DrawRectangle(GetClientRect);
+ if (Width < MarginWidth * 2) or (Height < MarginWidth * 2) then
+ Exit; //==>
+ r := GetClientRect;
+ InflateRect(r, FMarginWidth, FMarginWidth);
+ Canvas.DrawRectangle(r);
+ exit;
+ end;
+
+ // Draw margins
+ r.left := 0;
+ r.setbottom(0);
+ r.setright(FMarginWidth - 1);
+ r.top := Height - 1;
+ Canvas.Color := BackgroundColor;
+ Canvas.FillRectangle(r); // left
+ r.left := Width - FMarginWidth;
+ r.setright(Width - 1);
+ Canvas.FillRectangle(r); // right
+ r.left := FMarginWidth;
+ r.setright(Width - FMarginWidth - 1);
+ r.setbottom(Height - FMarginWidth);
+ r.top := Height - 1;
+ Canvas.FillRectangle(r); // top
+ r.setbottom(0);
+ r.top := FMarginWidth - 1;
+ Canvas.FillRectangle(r); // bottom
+
+ if (Width < MarginWidth * 2) or (Height < MarginWidth * 2) then
+ Exit; //==>
+
+ for Y := 0 to DrawHeight - 1 do
+ DrawLine(Y + FMarginWidth);
+
+ DrawCursor;
+end;
+
+procedure TfpgValueBar.HandleLMouseDown(x, y: integer; shiftstate: TShiftState);
+begin
+ inherited HandleLMouseDown(x, y, shiftstate);
+ FValue := ValueFromY(Y);
+ Change;
+ CaptureMouse;
+end;
+
+procedure TfpgValueBar.HandleMouseMove(x, y: integer; btnstate: word;
+ shiftstate: TShiftState);
+begin
+ inherited HandleMouseMove(x, y, btnstate, shiftstate);
+ if ((btnstate and MOUSE_LEFT) = 0) then
+ Exit; //==>
+ FValue := ValueFromY(Y);
+ Change;
+end;
+
+procedure TfpgValueBar.HandleLMouseUp(x, y: integer; shiftstate: TShiftState);
+begin
+ inherited HandleLMouseUp(x, y, shiftstate);
+ ReleaseMouse;
+end;
+
+constructor TfpgValueBar.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FMarginWidth := 5;
+ FValue := 1.0;
+ Width := 100;
+ Height := 100;
+ Name := 'ValueBar';
+ FCursorHeight := 10;
+end;
+
+procedure TfpgValueBar.SetHS(Hue: longint; Sat: double);
+begin
+ FHue := Hue;
+ FSaturation := Sat;
+ Invalidate;
+ Change;
+end;
+
+procedure TfpgValueBar.SetValue(Value: double);
+begin
+ FValue := Value;
+ Change;
+end;
+
+function TfpgValueBar.DrawWidth: longint;
+begin
+ Result := Width - FMarginWidth * 2;
+end;
+
+function TfpgValueBar.DrawHeight: longint;
+begin
+ Result := Height - FMarginWidth * 2;
+end;
+
+procedure TfpgValueBar.DrawCursor;
+var
+ Y: longint;
+ r: TfpgRect;
+begin
+ if (Width < MarginWidth * 2) or
+ (Height < MarginWidth * 2) then
+ Exit; //==>
+
+ Y := Trunc((FValue * DrawHeight) + FMarginWidth);
+
+ r.SetRect(FMarginWidth-1, Y - (FCursorHeight div 2), DrawWidth+1, FCursorHeight);
+ Canvas.Color := GetSelectedColor;
+ Canvas.FillRectangle(r);
+
+ Canvas.Color := clBlack;
+ Canvas.DrawControlFrame(r);
+end;
+
+procedure TfpgValueBar.SetMarginWidth(NewWidth: longint);
+begin
+ if MarginWidth < 0 then
+ MarginWidth := 0;
+ FMarginWidth := NewWidth;
+ Invalidate;
+end;
+
+procedure TfpgValueBar.SetCursorHeight(CursorHeight: longint);
+begin
+ if CursorHeight < 3 then
+ CursorHeight := 3;
+ FCursorHeight := CursorHeight;
+ Invalidate;
+end;
+
+function TfpgValueBar.GetSelectedColor: TfpgColor;
+begin
+ Result := HSVToRGB(FHue, FSaturation, FValue);
+end;
+
+function TfpgValueBar.ValueFromY(Y: longint): real;
+begin
+ Result := (Y - MarginWidth) / (DrawHeight - 1);
+ if Result < 0 then
+ Result := 0;
+ if Result > 1.0 then
+ Result := 1.0;
+end;
+
+procedure TfpgValueBar.Change;
+begin
+ Invalidate;
+ if FOnChange <> nil then
+ FOnChange(self);
+end;
+
+
+end.
+
generated by cgit v1.2.3-70-g09d2 (git 2.47.1) at 2024-12-27 09:52:21 +0000