source: trunk/UCanvas.pas

unit UCanvas;

{$mode delphi}

interface

uses
  Classes, SysUtils, Math, Types, fgl, UGraphics;

type
  TArrayOfPoint = array of TPoint;

  { TCanvasObject }

  TCanvasObject = class
    MetaCanvas: TCanvas;
    procedure Paint(Canvas: TCanvas); virtual;
    procedure Zoom(Factor: Double); virtual;
    procedure Move(Delta: TPoint); virtual;
    function GetRect: TRect; virtual;
  end;

  TCanvasObjects = class(TFPGObjectList<TCanvasObject>)
  end;

  { TCanvasText }

  TCanvasText = class(TCanvasObject)
    Brush: TBrush;
    Font: TFont;
    Position: TPoint;
    Text: string;
    procedure Paint(Canvas: TCanvas); override;
    procedure Zoom(Factor: Double); override;
    procedure Move(Delta: TPoint); override;
    function GetRect: TRect; override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TCanvasRectangle }

  TCanvasRectangle = class(TCanvasObject)
    Pen: TPen;
    Brush: TBrush;
    BoundingRect: TRect;
    Rounded: TPoint;
    procedure Paint(Canvas: TCanvas); override;
    procedure Zoom(Factor: Double); override;
    procedure Move(Delta: TPoint); override;
    function GetRect: TRect; override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TCanvasLine }

  TCanvasLine = class(TCanvasObject)
    Pen: TPen;
    P1, P2: TPoint;
    procedure Paint(Canvas: TCanvas); override;
    procedure Zoom(Factor: Double); override;
    procedure Move(Delta: TPoint); override;
    function GetRect: TRect; override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TCanvasPolygon }

  TCanvasPolygon = class(TCanvasObject)
    Pen: TPen;
    Brush: TBrush;
    Points: array of TPoint;
    procedure Paint(Canvas: TCanvas); override;
    procedure Zoom(Factor: Double); override;
    procedure Move(Delta: TPoint); override;
    function GetRect: TRect; override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TCanvasEllipse }

  TCanvasEllipse = class(TCanvasObject)
    Pen: TPen;
    Brush: TBrush;
    BoundingRect: TRect;
    procedure Paint(Canvas: TCanvas); override;
    procedure Zoom(Factor: Double); override;
    procedure Move(Delta: TPoint); override;
    function GetRect: TRect; override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TCanvasPie }

  TCanvasPie = class(TCanvasObject)
    Pen: TPen;
    Brush: TBrush;
    BoundingRect: TRect;
    StartPoint: TPoint;
    EndPoint: TPoint;
    procedure Paint(Canvas: TCanvas); override;
    procedure Zoom(Factor: Double); override;
    procedure Move(Delta: TPoint); override;
    function GetRect: TRect; override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TCanvasStretchDraw }

  TCanvasStretchDraw = class(TCanvasObject)
    SrcGraphic: TGraphic;
    DestRect: TRect;
    procedure Paint(Canvas: TCanvas); override;
    procedure Zoom(Factor: Double); override;
    procedure Move(Delta: TPoint); override;
    function GetRect: TRect; override;
    constructor Create;
    destructor Destroy; override;
  end;

  { TMetaCanvas }

  TMetaCanvas = class(TCanvas)
  private
    FSize: TSize;
  protected
    function GetSize: TSize; override;
    procedure SetSize(AValue: TSize); override;
  public
    Objects: TCanvasObjects;
    procedure Rectangle(const ARect: TRect); override;
    procedure Line(const P1, P2: TPoint); override;
    procedure TextOut(const Pos: TPoint; Text: string); override;
    procedure RoundRect(const Rect: TRect; RX, RY: Integer); overload;
    procedure Polygon(const Points: array of TPoint); virtual;
    procedure Ellipse(const Bounds: TRect); override;
    procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); override;
    function TextExtent(const Text: string): TSize; override;
    procedure Pie(EllipseX1, EllipseY1, EllipseX2, EllipseY2,
      StartX, StartY, EndX, EndY: Integer); override;
    function GetRealRect: TRect;
    procedure Reset;
    procedure DrawTo(Canvas: TCanvas);
    procedure Zoom(Factor: Double);
    procedure Move(Delta: TPoint);
    constructor Create;
    destructor Destroy; override;
  end;


implementation

uses
  UGeometric, LCLIntf;

{ TCanvasPie }

procedure TCanvasPie.Paint(Canvas: TCanvas);
begin
  Canvas.Brush.Assign(Brush);
  Canvas.Pen.Assign(Pen);
  Canvas.Pie(BoundingRect.Left, BoundingRect.Top,
    BoundingRect.Right, BoundingRect.Bottom, StartPoint.X, StartPoint.Y,
    EndPoint.X, EndPoint.Y);
end;

procedure TCanvasPie.Zoom(Factor: Double);
begin
  BoundingRect := Rect(Trunc(BoundingRect.Left * Factor),
    Trunc(BoundingRect.Top * Factor),
    Trunc(BoundingRect.Right * Factor),
    Trunc(BoundingRect.Bottom * Factor));
  Pen.Width := Trunc(Pen.Width * Factor);
  StartPoint := Point(Trunc(StartPoint.X * Factor), Trunc(StartPoint.Y * Factor));
  EndPoint := Point(Trunc(EndPoint.X * Factor), Trunc(EndPoint.Y * Factor));
end;

procedure TCanvasPie.Move(Delta: TPoint);
begin
  BoundingRect := ShiftRect(BoundingRect, Delta);
  StartPoint := AddPoint(StartPoint, Delta);
  EndPoint := AddPoint(EndPoint, Delta);
end;

function TCanvasPie.GetRect: TRect;
begin
  Result := BoundingRect;
end;

constructor TCanvasPie.Create;
begin
  Pen := TPen.Create;
  Brush := TBrush.Create;
end;

destructor TCanvasPie.Destroy;
begin
  Pen.Free;
  Brush.Free;
  inherited;
end;

{ TCanvasStretchDraw }

procedure TCanvasStretchDraw.Paint(Canvas: TCanvas);
begin
  Canvas.StretchDraw(DestRect, SrcGraphic);
end;

procedure TCanvasStretchDraw.Zoom(Factor: Double);
begin
  DestRect := Rect(Trunc(DestRect.Left * Factor),
    Trunc(DestRect.Top * Factor),
    Trunc(DestRect.Right * Factor),
    Trunc(DestRect.Bottom * Factor));
end;

procedure TCanvasStretchDraw.Move(Delta: TPoint);
begin
  DestRect := ShiftRect(DestRect, Delta);
end;

function TCanvasStretchDraw.GetRect: TRect;
begin
  Result := DestRect;
end;

constructor TCanvasStretchDraw.Create;
begin
  SrcGraphic := nil;
end;

destructor TCanvasStretchDraw.Destroy;
begin
  inherited;
end;

{ TCanvasEllipse }

procedure TCanvasEllipse.Paint(Canvas: TCanvas);
begin
  Canvas.Pen.Assign(Pen);
  Canvas.Brush.Assign(Brush);
  Canvas.Ellipse(BoundingRect);
end;

procedure TCanvasEllipse.Zoom(Factor: Double);
begin
  BoundingRect := Rect(Trunc(BoundingRect.Left * Factor),
    Trunc(BoundingRect.Top * Factor),
    Trunc(BoundingRect.Right * Factor),
    Trunc(BoundingRect.Bottom * Factor));
  Pen.Width := Trunc(Pen.Width * Factor);
end;

procedure TCanvasEllipse.Move(Delta: TPoint);
begin
  BoundingRect := ShiftRect(BoundingRect, Delta);
end;

function TCanvasEllipse.GetRect: TRect;
begin
  Result := BoundingRect;
end;

constructor TCanvasEllipse.Create;
begin
  Pen := TPen.Create;
  Brush := TBrush.Create;
end;

destructor TCanvasEllipse.Destroy;
begin
  Pen.Free;
  Brush.Free;
  inherited;
end;

{ TCanvasPolygon }

procedure TCanvasPolygon.Paint(Canvas: TCanvas);
begin
  Canvas.Pen.Assign(Pen);
  Canvas.Brush.Assign(Brush);
  Canvas.Polygon(Points);
end;

procedure TCanvasPolygon.Zoom(Factor: Double);
var
  I: Integer;
begin
  for I := 0 to High(Points) do
    Points[I] := Point(Trunc(Points[I].X * Factor),
      Trunc(Points[I].Y * Factor));
  Pen.Width := Trunc(Pen.Width * Factor);
end;

procedure TCanvasPolygon.Move(Delta: TPoint);
var
  I: Integer;
begin
  for I := 0 to High(Points) do
    Points[I] := AddPoint(Points[I], Delta);
end;

function TCanvasPolygon.GetRect: TRect;
var
  I: Integer;
begin
  if Length(Points) = 0 then
    Result.Empty
  else begin
    Result := TRect.Create(Points[0], Points[0]);
    for I := 1 to Length(Points) - 1 do
    with Points[I] do begin
      Result.Top := Min(Result.Top, Points[I].Y);
      Result.Left := Min(Result.Left, Points[I].Y);
      Result.Bottom := Max(Result.Bottom, Points[I].Y);
      Result.Right := Max(Result.Right, Points[I].Y);
    end;
  end;
end;

constructor TCanvasPolygon.Create;
begin
  Pen := TPen.Create;
  Brush := TBrush.Create;
end;

destructor TCanvasPolygon.Destroy;
begin
  Brush.Free;
  Pen.Free;
  inherited;
end;

{ TCanvasLine }

procedure TCanvasLine.Paint(Canvas: TCanvas);
begin
  Canvas.Pen.Assign(Pen);
  Canvas.Line(P1, P2);
end;

procedure TCanvasLine.Zoom(Factor: Double);
begin
  P1 := Point(Trunc(P1.X * Factor), Trunc(P1.Y * Factor));
  P2 := Point(Trunc(P2.X * Factor), Trunc(P2.Y * Factor));
  Pen.Width := Trunc(Pen.Width * Factor);
end;

procedure TCanvasLine.Move(Delta: TPoint);
begin
  P1 := AddPoint(P1, Delta);
  P2 := AddPoint(P2, Delta);
end;

function TCanvasLine.GetRect: TRect;
begin
  Result := TRect.Create(P1, P2);
end;

constructor TCanvasLine.Create;
begin
  Pen := TPen.Create;
end;

destructor TCanvasLine.Destroy;
begin
  Pen.Free;
  inherited;
end;

{ TCanvasRectangle }

procedure TCanvasRectangle.Paint(Canvas: TCanvas);
begin
  Canvas.Pen.Assign(Pen);
  Canvas.Brush.Assign(Brush);

  if Rounded <> Point(0, 0) then Canvas.RoundRect(BoundingRect, Rounded.X, Rounded.Y)
    else Canvas.Rectangle(BoundingRect);
end;

procedure TCanvasRectangle.Zoom(Factor: Double);
begin
  BoundingRect := Rect(Trunc(BoundingRect.Left * Factor),
    Trunc(BoundingRect.Top * Factor),
    Trunc(BoundingRect.Right * Factor),
    Trunc(BoundingRect.Bottom * Factor));
  Pen.Width := Trunc(Pen.Width * Factor);
end;

procedure TCanvasRectangle.Move(Delta: TPoint);
begin
  BoundingRect := ShiftRect(BoundingRect, Delta);
end;

function TCanvasRectangle.GetRect: TRect;
begin
  Result := BoundingRect;
end;

constructor TCanvasRectangle.Create;
begin
  Pen := TPen.Create;
  Brush := TBrush.Create;
  Rounded := Point(0, 0);
end;

destructor TCanvasRectangle.Destroy;
begin
  Pen.Free;
  Brush.Free;
  inherited;
end;

{ TCanvasText }

procedure TCanvasText.Paint(Canvas: TCanvas);
begin
  Canvas.Brush.Assign(Brush);
  Canvas.Font.Assign(Font);
  Canvas.TextOut(Position.X, Position.Y, Text);
end;

procedure TCanvasText.Zoom(Factor: Double);
begin
  Position := Point(Trunc(Position.X * Factor), Trunc(Position.Y * Factor));
  Font.Size := Trunc(Font.Size * Factor);
end;

procedure TCanvasText.Move(Delta: TPoint);
begin
  Position := AddPoint(Position, Delta);
end;

function TCanvasText.GetRect: TRect;
begin
  Result := Bounds(Position.X, Position.Y, Position.X + MetaCanvas.TextExtent(Text).Width,
    Position.Y + MetaCanvas.TextExtent(Text).Height);
end;

constructor TCanvasText.Create;
begin
  Font := TFont.Create;
  Brush := TBrush.Create;
end;

destructor TCanvasText.Destroy;
begin
  Brush.Free;
  Font.Free;
  inherited;
end;

{ TCanvasObject }

procedure TCanvasObject.Paint(Canvas: TCanvas);
begin

end;

procedure TCanvasObject.Zoom(Factor: Double);
begin

end;

procedure TCanvasObject.Move(Delta: TPoint);
begin
end;

function TCanvasObject.GetRect: TRect;
begin
  Result := TRect.Empty;
end;

{ TMetaCanvas }

procedure TMetaCanvas.Polygon(const Points: array of TPoint);
var
  NewObj: TCanvasPolygon;
  I: Integer;
begin
  NewObj := TCanvasPolygon.Create;
  NewObj.MetaCanvas := Self;
  NewObj.Brush.Assign(Brush);
  NewObj.Pen.Assign(Pen);
  SetLength(NewObj.Points, Length(Points));
  for I := 0 to High(Points) do
    NewObj.Points[I] := Points[I];
  Objects.Add(NewObj);
end;


procedure TMetaCanvas.Ellipse(const Bounds: TRect);
var
  NewObj: TCanvasEllipse;
begin
  NewObj := TCanvasEllipse.Create;
  NewObj.MetaCanvas := Self;
  NewObj.Brush.Assign(Brush);
  NewObj.Pen.Assign(Pen);
  NewObj.BoundingRect := Bounds;
  Objects.Add(NewObj);
end;

procedure TMetaCanvas.StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic);
var
  NewObj: TCanvasStretchDraw;
begin
  NewObj := TCanvasStretchDraw.Create;
  NewObj.MetaCanvas := Self;
  NewObj.SrcGraphic := SrcGraphic;
  NewObj.DestRect := DestRect;
  Objects.Add(NewObj);
end;

function TMetaCanvas.TextExtent(const Text: string): TSize;
var
  Canvas: TCanvas;
begin
{  Canvas := TCanvas.Create;
  Canvas.Handle := CreateCompatibleDC(0);
  Canvas.Font.Assign(Font);
  Result := Canvas.TextExtent(Text);
  DeleteDC(Canvas.Handle);
  Canvas.Free;
  }
end;

function TMetaCanvas.GetSize: TSize;
begin
  Result := FSize;
end;

procedure TMetaCanvas.SetSize(AValue: TSize);
begin
  FSize := AValue;
end;

procedure TMetaCanvas.Rectangle(const ARect: TRect);
var
  NewObj: TCanvasRectangle;
begin
  NewObj := TCanvasRectangle.Create;
  NewObj.MetaCanvas := Self;
  NewObj.Pen.Assign(Pen);
  NewObj.Brush.Assign(Brush);
  NewObj.BoundingRect := ARect;
  Objects.Add(NewObj);
end;

procedure TMetaCanvas.Line(const P1, P2: TPoint);
var
  NewObj: TCanvasLine;
begin
  NewObj := TCanvasLine.Create;
  NewObj.MetaCanvas := Self;
  NewObj.Pen.Assign(Pen);
  NewObj.P1 := P1;
  NewObj.P2 := P2;
  Objects.Add(NewObj);
end;

procedure TMetaCanvas.TextOut(const Pos: TPoint; Text: string);
var
  NewObj: TCanvasText;
begin
  NewObj := TCanvasText.Create;
  NewObj.MetaCanvas := Self;
  NewObj.Font.Assign(Font);
  NewObj.Brush.Assign(Brush);
  NewObj.Position := Pos;
  NewObj.Text := Text;
  Objects.Add(NewObj);
end;

procedure TMetaCanvas.RoundRect(const Rect: TRect; RX, RY: Integer);
var
  NewObj: TCanvasRectangle;
begin
  NewObj := TCanvasRectangle.Create;
  NewObj.MetaCanvas := Self;
  NewObj.Brush.Assign(Brush);
  NewObj.Pen.Assign(Pen);
  NewObj.BoundingRect := Rect;
  NewObj.Rounded := Point(RX, RY);
  Objects.Add(NewObj);
end;

procedure TMetaCanvas.Pie(EllipseX1, EllipseY1, EllipseX2, EllipseY2, StartX,
  StartY, EndX, EndY: Integer);
var
  NewObj: TCanvasPie;
begin
  NewObj := TCanvasPie.Create;
  NewObj.MetaCanvas := Self;
  NewObj.Brush.Assign(Brush);
  NewObj.Pen.Assign(Pen);
  NewObj.BoundingRect := Rect(EllipseX1, EllipseY1, EllipseX2, EllipseY2);
  NewObj.StartPoint := Point(StartX, StartY);
  NewObj.EndPoint := Point(EndX, EndY);
  Objects.Add(NewObj);
end;

function TMetaCanvas.GetRealRect: TRect;
var
  I: Integer;
begin
  Result := TRect.Empty;
  for I := 0 to Objects.Count - 1 do
    if Result.IsEmpty then Result := Objects[I].GetRect
      else Result.Union(Objects[I].GetRect);
end;

procedure TMetaCanvas.Reset;
begin
  Objects.Count := 0;
end;

procedure TMetaCanvas.DrawTo(Canvas: TCanvas);
var
  I: Integer;
begin
  for I := 0 to Objects.Count - 1 do
    Objects[I].Paint(Canvas);
end;

procedure TMetaCanvas.Zoom(Factor: Double);
var
  I: Integer;
begin
  for I := 0 to Objects.Count - 1 do
    Objects[I].Zoom(Factor);
end;

procedure TMetaCanvas.Move(Delta: TPoint);
var
  I: Integer;
begin
  for I := 0 to Objects.Count - 1 do
    Objects[I].Move(Delta);
end;

constructor TMetaCanvas.Create;
begin
  inherited;
  Objects := TCanvasObjects.Create;
end;

destructor TMetaCanvas.Destroy;
begin
  Objects.Free;
  inherited;
end;

end.