{ /*************************************************************************** PostscriptCanvas.pas ------------ PostScript Printer Canvas object ***************************************************************************/ ***************************************************************************** * * * This file is part of the Lazarus Component Library (LCL) * * * * See the file COPYING.LCL, included in this distribution, * * for details about the copyright. * * * * 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. * * * ***************************************************************************** Author: Olivier Guilbaud Informations : - Green Book Listing 9-1, on page 138 for Pattrens - PostScriptPrinter unit of Tony Maro - Piddle Project (Python language) - Internet PostScript forums Warnings : - Draw and StretchDraw it's slow for big image - Angles it's 1/16 of degre ToDo : - Implemente few methods } unit PostscriptCanvas; {$mode objfpc}{$H+} interface uses Classes, SysUtils, Math, Types, Graphics, Forms, GraphMath, GraphType, FPImage, IntfGraphics, Printers, LCLType, LCLIntf; Type TPostscriptPrinterCanvas = Class(TPrinterCanvas) private fHeader : TStringList; //Header document fDocument : TstringList; //Current document fFileName : String; //OutOut fileName fBuffer : TStringList; //PostScript temporary buffer //Current values fcBrushStyle : TBrushStyle; fcPenColor : TColor; //Color of Pen and Brush fcPenWidth : Integer; fcPenStyle : TPenStyle; fcLastFont : TFont; fPenPos : TPoint; FirstUpdatefont: Boolean; procedure WriteHeader(St : String); procedure Write(const St : String; Lst : TstringList = nil); overload; procedure WriteB(const St : string); procedure ClearBuffer; procedure Write(Lst : TStringList); overload; procedure WriteComment(const St : string); Procedure TranslateCoord(Var X,Y : Integer); procedure SetPosition(X,Y : Integer); procedure UpdateLineWidth; procedure UpdateLineColor(aColor : TColor = clNone); procedure UpdateLineStyle; procedure UpdateFillColor; procedure UpdateFont; function MappedFontName: string; function MapedString(const St : string):string; procedure MoveToLastPos; procedure SetBrushFillPattern(Lst : TStringList; SetBorder,SetFill : Boolean); procedure SetBrushFillPattern(SetBorder,SetFill : Boolean); overload; procedure GetRGBImage(SrcGraph: TGraphic; Lst : TStringList); protected procedure CreateHandle; override; procedure BeginDoc; override; procedure EndDoc; override; procedure NewPage; override; public constructor Create(APrinter : TPrinter); override; destructor Destroy; override; procedure SaveToFile(aFileName : string); Procedure MoveTo(X1,Y1: Integer); override; Procedure LineTo(X1,Y1: Integer); override; procedure Polyline(Points: PPoint; NumPts: Integer); override; procedure PolyBezier(Points: PPoint; NumPts: Integer; Filled: boolean = False; Continuous: boolean = False); override; Procedure Rectangle(X1,Y1,X2,Y2: Integer); override; procedure Frame(const ARect: TRect); override; // border using pen procedure FrameRect(const ARect: TRect); override; // border using brush Procedure FillRect(const ARect: TRect); override; Procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY: Integer); override; procedure Polygon(Points: PPoint; NumPts: Integer; Winding: boolean = False); override; procedure Ellipse(x1, y1, x2, y2: Integer); override; procedure Arc(Left,Top,Right,Bottom,angle1,angle2: Integer); override; procedure RadialPie(Left,Top,Right,Bottom,angle1,angle2: Integer); override; procedure Chord(x1, y1, x2, y2, angle1, angle2: Integer); override; procedure TextOut(X,Y: Integer; const Text: String); override; function TextExtent(const Text: string): TSize; override; Procedure Draw(X,Y: Integer; SrcGraphic: TGraphic); override; procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); override; //** Methods not definined on PostScript procedure FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle); override; Procedure CopyRect(const Dest: TRect; SrcCanvas: TCanvas; const Source: TRect); override; //** Methods not implemented procedure Arc(x,y,Right,Bottom,SX,SY,EX,EY: Integer); override; procedure Chord(x1, y1, x2, y2, SX, SY, EX, EY: Integer); override; procedure Frame3d(var ARect: TRect; const FrameWidth: integer; const Style: TGraphicsBevelCut); override; procedure RadialPie(x1,y1,x2,y2,sx,sy,ex,ey: Integer); override; procedure Pie(EllipseX1,EllipseY1,EllipseX2,EllipseY2, StartX,StartY,EndX,EndY: Integer); override; procedure TextRect(ARect: TRect; X, Y: integer; const Text: string; const Style: TTextStyle); override; property OutPutFileName : string read fFileName write fFileName; end; TPostscriptCanvas = Class(TPostscriptPrinterCanvas) public Constructor Create; overload; procedure BeginDoc; override; procedure EndDoc; override; procedure NewPage; override; end; implementation Type TFontsWidths = Array[32..255] of Integer; TFontPSMetrics = Record Name : string; Widths : TFontsWidths; end; Const cBrushStyle : Array[TBrushStyle] of String = ('bsClear', 'bsSolid', 'bsBDiagonal', 'bsFDiagonal', 'bsCross', 'bsDiagCross', 'bsHorizontal', 'bsVertical', 'bsImage', 'bsPattern'); cFontPSMetrics : Array[0..12] of TFontPSMetrics =( (Name : 'CourierISO'; Widths: (600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600) ), (Name : 'CourierISO-Bold'; Widths: (600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600) ), (Name : 'CourierISO-Oblique'; Widths: (600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600) ), (Name : 'CourierISO-Oblique-Bold'; Widths: (600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, 600) ), (Name : 'HelveticaISO'; Widths: (278, 278, 355, 556, 556, 889, 667, 191, 333, 333, 389, 584, 278, 333, 278, 278, 556, 556, 556, 556, 556, 556, 556, 556, 556, 556, 278, 278, 584, 584, 584, 556, 1015, 667, 667, 722, 722, 667, 611, 778, 722, 278, 500, 667, 556, 833, 722, 778, 667, 778, 722, 667, 611, 722, 667, 944, 667, 667, 611, 278, 278, 278, 469, 556, 333, 556, 556, 500, 556, 556, 278, 556, 556, 222, 222, 500, 222, 833, 556, 556, 556, 556, 333, 500, 278, 556, 500, 722, 500, 500, 500, 334, 260, 334, 584, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 333, 556, 556, 556, 556, 260, 556, 333, 737, 370, 556, 584, 333, 737, 333, 400, 584, 333, 333, 333, 556, 537, 278, 333, 333, 365, 556, 834, 834, 834, 611, 667, 667, 667, 667, 667, 667, 1000, 722, 667, 667, 667, 667, 278, 278, 278, 278, 722, 722, 778, 778, 778, 778, 778, 584, 778, 722, 722, 722, 722, 667, 667, 611, 556, 556, 556, 556, 556, 556, 889, 500, 556, 556, 556, 556, 278, 278, 278, 278, 556, 556, 556, 556, 556, 556, 556, 584, 611, 556, 556, 556, 556, 500, 556, 500) ), (Name : 'HelveticaISO-Bold'; Widths: (278, 333, 474, 556, 556, 889, 722, 238, 333, 333, 389, 584, 278, 333, 278, 278, 556, 556, 556, 556, 556, 556, 556, 556, 556, 556, 333, 333, 584, 584, 584, 611, 975, 722, 722, 722, 722, 667, 611, 778, 722, 278, 556, 722, 611, 833, 722, 778, 667, 778, 722, 667, 611, 722, 667, 944, 667, 667, 611, 333, 278, 333, 584, 556, 333, 556, 611, 556, 611, 556, 333, 611, 611, 278, 278, 556, 278, 889, 611, 611, 611, 611, 389, 556, 333, 611, 556, 778, 556, 556, 500, 389, 280, 389, 584, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 278, 333, 556, 556, 556, 556, 280, 556, 333, 737, 370, 556, 584, 333, 737, 333, 400, 584, 333, 333, 333, 611, 556, 278, 333, 333, 365, 556, 834, 834, 834, 611, 722, 722, 722, 722, 722, 722, 1000, 722, 667, 667, 667, 667, 278, 278, 278, 278, 722, 722, 778, 778, 778, 778, 778, 584, 778, 722, 722, 722, 722, 667, 667, 611, 556, 556, 556, 556, 556, 556, 889, 556, 556, 556, 556, 556, 278, 278, 278, 278, 611, 611, 611, 611, 611, 611, 611, 584, 611, 611, 611, 611, 611, 556, 611, 556) ), (Name : 'HelveticaISO-Oblique'; Widths: (278, 278, 355, 556, 556, 889, 667, 191, 333, 333, 389, 584, 278, 333, 278, 278, 556, 556, 556, 556, 556, 556, 556, 556, 556, 556, 278, 278, 584, 584, 584, 556, 1015, 667, 667, 722, 722, 667, 611, 778, 722, 278, 500, 667, 556, 833, 722, 778, 667, 778, 722, 667, 611, 722, 667, 944, 667, 667, 611, 278, 278, 278, 469, 556, 333, 556, 556, 500, 556, 556, 278, 556, 556, 222, 222, 500, 222, 833, 556, 556, 556, 556, 333, 500, 278, 556, 500, 722, 500, 500, 500, 334, 260, 334, 584, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 278, 333, 556, 556, 556, 556, 260, 556, 333, 737, 370, 556, 584, 333, 737, 333, 400, 584, 333, 333, 333, 556, 537, 278, 333, 333, 365, 556, 834, 834, 834, 611, 667, 667, 667, 667, 667, 667, 1000, 722, 667, 667, 667, 667, 278, 278, 278, 278, 722, 722, 778, 778, 778, 778, 778, 584, 778, 722, 722, 722, 722, 667, 667, 611, 556, 556, 556, 556, 556, 556, 889, 500, 556, 556, 556, 556, 278, 278, 278, 278, 556, 556, 556, 556, 556, 556, 556, 584, 611, 556, 556, 556, 556, 500, 556, 500) ), (Name : 'HelveticaISO-Oblique-Bold'; Widths: (278, 333, 474, 556, 556, 889, 722, 238, 333, 333, 389, 584, 278, 333, 278, 278, 556, 556, 556, 556, 556, 556, 556, 556, 556, 556, 333, 333, 584, 584, 584, 611, 975, 722, 722, 722, 722, 667, 611, 778, 722, 278, 556, 722, 611, 833, 722, 778, 667, 778, 722, 667, 611, 722, 667, 944, 667, 667, 611, 333, 278, 333, 584, 556, 333, 556, 611, 556, 611, 556, 333, 611, 611, 278, 278, 556, 278, 889, 611, 611, 611, 611, 389, 556, 333, 611, 556, 778, 556, 556, 500, 389, 280, 389, 584, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 278, 333, 556, 556, 556, 556, 280, 556, 333, 737, 370, 556, 584, 333, 737, 333, 400, 584, 333, 333, 333, 611, 556, 278, 333, 333, 365, 556, 834, 834, 834, 611, 722, 722, 722, 722, 722, 722, 1000, 722, 667, 667, 667, 667, 278, 278, 278, 278, 722, 722, 778, 778, 778, 778, 778, 584, 778, 722, 722, 722, 722, 667, 667, 611, 556, 556, 556, 556, 556, 556, 889, 556, 556, 556, 556, 556, 278, 278, 278, 278, 611, 611, 611, 611, 611, 611, 611, 584, 611, 611, 611, 611, 611, 556, 611, 556) ), (Name : 'RomanISO'; Widths: (250, 333, 408, 500, 500, 833, 778, 180, 333, 333, 500, 564, 250, 333, 250, 278, 500, 500, 500, 500, 500, 500, 500, 500, 500, 500, 278, 278, 564, 564, 564, 444, 921, 722, 667, 667, 722, 611, 556, 722, 722, 333, 389, 722, 611, 889, 722, 722, 556, 722, 667, 556, 611, 722, 722, 944, 722, 722, 611, 333, 278, 333, 469, 500, 333, 444, 500, 444, 500, 444, 333, 500, 500, 278, 278, 500, 278, 778, 500, 500, 500, 500, 333, 389, 278, 500, 500, 722, 500, 500, 444, 480, 200, 480, 541, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 250, 333, 500, 500, 500, 500, 200, 500, 333, 760, 276, 500, 564, 333, 760, 333, 400, 564, 300, 300, 333, 500, 453, 250, 333, 300, 310, 500, 750, 750, 750, 444, 722, 722, 722, 722, 722, 722, 889, 667, 611, 611, 611, 611, 333, 333, 333, 333, 722, 722, 722, 722, 722, 722, 722, 564, 722, 722, 722, 722, 722, 722, 556, 500, 444, 444, 444, 444, 444, 444, 667, 444, 444, 444, 444, 444, 278, 278, 278, 278, 500, 500, 500, 500, 500, 500, 500, 564, 500, 500, 500, 500, 500, 500, 500, 500) ), (Name : 'TimesISO-Bold'; Widths: (250, 333, 555, 500, 500, 1000, 833, 278, 333, 333, 500, 570, 250, 333, 250, 278, 500, 500, 500, 500, 500, 500, 500, 500, 500, 500, 333, 333, 570, 570, 570, 500, 930, 722, 667, 722, 722, 667, 611, 778, 778, 389, 500, 778, 667, 944, 722, 778, 611, 778, 722, 556, 667, 722, 722, 1000, 722, 722, 667, 333, 278, 333, 581, 500, 333, 500, 556, 444, 556, 444, 333, 500, 556, 278, 333, 556, 278, 833, 556, 500, 556, 556, 444, 389, 333, 556, 500, 722, 500, 500, 444, 394, 220, 394, 520, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 944, 250, 333, 500, 500, 500, 500, 220, 500, 333, 747, 300, 500, 570, 333, 747, 333, 400, 570, 300, 300, 333, 556, 540, 250, 333, 300, 330, 500, 750, 750, 750, 500, 722, 722, 722, 722, 722, 722, 1000, 722, 667, 667, 667, 667, 389, 389, 389, 389, 722, 722, 778, 778, 778, 778, 778, 570, 778, 722, 722, 722, 722, 722, 611, 556, 500, 500, 500, 500, 500, 500, 722, 444, 444, 444, 444, 444, 278, 278, 278, 278, 500, 556, 500, 500, 500, 500, 500, 570, 500, 556, 556, 556, 556, 500, 556, 500) ), (Name : 'TimesISO-Italic'; Widths: (250, 333, 420, 500, 500, 833, 778, 214, 333, 333, 500, 675, 250, 333, 250, 278, 500, 500, 500, 500, 500, 500, 500, 500, 500, 500, 333, 333, 675, 675, 675, 500, 920, 611, 611, 667, 722, 611, 611, 722, 722, 333, 444, 667, 556, 833, 667, 722, 611, 722, 611, 500, 556, 722, 611, 833, 611, 556, 556, 389, 278, 389, 422, 500, 333, 500, 500, 444, 500, 444, 278, 500, 500, 278, 278, 444, 278, 722, 500, 500, 500, 500, 389, 389, 278, 500, 444, 667, 444, 444, 389, 400, 275, 400, 541, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 833, 250, 389, 500, 500, 500, 500, 275, 500, 333, 760, 276, 500, 675, 333, 760, 333, 400, 675, 300, 300, 333, 500, 523, 250, 333, 300, 310, 500, 750, 750, 750, 500, 611, 611, 611, 611, 611, 611, 889, 667, 611, 611, 611, 611, 333, 333, 333, 333, 722, 667, 722, 722, 722, 722, 722, 675, 722, 722, 722, 722, 722, 556, 611, 500, 500, 500, 500, 500, 500, 500, 667, 444, 444, 444, 444, 444, 278, 278, 278, 278, 500, 500, 500, 500, 500, 500, 500, 675, 500, 500, 500, 500, 500, 444, 500, 444) ), (Name : 'TimesISO-Italic-Bold'; Widths: (250, 389, 555, 500, 500, 833, 778, 278, 333, 333, 500, 570, 250, 333, 250, 278, 500, 500, 500, 500, 500, 500, 500, 500, 500, 500, 333, 333, 570, 570, 570, 500, 832, 667, 667, 667, 722, 667, 667, 722, 778, 389, 500, 667, 611, 889, 722, 722, 611, 722, 667, 556, 611, 722, 667, 889, 667, 611, 611, 333, 278, 333, 570, 500, 333, 500, 500, 444, 500, 444, 333, 500, 556, 278, 278, 500, 278, 778, 556, 500, 500, 500, 389, 389, 278, 556, 444, 667, 500, 444, 389, 348, 220, 348, 570, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 889, 250, 389, 500, 500, 500, 500, 220, 500, 333, 747, 266, 500, 606, 333, 747, 333, 400, 570, 300, 300, 333, 576, 500, 250, 333, 300, 300, 500, 750, 750, 750, 500, 667, 667, 667, 667, 667, 667, 944, 667, 667, 667, 667, 667, 389, 389, 389, 389, 722, 722, 722, 722, 722, 722, 722, 570, 722, 722, 722, 722, 722, 611, 611, 500, 500, 500, 500, 500, 500, 500, 722, 444, 444, 444, 444, 444, 278, 278, 278, 278, 500, 556, 500, 500, 500, 500, 500, 570, 500, 556, 556, 556, 556, 444, 500, 444) ), (Name : 'Symbol'; Widths: (250,333,713,500,549,833,778,439, 333,333,500,549,250,549,250,278,500,500, 500,500,500,500,500,500,500,500,278,278, 549,549,549,444,549,722,667,722,612,611, 763,603,722,333,631,722,686,889,722,722, 768,741,556,592,611,690,439,768,645,795, 611,333,863,333,658,500,500,631,549,549, 494,439,521,411,603,329,603,549,549,576, 521,549,549,521,549,603,439,576,713,686, 493,686,494,480,200,480,549,0,0,0, 0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0, 0,620,247,549,167,713,500,753,753,753, 753,1042,987,603,987,603,400,549,411,549, 549,713,494,460,549,549,549,549,1000,603, 1000,658,823,686,795,987,768,768,823,768, 768,713,713,713,713,713,713,713,768,713, 790,790,890,823,549,250,713,603,603,1042, 987,603,987,603,494,329,790,790,786,713, 384,384,384,384,384,384,494,494,494,494, 0,329,274,686,686,686,384,384,384,384, 384,384,494,494,790, 250) ) ); { TPostscriptPrinterCanvas } //Write an instruction in the header of document procedure TPostscriptPrinterCanvas.WriteHeader(St: String); begin fHeader.Add(St); end; //Write an instruction in the document procedure TPostscriptPrinterCanvas.Write(const St: String; Lst : TStringList = Nil); begin If not Assigned(Lst) then Lst:=fDocument; Lst.Add(St); end; //Write data in fBuffer procedure TPostscriptPrinterCanvas.WriteB(const St: string); begin Write(St,fBuffer); end; //Clear all data of Buffer procedure TPostscriptPrinterCanvas.ClearBuffer; begin fBuffer.Clear; end; //Write all Lst.Strings in document procedure TPostscriptPrinterCanvas.Write(Lst: TStringList); begin fDocument.AddStrings(Lst); end; //Write an comment in the document procedure TPostscriptPrinterCanvas.WriteComment(const St: string); begin fDocument.Add('%'+St); end; //Convert an TCanvas Y point to PostScript Y point //The TCanvas origine is corner Left,Top and Postscript is Left,Bottom //Modify X and Y for use Left and Top margin procedure TPostscriptPrinterCanvas.TranslateCoord(var X,Y : Integer); begin Y:=PageHeight-TopMarging-Y; X:=X+LeftMarging; end; //Save the last position procedure TPostscriptPrinterCanvas.SetPosition(X, Y: Integer); begin fPenPos:= Point(X,Y); SetInternalPenPos(Point(X,Y)); end; //Init the width of line procedure TPostscriptPrinterCanvas.UpdateLineWidth; begin if Pen.Width<>fcPenWidth then begin Write(Format('%d setlinewidth',[Pen.Width])); fcPenWidth:=Pen.Width; end; end; //Init the color of line (pen) procedure TPostscriptPrinterCanvas.UpdateLineColor(aColor : TColor = clNone); Var R,G,B : Real; RGBColor : TColor; begin if aColor=clNone then aColor:=Pen.Color; if aColor<>fcPenColor then begin RGBColor:=ColorToRGB(aColor); R:=Red(RGBColor)/255; G:=Green(RGBColor)/255; B:=Blue(RGBColor)/255; Write(Format('%.3f %.3f %.3f setrgbcolor',[R,G,B])+' % '+ColorToString(aColor)); fcPenColor:=aColor; end; end; //Init the style of line procedure TPostscriptPrinterCanvas.UpdateLineStyle; Var st : string; begin if (Pen.Style<>fcPenStyle) and (Pen.Style<>psClear) then begin Case Pen.Style of psSolid : St:='[] 0'; psDash : St:='[5 2] 0'; psDot : St:='[1 3] 0'; psDashDot : St:='[5 2 2 2] 0'; psDashDotDot : St:='[5 2 2 2 2 2] 0'; end; Write(Format('%s setdash',[St])); fcPenStyle:=Pen.Style; end; end; //Init the color for fill procedure TPostscriptPrinterCanvas.UpdateFillColor; Var R,G,B : Real; RGBColor : TColor; begin if (Brush.Style=bsSolid) and (Brush.Color<>fcPenColor) then begin RGBColor:=ColorToRGB(Brush.Color); R:=Red(RGBColor)/255; G:=Green(RGBColor)/255; B:=Blue(RGBColor)/255; Write(Format('%.3f %.3f %.3f setrgbcolor',[R,G,B])+' % '+ColorToString(Brush.Color)); fcPenColor:=Brush.Color; end; end; //Update current font procedure TPostscriptPrinterCanvas.UpdateFont; Var R,G,B : Real; RGBColor : TColor; begin try if Font.Color=clNone then Font.Color:=clBlack; if Font.Size=0 then Font.Size:=12; if Font.Color<>fcPenColor then begin RGBColor:=ColorToRGB(Font.Color); R:=Red(RGBColor)/255; G:=Green(RGBColor)/255; B:=Blue(RGBColor)/255; Write(Format('%.3f %.3f %.3f setrgbcolor',[R,G,B])+' % '+ColorToString(Font.Color)); fcPenColor:=Font.Color; end; if (Font.Name<>fcLastFont.Name) or (Font.Size<>fcLastFont.Size) or (Font.Style<>fcLastFont.Style) or FirstUpdatefont then begin FirstUpdatefont:=False; Write(Format('/%s findfont %d scalefont setfont',[MappedFontName,Font.Size])); end; finally fcLastFont.Assign(Font); end; end; //Return an Postscript font Name function TPostscriptPrinterCanvas.MappedFontName: string; Var Atr : string; begin Atr:=''; Result:='HelveticaISO'; if LowerCase(Font.Name)='times' then Result:='TimesISO'; if LowerCase(Font.Name)='monospaced' then Result:='CourierISO'; if LowerCase(Font.Name)='serif' then Result:='TimesISO'; if LowerCase(Font.Name)='sansserif' then Result:='HelveticaISO'; if LowerCase(Font.Name)='symbol' then Result:='Symbol'; if (fsItalic in Font.Style) and ((Pos('Courier',Result)=1) or (Pos('Helvetica',Result)=1)) then Atr:=Atr+'-Oblique'; if (fsItalic in Font.Style) and (Pos('Times',Result)=1) then Atr:=Atr+'-Italic'; if (fsBold in Font.Style) and ((Pos('Courier',Result)=1) or (Pos('Helvetica',Result)=1) or (Pos('Times',Result)=1)) then Atr:=Atr+'-Bold'; if (Result+Atr='Times') or (Result+Atr='TimesISO') then Result:='RomanISO'; WriteComment(Format('MapedFontName "%s" -> "%s"',[Font.Name,Result])); Result:=Result+Atr; end; //Replace the controls chars by PostScript string function TPostscriptPrinterCanvas.MapedString(const St: string): string; begin Result:=St; Result:=StringReplace(Result,'\','\\',[rfReplaceAll]); Result:=StringReplace(Result,'(','\(',[rfReplaceAll]); Result:=StringReplace(Result,')','\)',[rfReplaceAll]); Result:=StringReplace(Result,#10,'\n',[rfReplaceAll]); Result:=StringReplace(Result,#13,'\r',[rfReplaceAll]); Result:=StringReplace(Result,#8, '\b',[rfReplaceAll]); Result:=StringReplace(Result,#9, '\t',[rfReplaceAll]); end; //Move pen at last pos procedure TPostscriptPrinterCanvas.MoveToLastPos; begin write(Format('%d %d moveto',[fPenPos.X,fPenPos.Y])+' %last pos'); end; //Add at the PstScript sequence, the Fill Pattern/Color and Broder //Use SetBorder and SetFill for initialize 1 or 2 sequence procedure TPostscriptPrinterCanvas.SetBrushFillPattern(Lst: TStringList; SetBorder, SetFill: Boolean); begin If not Assigned(Lst) then Exit; if SetFill then begin if (Brush.Color<>clNone) and (Brush.Style<>bsClear) then begin UpdateFillColor; Case Brush.Style of bsSolid : begin Write(Lst); Write('eofill'); end; bsClear : ; else begin UpdateLineColor(Brush.Color); write(Format('/%s findfont %% a pattern font patternfill',[cBrushStyle[Brush.Style]])); Write(Lst); write('patternfill'); end; end; end; end; if SetBorder and ((Pen.Color<>clNone) and ((Pen.Color<>Brush.Color) or (Brush.Style<>bsSolid))) then begin UpdateLineColor(clNone); UpdateLineWidth; UpdateLineStyle; Write(Lst); Write('stroke'); end; end; procedure TPostscriptPrinterCanvas.SetBrushFillPattern(SetBorder, SetFill: Boolean); begin SetBrushFillPattern(fBuffer,SetBorder,SetFill); end; //Add in Lst, all RGB pixels of SrcGraph picture procedure TPostscriptPrinterCanvas.GetRGBImage(SrcGraph: TGraphic; Lst: TStringList); var SrcIntfImg : TLazIntfImage; px, py : Integer; CurColor : TFPColor; St : String; begin if (SrcGraph is TBitMap) then begin SrcIntfImg:=TLazIntfImage.Create(0,0); Lst.BeginUpdate; Try SrcIntfImg.LoadFromBitmap(TBitMap(SrcGraph).Handle,TBitMap(SrcGraph).MaskHandle); St:=''; for py:=0 to SrcIntfImg.Height-1 do begin for px:=0 to SrcIntfImg.Width-1 do begin CurColor:=SrcIntfImg.Colors[px,py]; St:=St+IntToHex(Hi(CurColor.Red),2)+ IntToHex(Hi(CurColor.Green),2)+ IntToHex(Hi(CurColor.Blue),2); if Length(St)>=78 then begin Lst.Add(Copy(St,1,78)); System.Delete(St,1,78); end; end; end; if St<>'' then Lst.Add(St); finally Lst.EndUpdate; SrcIntfImg.Free; end; end; end; procedure TPostscriptPrinterCanvas.CreateHandle; begin SetHandle(1); end; constructor TPostscriptPrinterCanvas.Create(APrinter: TPrinter); begin inherited Create(APrinter); fcBrushStyle:=bsClear; fcPenColor :=clBlack; fcPenWidth :=0; fcPenStyle :=psSolid; fcLastFont :=TFont.Create; fHeader:=TStringList.Create; fBuffer:=TstringList.Create; fDocument:=TStringList.Create; end; destructor TPostscriptPrinterCanvas.Destroy; begin fBuffer.Free; fHeader.Free; fDocument.Free; fcLastFont.Free; inherited Destroy; end; procedure TPostscriptPrinterCanvas.SaveToFile(aFileName: string); Var Lst : TStringList; begin Lst:=TStringList.Create; try Lst.AddStrings(fHeader); Lst.AddStrings(fDocument); Lst.SaveTofile(ExpandFileName(aFileName)); finally Lst.Free; end; end; procedure TPostscriptPrinterCanvas.BeginDoc; begin Inherited BeginDoc; //Clear all existing values //before starting an new document fDocument.Clear; fHeader.Clear; FirstUpdatefont:=True; Font.Size:=12; Font.Color:=clBlack; WriteHeader('%!PS-Adobe-3.0'); WriteHeader('%%'+Format('BoundingBox: 0 0 %d %d',[PageWidth,PageHeight])); WriteHeader('%%'+Format('Creator: Lazarus PostScriptCanvas for %s',[Application.ExeName])); WriteHeader('%%'+Format('Title: %s',[Title])); WriteHeader('%%CreationDate: '+DateTimeToStr(Now)); WriteHeader('%%Pages: (atend)'); WriteHeader('%%PageResources: (atend)'); WriteHeader('%%PageOrder: Ascend'); WriteHeader('%%Page: 1'); WriteHeader(''); WriteHeader('%------------------------------------------------------------'); WriteHeader('%================== BEGIN SETUP=============================='); WriteHeader(''); WriteHeader('% ISO Fonts'); WriteHeader('/Helvetica findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/HelveticaISO exch definefont pop'); WriteHeader(''); WriteHeader('/Helvetica-Bold findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/HelveticaISO-Bold exch definefont pop'); WriteHeader(''); WriteHeader('/Helvetica-Oblique findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/HelveticaISO-Oblique exch definefont pop'); WriteHeader(''); WriteHeader('/Helvetica-Oblique-Bold findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/HelveticaISO-Oblique-Bold exch definefont pop'); WriteHeader(''); WriteHeader('/Courier findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/CourierISO exch definefont pop'); WriteHeader(''); WriteHeader('/Courier-Bold findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/CourierISO-Bold exch definefont pop'); WriteHeader(''); WriteHeader('/Courier-Oblique findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/CourierISO-Oblique exch definefont pop'); WriteHeader(''); WriteHeader('/Courier-Oblique-Bold findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/CourierISO-Oblique-Bold exch definefont pop'); WriteHeader(''); WriteHeader('/Times findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/TimesISO exch definefont pop'); WriteHeader(''); WriteHeader('/Times-Bold findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/TimesISO-Bold exch definefont pop'); WriteHeader(''); WriteHeader('/Times-Italic findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/TimesISO-Italic exch definefont pop'); WriteHeader(''); WriteHeader('/Times-Italic-Bold findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/TimesISO-Italic-Bold exch definefont pop'); WriteHeader(''); WriteHeader('/Roman findfont'); WriteHeader(' dup length dict begin'); WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); WriteHeader(' /Encoding ISOLatin1Encoding def'); WriteHeader(' currentdict'); WriteHeader('end'); WriteHeader('/RomanISO exch definefont pop'); WriteHeader(''); WriteHeader('/underline_on'); WriteHeader('{%def'); WriteHeader(' /underline true def'); WriteHeader(' /underlineposition exch def'); WriteHeader(' /underlinethickness exch def'); WriteHeader(' /TEXT { TEXTwith } def'); WriteHeader('} def'); WriteHeader('/underline_off'); WriteHeader('{ %def'); WriteHeader(' /undefline false def'); WriteHeader(' /TEXT { TEXTwithout } def'); WriteHeader('} def'); WriteHeader('/TEXTwithout { moveto show } bind def'); WriteHeader('/TEXTwith { %def'); WriteHeader(' moveto'); WriteHeader(' gsave'); WriteHeader(' [] 0 setdash'); WriteHeader(' 0 underlineposition rmoveto'); WriteHeader(' underlinethickness setlinewidth'); WriteHeader(' dup stringwidth rlineto stroke'); WriteHeader(' grestore'); WriteHeader(' show'); WriteHeader('} bind def'); WriteHeader('%%BeginProcSet: patternfill 1.0 0'); WriteHeader('% width height matrix proc key cache'); WriteHeader('% definepattern -\> font'); WriteHeader('/definepattern { %def'); WriteHeader(' 7 dict begin'); WriteHeader(' /FontDict 9 dict def'); WriteHeader(' FontDict begin'); WriteHeader(' /cache exch def'); WriteHeader(' /key exch def'); WriteHeader(' /proc exch cvx def'); WriteHeader(' /mtx exch matrix invertmatrix def'); WriteHeader(' /height exch def'); WriteHeader(' /width exch def'); WriteHeader(' /ctm matrix currentmatrix def'); WriteHeader(' /ptm matrix identmatrix def'); WriteHeader(' /str'); WriteHeader(' (12345678901234567890123456789012)'); WriteHeader(' def'); WriteHeader(' end'); WriteHeader(' /FontBBox [ %def'); WriteHeader(' 0 0 FontDict /width get'); WriteHeader(' FontDict /height get'); WriteHeader(' ] def'); WriteHeader(' /FontMatrix FontDict /mtx get def'); WriteHeader(' /Encoding StandardEncoding def'); WriteHeader(' /FontType 3 def'); WriteHeader(' /BuildChar { %def'); WriteHeader(' pop begin'); WriteHeader(' FontDict begin'); WriteHeader(' width 0 cache { %ifelse'); WriteHeader(' 0 0 width height setcachedevice'); WriteHeader(' }{ %else'); WriteHeader(' setcharwidth'); WriteHeader(' } ifelse'); WriteHeader(' 0 0 moveto width 0 lineto'); WriteHeader(' width height lineto 0 height lineto'); WriteHeader(' closepath clip newpath'); WriteHeader(' gsave proc grestore'); WriteHeader(' end end'); WriteHeader(' } def'); WriteHeader(' FontDict /key get currentdict definefont'); WriteHeader(' end'); WriteHeader('} bind def'); WriteHeader('% dict patternpath -'); WriteHeader('% dict matrix patternpath -'); WriteHeader('/patternpath { %def'); WriteHeader(' dup type /dicttype eq { %ifelse'); WriteHeader(' begin FontDict /ctm get setmatrix'); WriteHeader(' }{ %else'); WriteHeader(' exch begin FontDict /ctm get setmatrix'); WriteHeader(' concat'); WriteHeader(' } ifelse'); WriteHeader(' currentdict setfont'); WriteHeader(' FontDict begin'); WriteHeader(' FontMatrix concat'); WriteHeader(' width 0 dtransform'); WriteHeader(' round width div exch round width div exch'); WriteHeader(' 0 height dtransform'); WriteHeader(' round height div exch'); WriteHeader(' round height div exch'); WriteHeader(' 0 0 transform round exch round exch'); WriteHeader(' ptm astore setmatrix'); WriteHeader(' '); WriteHeader(' pathbbox'); WriteHeader(' height div ceiling height mul 4 1 roll'); WriteHeader(' width div ceiling width mul 4 1 roll'); WriteHeader(' height div floor height mul 4 1 roll'); WriteHeader(' width div floor width mul 4 1 roll'); WriteHeader(' '); WriteHeader(' 2 index sub height div ceiling cvi exch'); WriteHeader(' 3 index sub width div ceiling cvi exch'); WriteHeader(' 4 2 roll moveto'); WriteHeader(' '); WriteHeader(' FontMatrix ptm invertmatrix pop'); WriteHeader(' { %repeat'); WriteHeader(' gsave'); WriteHeader(' ptm concat'); WriteHeader(' dup str length idiv { %repeat'); WriteHeader(' str show'); WriteHeader(' } repeat'); WriteHeader(' dup str length mod str exch'); WriteHeader(' 0 exch getinterval show'); WriteHeader(' grestore'); WriteHeader(' 0 height rmoveto'); WriteHeader(' } repeat'); WriteHeader(' pop'); WriteHeader(' end end'); WriteHeader('} bind def'); WriteHeader(''); WriteHeader('% dict patternfill -'); WriteHeader('% dict matrix patternfill -'); WriteHeader('/patternfill { %def'); WriteHeader(' gsave'); WriteHeader(' clip patternpath'); WriteHeader(' grestore'); WriteHeader(' newpath'); WriteHeader('} bind def'); WriteHeader(''); WriteHeader('% dict patterneofill -'); WriteHeader('% dict matrix patterneofill -'); WriteHeader('/patterneofill { %def'); WriteHeader(' gsave'); WriteHeader(' eoclip patternpath'); WriteHeader(' grestore'); WriteHeader(' newpath'); WriteHeader('} bind def'); WriteHeader(''); WriteHeader('% dict patternstroke -'); WriteHeader('% dict matrix patternstroke -'); WriteHeader('/patternstroke { %def'); WriteHeader(' gsave'); WriteHeader(' strokepath clip patternpath'); WriteHeader(' grestore'); WriteHeader(' newpath'); WriteHeader('} bind def'); WriteHeader(''); WriteHeader('% dict ax ay string patternashow -'); WriteHeader('% dict matrix ax ay string patternashow -'); WriteHeader('/patternashow { %def'); WriteHeader(' (0) exch { %forall'); WriteHeader(' 2 copy 0 exch put pop dup'); WriteHeader(' false charpath '); WriteHeader(' currentpoint'); WriteHeader(' 5 index type /dicttype eq { %ifelse'); WriteHeader(' 5 index patternfill'); WriteHeader(' }{ %else'); WriteHeader(' 6 index 6 index patternfill'); WriteHeader(' } ifelse'); WriteHeader(' moveto'); WriteHeader(' 3 copy pop rmoveto'); WriteHeader(' } forall'); WriteHeader(' pop pop pop'); WriteHeader(' dup type /dicttype ne { pop } if pop'); WriteHeader('} bind def'); WriteHeader(''); WriteHeader('% dict string patternshow -'); WriteHeader('% dict matrix string patternshow -'); WriteHeader('/patternshow { %def'); WriteHeader(' 0 exch 0 exch patternashow'); WriteHeader('} bind def'); WriteHeader(''); WriteHeader('/opaquepatternfill { %def'); WriteHeader(' gsave'); WriteHeader(' 1 setgray'); WriteHeader(' fill'); WriteHeader(' grestore'); WriteHeader(' patternfill'); WriteHeader('} bind def'); WriteHeader(''); WriteHeader('%%EndProcSet'); WriteHeader('%%EndProlog'); WriteHeader(''); WriteHeader('%%BeginSetup'); WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]'); WriteHeader('{ %definepattern'); WriteHeader(' 2 setlinecap'); WriteHeader(' 7.5 0 moveto 15 7.5 lineto'); WriteHeader(' 0 7.5 moveto 7.5 15 lineto'); WriteHeader(' 2 setlinewidth stroke'); WriteHeader('} bind'); WriteHeader('/bsBDiagonal true definepattern pop'); WriteHeader(''); WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]'); WriteHeader('{ %definepattern'); WriteHeader(' 2 setlinecap'); WriteHeader(' 7.5 0 moveto 0 7.5 lineto'); WriteHeader(' 15 7.5 moveto 7.5 15 lineto'); WriteHeader(' 2 setlinewidth stroke'); WriteHeader('} bind'); WriteHeader('/bsFDiagonal true definepattern pop'); WriteHeader('30 30 [300 72 div 0 0 300 72 div 0 0]'); WriteHeader('{ %definepattern'); WriteHeader(' 2 2 scale'); WriteHeader(' 2 setlinecap'); WriteHeader(' 7.5 0 moveto 15 7.5 lineto'); WriteHeader(' 0 7.5 moveto 7.5 15 lineto'); WriteHeader(' 7.5 0 moveto 0 7.5 lineto'); WriteHeader(' 15 7.5 moveto 7.5 15 lineto'); WriteHeader(' 0.5 setlinewidth stroke'); WriteHeader('} bind'); WriteHeader('/bsDiagCross true definepattern pop'); WriteHeader(''); WriteHeader('30 30 [300 72 div 0 0 300 72 div 0 0]'); WriteHeader('{ %definepattern'); WriteHeader(' 2 setlinecap'); WriteHeader(' 15 0 moveto 15 30 lineto'); WriteHeader(' 0 15 moveto 30 15 lineto'); WriteHeader(' 2 setlinewidth stroke'); WriteHeader('} bind'); WriteHeader('/bsCross true definepattern pop'); WriteHeader(''); WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]'); WriteHeader('{ %definepattern'); WriteHeader(' 2 setlinecap'); WriteHeader(' 0 7.5 moveto 15 7.5 lineto'); WriteHeader(' 2 setlinewidth stroke'); WriteHeader('} bind'); WriteHeader('/bsHorizontal true definepattern pop'); WriteHeader(''); WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]'); WriteHeader('{ %definepattern'); WriteHeader(' 2 setlinecap'); WriteHeader(' 7.5 0 moveto 7.5 15 lineto'); WriteHeader(' 2 setlinewidth stroke'); WriteHeader('} bind'); WriteHeader('/bsVertical true definepattern pop'); WriteHeader('%%EndSetup'); WriteHeader('%%====================== END SETUP ========================='); WriteHeader(''); end; procedure TPostscriptPrinterCanvas.EndDoc; begin Inherited EndDoc; Write('stroke'); Write('showpage'); Write('%%EOF'); if Trim(fFileName)<>'' then SaveToFile(ExpandFileName(fFileName)); end; procedure TPostscriptPrinterCanvas.NewPage; begin Inherited NewPage; Write('stroke'); Write('showpage'); Write('%%'+Format('Page: %d',[PageNumber])); write('newpath'); end; //Move the current position procedure TPostscriptPrinterCanvas.MoveTo(X1, Y1: Integer); begin RequiredState([csHandleValid]); WriteComment(Format('MoveTo(%d,%d)',[x1,y1])); SetPosition(X1,Y1); TranslateCoord(X1,Y1); write(Format('%d %d moveto',[X1,Y1])); end; //Drawe line procedure TPostscriptPrinterCanvas.LineTo(X1, Y1: Integer); begin Changing; RequiredState([csHandleValid, csPenValid]); WriteComment(Format('LineTo(%d,%d)',[x1,y1])); SetPosition(X1,Y1); TranslateCoord(X1,Y1); UpdateLineColor(clNone); UpdateLineWidth; UpdateLineStyle; write(Format('%d %d lineto stroke',[X1,Y1])); changed; end; procedure TPostscriptPrinterCanvas.Polyline(Points: PPoint; NumPts: Integer); Var i : LongInt; Lst: TStringList; Pt : TPoint; begin if (NumPts<=1) or not Assigned(Points) then Exit; Changing; RequiredState([csHandleValid, csPenValid]); Lst:=TStringList.Create; try Pt:=Points[0]; TranslateCoord(Pt.x,Pt.y); Write(Format('%d %d moveto',[Pt.x,Pt.y]),Lst); for i:=1 to NumPts-1 do begin Pt:=Points[i]; TranslateCoord(Pt.x,Pt.y); SetPosition(Pt.x,Pt.y); TranslateCoord(Pt.x,Pt.y); Write(Format('%d %d lineto',[Pt.x,Pt.y]),Lst); end; if (Pen.Color<>clNone) and ((Pen.Color<>Brush.Color) or (Brush.Style<>bsSolid)) then begin UpdateLineColor(clNone); UpdateLineWidth; UpdateLineStyle; Write(Lst); write('stroke'); end; finally Lst.Free; end; MoveToLastPos; Changed; end; procedure TPostscriptPrinterCanvas.PolyBezier(Points: PPoint; NumPts: Integer; Filled: boolean; Continuous: boolean); Var i : Integer; St : String; Pt : TPoint; begin Changing; RequiredState([csHandleValid, csBrushValid, csPenValid]); if (NumPts>=4) then begin ClearBuffer; St:=''; Pt:=Points[0]; TranslateCoord(Pt.x,Pt.y); if Continuous then WriteB('newpath'); WriteB(Format('%d %d moveto',[Pt.x,Pt.y])); for i:=1 to NumPts-1 do begin Pt:=Points[i]; TranslateCoord(Pt.x,Pt.y); St:=St+Format(' %d %d',[Pt.x,Pt.y]); end; WriteB(Format('%s curveto',[St])); if Continuous then writeB('closepath'); SetBrushFillPattern(True,Filled); MoveToLastPos; end; Changed; end; //Draw an Rectangle procedure TPostscriptPrinterCanvas.Rectangle(X1, Y1, X2, Y2: Integer); begin Changing; RequiredState([csHandleValid, csBrushValid, csPenValid]); writecomment(Format('Rectangle(%d,%d,%d,%d)',[x1,y1,x2,y2])); TranslateCoord(X1,Y1); TranslateCoord(X2,Y2); ClearBuffer; //Tempo draw rect WriteB('newpath'); writeB(Format(' %d %d moveto',[X1,Y1])); writeB(Format(' %d %d lineto',[X2,Y1])); writeB(Format(' %d %d lineto',[X2,Y2])); writeB(Format(' %d %d lineto',[X1,Y2])); writeB('closepath'); SetBrushFillPattern(True,True); MoveToLastPos; Changed; end; procedure TPostscriptPrinterCanvas.Frame(const ARect: TRect); Var X1,Y1,X2,Y2 : Integer; begin Changing; RequiredState([csHandleValid, csPenValid]); X1:=aRect.Left; Y1:=aRect.Top; X2:=aRect.Right; Y2:=aRect.Bottom; TranslateCoord(X1,Y1); TranslateCoord(X2,Y2); ClearBuffer; //Tempo draw rect WriteB('newpath'); writeB(Format(' %d %d moveto',[X1,Y1])); writeB(Format(' %d %d lineto',[X2,Y1])); writeB(Format(' %d %d lineto',[X2,Y2])); writeB(Format(' %d %d lineto',[X1,Y2])); writeB('closepath'); SetBrushFillPattern(True,False); MoveToLastPos; Changed; end; procedure TPostscriptPrinterCanvas.FrameRect(const ARect: TRect); Var CL : TColor; begin Changing; RequiredState([csHandleValid, csBrushValid]); CL:=Pen.Color; try Pen.Color:=Brush.Color; Frame(aRect); finally Pen.Color:=CL; end; Changed; end; //Fill an Rectangular region procedure TPostscriptPrinterCanvas.FillRect(const ARect: TRect); Var X1,Y1,X2,Y2 : Integer; begin Changing; RequiredState([csHandleValid, csBrushValid]); X1:=ARect.Left; Y1:=ARect.Top; X2:=ARect.Right; Y2:=ARect.Bottom; Writecomment(Format('FillRect(%d,%d,%d,%d)',[x1,y1,x2,y2])); TranslateCoord(X1,Y1); TranslateCoord(X2,Y2); ClearBuffer; WriteB('newpath'); WriteB(Format(' %d %d moveto',[X1,Y1])); WriteB(Format(' %d %d lineto',[X2,Y1])); WriteB(Format(' %d %d lineto',[X2,Y2])); WriteB(Format(' %d %d lineto',[X1,Y2])); WriteB('closepath'); SetBrushFillPattern(False,True); MoveToLastPos; Changed; end; procedure TPostscriptPrinterCanvas.RoundRect(X1, Y1, X2, Y2: Integer; RX, RY: Integer); Var ellipsePath : string; begin Changing; RequiredState([csHandleValid, csBrushValid, csPenValid]); X1:=Min(X1,X2); X2:=Max(X1,X2); Y1:=Min(Y1,Y2); Y2:=Max(Y1,Y2); writecomment(Format('RoundRect(%d,%d,%d,%d,%d,%d)',[x1,y1,x2,y2,Rx,Ry])); TranslateCoord(X1,Y1); TranslateCoord(X2,Y2); ClearBuffer; {Note: arcto command draws a line from current point to beginning of arc save current matrix, translate to center of ellipse, scale by rx ry, and draw a circle of unit radius in counterclockwise dir, return to original matrix arguments are (cx, cy, rx, ry, startAngle, endAngle)} ellipsePath:='matrix currentmatrix %d %d translate %d %d scale 0 0 1 %d %d arc setmatrix'; {choice between newpath and moveto beginning of arc go with newpath for precision, does this violate any assumptions in code??? write(format('%d %d moveto',[x1+rx, y1]),Lst # this also works} WriteB('newpath'); WriteB(Format(ellipsePath,[x1+rx,y1-ry,rx,ry,90,180])); WriteB(Format(ellipsePath,[x1+rx,y2+ry,rx,ry,180,270])); WriteB(Format(ellipsePath,[x2-rx,y2+ry,rx,ry,270,360])); WriteB(Format(ellipsePath,[x2-rx,y1-ry,rx,ry,0,90])); WriteB('closepath'); SetBrushFillPattern(True,True); MoveToLastPos; Changed; end; procedure TPostscriptPrinterCanvas.Polygon(Points: PPoint; NumPts: Integer; Winding: boolean); Var i : LongInt; Pt : TPoint; begin if (NumPts<=1) or not Assigned(Points) then Exit; Changing; RequiredState([csHandleValid, csBrushValid, csPenValid]); ClearBuffer; Pt:=Points[0]; TranslateCoord(Pt.x,Pt.y); WriteB('newpath'); WriteB(Format('%d %d moveto',[Pt.x,Pt.y])); for i:=1 to NumPts-1 do begin Pt:=Points[i]; TranslateCoord(Pt.x,Pt.y); WriteB(Format('%d %d lineto',[Pt.x,Pt.y])); end; WriteB('closepath'); SetBrushFillPattern(True,True); MoveToLastPos; Changed; end; //Draw an Ellipse procedure TPostscriptPrinterCanvas.Ellipse(x1, y1, x2, y2: Integer); var xScale : Real; yScale : Real; cX, cY : Real; rX,Ry : Real; Code : string; stAng : Integer; ang : Integer; begin Changing; RequiredState([csHandleValid, csBrushValid, csPenValid]); writecomment(Format('Ellipse(%d,%d,%d,%d)',[x1,y1,x2,y2])); TranslateCoord(X1,Y1); TranslateCoord(X2,Y2); //Init StAng:=0; Ang:=360; //calculate centre of ellipse cx:=(x1+x2)/2; cy:=(y1+y2)/2; rx:=(x2-x1)/2; ry:=(y2-y1)/2; //calculate semi-minor and semi-major axes of ellipse xScale:=Abs((x2-x1)/2.0); yScale:=Abs((y2-y1)/2.0); Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %d %d %s setmatrix', [cX,cY,xScale,yScale,StAng,Ang,'arc']); ClearBuffer; WriteB(Format('%.3f %.3f moveto',[cX,cY])); //move to center of circle WriteB(Code); SetBrushFillPattern(False,True); //move current point to start of arc, note negative //angle because y increases down ClearBuffer; WriteB(Format('%.3f %.3f moveto',[cX+(rX*Cos(StAng*-1)),cY+(rY*Sin(StAng*-1))])); WriteB(Code); SetBrushFillPattern(True,False); MoveToLastPos; Changed; end; //Draw an Arc procedure TPostscriptPrinterCanvas.Arc(Left,Top,Right,Bottom, angle1, angle2: Integer); var xScale : Real; yScale : Real; cX, cY : Real; rX,Ry : Real; Code : string; ang : string; begin Changing; RequiredState([csHandleValid, csBrushValid, csPenValid]); TranslateCoord(Left,Top); //calculate centre of ellipse cx:=Left; cy:=Top; rx:=Right-Left; ry:=Bottom-Top; if Angle2>=0 then Ang:='arc' else Ang:='arcn'; //calculate semi-minor and semi-major axes of ellipse xScale:=Abs(rx); yScale:=Abs(ry); Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %.3f %.3f %s setmatrix', [cX,cY,xScale,yScale,Angle1/16,Angle2/16,ang]); if (Pen.Color<>clNone) and ((Pen.Color<>Brush.Color) or (Brush.Style<>bsSolid)) then begin UpdateLineColor(clNone); UpdateLineWidth; UpdateLineStyle; //move current point to start of arc, note negative //angle because y increases down write(Format('%.3f %.3f moveto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))])); Write(Code); write('stroke'); end; MoveToLastPos; Changed; end; procedure TPostscriptPrinterCanvas.RadialPie(Left, Top, Right, Bottom, angle1, angle2: Integer); var xScale : Real; yScale : Real; cX, cY : Real; rX,Ry : Real; Code : string; ang : string; begin Changing; RequiredState([csHandleValid, csBrushValid, csPenValid]); writecomment(Format('RadialPie(%d,%d,%d,%d,%d,%d)',[Left,Top,Right-Left,Bottom-Top,Angle1,Angle2])); TranslateCoord(Left,Top); //calculate centre of ellipse cx:=Left; cy:=Top; rx:=Right-Left; ry:=Bottom-Top; if Angle2>=0 then Ang:='arc' else Ang:='arcn'; //calculate semi-minor and semi-major axes of ellipse xScale:=Abs(rx); yScale:=Abs(ry); Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %.3f %.3f %s setmatrix', [cX,cY,xScale,yScale,Angle1/16,Angle2/16,ang]); //move current point to start of arc, note negative //angle because y increases down ClearBuffer; writeB(Format('%.3f %.3f moveto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))])); WriteB(Code); writeB(Format('%d %d lineto',[Left,Top])); writeB(Format('%.3f %.3f lineto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))])); SetBrushFillPattern(False,True); //move current point to start of arc, note negative //angle because y increases down ClearBuffer; writeB(Format('%.3f %.3f moveto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))])); WriteB(Code); writeB(Format('%d %d lineto',[Left,Top])); writeB(Format('%.3f %.3f lineto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))])); SetBrushFillPattern(True,False); MoveToLastPos; Changed; end; //Out the text at the X,Y coord. Set the font procedure TPostscriptPrinterCanvas.TextOut(X, Y: Integer; const Text: String); Var PenUnder : Real; PosUnder : Integer; begin TranslateCoord(X,Y); UpdateFont; //The Y origine for ps text it's Left bottom corner Dec(Y,Abs(Round(Font.Size))); if fsUnderline in Font.Style then begin PenUnder:=0.5; if fsBold in Font.Style then PenUnder:=1.0; PosUnder:=(Abs(Round(Font.Size/3))*-1)+2; write(Format('%.3f %d underline_on',[PenUnder,PosUnder])); write(Format('(%s) %d %d TEXT',[MapedString(Text),X,Y])); write('underline_off'); end else begin write(Format('%d %d moveto',[X,Y])); write(Format('(%s) show',[MapedString(Text)])); end; MoveToLastPos; end; function TPostscriptPrinterCanvas.TextExtent(const Text: string): TSize; Var IndexFont,i : Integer; FontName : string; c: Char; begin Result.cX := 0; Result.cY := 0; if Text='' then Exit; RequiredState([csHandleValid, csFontValid]); Result.cY:=Font.Size; FontName:=MappedFontName; IndexFont:=0; //By default, use CourierISO metrics for i:=0 to High(cFontPSMetrics) do begin if cFontPSMetrics[i].Name=FontName then begin IndexFont:=i; Break; end; end; for i:=1 to Length(Text) do begin c:=Text[i]; if (c in [#32..#255]) then Inc(Result.cX,cFontPSMetrics[IndexFont].Widths[Ord(c)]); end; Result.cX:=Round(Result.cX*Font.Size*0.001); end; //Draw an Picture procedure TPostscriptPrinterCanvas.Draw(X, Y: Integer; SrcGraphic: TGraphic); begin if not Assigned(SrcGraphic) then exit; StretchDraw(Rect(X,Y,X+SrcGraphic.Width,Y+SrcGraphic.Height),SrcGraphic); end; //Draw an picture with scale size procedure TPostscriptPrinterCanvas.StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); var X1,Y1,X2,Y2 : Integer; DrawWidth : Integer; DrawHeight: Integer; ImgWidth : Integer; ImgHeight : Integer; begin if not Assigned(SrcGraphic) then exit; Changing; RequiredState([csHandleValid]); X1:=DestRect.Left; Y1:=DestRect.Top; X2:=DestRect.Right; Y2:=DestRect.Bottom; TranslateCoord(X1,Y1); TransLateCoord(X2,Y2); ImgWidth:=SrcGraphic.Width; ImgHeight:=SrcGraphic.Height; //if not FPImage then draw ab Rectangle because other wise PostScript //interpreter wait infinite some RGB datas DrawWidth:=X2-X1; DrawHeight:=Y1-Y2; ClearBuffer; WriteB('gsave'); writeB(Format('%d %d translate',[X1,Y1-DrawHeight])); WriteB(Format('%d %d scale',[DrawWidth,DrawHeight])); WriteB(Format('/scanline %d 3 mul string def',[ImgWidth])); WriteB(Format('%d %d %d',[ImgWidth,ImgHeight,8])); WriteB(Format('[%d %d %d %d %d %d]',[ImgWidth,0,0,-ImgHeight,0,ImgHeight])); WriteB('{ currentfile scanline readhexstring pop } false 3'); WriteB('colorimage'); GetRGBImage(SrcGraphic,fBuffer); WriteB('% end of image data'); WriteB('grestore'); Write(fBuffer); Changed; end; procedure TPostscriptPrinterCanvas.Arc(x, y, Right, Bottom, SX, SY, EX, EY: Integer); begin //Not implemented end; procedure TPostscriptPrinterCanvas.Chord(x1, y1, x2, y2, angle1,angle2: Integer); var xScale : Real; yScale : Real; cX, cY : Real; rX,Ry : Real; Code : string; ang : string; begin Changing; RequiredState([csHandleValid, csBrushValid, csPenValid]); writecomment(Format('Chord(%d,%d,%d,%d,%d,%d)',[x1,y1,x2-x1,y2-y1,Angle1,Angle2])); TranslateCoord(x1, y1); //calculate centre of ellipse cx:=x1; cy:=y1; rx:=x2-x1; ry:=y2-y1; if Angle2>=0 then Ang:='arc' else Ang:='arcn'; //calculate semi-minor and semi-major axes of ellipse xScale:=Abs(rx); yScale:=Abs(ry); Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %.3f %.3f %s setmatrix', [cX,cY,xScale,yScale,Angle1/16,Angle2/16,ang]); //move current point to start of arc, note negative //angle because y increases down.ClosePath for draw chord ClearBuffer; writeB('newpath'); writeB(Format('%.3f %.3f moveto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))])); WriteB(Code); writeB('closepath'); SetBrushFillPattern(True,True); MoveToLastPos; Changed; end; procedure TPostscriptPrinterCanvas.Chord(x1, y1, x2, y2, SX, SY, EX, EY: Integer); begin //Not implemented end; procedure TPostscriptPrinterCanvas.Frame3d(var ARect: TRect; const FrameWidth: integer; const Style: TGraphicsBevelCut); begin //Not implemented end; procedure TPostscriptPrinterCanvas.RadialPie(x1, y1, x2, y2, sx, sy, ex, ey: Integer); begin //Not implemented end; procedure TPostscriptPrinterCanvas.Pie(EllipseX1, EllipseY1, EllipseX2, EllipseY2, StartX, StartY, EndX, EndY: Integer); begin //Not implemented end; procedure TPostscriptPrinterCanvas.TextRect(ARect: TRect; X, Y: integer; const Text: string; const Style: TTextStyle); begin //Not implemented end; procedure TPostscriptPrinterCanvas.FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle); begin //Not implemented end; procedure TPostscriptPrinterCanvas.CopyRect(const Dest: TRect; SrcCanvas: TCanvas; const Source: TRect); begin //Not implemented end; { TPostscriptCanvas } constructor TPostscriptCanvas.Create; begin Inherited Create(nil); end; procedure TPostscriptCanvas.BeginDoc; begin inherited BeginDoc; end; procedure TPostscriptCanvas.EndDoc; begin inherited EndDoc; end; procedure TPostscriptCanvas.NewPage; begin inherited NewPage; end; end.