mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-05 18:53:00 +02:00
1116 lines
30 KiB
ObjectPascal
1116 lines
30 KiB
ObjectPascal
unit CairoCanvas;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
{$define pangocairo}
|
|
|
|
interface
|
|
|
|
uses
|
|
Types, Graphics, GraphMath, LCLType, Classes, SysUtils, Printers, Cairo, math
|
|
{$ifdef pangocairo}
|
|
,Pango, PangoCairo, GLib2
|
|
{$endif}
|
|
;
|
|
|
|
type
|
|
{ TCairoPrinterCanvas }
|
|
|
|
TCairoPrinterCanvas = Class(TFilePrinterCanvas)
|
|
private
|
|
FLazClipRect : TRect;
|
|
procedure SelectFontEx(AStyle: TFontStyles; const AName: string;
|
|
ASize: double);
|
|
function SX(x: double): double;
|
|
function SY(y: double): double;
|
|
function SX2(x: double): double;
|
|
function SY2(y: double): double;
|
|
procedure SetSourceColor(Color: TColor);
|
|
procedure SetPenProperties;
|
|
procedure SetBrushProperties;
|
|
procedure SelectFont;
|
|
procedure PolylinePath(Points: PPoint; NumPts: Integer);
|
|
procedure EllipseArcPath(CX, CY, RX, RY: Double; Angle1, Angle2: Double;
|
|
Clockwise, Continuous: Boolean);
|
|
procedure ArcPath(ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength: double);
|
|
procedure ArcPath(ALeft, ATop, ARight, ABottom, StX, StY, EX, EY: double);
|
|
procedure FillAndStroke;
|
|
procedure FillOnly;
|
|
procedure StrokeOnly;
|
|
{$ifdef pangocairo}
|
|
function StylesToStr(Styles: TFontStyles):string;
|
|
function StyleToStr(Style: TFontStyle):string;
|
|
{$endif}
|
|
protected
|
|
cr: Pcairo_t;
|
|
ScaleX, ScaleY, FontScale: Double;
|
|
procedure DoLineTo(X1,Y1: Integer); override;
|
|
procedure CreateCairoHandle(BaseHandle: HDC); virtual;
|
|
procedure DestroyCairoHandle; virtual;
|
|
procedure SetHandle(NewHandle: HDC); override;
|
|
procedure BeginDoc; override;
|
|
procedure EndDoc; override;
|
|
procedure NewPage; override;
|
|
procedure CreateBrush; override;
|
|
public
|
|
SurfaceXDPI, SurfaceYDPI: Integer;
|
|
constructor Create(APrinter : TPrinter); override;
|
|
constructor Create; overload;
|
|
destructor Destroy; override;
|
|
procedure FillRect(const ARect: TRect); override;
|
|
procedure Rectangle(X1,Y1,X2,Y2: Integer); override;
|
|
procedure Polyline(Points: PPoint; NumPts: Integer); override;
|
|
procedure Polygon(Points: PPoint; NumPts: Integer; Winding: boolean = False); override;
|
|
procedure FrameRect(const ARect: TRect); override;
|
|
procedure Frame(const ARect: TRect); override;
|
|
procedure RoundRect(X1, Y1, X2, Y2: Integer; RX, RY: Integer); override;
|
|
procedure Ellipse(X1, Y1, X2, Y2: Integer); override;
|
|
procedure Arc(ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength: Integer); override;
|
|
procedure Arc(ALeft, ATop, ARight, ABottom, StX, StY, EX, EY: Integer); override;
|
|
procedure Chord(X1, Y1, X2, Y2, Angle1, Angle2: Integer); override;
|
|
procedure Chord(X1, Y1, X2, Y2, StX, StY, EX, EY: Integer); override;
|
|
procedure Pie(EllipseX1, EllipseY1, EllipseX2, EllipseY2, StartX, StartY, EndX, EndY: Integer); override;
|
|
procedure RadialPie(Left, Top, Right, Bottom, Angle1, Angle2: Integer); override;
|
|
procedure PolyBezier(Points: PPoint; NumPts: Integer; Filled: boolean = False; Continuous: boolean = False); override;
|
|
procedure TextOut(X,Y: Integer; const Text: String); override;
|
|
procedure TextRect(ARect: TRect; X1, Y1: integer; const Text: string; const Style: TTextStyle); override;
|
|
function TextExtent(const Text: string): TSize; override;
|
|
function GetTextMetrics(out M: TLCLTextMetric): boolean; override;
|
|
procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); override;
|
|
procedure SetPixel(X,Y: Integer; Value: TColor); override;
|
|
{ Not implemented
|
|
procedure FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle); override;
|
|
procedure CopyRect(const Dest: TRect; SrcCanvas: TCanvas; const Source: TRect); override;
|
|
procedure Frame3d(var ARect: TRect; const FrameWidth: integer; const Style: TGraphicsBevelCut); override;}
|
|
end;
|
|
|
|
{ TCairoFileCanvas }
|
|
|
|
TCairoFileCanvas = class (TCairoPrinterCanvas)
|
|
protected
|
|
sf: Pcairo_surface_t;
|
|
procedure CreateHandle; override;
|
|
procedure DestroyCairoHandle; override;
|
|
end;
|
|
|
|
{ TCairoPdfCanvas }
|
|
|
|
TCairoPdfCanvas = class(TCairoFileCanvas)
|
|
protected
|
|
procedure CreateCairoHandle(BaseHandle: HDC); override;
|
|
end;
|
|
|
|
{ TCairoSvgCanvas }
|
|
|
|
TCairoSvgCanvas = class(TCairoFileCanvas)
|
|
protected
|
|
procedure CreateCairoHandle(BaseHandle: HDC); override;
|
|
end;
|
|
|
|
{ TCairoPngCanvas }
|
|
|
|
TCairoPngCanvas = class(TCairoFileCanvas)
|
|
protected
|
|
procedure CreateCairoHandle(BaseHandle: HDC); override;
|
|
procedure DestroyCairoHandle; override;
|
|
public
|
|
constructor Create(APrinter: TPrinter); override;
|
|
end;
|
|
|
|
{ TCairoPsCanvas }
|
|
|
|
TCairoPsCanvas = class(TCairoFileCanvas)
|
|
protected
|
|
procedure CreateCairoHandle(BaseHandle: HDC); override;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
IntfGraphics, GraphType, FPimage;
|
|
|
|
{ TCairoPrinterCanvas }
|
|
|
|
const
|
|
Dash_Dash: array [0..2] of double = (3, 1, 3); //_ _
|
|
Dash_Dot: array [0..1] of double = (1, 1); //. .
|
|
Dash_DashDot: array [0..4] of double = (3, 1, 1, 1, 3); //_ . _
|
|
Dash_DashDotDot: array [0..6] of double = (3, 1, 1, 1, 1, 1, 3); //_ . . _
|
|
|
|
procedure TCairoPrinterCanvas.SetPenProperties;
|
|
|
|
procedure SetDash(d: array of double);
|
|
var
|
|
i, w: integer;
|
|
begin
|
|
w := Pen.Width;
|
|
for i := 0 to High(d) do
|
|
d[i] := d[i] * w;
|
|
cairo_set_dash(cr, @d, High(d), 0);
|
|
end;
|
|
begin
|
|
SetSourceColor(Pen.Color);
|
|
(* case Pen.Mode of
|
|
pmBlack: begin
|
|
SetSourceColor(clBlack);
|
|
cairo_set_operator(cr, CAIRO_OPERATOR_OVER);
|
|
end;
|
|
pmWhite: begin
|
|
SetSourceColor(clWhite);
|
|
cairo_set_operator(cr, CAIRO_OPERATOR_OVER);
|
|
end;
|
|
pmCopy: cairo_set_operator(cr, CAIRO_OPERATOR_OVER);
|
|
pmXor: cairo_set_operator(cr, CAIRO_OPERATOR_XOR);
|
|
pmNotXor: cairo_set_operator(cr, CAIRO_OPERATOR_XOR);
|
|
{ pmNop,
|
|
pmNot,
|
|
pmCopy,
|
|
pmNotCopy,
|
|
pmMergePenNot,
|
|
pmMaskPenNot,
|
|
pmMergeNotPen,
|
|
pmMaskNotPen,
|
|
pmMerge,
|
|
pmNotMerge,
|
|
pmMask,
|
|
pmNotMask,}
|
|
else
|
|
cairo_set_operator(cr, CAIRO_OPERATOR_OVER);
|
|
end;*)
|
|
case Pen.Style of
|
|
psSolid: cairo_set_dash(cr, nil, 0, 0);
|
|
psDash: SetDash(Dash_Dash);
|
|
psDot: SetDash(Dash_Dot);
|
|
psDashDot: SetDash(Dash_DashDot);
|
|
psDashDotDot: SetDash(Dash_DashDotDot);
|
|
else
|
|
cairo_set_dash(cr, nil, 0, 0);
|
|
end;
|
|
case Pen.EndCap of
|
|
pecRound: cairo_set_line_cap(cr, CAIRO_LINE_CAP_ROUND);
|
|
pecSquare: cairo_set_line_cap(cr, CAIRO_LINE_CAP_SQUARE);
|
|
pecFlat: cairo_set_line_cap(cr, CAIRO_LINE_CAP_BUTT);
|
|
end;
|
|
case Pen.JoinStyle of
|
|
pjsRound: cairo_set_line_join(cr, CAIRO_LINE_JOIN_ROUND);
|
|
pjsBevel: cairo_set_line_join(cr, CAIRO_LINE_JOIN_BEVEL);
|
|
pjsMiter: cairo_set_line_join(cr, CAIRO_LINE_JOIN_MITER);
|
|
end;
|
|
|
|
cairo_set_line_width(cr, Pen.Width*72/XDPI); //line_width is diameter of the pen circle
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.SetBrushProperties;
|
|
begin
|
|
SetSourceColor(Brush.Color);
|
|
{ case Brush.Style of
|
|
bsSolid
|
|
bsClear
|
|
bsHorizontal
|
|
bsVertical
|
|
bsFDiagonal
|
|
bsBDiagonal
|
|
bsCross
|
|
bsDiagCross
|
|
bsImage
|
|
bsPattern
|
|
end;}
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.DoLineTo(X1, Y1: Integer);
|
|
begin
|
|
cairo_move_to(cr, SX(PenPos.X), SY(PenPos.Y));
|
|
inherited DoLineTo(X1, Y1);
|
|
cairo_line_to(cr, SX(X1), SY(Y1));
|
|
StrokeOnly;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.CreateCairoHandle(BaseHandle: HDC);
|
|
begin
|
|
ScaleX := SurfaceXDPI/XDPI; //DPI can be changed between Create and CreateCairoHandle
|
|
ScaleY := SurfaceYDPI/YDPI;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.DestroyCairoHandle;
|
|
begin
|
|
cairo_destroy(cr);
|
|
cr := nil;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.SetHandle(NewHandle: HDC);
|
|
begin
|
|
if Assigned(cr) then
|
|
DestroyCairoHandle;
|
|
inherited SetHandle(NewHandle);
|
|
if NewHandle <> 0 then
|
|
CreateCairoHandle(NewHandle);
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.BeginDoc;
|
|
begin
|
|
inherited BeginDoc;
|
|
if assigned(printer) then
|
|
FLazClipRect:=printer.PaperSize.PaperRect.WorkRect;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.EndDoc;
|
|
begin
|
|
inherited EndDoc;
|
|
//if caller is printer, then at the end destroy cairo handles (flush output)
|
|
//and establishes CreateCairoHandle call on the next print
|
|
Handle := 0;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.NewPage;
|
|
begin
|
|
inherited NewPage;
|
|
cairo_show_page(cr);
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.CreateBrush;
|
|
begin
|
|
end;
|
|
|
|
constructor TCairoPrinterCanvas.Create(APrinter: TPrinter);
|
|
begin
|
|
inherited Create(APrinter);
|
|
ScaleX := 1;
|
|
ScaleY := 1;
|
|
FontScale := 1;
|
|
SurfaceXDPI := 72;
|
|
SurfaceYDPI := 72;
|
|
XDPI := SurfaceXDPI;
|
|
YDPI := SurfaceXDPI;
|
|
end;
|
|
|
|
constructor TCairoPrinterCanvas.Create;
|
|
begin
|
|
Create(nil);
|
|
end;
|
|
|
|
destructor TCairoPrinterCanvas.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TCairoPrinterCanvas.SX(x: double): double;
|
|
begin
|
|
Result := ScaleX*(x+FLazClipRect.Left);
|
|
end;
|
|
|
|
function TCairoPrinterCanvas.SY(y: double): double;
|
|
begin
|
|
Result := ScaleY*(y+FLazClipRect.Top);
|
|
end;
|
|
|
|
function TCairoPrinterCanvas.SX2(x: double): double;
|
|
begin
|
|
Result := ScaleX*x;
|
|
end;
|
|
|
|
function TCairoPrinterCanvas.SY2(y: double): double;
|
|
begin
|
|
Result := ScaleY*y;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.SetSourceColor(Color: TColor);
|
|
var
|
|
R, G, B: double;
|
|
begin
|
|
//TColor je ve formatu BGR
|
|
R := (Color and $FF) / 255;
|
|
G := ((Color shr 8) and $FF) / 255;
|
|
B := ((Color shr 16) and $FF) / 255;
|
|
cairo_set_source_rgb(cr, R, G, B);
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csBrushValid, csPenValid]);
|
|
SetPenProperties;
|
|
cairo_rectangle(cr, SX(X1), SY(Y1), SX2(X2-X1), SY2(Y2-Y1));
|
|
FillAndStroke;
|
|
Changed;
|
|
end;
|
|
|
|
//1 point rectangle in _Brush_ color
|
|
procedure TCairoPrinterCanvas.FrameRect(const ARect: TRect);
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csBrushValid]);
|
|
cairo_rectangle(cr, SX(ARect.Left), SY(ARect.Top), SX2(ARect.Right-ARect.Left), SY2(ARect.Bottom-ARect.Top));
|
|
SetSourceColor(Brush.Color);
|
|
cairo_set_line_width(cr, 1);
|
|
cairo_stroke(cr); //Don't touch
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.Frame(const ARect: TRect);
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csPenValid]);
|
|
cairo_rectangle(cr, SX(ARect.Left), SY(ARect.Top), SX2(ARect.Right-ARect.Left), SY2(ARect.Bottom-ARect.Top));
|
|
cairo_set_line_width(cr, 1);
|
|
SetSourceColor(Pen.Color);
|
|
cairo_stroke(cr); //Don't touch
|
|
Changed;
|
|
end;
|
|
|
|
//C* - center, R* - halfaxis
|
|
procedure TCairoPrinterCanvas.EllipseArcPath(CX, CY, RX, RY: Double; Angle1, Angle2: Double; Clockwise, Continuous: Boolean);
|
|
begin
|
|
if (RX=0) or (RY=0) then //cairo_scale do not likes zero params
|
|
Exit;
|
|
cairo_save(cr);
|
|
try
|
|
cairo_translate(cr, SX(CX), SY(CY));
|
|
cairo_scale(cr, SX2(RX), SY2(RY));
|
|
if not Continuous then
|
|
cairo_move_to(cr, cos(Angle1), sin(Angle1)); //Move to arcs starting point
|
|
if Clockwise then
|
|
cairo_arc(cr, 0, 0, 1, Angle1, Angle2)
|
|
else
|
|
cairo_arc_negative(cr, 0, 0, 1, Angle1, Angle2);
|
|
finally
|
|
cairo_restore(cr);
|
|
end;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.FillOnly;
|
|
begin
|
|
if Brush.Style <> bsClear then begin
|
|
SetBrushProperties;
|
|
cairo_fill(cr);
|
|
end;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.StrokeOnly;
|
|
begin
|
|
if Pen.Style <> psClear then begin
|
|
SetPenProperties;
|
|
cairo_stroke(cr);
|
|
end;
|
|
end;
|
|
|
|
{$ifdef pangocairo}
|
|
function TCairoPrinterCanvas.StylesToStr(Styles: TFontStyles): string;
|
|
begin
|
|
Result := '';
|
|
if fsBold in Styles then
|
|
Result := Result + 'bold ';
|
|
if fsItalic in Styles then
|
|
Result := Result + 'italic ';
|
|
end;
|
|
|
|
function TCairoPrinterCanvas.StyleToStr(Style: TFontStyle): string;
|
|
begin
|
|
result := '';
|
|
case Style of
|
|
fsBold: result := 'bold ';
|
|
fsItalic: result := 'italic ';
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
procedure TCairoPrinterCanvas.FillAndStroke;
|
|
begin
|
|
if Brush.Style <> bsClear then begin
|
|
SetBrushProperties;
|
|
if Pen.Style = psClear then
|
|
cairo_fill(cr)
|
|
else
|
|
cairo_fill_preserve(cr);
|
|
end;
|
|
if Pen.Style <> psClear then begin
|
|
SetPenProperties;
|
|
cairo_stroke(cr);
|
|
end;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.RoundRect(X1, Y1, X2, Y2: Integer; RX, RY: Integer);
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csPenValid, csBrushValid]);
|
|
cairo_move_to(cr, SX(X1+RX), SY(Y1));
|
|
cairo_line_to(cr, SX(X2-RX), SY(Y1));
|
|
EllipseArcPath(X2-RX, Y1+RY, RX, RY, -PI/2, 0, True, True);
|
|
cairo_line_to(cr, SX(X2), SY(Y2-RY));
|
|
EllipseArcPath(X2-RX, Y2-RY, RX, RY, 0, PI/2, True, True);
|
|
cairo_line_to(cr, SX(X1+RX), SY(Y2));
|
|
EllipseArcPath(X1+RX, Y2-RY, RX, RY, PI/2, PI, True, True);
|
|
cairo_line_to(cr, SX(X1), SY(Y1+RX));
|
|
EllipseArcPath(X1+RX, Y1+RY, RX, RY, PI, PI*1.5, True, True);
|
|
FillAndStroke;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.Ellipse(X1, Y1, X2, Y2: Integer);
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csPenValid, csBrushValid]);
|
|
EllipseArcPath((X2+X1)/2, (Y2+Y1)/2, (X2-X1)/2, (Y2-Y1)/2, 0, 2*PI, True, False);
|
|
FillAndStroke;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.Arc(ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength: Integer);
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csPenValid]);
|
|
ArcPath(ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength);
|
|
StrokeOnly;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.Chord(X1, Y1, X2, Y2, Angle1, Angle2: Integer);
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csPenValid, csBrushValid]);
|
|
ArcPath(X1, Y1, X2, Y2, Angle1, Angle2);
|
|
cairo_close_path(cr);
|
|
FillAndStroke;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.RadialPie(Left, Top, Right, Bottom, Angle1, Angle2: Integer);
|
|
var
|
|
cx, cy: double;
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csPenValid, csBrushValid]);
|
|
ArcPath(Left, Top, Right, Bottom, Angle1, Angle2);
|
|
cx := (Right+Left)/2;
|
|
cy := (Bottom+Top)/2;
|
|
cairo_line_to(cr, SX(cx), SY(cy));
|
|
cairo_close_path(cr);
|
|
FillAndStroke;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.ArcPath(ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength: double);
|
|
var
|
|
k: Double;
|
|
begin
|
|
k := - 2*PI/(360*16);
|
|
EllipseArcPath((ARight+ALeft)/2, (ABottom+ATop)/2, (ARight-ALeft)/2, (ABottom-ATop)/2,
|
|
Angle16Deg*k, Angle16DegLength*k, False, False);
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.Arc(ALeft, ATop, ARight, ABottom, StX, StY, EX, EY: Integer);
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csPenValid]);
|
|
ArcPath(ALeft, ATop, ARight, ABottom, StX, StY, EX, EY);
|
|
StrokeOnly;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.Chord(X1, Y1, X2, Y2, StX, StY, EX, EY: Integer);
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csPenValid, csBrushValid]);
|
|
ArcPath(X1, Y1, X2, Y2, StX, StY, EX, EY);
|
|
cairo_close_path(cr);
|
|
FillAndStroke;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.Pie(EllipseX1, EllipseY1, EllipseX2, EllipseY2,
|
|
StartX, StartY, EndX, EndY: Integer);
|
|
var
|
|
cx, cy: double;
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csPenValid, csBrushValid]);
|
|
ArcPath(EllipseX1, EllipseY1, EllipseX2, EllipseY2, StartX, StartY, EndX, EndY);
|
|
cx := (EllipseX2+EllipseX1)/2;
|
|
cy := (EllipseY2+EllipseY1)/2;
|
|
cairo_line_to(cr, SX(cx), SY(cy));
|
|
cairo_close_path(cr);
|
|
FillAndStroke;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.ArcPath(ALeft, ATop, ARight, ABottom, StX, StY, EX, EY: double);
|
|
|
|
function ATanInt(x, y: double): double;
|
|
begin
|
|
if x <> 0 then begin
|
|
result := ArcTan(y/x);
|
|
if x < 0 then
|
|
result := result + PI;
|
|
end else begin
|
|
if y > 0 then
|
|
result := PI/2
|
|
else
|
|
result := - PI/2;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
Angle1, Angle2: double;
|
|
cx, cy: double;
|
|
begin
|
|
cx := (ARight+ALeft)/2;
|
|
cy := (ABottom+ATop)/2;
|
|
Angle1 := ATanInt(StX-cx, StY-cy);
|
|
Angle2 := ATanInt(EX-cx, EY-cy);
|
|
EllipseArcPath(cx, cy, (ARight-ALeft)/2, (ABottom-ATop)/2, Angle1, Angle2, False, False);
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.PolyBezier(Points: PPoint; NumPts: Integer; Filled: boolean; Continuous: boolean);
|
|
var
|
|
p, ep: PPoint;
|
|
begin
|
|
p := Points;
|
|
ep := Points + NumPts;
|
|
while p < ep do begin
|
|
if (p = Points) or not Continuous then begin //First or non cont.
|
|
cairo_move_to(cr, SX(p^.X), SY(p^.Y));
|
|
inc(p);
|
|
end;
|
|
cairo_curve_to(cr, SX(p^.X), SY(p^.Y), SX((p+1)^.X), SY((p+1)^.Y), SX((p+2)^.X), SY((p+2)^.Y));
|
|
inc(p, 3);
|
|
end;
|
|
if Filled then begin
|
|
cairo_close_path(cr);
|
|
FillAndStroke;
|
|
end else
|
|
StrokeOnly;
|
|
end;
|
|
|
|
//Toy interface
|
|
procedure TCairoPrinterCanvas.SelectFont;
|
|
begin
|
|
RequiredState([csHandleValid]);
|
|
SelectFontEx(Font.Style, Font.Name, abs(Font.Size));
|
|
SetSourceColor(Font.Color);
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.SelectFontEx(AStyle: TFontStyles; const AName: string; ASize: double);
|
|
var
|
|
slant: cairo_font_slant_t;
|
|
weight: cairo_font_weight_t;
|
|
begin
|
|
if fsBold in Font.Style then
|
|
weight := CAIRO_FONT_WEIGHT_BOLD
|
|
else
|
|
weight := CAIRO_FONT_WEIGHT_NORMAL;
|
|
if fsItalic in Font.Style then
|
|
slant := CAIRO_FONT_SLANT_ITALIC
|
|
else
|
|
slant := CAIRO_FONT_SLANT_NORMAL;
|
|
cairo_select_font_face(cr, PChar(AName), slant, weight);
|
|
cairo_set_font_size(cr, ASize*FontScale)
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.TextOut(X, Y: Integer; const Text: String);
|
|
var
|
|
e: cairo_font_extents_t;
|
|
{$ifdef pangocairo}
|
|
Layout: PPangoLayout;
|
|
desc: PPangoFontDescription;
|
|
theFont: string;
|
|
{$endif}
|
|
begin
|
|
Changing;
|
|
|
|
RequiredState([csHandleValid, csFontValid, csBrushValid]);
|
|
SelectFont;
|
|
cairo_font_extents(cr, @e);
|
|
cairo_save(cr);
|
|
{$ifdef pangocairo}
|
|
// use absolute font size sintax (px)
|
|
theFOnt := format('%s %s %dpx',[Font.name, StylesToStr(Font.Style), abs(Font.Size)]);
|
|
Layout := Pango_Cairo_Create_Layout(cr);
|
|
desc := pango_font_description_from_string(pchar(TheFont));
|
|
pango_layout_set_font_description(layout, desc);
|
|
{$endif}
|
|
if Font.Orientation = 0 then
|
|
begin
|
|
cairo_move_to(cr, SX(X), SY(Y)+e.ascent);
|
|
{$ifdef pangocairo}
|
|
pango_layout_set_text(layout, PChar(Text), -1);
|
|
{$else}
|
|
cairo_show_text(cr, PChar(Text)); //Reference point is on the base line
|
|
{$endif}
|
|
end
|
|
else
|
|
begin
|
|
cairo_move_to(cr, SX(X)+e.ascent, SY(Y));
|
|
cairo_rotate(cr, -gradtorad(Font.Orientation));
|
|
{$ifdef pangocairo}
|
|
pango_layout_set_text(layout, PChar(Text), -1);
|
|
{$else}
|
|
cairo_show_text(cr, PChar(Text)); //Reference point is on the base line
|
|
{$endif}
|
|
end;
|
|
{$ifdef pangocairo}
|
|
pango_cairo_update_layout(cr, layout);
|
|
// get the same text origin as cairo_show_text (baseline left, instead of Pango's top left)
|
|
pango_cairo_show_layout_line (cr, pango_layout_get_line (layout, 0));
|
|
g_object_unref(layout);
|
|
pango_font_description_free(desc);
|
|
{$endif}
|
|
cairo_restore(cr);
|
|
Changed;
|
|
end;
|
|
|
|
type
|
|
TLine = class
|
|
Start, EndL: Integer;
|
|
Width: Double;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.TextRect(ARect: TRect; X1, Y1: integer; const Text: string; const Style: TTextStyle);
|
|
var
|
|
Lines: TList;
|
|
CurLine: TLine;
|
|
len: integer;
|
|
LastBreakEndL: Integer;
|
|
LastBreakStart: Integer;
|
|
s: string;
|
|
fe: cairo_font_extents_t;
|
|
|
|
procedure BreakLine(en, st: Integer);
|
|
var
|
|
s1: string;
|
|
te: cairo_text_extents_t;
|
|
begin
|
|
if en>=0 then begin
|
|
if en>1 then begin
|
|
if en <= len then
|
|
CurLine.EndL := en
|
|
else
|
|
CurLine.EndL := len;
|
|
end else
|
|
CurLine.EndL := 1;
|
|
s1 := Copy(s, CurLine.Start, CurLine.EndL-CurLine.Start+1);
|
|
cairo_text_extents(cr, PChar(s1), @te);
|
|
CurLine.Width := te.width + te.x_bearing;
|
|
end;
|
|
if st > 0 then begin
|
|
CurLine := TLine.Create;
|
|
Lines.Add(CurLine);
|
|
if st <= len then
|
|
CurLine.Start := st
|
|
else
|
|
CurLine.Start := len;
|
|
CurLine.EndL := 0;
|
|
end;
|
|
LastBreakEndL := 0;
|
|
LastBreakStart := 0;
|
|
end;
|
|
var
|
|
te: cairo_text_extents_t;
|
|
fd: TFontData;
|
|
s1, ch: string;
|
|
i, j: integer;
|
|
BoxLeft, BoxTop, BoxWidth, BoxHeight: Double;
|
|
StartLeft, StartTop: Double;
|
|
BreakBoxWidth: Double;
|
|
x, y: Double;
|
|
{$ifdef pangocairo}
|
|
Layout: PPangoLayout;
|
|
desc: PPangoFontDescription;
|
|
theFont: string;
|
|
{$endif}
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csFontValid, csBrushValid]);
|
|
Lines := TList.Create;
|
|
cairo_save(cr);
|
|
try
|
|
s := Text;
|
|
BoxWidth := SX2(ARect.Right-ARect.Left);
|
|
BoxHeight := SY2(ARect.Bottom-ARect.Top);
|
|
BoxLeft := SX(ARect.Left);
|
|
BoxTop := SY(ARect.Top);
|
|
StartLeft := SX(X1);
|
|
StartTop := SY(Y1);
|
|
if Style.Alignment = taLeftJustify then
|
|
BreakBoxWidth := SX(ARect.Right - X1)
|
|
else
|
|
BreakBoxWidth := BoxWidth;
|
|
|
|
if Style.Clipping then begin
|
|
cairo_rectangle(cr, BoxLeft, BoxTop, BoxWidth+Pen.Width, BoxHeight+Pen.Width);
|
|
cairo_clip(cr);
|
|
end;
|
|
if Style.ExpandTabs then
|
|
s := StringReplace(s, #9, ' ', [rfReplaceAll])
|
|
else
|
|
s := StringReplace(s, #9, ' ', [rfReplaceAll]);
|
|
if Style.SingleLine then begin
|
|
s := StringReplace(s, #13+#10, ' ', [rfReplaceAll]);
|
|
s := StringReplace(s, #13, ' ', [rfReplaceAll]);
|
|
s := StringReplace(s, #10, ' ', [rfReplaceAll]);
|
|
end;
|
|
if Style.Opaque then begin
|
|
SetSourceColor(Brush.Color);
|
|
cairo_rectangle(cr, BoxLeft, BoxTop, BoxWidth, BoxHeight);
|
|
cairo_fill(cr)
|
|
end;
|
|
if Style.SystemFont and Assigned(OnGetSystemFont) then begin
|
|
fd := GetFontData(OnGetSystemFont());
|
|
SelectFontEx(fd.Style, fd.Name, fd.Height);
|
|
SetSourceColor(clWindowText);
|
|
{$ifdef pangocairo}
|
|
theFont := format('%s %s %d',[fd.name, StylesToStr(fd.Style), Round(fd.Height*FontScale)]);
|
|
{$endif}
|
|
end else begin
|
|
SelectFont;
|
|
{$ifdef pangocairo}
|
|
// use absolute font size sintax (px)
|
|
theFOnt := format('%s %s %dpx',[Font.name, StylesToStr(Font.Style), abs(Font.Size)]);
|
|
{$endif}
|
|
end;
|
|
cairo_font_extents(cr, @fe);
|
|
|
|
//Break lines
|
|
len := Length(s);
|
|
BreakLine(-1, 1);
|
|
i := 1;
|
|
while i<=len+1 do begin
|
|
if i<=len then
|
|
ch := s[i]
|
|
else
|
|
ch := '';
|
|
//CR LF breaking
|
|
if ch = #13 then begin
|
|
if (i < len) and (s[i+1] = #10) then begin
|
|
BreakLine(i-1, i+2);
|
|
inc(i, 2);
|
|
Continue;
|
|
end else begin
|
|
BreakLine(i-1, i+1);
|
|
inc(i, 1);
|
|
Continue;
|
|
end;
|
|
end;
|
|
if ch = #10 then begin
|
|
BreakLine(i-1, i+1);
|
|
inc(i, 1);
|
|
Continue;
|
|
end;
|
|
|
|
//Word breaking
|
|
if Style.Wordbreak then begin
|
|
if (ch = '') or (ch = ' ') then begin //'' last char
|
|
s1 := Copy(s, CurLine.Start, i-CurLine.Start);
|
|
cairo_text_extents(cr, PChar(s1), @te);
|
|
//skip following break chars
|
|
j := i+1;
|
|
while (j<=len) and (s[j] = ' ') do
|
|
inc(j);
|
|
if te.width <= BreakBoxWidth then begin
|
|
LastBreakEndL := i-1;
|
|
LastBreakStart := j;
|
|
end else begin //overflow
|
|
if LastBreakEndL<=0 then begin //cannot break
|
|
BreakLine(i-1, j);
|
|
inc(i);
|
|
Continue;
|
|
end else begin
|
|
i := LastBreakStart; //before BreakLine where is LastBreakStart changed
|
|
BreakLine(LastBreakEndL, LastBreakStart);
|
|
Continue;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
//next char
|
|
inc(i);
|
|
end;
|
|
//Close last CurLine
|
|
BreakLine(Len, -1);
|
|
|
|
//Calc start positions
|
|
case Style.Layout of
|
|
tlTop: y := StartTop;
|
|
tlCenter: y := boxTop + BoxHeight/2 - fe.height*Lines.Count/2;
|
|
tlBottom: y := BoxTop+BoxHeight - fe.height*Lines.Count;
|
|
end;
|
|
{$ifdef pangocairo}
|
|
Layout := Pango_Cairo_Create_Layout(cr);
|
|
desc := pango_font_description_from_string(pchar(TheFont));
|
|
pango_layout_set_font_description(layout, desc);
|
|
{$endif}
|
|
//Text output
|
|
for i := 0 to Lines.Count-1 do begin
|
|
CurLine := TLine(Lines.Items[i]);
|
|
case Style.Alignment of
|
|
taLeftJustify: x := StartLeft;
|
|
taCenter: x := BoxLeft + BoxWidth/2 - CurLine.Width/2;
|
|
taRightJustify: x := BoxLeft+BoxWidth - CurLine.Width;
|
|
end;
|
|
cairo_move_to(cr, x, y+fe.ascent);
|
|
s1 := Copy(s, CurLine.Start, CurLine.EndL-CurLine.Start+1);
|
|
{$ifdef pangocairo}
|
|
pango_layout_set_text(layout, pchar(s1), -1);
|
|
{$else}
|
|
cairo_show_text(cr, PChar(s1)); //Reference point is on the base line
|
|
{$endif}
|
|
y := y + fe.height;
|
|
end;
|
|
{$ifdef pangocairo}
|
|
pango_cairo_update_layout(cr, layout);
|
|
// get the same text origin as cairo_show_text (baseline left, instead of Pango's top left)
|
|
pango_cairo_show_layout_line (cr, pango_layout_get_line (layout, 0));
|
|
g_object_unref(layout);
|
|
pango_font_description_free(desc);
|
|
{$endif}
|
|
|
|
finally
|
|
cairo_restore(cr);
|
|
for i := 0 to Lines.Count-1 do
|
|
TLine(Lines.Items[i]).Free;
|
|
Lines.Free;
|
|
end;
|
|
Changed;
|
|
end;
|
|
|
|
function TCairoPrinterCanvas.TextExtent(const Text: string): TSize;
|
|
var
|
|
extents: cairo_text_extents_t;
|
|
begin
|
|
SelectFont;
|
|
cairo_text_extents(cr, PChar(Text), @extents); //transformation matrix is here ignored
|
|
Result.cx := Round(extents.width/ScaleX);
|
|
Result.cy := Round(extents.height/ScaleY);
|
|
end;
|
|
|
|
function TCairoPrinterCanvas.GetTextMetrics(out M: TLCLTextMetric): boolean;
|
|
var
|
|
e: cairo_font_extents_t;
|
|
begin
|
|
SelectFont;
|
|
cairo_font_extents(cr, @e); //transformation matrix is here ignored
|
|
FillChar(M, SizeOf(M), 0);
|
|
M.Ascender := Round(e.ascent/ScaleY);
|
|
M.Descender := Round(e.descent/ScaleY);
|
|
M.Height := Round(e.height/ScaleY);
|
|
Result := True;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic);
|
|
|
|
function TranslateBufferByIntfImage(buf: PByte; W, H: Integer): Boolean;
|
|
var
|
|
p: PDWord;
|
|
x, y: Integer;
|
|
c: TFPColor;
|
|
Img: TLazIntfImage;
|
|
begin
|
|
Img := TRasterImage(SrcGraphic).CreateIntfImage;
|
|
try
|
|
if Img.DataDescription.Format=ricfNone then begin
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
p := Pointer(buf);
|
|
for y := 0 to H-1 do begin
|
|
for x := 0 to W-1 do begin
|
|
c := Img.Colors[x, y];
|
|
p^ := Hi(c.alpha) shl 24 + Hi(c.red) shl 16 + Hi(c.green) shl 8 + Hi(c.blue);
|
|
inc(p);
|
|
end;
|
|
end;
|
|
finally
|
|
Img.Free;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
var
|
|
sf: Pcairo_surface_t;
|
|
buf: PByte;
|
|
W, H: Integer;
|
|
SW, SH: Double;
|
|
begin
|
|
if not (SrcGraphic is TRasterImage) then begin
|
|
inherited StretchDraw(DestRect, SrcGraphic);
|
|
Exit;
|
|
end;
|
|
|
|
Changing;
|
|
RequiredState([csHandleValid]);
|
|
W := SrcGraphic.Width;
|
|
H := SrcGraphic.Height;
|
|
|
|
buf := GetMem(W*H*4);
|
|
try
|
|
cairo_save(cr);
|
|
//FillDWord(buf^, W*H, $00000000);
|
|
if not TranslateBufferByIntfImage(buf, W, H) then
|
|
Exit;
|
|
|
|
sf := cairo_image_surface_create_for_data(buf, CAIRO_FORMAT_ARGB32, W, H, W*4);
|
|
cairo_translate(cr, SX(DestRect.Left), SY(DestRect.Top));
|
|
SW := (DestRect.Right - DestRect.Left)/W;
|
|
SH := (DestRect.Bottom - DestRect.Top)/H;
|
|
cairo_scale(cr, SX2(SW), SY2(SH));
|
|
cairo_set_source_surface(cr, sf, 0, 0);
|
|
cairo_paint(cr);
|
|
cairo_surface_destroy(sf);
|
|
cairo_restore(cr);
|
|
finally
|
|
FreeMem(buf);
|
|
end;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.SetPixel(X, Y: Integer; Value: TColor);
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csPenValid]);
|
|
SetSourceColor(Value);
|
|
cairo_rectangle(cr, SX(X), SY(Y), 1, 1);
|
|
cairo_fill(cr);
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.PolylinePath(Points: PPoint; NumPts: Integer);
|
|
var
|
|
p: PPoint;
|
|
i: integer;
|
|
begin
|
|
p := Points;
|
|
cairo_move_to(cr, SX(p^.X), SY(p^.Y));
|
|
for i := 0 to NumPts-2 do begin
|
|
inc(p);
|
|
cairo_line_to(cr, SX(p^.X), SY(p^.Y));
|
|
end;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.Polyline(Points: PPoint; NumPts: Integer);
|
|
begin
|
|
if NumPts <= 0 then
|
|
Exit;
|
|
Changing;
|
|
RequiredState([csHandleValid, csPenValid]);
|
|
PolylinePath(Points, NumPts);
|
|
StrokeOnly;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.Polygon(Points: PPoint; NumPts: Integer; Winding: boolean);
|
|
begin
|
|
if NumPts <= 0 then
|
|
Exit;
|
|
Changing;
|
|
RequiredState([csHandleValid, csBrushValid, csPenValid]);
|
|
PolylinePath(Points, NumPts);
|
|
cairo_close_path(cr);
|
|
FillAndStroke;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TCairoPrinterCanvas.FillRect(const ARect: TRect);
|
|
begin
|
|
Changing;
|
|
RequiredState([csHandleValid, csBrushValid]);
|
|
cairo_rectangle(cr, SX(ARect.Left), SY(ARect.Top), SX2(ARect.Right-ARect.Left), SY2(ARect.Bottom-ARect.Top));
|
|
FillOnly;
|
|
Changed;
|
|
end;
|
|
|
|
{ TCairoFileCanvas }
|
|
|
|
procedure TCairoFileCanvas.CreateHandle;
|
|
begin
|
|
Handle := 1; // set dummy handle (calls SetHandle)
|
|
end;
|
|
|
|
procedure TCairoFileCanvas.DestroyCairoHandle;
|
|
begin
|
|
cairo_surface_finish(sf);
|
|
cairo_surface_destroy(sf);
|
|
sf := nil;
|
|
inherited DestroyCairoHandle;
|
|
end;
|
|
|
|
{ TCairoPdfCanvas }
|
|
|
|
procedure TCairoPdfCanvas.CreateCairoHandle(BaseHandle: HDC);
|
|
begin
|
|
inherited CreateCairoHandle(BaseHandle);
|
|
//Sizes are in Points, 72DPI (1pt = 1/72")
|
|
sf := cairo_pdf_surface_create(PChar(FOutputFileName), PaperWidth*ScaleX, PaperHeight*ScaleY);
|
|
cr := cairo_create(sf);
|
|
end;
|
|
|
|
{ TCairoPsCanvas }
|
|
|
|
procedure TCairoPsCanvas.CreateCairoHandle(BaseHandle: HDC);
|
|
var
|
|
s: string;
|
|
W, H: Double;
|
|
begin
|
|
inherited CreateCairoHandle(BaseHandle);
|
|
|
|
if Orientation = poLandscape then begin
|
|
s := '%%PageOrientation: Landscape';
|
|
W := PaperHeight*ScaleY; //switch H, W
|
|
H := PaperWidth*ScaleX;
|
|
end else begin
|
|
s := '%%PageOrientation: Portait';
|
|
W := PaperWidth*ScaleX;
|
|
H := PaperHeight*ScaleY;
|
|
end;
|
|
|
|
//Sizes are in Points, 72DPI (1pt = 1/72")
|
|
sf := cairo_ps_surface_create(PChar(FOutputFileName), W, H);
|
|
cr := cairo_create(sf);
|
|
|
|
cairo_ps_surface_dsc_begin_setup(sf);
|
|
cairo_ps_surface_dsc_comment(sf, PChar(s));
|
|
|
|
if Orientation = poLandscape then begin //rotate and move
|
|
cairo_translate(cr, 0, H);
|
|
cairo_rotate(cr, -PI/2);
|
|
end;
|
|
end;
|
|
|
|
{ TCairoSvgCanvas }
|
|
|
|
procedure TCairoSvgCanvas.CreateCairoHandle(BaseHandle: HDC);
|
|
begin
|
|
inherited CreateCairoHandle(BaseHandle);
|
|
//Sizes are in Points, 72DPI (1pt = 1/72")
|
|
sf := cairo_svg_surface_create(PChar(FOutputFileName), PaperWidth*ScaleX, PaperHeight*ScaleY);
|
|
cr := cairo_create(sf);
|
|
end;
|
|
|
|
{ TCairoPngCanvas }
|
|
|
|
constructor TCairoPngCanvas.Create(APrinter: TPrinter);
|
|
begin
|
|
inherited Create(APrinter);
|
|
end;
|
|
|
|
procedure TCairoPngCanvas.CreateCairoHandle(BaseHandle: HDC);
|
|
begin
|
|
inherited CreateCairoHandle(BaseHandle);
|
|
//I do not know how to retrieve DPI of cairo_image_surface
|
|
//It looks like that Cairo uses same DPI as Screen, but how much is it in case of console app???
|
|
//You must set Surface?DPI externally. For example:
|
|
//c := TCairoPngCanvas.Create;
|
|
//c.SurfaceXDPI := GetDeviceCaps(DC, LOGPIXELSX);
|
|
//c.SurfaceYDPI := GetDeviceCaps(DC, LOGPIXELSY);
|
|
sf := cairo_image_surface_create(CAIRO_FORMAT_ARGB32, PaperWidth, PaperHeight);
|
|
cr := cairo_create(sf);
|
|
cairo_scale(cr, 1/ScaleX, 1/ScaleY);
|
|
end;
|
|
|
|
procedure TCairoPngCanvas.DestroyCairoHandle;
|
|
begin
|
|
cairo_surface_write_to_png(sf, PChar(FOutputFileName));
|
|
inherited DestroyCairoHandle;
|
|
end;
|
|
|
|
end.
|
|
|