unit SpkGraphTools;

{$mode ObjFpc}
{$H+}
{$DEFINE SPKGRAPHTOOLS}

interface

uses
  LCLIntf, Graphics, LCLType, Classes, Math, Sysutils, Dialogs, SpkMath;

const
  NUM_ZERO = 0.00000001;


(*******************************************************************************
*                                                                              *
*                              Simple structure                                *
*                                                                              *
*******************************************************************************)

type
  // Pointer to an array of TRGBTriple
  PRGBTripleArray = ^TRGBTripleArray;
  // Array of TRGBTriple records
  TRGBTripleArray = array[word] of TRGBTriple;

  THSLTriple = record
    H, S, L: extended;
  end;

  // Gradient types
  TGradientType = (gtVertical, gtHorizontal);
  // Line gradient types
  TGradientLineShade = (lsShadeStart, lsShadeEnds, lsShadeCenter, lsShadeEnd);
  // Line gradient types (3D)
  TGradient3dLine = (glRaised, glLowered);


(*******************************************************************************
*                                                                              *
*                               Utility classes                                *
*                                                                              *
*******************************************************************************)

  TColorTools = class
  public
    class function Darken(AColor: TColor; APercentage: byte): TColor;
    class function Brighten(AColor: TColor; APercentage: Integer): TColor;
    class function Shade(AColor1, AColor2: TColor; APercentage: Integer): TColor; overload;
    class function Shade(AColor1, AColor2: TColor; AStep: extended): TColor; overload;
    class function AddColors(AColor1, AColor2: TColor): TColor;
    class function MultiplyColors(AColor1, AColor2: TColor): TColor;
    class function MultiplyColor(AColor: TColor; AScalar: integer): TColor; overload;
    class function MultiplyColor(AColor: TColor; AScalar: extended): TColor; overload;
    class function percent(AMin, APos, AMax: integer): byte;
    class function RGB2HSL(ARGB: TRGBTriple): THSLTriple;
    class function HSL2RGB(AHSL: THSLTriple): TRGBTriple;
    class function RgbTripleToColor(ARgbTriple: TRGBTriple): TColor;
    class function ColorToRgbTriple(AColor: TColor): TRGBTriple;
    class function ColorToGrayscale(AColor: TColor): TColor;
  end;

  TGradientTools = class
  public
    class procedure HGradient(ACanvas: TCanvas; cStart,cEnd: TColor; ARect: T2DIntRect); overload;
    class procedure HGradient(ACanvas: TCanvas; cStart,cEnd: TColor; p1, p2: TPoint); overload;
    class procedure HGradient(ACanvas: TCanvas; cStart,cEnd: TColor; x1,y1,x2,y2: integer); overload;

    class procedure VGradient(ACanvas: TCanvas; cStart,cEnd: TColor; ARect: T2DIntRect); overload;
    class procedure VGradient(ACanvas: TCanvas; cStart,cEnd: TColor; p1, p2: TPoint); overload;
    class procedure VGradient(ACanvas: TCanvas; cStart,cEnd: TColor; x1,y1,x2,y2: integer); overload;

    class procedure Gradient(ACanvas: TCanvas; cStart,cEnd: TColor; ARect: T2DIntRect; AGradientType : TGradientType); overload;
    class procedure Gradient(ACanvas: TCanvas; cStart,cEnd: TColor; p1, p2: TPoint; AGradientType : TGradientType); overload;
    class procedure Gradient(ACanvas: TCanvas; cStart,cEnd: TColor; x1,y1,x2,y2: integer; AGradientType : TGradientType); overload;

    class procedure HGradientLine(ACanvas: TCanvas; cBase, cShade: TColor; x1, x2, y: integer; ShadeMode: TGradientLineShade);
    class procedure VGradientLine(ACanvas: TCanvas; cBase, cShade: TColor; x, y1, y2: integer; ShadeMode: TGradientLineShade);

    class procedure HGradient3dLine(ACanvas: TCanvas; x1,x2,y: integer; ShadeMode: TGradientLineShade; A3dKind: TGradient3dLine = glLowered);
    class procedure VGradient3dLine(ACanvas: TCanvas; x,y1,y2: integer; ShadeMode: TGradientLineShade; A3dKind: TGradient3dLine = glLowered);
  end;

  TTextTools = class
  public
    class procedure OutlinedText(ACanvas: TCanvas; x, y: integer; const AText: string);
  end;

implementation

type
  TRgbColor = packed record
    R,G,B,A: Byte;
  end;


{ TColorTools }

class function TColorTools.Darken(AColor: TColor; APercentage: byte): TColor;
var
  c: TRGBColor;
  f: extended;
begin
  c := TRGBColor(ColorToRGB(AColor));
  f := (100 - APercentage) / 100;
  result := rgb(
    round(c.R * f),
    round(c.G * f),
    round(c.B * f)
  );
end;

class function TColorTools.Brighten(AColor: TColor; APercentage: Integer): TColor;
var
  c: TRgbColor;
  p: Extended;
begin
  c := TRgbColor(ColorToRGB(AColor));
  p := APercentage/100;
  result := rgb(
    EnsureRange(round(c.R + (255-c.R)*p), 0, 255),
    EnsureRange(round(c.G + (255-c.G)*p), 0, 255),
    EnsureRange(round(c.B + (255-c.B)*p), 0, 255)
  );
end;

class function TColorTools.Shade(AColor1, AColor2: TColor;
  APercentage: Integer): TColor;
var
  c1, c2: TRgbColor;
  Step: Extended;  // percentage as floating point number
begin
  c1 := TRGBColor(ColorToRGB(AColor1));
  c2 := TRGBColor(ColorToRGB(AColor2));
  Step := APercentage / 100;
  result := rgb(
    EnsureRange(round(c1.R + (c2.R - c1.R) * Step), 0, 255),
    EnsureRange(round(c1.G + (c2.G - c1.G) * Step), 0, 255),
    EnsureRange(round(c1.B + (c2.B - c1.B) * Step), 0, 255)
  );
end;

class function TColorTools.Shade(AColor1, AColor2: TColor; AStep: extended): TColor;
var
  c1, c2: TRgbColor;
begin
  c1 := TRgbColor(ColorToRGB(AColor1));
  c2 := TRgbColor(ColorToRGB(AColor2));
  result := rgb(
    round(c1.R + (c2.R - c1.R) * AStep),
    round(c1.G + (c2.G - c1.G) * AStep),
    round(c1.B + (c2.B - c1.B) * AStep)
  );
end;

class function TColorTools.AddColors(AColor1, AColor2: TColor): TColor;
var
  c1, c2: TRgbColor;
begin
  c1 := TRgbColor(ColorToRGB(AColor1));
  c2 := TRgbColor(ColorToRGB(AColor2));
  result := rgb(
    max(0, min(255, Integer(c1.R) + c2.R)),
    max(0, min(255, Integer(c1.G) + c2.G)),
    max(0, min(255, Integer(c1.B) + c2.B))
  );
end;

class function TColorTools.MultiplyColors(AColor1, AColor2: TColor): TColor;
var
  c1, c2: TRgbColor;
begin
  c1 := TRgbColor(ColorToRGB(AColor1));
  c2 := TRgbColor(ColorToRGB(AColor2));
  result := rgb(
    max(0, min(255, Integer(c1.R) * c2.R)),
    max(0, min(255, Integer(c1.G) * c2.G)),
    max(0, min(255, Integer(c1.B) * c2.B))
  );
end;

class function TColorTools.MultiplyColor(AColor: TColor; AScalar: integer): TColor;
var
  c: TRgbColor;
begin
  c := TRgbColor(ColorToRGB(AColor));
  result := rgb(
    max(0, min(255, AScalar * c.R)),
    max(0, min(255, AScalar * c.G)),
    max(0, min(255, AScalar * c.B))
  );
end;

class function TColorTools.MultiplyColor(AColor: TColor; AScalar: extended): TColor;
var
  c: TRgbColor;
begin
  c := TRgbColor(ColorToRGB(AColor));
  result := rgb(
    max(0, min(255, round(c.R * AScalar))),
    max(0, min(255, round(c.G * AScalar))),
    max(0, min(255, round(c.B * AScalar)))
  );
end;

class function TColorTools.Percent(AMin, APos, AMax: integer): byte;
begin
  if AMax = AMin then
    result := AMax    // wp: is this correct? Shouldn't this be a value between a and 100?
  else
    result := round((APos - AMin) * 100 / (AMax - AMin));
end;

{.$MESSAGE WARN 'Comparing real numbers? This has to be corrected.'}
class function TColorTools.RGB2HSL(ARGB: TRGBTriple): THSLTriple;
var
  RGBmin, RGBmax, RGBrange: extended;
  R, G, B: extended;
  H, S, L: extended;
begin
  R := ARGB.rgbtRed/255;
  G := ARGB.rgbtGreen/255;
  B := ARGB.rgbtBlue/255;

  RGBmin := min(R, min(G, B));
  RGBmax := max(R, min(G, B));
  RGBrange := RGBmax - RGBmin;

  H := 0;
  if RGBmax = RGBmin then
    H := 0
  else
  if (R = RGBmax) and (G >= B) then
    H := pi/3 * (G-B) / RGBrange + 0
  else
  if (R = RGBmax) and (G < B) then
    H := pi/3 * (G-B) / RGBrange + 2*pi
  else
  if (G = RGBmax) then
    H := pi/3 * (B-R) / RGBrange + 2*pi/3
  else
  if (B = RGBmax) then
    H := pi/3 * (R-G) / RGBrange + 4*pi/3;

  L := RGBrange / 2;

  S:=0;
  if (L < NUM_ZERO) or (rgbMin = rgbMax) then
    S := 0
  else
  if (L <= 0.5) then
    S := RGBrange / (2*L)
  else
  if (L > 0.5) then
    S := RGBrange / (2-2*L);

  result.H := H / (2*pi);
  result.S := S;
  result.L := L;
end;

class function TColorTools.HSL2RGB(AHSL: THSLTriple): TRGBTriple;
var
  R, G, B: extended;
  TR, TG, TB: extended;
  Q, P: extended;

  function ProcessColor(c: extended): extended;
  begin
    if (c < 1/6) then
      result := P + (Q - P) * 6.0 * c
    else
    if (c < 1/2) then
      result := Q
    else
    if (c < 2/3) then
      result := P + (Q - P) * (2/3 - c) * 6.0
    else
      result := P;
  end;

begin
  if AHSL.S < NUM_ZERO then
  begin
    R := AHSL.L;
    G := AHSL.L;
    B := AHSL.L;
  end else
  begin
    if (AHSL.L < 0.5) then
      Q := AHSL.L * (AHSL.S + 1.0)
    else
      Q := AHSL.L + AHSL.S - AHSL.L*AHSL.S;

    P := 2.0*AHSL.L - Q;

    TR := AHSL.H + 1/3;
    TG := AHSL.H;
    TB := AHSL.H - 1/3;

    if (TR < 0) then
      TR := TR + 1
    else
    if (TR > 1) then
      TR := TR - 1;

    if (TG < 0) then
      TG := TG + 1
    else
    if (TG > 1) then
      TG := TG - 1;

    if (TB < 0) then
      TB := TB + 1
    else
    if (TB > 1) then
      TB := TB - 1;

    R := ProcessColor(TR);
    G := ProcessColor(TG);
    B := ProcessColor(TB);
  end;

  result.rgbtRed   := round(255*R);
  result.rgbtGreen := round(255*G);
  result.rgbtBlue  := round(255*B);
end;

class function TColorTools.RgbTripleToColor(ARgbTriple: TRGBTriple) : TColor;
begin
  result := rgb(
    ARgbTriple.rgbtRed,
    ARgbTriple.rgbtGreen,
    ARgbTriple.rgbtBlue
  );
end;

class function TColorTools.ColorToGrayscale(AColor: TColor): TColor;
var
  c: TRgbColor;
  avg : byte;
begin
  c := TRgbColor(ColorToRGB(AColor));
  avg := (c.R + c.G + c.B) div 3;
  result := rgb(avg, avg, avg);
end;

class function TColorTools.ColorToRgbTriple(AColor: TColor): TRGBTriple;
var
  c: TRgbColor;
begin
  c := TRgbColor(ColorToRGB(AColor));
  result.rgbtRed   := c.R;
  result.rgbtGreen := c.G;
  result.rgbtBlue  := c.B;
end;


{ TGradientTools }

class procedure TGradientTools.HGradient(ACanvas: TCanvas; cStart, cEnd: TColor;
  ARect: T2DIntRect);
begin
  ACanvas.GradientFill(ARect.ForWinAPI,cStart, cEnd, gdHorizontal);
end;

{  -- old version ...
var vert : array[0..1] of TRIVERTEX;
    gRect : GRADIENTRECT;
    Col1,Col2 : TColor;

begin
Col1:=ColorToRGB(cStart);
Col2:=ColorToRGB(cEnd);
with vert[0] do
     begin
     x:=rect.left;
     y:=rect.top;
     Red:=GetRValue(Col1) shl 8;
     Green:=GetGValue(Col1) shl 8;
     Blue:=GetBValue(Col1) shl 8;
     Alpha:=0;
     end;

with vert[1] do
     begin
     x:=rect.right;
     y:=rect.bottom;
     Red:=GetRValue(Col2) shl 8;
     Green:=GetGValue(Col2) shl 8;
     Blue:=GetBValue(Col2) shl 8;
     Alpha:=0;
     end;

gRect.UpperLeft:=0;
gRect.LowerRight:=1;
GradientFill(canvas.Handle,@vert,2,@gRect,1,GRADIENT_FILL_RECT_H);
end;   }

class procedure TGradientTools.HGradient(ACanvas: TCanvas; cStart, cEnd: TColor;
  p1, p2: TPoint);
begin
  HGradient(ACanvas, cStart, cEnd, rect(p1.x,p1.y,p2.x,p2.y));
end;

class procedure TGradientTools.HGradient(ACanvas: TCanvas; cStart, cEnd: TColor;
  x1,y1,x2,y2: integer);
begin
  HGradient(ACanvas, cStart, cEnd, rect(x1,y1,x2,y2));
end;

class procedure TGradientTools.VGradient(ACanvas: TCanvas; cStart, cEnd: TColor;
  ARect: T2DIntRect);
begin
  ACanvas.GradientFill(ARect.ForWinAPI, cStart, cEnd, gdVertical);
end;

{  --- old version...
class procedure TGradientTools.VGradient(canvas : TCanvas; cStart,cEnd : TColor; rect : T2DIntRect);

var vert : array[0..1] of TRIVERTEX;
    gRect : GRADIENTRECT;
    Col1,Col2 : TColor;

begin
Col1:=ColorToRGB(cStart);
Col2:=ColorToRGB(cEnd);
with vert[0] do
     begin
     x:=rect.left;
     y:=rect.top;
     Red:=GetRValue(Col1) shl 8;
     Green:=GetGValue(Col1) shl 8;
     Blue:=GetBValue(Col1) shl 8;
     Alpha:=0;
     end;

with vert[1] do
     begin
     x:=rect.right;
     y:=rect.bottom;
     Red:=GetRValue(Col2) shl 8;
     Green:=GetGValue(Col2) shl 8;
     Blue:=GetBValue(Col2) shl 8;
     Alpha:=0;
     end;

gRect.UpperLeft:=0;
gRect.LowerRight:=1;
GradientFill(canvas.Handle,@vert,2,@gRect,1,GRADIENT_FILL_RECT_V);
end;           }

class procedure TGradientTools.VGradient(ACanvas: TCanvas; cStart, cEnd: TColor;
  p1, p2: TPoint);
begin
  VGradient(ACanvas, cStart, cEnd, rect(p1.x,p1.y,p2.x,p2.y));
end;

class procedure TGradientTools.VGradient(ACanvas: TCanvas; cStart, cEnd: TColor;
  x1,y1,x2,y2: integer);
begin
  VGradient(ACanvas, cStart, cEnd, rect(x1,y1,x2,y2));
end;

class procedure TGradientTools.Gradient(ACanvas: TCanvas; cStart, cEnd: TColor;
  ARect: T2DIntRect; AGradientType: TGradientType);
begin
  if AGradientType = gtVertical then
    VGradient(ACanvas, cStart, cEnd, ARect)
  else
    HGradient(ACanvas, cStart, cEnd, ARect);
end;

class procedure TGradientTools.Gradient(ACanvas: TCanvas; cStart, cEnd: TColor;
  p1, p2: TPoint; AGradientType: TGradientType);
begin
  if AGradientType = gtVertical then
    VGradient(ACanvas, cStart, cEnd, p1, p2)
  else
    HGradient(ACanvas, cStart, cEnd, p1, p2);
end;

class procedure TGradientTools.Gradient(ACanvas: TCanvas; cStart, cEnd: TColor;
  x1,y1,x2,y2: integer; AGradientType: TGradientType);
begin
  if AGradientType = gtVertical then
    VGradient(ACanvas, cStart, cEnd, x1, y1, x2, y2)
  else
    HGradient(ACanvas, cStart, cEnd, x1, y1, x2, y2);
end;

class procedure TGradientTools.HGradientLine(ACanvas: TCanvas;
  cBase, cShade: TColor; x1, x2, y: integer; ShadeMode: TGradientLineShade);
var
  i: integer;
begin
  if x1 = x2 then
    exit;
  if x1 > x2 then
  begin
    i := x1;
    x1 := x2;
    x2 := i;
  end;
  case ShadeMode of
    lsShadeStart:
      HGradient(ACanvas, cShade, cBase, rect(x1,y,x2,y+1));
    lsShadeEnds:
      begin
        i := (x1 + x2) div 2;
        HGradient(ACanvas, cShade, cBase, rect(x1,y,i,y+1));
        HGradient(ACanvas, cBase, cShade, rect(i,y,x2,y+1));
      end;
    lsShadeCenter:
      begin
        i := (x1 + x2) div 2;
        HGradient(ACanvas, cBase, cShade, rect(x1,y,i,y+1));
        HGradient(ACanvas, cShade, cBase, rect(i,y,x2,y+1));
      end;
    lsShadeEnd:
      HGradient(ACanvas,cBase,cShade,rect(x1,y,x2,y+1));
  end;
end;

class procedure TGradientTools.VGradientLine(ACanvas: TCanvas;
  cBase, cShade: TColor; x, y1, y2: integer; ShadeMode: TGradientLineShade);
var
  i : integer;
begin
  if y1 = y2 then
    exit;
  if y1 > y2 then
  begin
    i := y1;
    y1 := y2;
    y2 := i;
  end;
  case ShadeMode of
    lsShadeStart:
      VGradient(ACanvas, cShade, cBase, rect(x,y1,x+1,y2));
    lsShadeEnds:
      begin
        i := (y1 + y2) div 2;
        VGradient(ACanvas, cShade, cBase, rect(x,y1,x+1,i));
        VGradient(ACanvas, cBase, cShade, rect(x,i,x+1,y2));
      end;
    lsShadeCenter:
      begin
        i := (y1 + y2) div 2;
        VGradient(ACanvas, cBase, cShade, rect(x,y1,x+1,i));
        VGradient(ACanvas, cShade, cBase, rect(x,i,x+1,y2));
      end;
    lsShadeEnd:
      VGradient(ACanvas, cBase, cShade, rect(x,y1,x+1,y2));
  end;
end;

class procedure TGradientTools.HGradient3dLine(ACanvas: TCanvas; x1,x2,y: integer;
  ShadeMode: TGradientLineShade; A3dKind: TGradient3dLine = glLowered);
begin
  if A3dKind = glRaised then
  begin
    HGradientLine(ACanvas, clBtnHighlight, clBtnFace, x1,x2,y, ShadeMode);
    HGradientLine(ACanvas, clBtnShadow, clBtnFace, x1,x2,y+1, ShadeMode);
  end else
  begin
    HGradientLine(ACanvas, clBtnShadow, clBtnFace, x1,x2,y, ShadeMode);
    HGradientLine(ACanvas, clBtnHighlight, clBtnFace, x1,x2,y+1, ShadeMode);
  end;
end;

class procedure TGradientTools.VGradient3dLine(ACanvas: TCanvas; x,y1,y2: integer;
  ShadeMode: TGradientLineShade; A3dKind: TGradient3dLine = glLowered);
begin
  if A3dKind = glLowered then
  begin
    VGradientLine(ACanvas, clBtnFace, clBtnHighlight, x,y1,y2, ShadeMode);
    VGradientLine(ACanvas, clBtnFace, clBtnShadow, x+1,y1,y2, ShadeMode);
  end else
  begin
    VGradientLine(ACanvas, clBtnFace, clBtnShadow, x,y1,y2, ShadeMode);
    VGradientLine(ACanvas, clBtnFace, clBtnHighlight, x+1,y1,y2, ShadeMode);
  end;
end;


{ TTextTools }

class procedure TTextTools.OutlinedText(ACanvas: TCanvas; x, y: integer; const AText: string);
var
  TmpColor: TColor;
  TmpBrushStyle: TBrushStyle;
begin
  TmpColor := ACanvas.Font.Color;
  TmpBrushStyle := ACanvas.Brush.Style;

  ACanvas.Brush.Style := bsClear;

  ACanvas.Font.Color := clBlack;
  ACanvas.TextOut(x-1, y,   AText);
  ACanvas.TextOut(x+1, y,   AText);
  ACanvas.TextOut(x,   y-1, AText);
  ACanvas.TextOut(x,   y+1, AText);

  ACanvas.Font.Color := TmpColor;
  ACanvas.TextOut(x, y, AText);

  ACanvas.Brush.Style := TmpBrushStyle;
end;


end.