unit CanvasEx;

interface

{$IF DECLARED(FireMonkeyVersion)}
  {$IF FMX.Types.FireMonkeyVersion >= 16}
    {$DEFINE FMX}
  {$IFEND}
{$ENDIF}

uses
{$IFNDEF FMX}
  GR32, GR32_Resamplers, GR32_Backends, GR32_Polygons,
{$ENDIF}
  System.Types, System.UITypes, System.SyncObjs, System.SysUtils, System.Classes,
  System.Math.Vectors,
{$IFDEF FMX}
  FMX.Graphics, FMX.Surfaces, FMX.Types;
{$ELSE}
  Winapi.Windows, Vcl.Graphics, Vcl.Direct2D, Winapi.D2D1,
  GDIPAPI, GDIPOBJ;
{$ENDIF}

{$M+}

type

{$IFDEF FMX}
  TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear, psInsideFrame, psUserStyle, psAlternate);
  TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical, bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);

  TColor = type cardinal;   // $00BBGGRR
  TColor32 = type cardinal; // $AABBGGRR

  TColor32Helper = record helper for TColor32
    function ARGB: TColor32;
  end;

  TCanvas = FMX.Graphics.TCanvas;
  TBitmap = FMX.Graphics.TBitmap;

const
  clBlack       = $00000000;
  clDimGray     = $003F3F3F;
  clGray        = $007F7F7F;
  clLightGray   = $00BFBFBF;
  clWhite       = $00FFFFFF;
  clMaroon      = $007F0000;
  clGreen       = $00007F00;
  clOlive       = $007F7F00;
  clNavy        = $0000007F;
  clPurple      = $007F007F;
  clTeal        = $00007F7F;
  clRed         = $00FF0000;
  clLime        = $0000FF00;
  clYellow      = $00FFFF00;
  clBlue        = $000000FF;
  clFuchsia     = $00FF00FF;
  clAqua        = $0000FFFF;
  clSilver      = $00C0C0C0;

  clBlack32     = $FF000000 and clBlack;
  clDimGray32   = $FF000000 and clDimGray;
  clGray32      = $FF000000 and clGray;
  clLightGray32 = $FF000000 and clLightGray;
  clWhite32     = $FF000000 and clWhite;
  clMaroon32    = $FF000000 and clMaroon;
  clGreen32     = $FF000000 and clGreen;
  clOlive32     = $FF000000 and clOlive;
  clNavy32      = $FF000000 and clNavy;
  clPurple32    = $FF000000 and clPurple;
  clTeal32      = $FF000000 and clTeal;
  clRed32       = $FF000000 and clRed;
  clLime32      = $FF000000 and clLime;
  clYellow32    = $FF000000 and clYellow;
  clBlue32      = $FF000000 and clBlue;
  clFuchsia32   = $FF000000 and clFuchsia;
  clAqua32      = $FF000000 and clAqua;
  clSilver32    = $FF000000 and clSilver;

  clNone        = $01000000;

{$ELSE}
  TPointF = record
    X,Y : double;
  end;
{$ENDIF}

type
{$IFNDEF FMX}
  TRenderMode = (rmAuto, rmGDI, rmGDIPlus, rmGR32, rmDirect2D);
{$ELSE}
  TRenderMode = (rmAuto, rmFireMonkey);
{$ENDIF}

  TColorHelper = record helper for TColor
    function isNull: boolean;
    function isNotNull: boolean;
  end;

  TCanvasEx = class;

  TPenEx = class
  private
    FParent  : TCanvasEx;
    FColor32 : TColor32;
    FStyle   : TPenStyle;
    FWidth   : double;
    procedure SetColor32(const Value: TColor32);
    function GetColor: TColor; overload;
    procedure SetColor(Value: TColor);
    procedure SetStyle(const Value: TPenStyle);
    procedure SetWidth(const Value: double); overload;
    procedure SetWidth(const Value: integer); overload;
    function GetWidth: integer;
  public
    Optimizations : boolean;

    constructor Create(Parent: TCanvasEx);
    procedure Assign(Source: TPenEx); overload;
    procedure Assign(Source: TCanvas); overload;
{$IFNDEF FMX}
    procedure Assign(Source: TPen); overload;
{$ENDIF}
  published
    property Color: TColor read GetColor write SetColor default clWhite;
    property Width: integer read GetWidth write SetWidth;
    property WidthD: double read FWidth write SetWidth;
    property Style: TPenStyle read FStyle write SetStyle default psSolid;
    property Color32: TColor32 read FColor32 write SetColor32 default clWhite32;
  end;

  TBrushEx = class
  private
    FParent  : TCanvasEx;
    FColor32 : TColor32;
    FStyle   : TBrushStyle;
    procedure SetColor32(const Value: TColor32);
    function GetColor: TColor; overload;
    procedure SetColor(Value: TColor); overload;
    procedure SetStyle(const Value: TBrushStyle);
  public
    Optimizations : boolean;

    constructor Create(Parent: TCanvasEx);
    procedure Assign(Source: TBrushEx); overload;
    procedure Assign(Source: TCanvas); overload;
{$IFNDEF FMX}
    procedure Assign(Source: TBrush); overload;
{$ENDIF}
  published
    property Color: TColor read GetColor write SetColor default clWhite;
    property Color32: TColor32 read FColor32 write SetColor32 default clWhite32;
    property Style: TBrushStyle read FStyle write SetStyle default bsSolid;
  end;

  TFontEx = class
  private
    FParent        : TCanvasEx;
    FColor32       : TColor32;
    FName          : TFontName;
    FStyle         : TFontStyles;
    FOrientation   : Integer;
    FSize          : Integer;
    FPixelsPerInch : Integer;

{$IFNDEF FMX}
    function FontStylesToInt(FS: TFontStyles): integer;
{$ENDIF}
    function GetColor: TColor;
    procedure SetColor(const Value: TColor);
    procedure SetColor32(const Value: TColor32);
    procedure SetHeight(const Value: Integer);
    procedure SetName(const Value: TFontName);
    procedure SetOrientation(const Value: Integer);
    procedure SetSize(const Value: Integer);
    procedure SetStyle(const Value: TFontStyles);
    function GetHeight: Integer;
  public
    Optimizations  : boolean;
    Charset        : integer;

    constructor Create(Parent: TCanvasEx);
    procedure Assign(Source: TFontEx); overload;
    procedure Assign(Source: TCanvas); overload;
{$IFNDEF FMX}
    procedure Assign(Source: TFont); overload;
{$ENDIF}
  published
    property Color: TColor read GetColor write SetColor default clWhite;
    property Color32: TColor32 read FColor32 write SetColor32 default clWhite32;
    property Height: Integer read GetHeight write SetHeight;
    property Name: TFontName read FName write SetName;
    property Orientation: Integer read FOrientation write SetOrientation default 0;
    property Size: Integer read FSize write SetSize stored False;
    property Style: TFontStyles read FStyle write SetStyle;
  end;


{$IFNDEF FMX}
  TDirect2DCanvasHelper = class helper for Vcl.Direct2D.TDirect2DCanvas
    procedure LineTo(X, Y: Integer);
  end;

  TDirect2DBrushHelper = class helper for Vcl.Direct2D.TDirect2DBrush
  private
    function GetColor32: TColor32;
    procedure SetColor32(const Value: TColor32);
  public
    property Color32: TColor32 read GetColor32 write SetColor32 default clBlack32;
  end;

  TDirect2DPenHelper = class helper for Vcl.Direct2D.TDirect2DPen
  private
    function GetColor32: TColor32;
    procedure SetColor32(const Value: TColor32);
  public
    property Color32: TColor32 read GetColor32 write SetColor32 default clBlack32;
  end;
{$ENDIF}

  TCanvasEx = class
  private
    FAntialiased: boolean;
    procedure SetAntialiased(const Value: boolean);
  const
    FD2DOpLimit = 100000;
    FGR32EllipseQuality = 1;
  var
    FSource       : TCanvas;

    FPen          : TPenEx;
    FFont         : TFontEx;
    FBrush        : TBrushEx;

    FLastPenPos   : TPoint;

{$IFNDEF FMX}
    FGDI          : TCanvas;

    FGDP          : TGPGraphics;
    FGDPPen       : TGPPen;
    FGDPBrush     : TGPBrush;
    FGDPFont      : TGPFont;
    FGDPFontBrush : TGPBrush;

    FG32          : TBitmap32;
    FG32Resampler : TKernelResampler;
    FG32Poly      : TPolygon32;

    FD2D          : TDirect2DCanvas;

    FRendererMode :  TRenderMode;
{$ENDIF}
    procedure SetBrush(const Value: TBrushEx);
    procedure SetFont(const Value: TFontEx);
    procedure SetPen(const Value: TPenEx);

    function GetPixel(X, Y: Integer): TColor;
    procedure SetPixel(X, Y: Integer; Value: TColor);
    function GetClipRect: TRect;
  public
    Optimizations  : boolean;

    constructor Create(Source: TCanvas; RenderMode: TRenderMode = rmAuto);
    destructor Destroy; override;

{$IFNDEF FMX}
    function Handle: HWND;
{$ENDIF}
    function Parent: TCanvas;

    // Support

    property ClipRect: TRect read GetClipRect;

    procedure BeginUpdates;
    procedure EndUpdates;

    procedure Clear(Color: TColor); overload;
    procedure Clear(Color: TColor32); overload;

    // Draw Routines

    procedure MoveTo(X, Y: Integer);
    procedure LineTo(X, Y: Integer);

    procedure Line(X1, Y1, X2, Y2: Integer);

    procedure Polyline(const Points: array of TPoint);

    procedure Rectangle(X1, Y1, X2, Y2: Integer); overload;
    procedure Rectangle(const Rect: TRect); overload;

    procedure FillRect(const Rect: TRect); overload;
    procedure FillRect(X1, Y1, X2, Y2: Integer); overload;

    procedure Polygon(const Points: array of TPoint); overload;
    procedure Polygon(const Points: array of TPointF); overload;
    procedure Polygon(Points: array of TPoint; NPoints: array of integer); overload;

    procedure Ellipse(X1, Y1, X2, Y2: double); overload;
    procedure Ellipse(X, Y, Radius: double); overload;
    procedure Ellipse(R: TRect); overload;

    procedure TextOut(X, Y: Integer; const Text: string); overload;
    procedure TextOut(X, Y, Angle: Integer; const Text: string); overload;

    procedure StretchDraw(const Rect: TRect; Graphic: TBitmap); overload;
{$IFNDEF FMX}
    procedure StretchDraw(const Rect: TRect; Graphic: TBitmap32); overload;
    procedure Draw(X, Y: Integer; Graphic: TGraphic);
{$ENDIF}
    procedure Draw(X, Y: Integer; Graphic: TBitmap);

    function TextHeight(const Text: string): Integer;
    function TextWidth(const Text: string): Integer;

    procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); overload;
    procedure Pie(X, Y, Radius: integer; AngleStart, AngleSize: double); overload;

    // Styles

    property AntialiasedGeometry: boolean read FAntialiased write SetAntialiased;

    property Pen: TPenEx read FPen write SetPen;
    property Brush: TBrushEx read FBrush write SetBrush;
    property Font: TFontEx read FFont write SetFont;

    property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
  end;