1 {
2 /***************************************************************************
3 PostScriptCanvas.pas
4 ------------
5 PostScript Printer Canvas object
6
7 ***************************************************************************/
8
9 *****************************************************************************
10 This file is part of the Lazarus Component Library (LCL)
11
12 See the file COPYING.modifiedLGPL.txt, included in this distribution,
13 for details about the license.
14 *****************************************************************************
15
16 Author: Olivier Guilbaud
17
18 Informations :
19 - Green Book Listing 9-1, on page 138 for Pattrens
20 - PostScriptPrinter unit of Tony Maro
21 - Piddle Project (Python language)
22 - Internet PostScript forums
23
24 Warnings :
25 - Draw and StretchDraw it's slow for big image
26 - Angles it's 1/16 of degre
27 ToDo :
28 - Implemente few methods
29 }
30
31 {
32 12 December 2012
33 TextRect implemented T. P. Launchbury
34 }
35
36 {$DEFINE ASCII85}
37
38 unit PostScriptCanvas;
39
40 {$mode objfpc}{$H+}
41
42 interface
43
44 uses
45 // RTL + FCL
46 Classes, SysUtils, strutils, Math, Types, FPImage,
47 // LCL
48 Graphics, Forms, GraphMath, GraphType, IntfGraphics, Printers,
49 LCLType, LCLIntf, LCLProc, PostScriptUnicode,
50 // LazUtils
51 LazFileUtils, IntegerList, LazUTF8, LazUTF8Classes;
52
53 Type
54
55 { TPostScriptPrinterCanvas }
56 TpsPoint=record
57 fx,fy:single;
58 end;
59 TpsBounds=record
60 fx,fy,fwidth,fheight:single;
61 end;
62
63 TPsCanvasState = ( pcsPosValid, pcsClipping, pcsClipSaved );
64 TPsCanvasStatus = set of TPsCanvasState;
65
66 TPostScriptPrinterCanvas = Class(TFilePrinterCanvas)
67 private
68 fHeader : TStringList; //Header document
69 fDocument : TstringList; //Current document
70
71 fBuffer : TStringList; //PostScript temporary buffer
72
73 //Current values
74 fcBrushStyle : TBrushStyle;
75 fcPenColor : TColor; //Color of Pen and Brush
76 fcPenWidth : Integer;
77 fcPenStyle : TPenStyle;
78 FPsUnicode : TPSUnicode;
79 FFs : TFormatSettings;
80 fSaveCount : Integer;
81 FLazClipRect : TRect;
82 FStatus : TPsCanvasStatus;
83
84 procedure psDrawRect(ARect:TRect);
85 procedure WriteHeader(St : String);
86 procedure Write(const St : String; Lst : TStringList = nil); overload;
87 procedure WriteB(const St : string);
88 procedure ClearBuffer;
89 procedure Write(Lst : TStringList); overload;
90 procedure WriteComment(const St : string);
91 procedure WritePageTransform;
92 procedure WriteOrientation(UseHeader: boolean);
93 procedure WriteBoundingBox(UseHeader: boolean);
94
TranslateCoordnull95 function TranslateCoord(cnvX,cnvY : Integer):TpsPoint;
TxRectToBoundsnull96 function TxRectToBounds(aRect: TRect): TpsBounds;
97 procedure SetPosition(X,Y : Integer);
98
99 procedure UpdateLineWidth;
100 procedure UpdateLineColor(aColor : TColor = clNone);
101 procedure UpdateLineStyle;
102 procedure UpdateFillColor;
103 procedure UpdateFont;
MappedFontNamenull104 function MappedFontName: string;
105
106 procedure MoveToLastPos;
107 procedure SetBrushFillPattern(Lst : TStringList; SetBorder,SetFill : Boolean);
108 procedure SetBrushFillPattern(SetBorder,SetFill : Boolean); overload;
109
110 procedure GetRGBImage(SrcGraph: TGraphic; Lst : TStringList);
111 procedure PixelsToPoints(const PixX,PixY: Integer; out PtX,PtY:Single);
GetFontSizenull112 function GetFontSize: Integer;
113 procedure RestoreClip;
114 procedure SaveClip;
115 procedure CheckLastPos;
GetFontIndexnull116 function GetFontIndex: Integer;
FontUnitsToPixelsXnull117 function FontUnitsToPixelsX(const Value:Integer): Integer;
FontUnitsToPixelsYnull118 function FontUnitsToPixelsY(const Value:Integer): Integer;
FontUnitsToPixelsYnull119 function FontUnitsToPixelsY(const Value:Double): Integer;
120 protected
121 procedure CreateHandle; override;
122 procedure CreateBrush; override;
123 procedure CreateFont; override;
124 procedure CreatePen; override;
125 procedure CreateRegion; override;
126 procedure DeselectHandles; override;
127 procedure PenChanging(APen: TObject); override;
128 procedure FontChanging(APen: TObject); override;
129 procedure BrushChanging(APen: TObject); override;
130 procedure RegionChanging(APen: TObject); override;
131 procedure RequiredState(ReqState: TCanvasState); override;
132 procedure DoEllipseAndFill(const Bounds: TRect); override;
133 procedure RealizeAntialiasing; override;
134
GetClipRectnull135 function GetClipRect: TRect; override;
136 procedure SetClipRect(const ARect: TRect); override;
GetClippingnull137 function GetClipping: Boolean; override;
138 procedure SetClipping(const AValue: boolean); override;
139
140 procedure DoMoveTo(X1,Y1: Integer); override;
141 procedure DoLineTo(X1,Y1: Integer); override;
142 public
143 constructor Create(APrinter : TPrinter); override;
144 destructor Destroy; override;
145 procedure BeginDoc; override;
146 procedure EndDoc; override;
147 procedure NewPage; override;
148
149 procedure SaveToFile(aFileName : string);
150
151 procedure Polyline(Points: PPoint; NumPts: Integer); override;
152 procedure PolyBezier(Points: PPoint; NumPts: Integer;
153 Filled: boolean = False;
154 Continuous: boolean = False); override;
155
156 procedure Rectangle(X1,Y1,X2,Y2: Integer); override;
157 procedure Frame(const ARect: TRect); override; // border using pen
158 procedure FrameRect(const ARect: TRect); override; // border using brush
159
160 procedure FillRect(const ARect: TRect); override;
161 procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY: Integer); override;
162 procedure Polygon(Points: PPoint; NumPts: Integer;
163 Winding: boolean = False); override;
164
165 procedure Ellipse(x1, y1, x2, y2: Integer); override;
166 procedure Arc(Left,Top,Right,Bottom,angle1,angle2: Integer); override;
167 procedure RadialPie(Left,Top,Right,Bottom,angle1,angle2: Integer); override;
168 procedure Chord(x1, y1, x2, y2, angle1, angle2: Integer); override;
169
170 procedure TextOut(X,Y: Integer; const Text: String); override;
TextExtentnull171 function TextExtent(const Text: string): TSize; override;
172 procedure TextRect(ARect: TRect; X, Y: integer; const Text: string;
173 const Style: TTextStyle); override;
174
175 procedure Draw(X,Y: Integer; SrcGraphic: TGraphic); override;
176 procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); override;
177
GetTextMetricsnull178 function GetTextMetrics(out TM: TLCLTextMetric): boolean; override;
179
180 //** Methods not definined on PostScript
181 procedure FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle); override;
182 procedure CopyRect(const Dest: TRect; SrcCanvas: TCanvas; const Source: TRect); override;
183
184 //** Methods not implemented
185 procedure Arc(x,y,Right,Bottom,SX,SY,EX,EY: Integer); override;
186 procedure Chord(x1, y1, x2, y2, SX, SY, EX, EY: Integer); override;
187 procedure Frame3d(var ARect: TRect; const FrameWidth: integer;
188 const Style: TGraphicsBevelCut); override;
189 procedure Pie(EllipseX1,EllipseY1,EllipseX2,EllipseY2,
190 StartX,StartY,EndX,EndY: Integer); override;
191 procedure SetPixel(X,Y: Integer; Value: TColor); override;
192
193
194 end;
195
196 TPostScriptCanvas = Class(TPostScriptPrinterCanvas)
197 public
198 constructor Create; overload;
199
200 procedure BeginDoc; override;
201 procedure EndDoc; override;
202 procedure NewPage; override;
203 end;
204
205 implementation
206 Type
207 TFontsWidths = Array[32..255] of Integer;
208 TFontPSMetrics = Record
209 Name : string;
210 ULPos, ULThickness, Ascender, Descender: Integer;
211 Widths : TFontsWidths;
212 end;
213
214 Const
215 cFontPSMetrics : Array[0..12] of TFontPSMetrics =(
216 (Name : 'Courier';
217 ULPos : -100; ULThickness : 50; Ascender : 604; Descender : -186;
218 Widths: (600, 600, 600, 600, 600, 600, 600, 600,
219 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
220 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
221 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
222 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
223 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
224 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
225 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
226 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
227 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
228 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
229 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
230 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
231 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
232 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
233 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
234 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
235 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
236 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
237 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
238 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
239 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
240 600, 600, 600, 600, 600, 600)
241 ),
242 (Name : 'Courier-Bold';
243 ULPos : -100; ULThickness : 50; Ascender : 624; Descender : -205;
244 Widths: (600, 600, 600, 600, 600, 600, 600, 600,
245 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
246 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
247 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
248 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
249 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
250 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
251 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
252 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
253 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
254 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
255 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
256 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
257 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
258 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
259 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
260 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
261 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
262 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
263 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
264 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
265 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
266 600, 600, 600, 600, 600, 600)
267 ),
268 (Name : 'Courier-Oblique';
269 ULPos : -100; ULThickness : 50; Ascender : 604; Descender : -186;
270 Widths: (600, 600, 600, 600, 600, 600, 600, 600,
271 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
272 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
273 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
274 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
275 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
276 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
277 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
278 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
279 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
280 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
281 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
282 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
283 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
284 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
285 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
286 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
287 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
288 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
289 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
290 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
291 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
292 600, 600, 600, 600, 600, 600)
293 ),
294 (Name : 'Courier-BoldOblique';
295 ULPos : -100; ULThickness : 50; Ascender : 624; Descender : -205;
296 Widths: (600, 600, 600, 600, 600, 600, 600, 600,
297 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
298 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
299 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
300 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
301 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
302 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
303 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
304 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
305 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
306 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
307 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
308 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
309 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
310 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
311 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
312 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
313 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
314 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
315 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
316 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
317 600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
318 600, 600, 600, 600, 600, 600)
319 ),
320 (Name : 'Helvetica';
321 ULPos : -151; ULThickness : 50; Ascender : 729; Descender : -218;
322 Widths: (278, 278, 355, 556, 556, 889, 667, 191,
323 333, 333, 389, 584, 278, 333, 278, 278, 556, 556,
324 556, 556, 556, 556, 556, 556, 556, 556, 278, 278,
325 584, 584, 584, 556, 1015, 667, 667, 722, 722, 667,
326 611, 778, 722, 278, 500, 667, 556, 833, 722, 778,
327 667, 778, 722, 667, 611, 722, 667, 944, 667, 667,
328 611, 278, 278, 278, 469, 556, 333, 556, 556, 500,
329 556, 556, 278, 556, 556, 222, 222, 500, 222, 833,
330 556, 556, 556, 556, 333, 500, 278, 556, 500, 722,
331 500, 500, 500, 334, 260, 334, 584, 278, 278, 278,
332 278, 278, 278, 278, 278, 278, 278, 278, 278, 278,
333 278, 278, 278, 278, 278, 278, 278, 278, 278, 278,
334 278, 278, 278, 278, 278, 278, 278, 278, 278, 278,
335 278, 333, 556, 556, 556, 556, 260, 556, 333, 737,
336 370, 556, 584, 333, 737, 333, 400, 584, 333, 333,
337 333, 556, 537, 278, 333, 333, 365, 556, 834, 834,
338 834, 611, 667, 667, 667, 667, 667, 667, 1000, 722,
339 667, 667, 667, 667, 278, 278, 278, 278, 722, 722,
340 778, 778, 778, 778, 778, 584, 778, 722, 722, 722,
341 722, 667, 667, 611, 556, 556, 556, 556, 556, 556,
342 889, 500, 556, 556, 556, 556, 278, 278, 278, 278,
343 556, 556, 556, 556, 556, 556, 556, 584, 611, 556,
344 556, 556, 556, 500, 556, 500)
345 ),
346 (Name : 'Helvetica-Bold';
347 ULPos : -155; ULThickness : 69; Ascender : 729; Descender : -218;
348 Widths: (278, 333, 474, 556, 556, 889, 722, 238,
349 333, 333, 389, 584, 278, 333, 278, 278, 556, 556,
350 556, 556, 556, 556, 556, 556, 556, 556, 333, 333,
351 584, 584, 584, 611, 975, 722, 722, 722, 722, 667,
352 611, 778, 722, 278, 556, 722, 611, 833, 722, 778,
353 667, 778, 722, 667, 611, 722, 667, 944, 667, 667,
354 611, 333, 278, 333, 584, 556, 333, 556, 611, 556,
355 611, 556, 333, 611, 611, 278, 278, 556, 278, 889,
356 611, 611, 611, 611, 389, 556, 333, 611, 556, 778,
357 556, 556, 500, 389, 280, 389, 584, 833, 833, 833,
358 833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
359 833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
360 833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
361 278, 333, 556, 556, 556, 556, 280, 556, 333, 737,
362 370, 556, 584, 333, 737, 333, 400, 584, 333, 333,
363 333, 611, 556, 278, 333, 333, 365, 556, 834, 834,
364 834, 611, 722, 722, 722, 722, 722, 722, 1000, 722,
365 667, 667, 667, 667, 278, 278, 278, 278, 722, 722,
366 778, 778, 778, 778, 778, 584, 778, 722, 722, 722,
367 722, 667, 667, 611, 556, 556, 556, 556, 556, 556,
368 889, 556, 556, 556, 556, 556, 278, 278, 278, 278,
369 611, 611, 611, 611, 611, 611, 611, 584, 611, 611,
370 611, 611, 611, 556, 611, 556)
371 ),
372 (Name : 'Helvetica-Oblique';
373 ULPos : -151; ULThickness : 50; Ascender : 729; Descender : -213;
374 Widths: (278, 278, 355, 556, 556, 889, 667, 191,
375 333, 333, 389, 584, 278, 333, 278, 278, 556, 556,
376 556, 556, 556, 556, 556, 556, 556, 556, 278, 278,
377 584, 584, 584, 556, 1015, 667, 667, 722, 722, 667,
378 611, 778, 722, 278, 500, 667, 556, 833, 722, 778,
379 667, 778, 722, 667, 611, 722, 667, 944, 667, 667,
380 611, 278, 278, 278, 469, 556, 333, 556, 556, 500,
381 556, 556, 278, 556, 556, 222, 222, 500, 222, 833,
382 556, 556, 556, 556, 333, 500, 278, 556, 500, 722,
383 500, 500, 500, 334, 260, 334, 584, 833, 833, 833,
384 833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
385 833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
386 833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
387 278, 333, 556, 556, 556, 556, 260, 556, 333, 737,
388 370, 556, 584, 333, 737, 333, 400, 584, 333, 333,
389 333, 556, 537, 278, 333, 333, 365, 556, 834, 834,
390 834, 611, 667, 667, 667, 667, 667, 667, 1000, 722,
391 667, 667, 667, 667, 278, 278, 278, 278, 722, 722,
392 778, 778, 778, 778, 778, 584, 778, 722, 722, 722,
393 722, 667, 667, 611, 556, 556, 556, 556, 556, 556,
394 889, 500, 556, 556, 556, 556, 278, 278, 278, 278,
395 556, 556, 556, 556, 556, 556, 556, 584, 611, 556,
396 556, 556, 556, 500, 556, 500)
397 ),
398 (Name : 'Helvetica-BoldOblique';
399 ULPos : -111; ULThickness : 69; Ascender : 729; Descender : -218;
400 Widths: (278, 333, 474, 556, 556, 889, 722, 238,
401 333, 333, 389, 584, 278, 333, 278, 278, 556, 556,
402 556, 556, 556, 556, 556, 556, 556, 556, 333, 333,
403 584, 584, 584, 611, 975, 722, 722, 722, 722, 667,
404 611, 778, 722, 278, 556, 722, 611, 833, 722, 778,
405 667, 778, 722, 667, 611, 722, 667, 944, 667, 667,
406 611, 333, 278, 333, 584, 556, 333, 556, 611, 556,
407 611, 556, 333, 611, 611, 278, 278, 556, 278, 889,
408 611, 611, 611, 611, 389, 556, 333, 611, 556, 778,
409 556, 556, 500, 389, 280, 389, 584, 833, 833, 833,
410 833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
411 833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
412 833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
413 278, 333, 556, 556, 556, 556, 280, 556, 333, 737,
414 370, 556, 584, 333, 737, 333, 400, 584, 333, 333,
415 333, 611, 556, 278, 333, 333, 365, 556, 834, 834,
416 834, 611, 722, 722, 722, 722, 722, 722, 1000, 722,
417 667, 667, 667, 667, 278, 278, 278, 278, 722, 722,
418 778, 778, 778, 778, 778, 584, 778, 722, 722, 722,
419 722, 667, 667, 611, 556, 556, 556, 556, 556, 556,
420 889, 556, 556, 556, 556, 556, 278, 278, 278, 278,
421 611, 611, 611, 611, 611, 611, 611, 584, 611, 611,
422 611, 611, 611, 556, 611, 556)
423 ),
424 (Name : 'Times-Roman';
425 ULPos : -100; ULThickness : 50; Ascender : 683; Descender : -217;
426 Widths: (250, 333, 408, 500, 500, 833, 778, 180,
427 333, 333, 500, 564, 250, 333, 250, 278, 500, 500,
428 500, 500, 500, 500, 500, 500, 500, 500, 278, 278,
429 564, 564, 564, 444, 921, 722, 667, 667, 722, 611,
430 556, 722, 722, 333, 389, 722, 611, 889, 722, 722,
431 556, 722, 667, 556, 611, 722, 722, 944, 722, 722,
432 611, 333, 278, 333, 469, 500, 333, 444, 500, 444,
433 500, 444, 333, 500, 500, 278, 278, 500, 278, 778,
434 500, 500, 500, 500, 333, 389, 278, 500, 500, 722,
435 500, 500, 444, 480, 200, 480, 541, 889, 889, 889,
436 889, 889, 889, 889, 889, 889, 889, 889, 889, 889,
437 889, 889, 889, 889, 889, 889, 889, 889, 889, 889,
438 889, 889, 889, 889, 889, 889, 889, 889, 889, 889,
439 250, 333, 500, 500, 500, 500, 200, 500, 333, 760,
440 276, 500, 564, 333, 760, 333, 400, 564, 300, 300,
441 333, 500, 453, 250, 333, 300, 310, 500, 750, 750,
442 750, 444, 722, 722, 722, 722, 722, 722, 889, 667,
443 611, 611, 611, 611, 333, 333, 333, 333, 722, 722,
444 722, 722, 722, 722, 722, 564, 722, 722, 722, 722,
445 722, 722, 556, 500, 444, 444, 444, 444, 444, 444,
446 667, 444, 444, 444, 444, 444, 278, 278, 278, 278,
447 500, 500, 500, 500, 500, 500, 500, 564, 500, 500,
448 500, 500, 500, 500, 500, 500)
449 ),
450 (Name : 'Times-Bold';
451 ULPos : -100; ULThickness : 50; Ascender : 676; Descender : -205;
452 Widths: (250, 333, 555, 500, 500, 1000, 833, 278,
453 333, 333, 500, 570, 250, 333, 250, 278, 500, 500,
454 500, 500, 500, 500, 500, 500, 500, 500, 333, 333,
455 570, 570, 570, 500, 930, 722, 667, 722, 722, 667,
456 611, 778, 778, 389, 500, 778, 667, 944, 722, 778,
457 611, 778, 722, 556, 667, 722, 722, 1000, 722, 722,
458 667, 333, 278, 333, 581, 500, 333, 500, 556, 444,
459 556, 444, 333, 500, 556, 278, 333, 556, 278, 833,
460 556, 500, 556, 556, 444, 389, 333, 556, 500, 722,
461 500, 500, 444, 394, 220, 394, 520, 944, 944, 944,
462 944, 944, 944, 944, 944, 944, 944, 944, 944, 944,
463 944, 944, 944, 944, 944, 944, 944, 944, 944, 944,
464 944, 944, 944, 944, 944, 944, 944, 944, 944, 944,
465 250, 333, 500, 500, 500, 500, 220, 500, 333, 747,
466 300, 500, 570, 333, 747, 333, 400, 570, 300, 300,
467 333, 556, 540, 250, 333, 300, 330, 500, 750, 750,
468 750, 500, 722, 722, 722, 722, 722, 722, 1000, 722,
469 667, 667, 667, 667, 389, 389, 389, 389, 722, 722,
470 778, 778, 778, 778, 778, 570, 778, 722, 722, 722,
471 722, 722, 611, 556, 500, 500, 500, 500, 500, 500,
472 722, 444, 444, 444, 444, 444, 278, 278, 278, 278,
473 500, 556, 500, 500, 500, 500, 500, 570, 500, 556,
474 556, 556, 556, 500, 556, 500)
475 ),
476 (Name : 'Times-Italic';
477 ULPos : -100; ULThickness : 50; Ascender : 683; Descender : -205;
478 Widths: (250, 333, 420, 500, 500, 833, 778, 214,
479 333, 333, 500, 675, 250, 333, 250, 278, 500, 500,
480 500, 500, 500, 500, 500, 500, 500, 500, 333, 333,
481 675, 675, 675, 500, 920, 611, 611, 667, 722, 611,
482 611, 722, 722, 333, 444, 667, 556, 833, 667, 722,
483 611, 722, 611, 500, 556, 722, 611, 833, 611, 556,
484 556, 389, 278, 389, 422, 500, 333, 500, 500, 444,
485 500, 444, 278, 500, 500, 278, 278, 444, 278, 722,
486 500, 500, 500, 500, 389, 389, 278, 500, 444, 667,
487 444, 444, 389, 400, 275, 400, 541, 833, 833, 833,
488 833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
489 833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
490 833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
491 250, 389, 500, 500, 500, 500, 275, 500, 333, 760,
492 276, 500, 675, 333, 760, 333, 400, 675, 300, 300,
493 333, 500, 523, 250, 333, 300, 310, 500, 750, 750,
494 750, 500, 611, 611, 611, 611, 611, 611, 889, 667,
495 611, 611, 611, 611, 333, 333, 333, 333, 722, 667,
496 722, 722, 722, 722, 722, 675, 722, 722, 722, 722,
497 722, 556, 611, 500, 500, 500, 500, 500, 500, 500,
498 667, 444, 444, 444, 444, 444, 278, 278, 278, 278,
499 500, 500, 500, 500, 500, 500, 500, 675, 500, 500,
500 500, 500, 500, 444, 500, 444)
501 ),
502 (Name : 'Times-BoldItalic';
503 ULPos : -100; ULThickness : 50; Ascender : 699; Descender : -205;
504 Widths: (250, 389, 555, 500, 500, 833, 778, 278,
505 333, 333, 500, 570, 250, 333, 250, 278, 500, 500,
506 500, 500, 500, 500, 500, 500, 500, 500, 333, 333,
507 570, 570, 570, 500, 832, 667, 667, 667, 722, 667,
508 667, 722, 778, 389, 500, 667, 611, 889, 722, 722,
509 611, 722, 667, 556, 611, 722, 667, 889, 667, 611,
510 611, 333, 278, 333, 570, 500, 333, 500, 500, 444,
511 500, 444, 333, 500, 556, 278, 278, 500, 278, 778,
512 556, 500, 500, 500, 389, 389, 278, 556, 444, 667,
513 500, 444, 389, 348, 220, 348, 570, 889, 889, 889,
514 889, 889, 889, 889, 889, 889, 889, 889, 889, 889,
515 889, 889, 889, 889, 889, 889, 889, 889, 889, 889,
516 889, 889, 889, 889, 889, 889, 889, 889, 889, 889,
517 250, 389, 500, 500, 500, 500, 220, 500, 333, 747,
518 266, 500, 606, 333, 747, 333, 400, 570, 300, 300,
519 333, 576, 500, 250, 333, 300, 300, 500, 750, 750,
520 750, 500, 667, 667, 667, 667, 667, 667, 944, 667,
521 667, 667, 667, 667, 389, 389, 389, 389, 722, 722,
522 722, 722, 722, 722, 722, 570, 722, 722, 722, 722,
523 722, 611, 611, 500, 500, 500, 500, 500, 500, 500,
524 722, 444, 444, 444, 444, 444, 278, 278, 278, 278,
525 500, 556, 500, 500, 500, 500, 500, 570, 500, 556,
526 556, 556, 556, 444, 500, 444)
527 ),
528 (Name : 'Symbol';
529 ULPos : -229; ULThickness : 46; Ascender : 673; Descender : -222;
530 Widths: (250,333,713,500,549,833,778,439,
531 333,333,500,549,250,549,250,278,500,500,
532 500,500,500,500,500,500,500,500,278,278,
533 549,549,549,444,549,722,667,722,612,611,
534 763,603,722,333,631,722,686,889,722,722,
535 768,741,556,592,611,690,439,768,645,795,
536 611,333,863,333,658,500,500,631,549,549,
537 494,439,521,411,603,329,603,549,549,576,
538 521,549,549,521,549,603,439,576,713,686,
539 493,686,494,480,200,480,549,0,0,0,
540 0,0,0,0,0,0,0,0,0,0,
541 0,0,0,0,0,0,0,0,0,0,
542 0,0,0,0,0,0,0,0,0,0,
543 0,620,247,549,167,713,500,753,753,753,
544 753,1042,987,603,987,603,400,549,411,549,
545 549,713,494,460,549,549,549,549,1000,603,
546 1000,658,823,686,795,987,768,768,823,768,
547 768,713,713,713,713,713,713,713,768,713,
548 790,790,890,823,549,250,713,603,603,1042,
549 987,603,987,603,494,329,790,790,786,713,
550 384,384,384,384,384,384,494,494,494,494,
551 0,329,274,686,686,686,384,384,384,384,
552 384,384,494,494,790, 250)
553 )
554 );
555
556 const
557 PageOpArr: array[boolean] of string[5] = ('Page','');
558 OrientArr: array[boolean] of string[10] = ('Landscape','Portrait');
559
560 {$IFDEF ASCII85}
561 type
562
563 { TAscii85Encoder }
564
565 TAscii85Encoder=class
566 private
567 FStream: TMemoryStream;
568 FData: LongWord;
569 FCount: Integer;
570 FMaxWidth,FWritten: Integer;
571 procedure EmitData;
572 procedure WriteByte(const B:Byte);
573 public
574 destructor Destroy; override;
575 procedure Add(B: Byte);
576 procedure Finish;
577
578 property Stream: TMemoryStream read FStream;
579 property MaxWidth: Integer read FMaxWidth write FMaxWidth;
580 end;
581
582 { TAscii85Encoder }
583
584 procedure TAscii85Encoder.EmitData;
585 const
586 Cn: array[0..4] of longword = (85*85*85*85,85*85*85,85*85,85,1);
587 var
588 B: byte;
589 i,n: Integer;
590 begin
591 if FCount=0 then
592 exit;
593
594 if FStream=nil then
595 FStream := TMemoryStream.Create;
596
597 if (FCount=4) and (FData=0) then
598
599 // special case, zeroed 5-tuple will be generated
600 WriteByte(ord('z'))
601
602 else begin
603
604 n := FCount;
605 while FCount<4 do begin
606 FData := (FData shl 8);
607 inc(FCount);
608 end;
609 for i:=0 to n do begin
610 B := byte((FData div Cn[i])+33);
611 FData := FData mod Cn[i];
612 WriteByte(B);
613 end;
614
615 end;
616
617 FCount := 0;
618 FData := 0;
619 end;
620
621 procedure TAscii85Encoder.WriteByte(const B: Byte);
622 var
623 e: string;
624 begin
625 FStream.WriteByte(B);
626 if FMaxWidth>0 then begin
627 Inc(FWritten);
628 if FWritten>=FMaxWidth then begin
629 // write lineending
630 e:=LineEnding;
631 FStream.Write(e[1],length(e));
632 FWritten := 0;
633 end;
634 end;
635 end;
636
637 destructor TAscii85Encoder.Destroy;
638 begin
639 if FStream<>nil then
640 FStream.Free;
641 inherited Destroy;
642 end;
643
644 procedure TAscii85Encoder.Add(B: Byte);
645 begin
646 FData := (FData shl 8) or B;
647 inc(FCount);
648 if FCount=4 then
649 EmitData;
650 end;
651
652 procedure TAscii85Encoder.Finish;
653 begin
654 EmitData;
655 FStream.WriteByte(ord('~'));
656 FStream.WriteByte(ord('>'));
657 FStream.Position:=0;
658 end;
659
660 {$ENDIF}
661
662 { TPostScriptPrinterCanvas }
663
664 //Write an instruction in the header of document
665 procedure TPostScriptPrinterCanvas.WriteHeader(St: String);
666 begin
667 fHeader.Add(St);
668 end;
669
670 //Write an instruction in the document
671 procedure TPostScriptPrinterCanvas.Write(const St: String; Lst: TStringList = nil);
672 begin
673 If not Assigned(Lst) then
674 Lst:=fDocument;
675
676 Lst.Add(St);
677 end;
678
679 //Write data in fBuffer
680 procedure TPostScriptPrinterCanvas.WriteB(const St: string);
681 begin
682 Write(St,fBuffer);
683 end;
684
685 //Clear all data of Buffer
686 procedure TPostScriptPrinterCanvas.ClearBuffer;
687 begin
688 fBuffer.Clear;
689 end;
690
691 //Write all Lst.Strings in document
692 procedure TPostScriptPrinterCanvas.Write(Lst: TStringList);
693 begin
694 fDocument.AddStrings(Lst);
695 end;
696
697 //Write an comment in the document
698 procedure TPostScriptPrinterCanvas.WriteComment(const St: string);
699 begin
700 fDocument.Add('%'+St);
701 end;
702
703 procedure TPostScriptPrinterCanvas.WritePageTransform;
704 var
705 h,w:integer;
706 begin
707 case Orientation of
708 poReversePortrait:
709 begin
710 w:=round(PaperWidth*72/XDPI);
711 h:=round(PaperHeight*72/YDPI);
712 Write(format('%d %d translate 180 rotate',[w,h]));
713 end;
714 poLandscape:
715 begin
716 h:=round(PaperHeight*72/YDPI);
717 Write(format('%d 0 translate 90 rotate',[h]));
718 end;
719 poReverseLandscape:
720 begin
721 w:=round((PaperWidth-PaperHeight)*72/XDPI);
722 h:=round(PaperHeight*72/XDPI);
723 Write(format('%d %d translate 90 neg rotate',[w,h]));
724 end;
725 end;
726 end;
727
728 procedure TPostScriptPrinterCanvas.WriteOrientation(UseHeader: boolean);
729 var
730 L: TStringList;
731 begin
732
733 if UseHeader then
734 L := Fheader
735 else
736 L := nil;
737
738 Write('%%'+PageOpArr[UseHeader]+'Orientation: '+
739 OrientArr[(Orientation=poPortrait)or(Orientation=poReversePortrait)], L);
740 end;
741
742 procedure TPostScriptPrinterCanvas.WriteBoundingBox(UseHeader: boolean);
743 var
744 a,l,t,w,h: Integer;
745 Lst: TStringList;
746 begin
747
748 l := round(LeftMargin * 72 / XDPI);
749 t := round(TopMargin * 72 / YDPI);
750 w := round((PaperWidth - RightMargin) * 72 / XDPI);
751 h := round((PaperHeight - BottomMargin) * 72 / YDPI);
752
753 if (Orientation=poLandscape) or (Orientation=poReverseLandscape) then
754 begin
755 a := l; l := t; t := a;
756 a := w; w := h; h := a;
757 end;
758
759 if UseHeader then
760 Lst := FHeader
761 else
762 Lst := nil;
763
764 Write('%%'+PageOpArr[UseHeader]+Format('BoundingBox: %d %d %d %d',[l,t,w,h]),
765 Lst);
766 end;
767
768 //Convert an TCanvas Y point to PostScript Y point
769 //The TCanvas origine is corner Left,Top and PostScript is Left,Bottom
770 //Modify X and Y for use Left and Top margin
TranslateCoordnull771 function TPostScriptPrinterCanvas.TranslateCoord(cnvX,cnvY : Integer):TpsPoint;
772 begin
773 PixelsToPoints(cnvX+LeftMargin, PageHeight+BottomMargin-cnvY,
774 Result.Fx, Result.Fy);
775 end;
776
TPostScriptPrinterCanvas.TxRectToBoundsnull777 function TPostScriptPrinterCanvas.TxRectToBounds(aRect: TRect): TpsBounds;
778 var
779 p1,p2: TPsPoint;
780 begin
781 p1 := TranslateCoord(aRect.Left, aRect.Top);
782 p2 := TranslateCoord(aRect.Right, aRect.Bottom);
783 Result.fx := p1.fx;
784 Result.fy := p2.fy;
785 Result.fwidth := p2.fx-p1.fx;
786 Result.fheight := p1.fy-p2.fy;
787 end;
788
789 //Save the last position
790 procedure TPostScriptPrinterCanvas.SetPosition(X, Y: Integer);
791 begin
792 SetInternalPenPos(Point(X,Y));
793 end;
794
795 //Init the width of line
796 procedure TPostScriptPrinterCanvas.UpdateLineWidth;
797 var
798 pw:single;
799 begin
800 if Pen.Width<>fcPenWidth then
801 begin
802 pw:=1/XDPI; // printer pixel in inches
803 pw:=Pen.Width*pw*72; // pen width in Points -> 1/72 inches
804 Write(Format('%.3f setlinewidth',[pw],FFs));
805 fcPenWidth:=Pen.Width;
806 end;
807 end;
808
809 //Init the color of line (pen)
810 procedure TPostScriptPrinterCanvas.UpdateLineColor(aColor : TColor = clNone);
811 Var R,G,B : Real;
812 RGBColor : TColorRef;
813 begin
814 if aColor=clNone then
815 aColor:=Pen.Color;
816
817 if aColor<>fcPenColor then
818 begin
819 RGBColor:=ColorToRGB(aColor);
820
821 R:=Red(RGBColor)/255;
822 G:=Green(RGBColor)/255;
823 B:=Blue(RGBColor)/255;
824 Write(Format('%.3f %.3f %.3f setrgbcolor',[R,G,B],FFs)+' % '+ColorToString(aColor));
825 fcPenColor:=aColor;
826 end;
827 end;
828
829 //Init the style of line
830 procedure TPostScriptPrinterCanvas.UpdateLineStyle;
831 Var St : string;
832 begin
833 if (Pen.Style<>fcPenStyle) and (Pen.Style<>psClear) then
834 begin
835 Case Pen.Style of
836 psSolid : St:='[] 0';
837 psDash : St:='[5 2] 0';
838 psDot : St:='[1 3] 0';
839 psDashDot : St:='[5 2 2 2] 0';
840 psDashDotDot : St:='[5 2 2 2 2 2] 0';
841 else St:='';
842 end;
843
844 Write(Format('%s setdash',[St]));
845 fcPenStyle:=Pen.Style;
846 end;
847 end;
848
849 //Init the color for fill
850 procedure TPostScriptPrinterCanvas.UpdateFillColor;
851 Var R,G,B : Real;
852 RGBColor : TColorRef;
853 begin
854 if (Brush.Style=bsSolid) and (Brush.Color<>fcPenColor) then
855 begin
856 RGBColor:=ColorToRGB(Brush.Color);
857
858 R:=Red(RGBColor)/255;
859 G:=Green(RGBColor)/255;
860 B:=Blue(RGBColor)/255;
861 Write(Format('%.3f %.3f %.3f setrgbcolor',[R,G,B],FFs)+' % '+ColorToString(Brush.Color));
862 fcPenColor:=Brush.Color;
863 end;
864 end;
865
866 //Update current font
867 procedure TPostScriptPrinterCanvas.UpdateFont;
868 Var R,G,B : Real;
869 RGBColor : TColorRef;
870 begin
871 if Font.Color=clNone then
872 Font.Color:=clBlack;
873 if Font.Size=0 then
874 Font.Size:=12;
875
876 if Font.Color<>fcPenColor then
877 begin
878 RGBColor:=ColorToRGB(Font.Color);
879
880 R:=Red(RGBColor)/255;
881 G:=Green(RGBColor)/255;
882 B:=Blue(RGBColor)/255;
883
884 Write(Format('%.3f %.3f %.3f setrgbcolor',[R,G,B],FFs)+' % '+ColorToString(Font.Color));
885 fcPenColor:=Font.Color;
886 end;
887 end;
888
889 //Return an PostScript font Name
MappedFontNamenull890 function TPostScriptPrinterCanvas.MappedFontName: string;
891 Var Atr : string;
892 begin
893 Atr:='';
894 Result := '';
895 if Copy(LowerCase(Font.Name),1,5)='times' then
896 Result:='Times';
897 if (LowerCase(Font.Name)='monospaced') or (Copy(LowerCase(Font.Name),1,7)='courier') then
898 Result:='Courier';
899 if LowerCase(Font.Name)='serif' then
900 Result:='Times';
901 if LowerCase(Font.Name)='sansserif' then
902 Result:='Helvetica';
903 if LowerCase(Font.Name)='symbol' then
904 Result:='Symbol';
905
906 if Result='' then
907 Result:='Helvetica';
908
909 if (fsBold in Font.Style) and ((Pos('Courier',Result)=1) or (Pos('Helvetica',Result)=1) or (Pos('Times',Result)=1)) then
910 Atr:=Atr+'Bold';
911 if (fsItalic in Font.Style) and ((Pos('Courier',Result)=1) or (Pos('Helvetica',Result)=1)) then
912 Atr:=Atr+'Oblique';
913 if (fsItalic in Font.Style) and (Pos('Times',Result)=1) then
914 Atr:=Atr+'Italic';
915 if (Result+Atr='Times') or (Result+Atr='Times') then
916 Result:='Times-Roman';
917
918 //WriteComment(Format('MapedFontName "%s" -> "%s"',[Font.Name,Result]));
919
920 if Atr <> '' then
921 Result:=Result+'-'+Atr;
922 end;
923
924 //Move pen at last pos
925 procedure TPostScriptPrinterCanvas.MoveToLastPos;
926 var
927 pp:TpsPoint;
928 begin
929 pp:=Self.TranslateCoord(PenPos.X,PenPos.Y);
930 write(Format('%f %f moveto',[pp.fx,pp.fy],Ffs)+' %last pos');
931 Include(FStatus, pcsPosValid);
932 end;
933
934 //Add at the PstScript sequence, the Fill Pattern/Color and Broder
935 //Use SetBorder and SetFill for initialize 1 or 2 sequence
936 procedure TPostScriptPrinterCanvas.SetBrushFillPattern(Lst: TStringList;
937 SetBorder, SetFill: Boolean);
938 var
939 s: string;
940 begin
941 If not Assigned(Lst) then Exit;
942
943 if SetFill then
944 begin
945 if (Brush.Color<>clNone) and (Brush.Style<>bsClear) then
946 begin
947 UpdateFillColor;
948
949 Case Brush.Style of
950 bsSolid : begin
951 Write(Lst);
952 Write('eofill');
953 end;
954 bsClear : ;
955 else
956 begin
957 UpdateLineColor(Brush.Color);
958 WriteStr(s, Brush.Style);
959 write(Format('/%s findfont %% a pattern font patternfill',[s]));
960 Write(Lst);
961 write('patternfill');
962 end;
963 end;
964 end;
965 end;
966
967 if SetBorder and ((Pen.Color<>clNone) and ((Pen.Color<>Brush.Color) or (Brush.Style<>bsSolid))) then
968 begin
969 UpdateLineColor(clNone);
970 UpdateLineWidth;
971 UpdateLineStyle;
972 Write(Lst);
973 Write('stroke');
974 end;
975 end;
976
977 procedure TPostScriptPrinterCanvas.SetBrushFillPattern(SetBorder, SetFill: Boolean);
978 begin
979 SetBrushFillPattern(fBuffer,SetBorder,SetFill);
980 end;
981
982 //Add in Lst, all RGB pixels of SrcGraph picture
983 procedure TPostScriptPrinterCanvas.GetRGBImage(SrcGraph: TGraphic;
984 Lst: TStringList);
985 var
986 SrcIntfImg : TLazIntfImage;
987
988 {$IFDEF ASCII85}
989 procedure TransferRGB;
990 var
991 px, py : Integer;
992 CurColor : TFPColor;
993 Encoder : TAscii85Encoder;
994 A : Byte;
995 Ratio : Single;
996 begin
997 Encoder := TAscii85Encoder.Create;
998 try
999 Encoder.MaxWidth:=75;
1000 for py:=0 to SrcIntfImg.Height-1 do
1001 begin
1002 for px:=0 to SrcIntfImg.Width-1 do
1003 begin
1004 CurColor:=SrcIntfImg.Colors[px,py];
1005 A := Hi(CurColor.alpha);
1006 if A=0 then begin
1007 Encoder.Add(255);
1008 Encoder.Add(255);
1009 Encoder.Add(255);
1010 end else
1011 if A=255 then begin
1012 Encoder.Add(Hi(CurColor.Red));
1013 Encoder.Add(Hi(CurColor.Green));
1014 Encoder.Add(Hi(CurColor.Blue));
1015 end else begin
1016 Ratio := 1-(255-A)/255;
1017 Encoder.Add(round(Hi(CurColor.Red )*Ratio+255*(1-Ratio)));
1018 Encoder.Add(round(Hi(CurColor.Green)*Ratio+255*(1-Ratio)));
1019 Encoder.Add(round(Hi(CurColor.Blue )*Ratio+255*(1-Ratio)));
1020 end;
1021 end;
1022 end;
1023 Encoder.Finish;
1024 Encoder.Stream.Position:=0;
1025 Lst.LoadFromStream(Encoder.Stream);
1026 finally
1027 Encoder.Free;
1028 end;
1029 end;
1030 {$ELSE}
1031 procedure TransferRGB;
1032 var
1033 px, py : Integer;
1034 CurColor : TFPColor;
1035 St : String;
1036 begin
1037 St:='';
1038 for py:=0 to SrcIntfImg.Height-1 do
1039 begin
1040 for px:=0 to SrcIntfImg.Width-1 do
1041 begin
1042 CurColor:=SrcIntfImg.Colors[px,py];
1043 St:=St+IntToHex(Hi(CurColor.Red),2)+
1044 IntToHex(Hi(CurColor.Green),2)+
1045 IntToHex(Hi(CurColor.Blue),2);
1046
1047 if Length(St)>=78 then
1048 begin
1049 Lst.Add(Copy(St,1,78));
1050 System.Delete(St,1,78);
1051 end;
1052 end;
1053 end;
1054 if St<>'' then
1055 Lst.Add(St);
1056 end;
1057 {$ENDIF}
1058
1059 procedure TransferRGBA;
1060 begin
1061 TransferRGB;
1062 end;
1063
1064 begin
1065 if (SrcGraph is TRasterImage) then
1066 begin
1067 SrcIntfImg:=TLazIntfImage.Create(0,0,[]);
1068 Lst.BeginUpdate;
1069 Try
1070 SrcIntfImg.LoadFromBitmap(TRasterImage(SrcGraph).BitmapHandle,
1071 TRasterImage(SrcGraph).MaskHandle);
1072
1073 if SrcIntfImg.DataDescription.Format<>ricfNone then
1074 begin
1075 if SrcIntfImg.DataDescription.AlphaPrec<>0 then
1076 TransferRGBA
1077 else
1078 TransferRGB;
1079 end;
1080
1081 finally
1082 Lst.EndUpdate;
1083 SrcIntfImg.Free;
1084 end;
1085 end;
1086 end;
1087
1088 procedure TPostScriptPrinterCanvas.PixelsToPoints(const PixX,PixY: Integer;
1089 out PtX,PtY:Single);
1090 begin
1091 PtX:=72*(PixX/XDPI); // pixels to points
1092 PtY:=72*(PixY/YDPI);
1093 end;
1094
GetFontSizenull1095 function TPostScriptPrinterCanvas.GetFontSize: Integer;
1096 begin
1097 if Font.Size=0 then
1098 Result := 12
1099 else
1100 Result := Font.Size;
1101 end;
1102
1103 procedure TPostScriptPrinterCanvas.RestoreClip;
1104 begin
1105 if pcsClipSaved in FStatus then
1106 begin
1107 Self.WriteComment('Restoring Old clip rect');
1108 Self.Write('cliprestore');
1109 Exclude(FStatus, pcsClipSaved);
1110 end;
1111 end;
1112
1113 procedure TPostScriptPrinterCanvas.SaveClip;
1114 var
1115 B: TpsBounds;
1116 begin
1117 Self.WriteComment('Pushing and Setting current clip rect');
1118 Self.Write('clipsave');
1119 B := TxRectToBounds(FLazClipRect);
1120 Write(Format('%f %f %f %f rectclip',[B.fx, B.fy, B.fwidth, B.fheight],FFs));
1121 Include(FStatus, pcsClipSaved);
1122 end;
1123
1124 procedure TPostScriptPrinterCanvas.CheckLastPos;
1125 begin
1126 if not (pcsPosValid in FStatus) then
1127 MoveToLastPos;
1128 end;
1129
TPostScriptPrinterCanvas.GetFontIndexnull1130 function TPostScriptPrinterCanvas.GetFontIndex: Integer;
1131 var
1132 FontName: string;
1133 i: Integer;
1134 begin
1135 FontName:=MappedFontName;
1136 Result:=0; //By default, use Courier metrics
1137 for i:=0 to High(cFontPSMetrics) do
1138 begin
1139 if cFontPSMetrics[i].Name=FontName then
1140 begin
1141 Result:=i;
1142 Break;
1143 end;
1144 end;
1145 end;
1146
FontUnitsToPixelsXnull1147 function TPostScriptPrinterCanvas.FontUnitsToPixelsX(const Value: Integer
1148 ): Integer;
1149 begin
1150 result := Round(Value*Abs(GetFontSize/72)*0.001*XDPI);
1151 end;
1152
FontUnitsToPixelsYnull1153 function TPostScriptPrinterCanvas.FontUnitsToPixelsY(const Value: Integer
1154 ): Integer;
1155 begin
1156 result := Round(Value*Abs(GetFontSize/72)*0.001*YDPI);
1157 end;
1158
FontUnitsToPixelsYnull1159 function TPostScriptPrinterCanvas.FontUnitsToPixelsY(const Value: Double
1160 ): Integer;
1161 var
1162 FontSize: Integer;
1163 begin
1164 FontSize := GetFontSize;
1165 if FontSize<0 then
1166 FontSize := -FontSize;
1167 result := Round(Value*FontSize/72*0.001*YDPI);
1168 end;
1169
1170 procedure TPostScriptPrinterCanvas.CreateHandle;
1171 begin
1172 SetHandle(1); // set dummy handle
1173 end;
1174
1175 procedure TPostScriptPrinterCanvas.RealizeAntialiasing;
1176 begin
1177 // handle is dummy, so do nothing here
1178 end;
1179
1180 procedure TPostScriptPrinterCanvas.CreateBrush;
1181 begin
1182 // handle is dummy, so do nothing here
1183 end;
1184
1185 procedure TPostScriptPrinterCanvas.CreateFont;
1186 begin
1187 // handle is dummy, so do nothing here
1188 end;
1189
1190 procedure TPostScriptPrinterCanvas.CreatePen;
1191 begin
1192 // handle is dummy, so do nothing here
1193 end;
1194
1195 procedure TPostScriptPrinterCanvas.CreateRegion;
1196 begin
1197 // handle is dummy, so do nothing here
1198 end;
1199
1200 procedure TPostScriptPrinterCanvas.DeselectHandles;
1201 begin
1202 // handle is dummy, so do nothing here
1203 end;
1204
1205 procedure TPostScriptPrinterCanvas.PenChanging(APen: TObject);
1206 begin
1207 // handle is dummy, so do nothing here
1208 end;
1209
1210 procedure TPostScriptPrinterCanvas.FontChanging(APen: TObject);
1211 begin
1212 // handle is dummy, so do nothing here
1213 end;
1214
1215 procedure TPostScriptPrinterCanvas.BrushChanging(APen: TObject);
1216 begin
1217 // handle is dummy, so do nothing here
1218 end;
1219
1220 procedure TPostScriptPrinterCanvas.RegionChanging(APen: TObject);
1221 begin
1222 // handle is dummy, so do nothing here
1223 end;
1224
1225 procedure TPostScriptPrinterCanvas.RequiredState(ReqState: TCanvasState);
1226 begin
1227 if csHandleValid in ReqState then
1228 inherited RequiredState([csHandleValid]);
1229 // other states are anyway impossible, because handle is dummy
1230 end;
1231
1232 procedure TPostScriptPrinterCanvas.DoEllipseAndFill(const Bounds: TRect);
1233 begin
1234 Ellipse(Bounds.Left, Bounds.Top, Bounds.Right, Bounds.Bottom);
1235 end;
1236
TPostScriptPrinterCanvas.GetClipRectnull1237 function TPostScriptPrinterCanvas.GetClipRect: TRect;
1238 begin
1239 Result:=FLazClipRect;
1240 end;
1241
1242 constructor TPostScriptPrinterCanvas.Create(APrinter: TPrinter);
1243 begin
1244 inherited Create(APrinter);
1245
1246 fcBrushStyle:=bsClear;
1247 fcPenColor :=clBlack;
1248 fcPenWidth :=0;
1249 fcPenStyle :=psSolid;
1250
1251 fHeader:=TStringList.Create;
1252 fBuffer:=TstringList.Create;
1253 fDocument:=TStringList.Create;
1254
1255 Ffs.DecimalSeparator:='.';
1256 Ffs.ThousandSeparator:=#0;
1257 Include(FStatus, pcsClipping);
1258 end;
1259
1260 destructor TPostScriptPrinterCanvas.Destroy;
1261 begin
1262 if FPSUnicode<>nil then
1263 FPSUnicode.Free;
1264
1265 fBuffer.Free;
1266 fHeader.Free;
1267 fDocument.Free;
1268
1269 inherited Destroy;
1270 end;
1271
1272 procedure TPostScriptPrinterCanvas.SaveToFile(aFileName: string);
1273 Var Lst : TStringListUTF8;
1274 begin
1275 Lst:=TStringListUTF8.Create;
1276 try
1277 Lst.AddStrings(fHeader);
1278 Lst.AddStrings(fDocument);
1279
1280 Lst.SaveTofile(ExpandFileNameUTF8(aFileName));
1281 finally
1282 Lst.Free;
1283 end;
1284 end;
1285
1286 procedure TPostScriptPrinterCanvas.BeginDoc;
1287 begin
1288 inherited BeginDoc;
1289
1290 if FPSUnicode=nil then
1291 FPSUnicode := TPSUnicode.Create;
1292 FPSUnicode.OutLst := FDocument;
1293 //Clear all existing values
1294 //before starting an new document
1295 fDocument.Clear;
1296 fHeader.Clear;
1297
1298 Font.Size:=12;
1299 Font.Color:=clBlack;
1300
1301 WriteHeader('%!PS-Adobe-3.0');
1302 WriteBoundingBox(True);
1303 WriteHeader('%%'+Format('Creator: Lazarus PostScriptCanvas for %s',[Application.ExeName]));
1304 WriteHeader('%%'+Format('Title: %s',[Title]));
1305 WriteHeader('%%CreationDate: '+DateTimeToStr(Now));
1306 WriteOrientation(true);
1307 WriteHeader('%%Pages: (atend)');
1308 WriteHeader('%%PageResources: (atend)');
1309 WriteHeader('%%PageOrder: Ascend');
1310 WriteHeader('');
1311 WriteHeader('%------------------------------------------------------------');
1312 WriteHeader('%================== BEGIN SETUP==============================');
1313 WriteHeader('');
1314 WriteHeader('/RE { % /NewFontName [NewEncodingArray] /FontName RE -');
1315 WriteHeader(' findfont dup length dict begin');
1316 WriteHeader(' {');
1317 WriteHeader(' 1 index /FID ne');
1318 WriteHeader(' {def}');
1319 WriteHeader(' {pop pop} ifelse');
1320 WriteHeader(' } forall');
1321 WriteHeader(' /Encoding exch def');
1322 WriteHeader(' /FontName 1 index def');
1323 WriteHeader(' currentdict definefont pop');
1324 WriteHeader(' end');
1325 WriteHeader('} bind def');
1326 WriteHeader('');
1327 WriteHeader('/scp {currentpoint /oldy exch def /oldx exch def } def');
1328 WriteHeader('/rcp {oldx oldy moveto} bind def');
1329 WriteHeader('/uli { 2 copy /uposy exch def /uposx exch def moveto } def');
1330 WriteHeader('/ule { % underlinepenwidh underlinepos');
1331 WriteHeader('scp gsave 0 exch rmoveto setlinewidth');
1332 WriteHeader('uposx oldx sub 0 rlineto [] 0 setdash stroke grestore rcp } def');
1333 WriteHeader('');
1334 WriteHeader('%%BeginProcSet: patternfill 1.0 0');
1335 WriteHeader('% width height matrix proc key cache');
1336 WriteHeader('% definepattern -\> font');
1337 WriteHeader('/definepattern { %def');
1338 WriteHeader(' 7 dict begin');
1339 WriteHeader(' /FontDict 9 dict def');
1340 WriteHeader(' FontDict begin');
1341 WriteHeader(' /cache exch def');
1342 WriteHeader(' /key exch def');
1343 WriteHeader(' /proc exch cvx def');
1344 WriteHeader(' /mtx exch matrix invertmatrix def');
1345 WriteHeader(' /height exch def');
1346 WriteHeader(' /width exch def');
1347 WriteHeader(' /ctm matrix currentmatrix def');
1348 WriteHeader(' /ptm matrix identmatrix def');
1349 WriteHeader(' /str');
1350 WriteHeader(' (12345678901234567890123456789012)');
1351 WriteHeader(' def');
1352 WriteHeader(' end');
1353 WriteHeader(' /FontBBox [ %def');
1354 WriteHeader(' 0 0 FontDict /width get');
1355 WriteHeader(' FontDict /height get');
1356 WriteHeader(' ] def');
1357 WriteHeader(' /FontMatrix FontDict /mtx get def');
1358 WriteHeader(' /Encoding StandardEncoding def');
1359 WriteHeader(' /FontType 3 def');
1360 WriteHeader(' /BuildChar { %def');
1361 WriteHeader(' pop begin');
1362 WriteHeader(' FontDict begin');
1363 WriteHeader(' width 0 cache { %ifelse');
1364 WriteHeader(' 0 0 width height setcachedevice');
1365 WriteHeader(' }{ %else');
1366 WriteHeader(' setcharwidth');
1367 WriteHeader(' } ifelse');
1368 WriteHeader(' 0 0 moveto width 0 lineto');
1369 WriteHeader(' width height lineto 0 height lineto');
1370 WriteHeader(' closepath clip newpath');
1371 WriteHeader(' gsave proc grestore');
1372 WriteHeader(' end end');
1373 WriteHeader(' } def');
1374 WriteHeader(' FontDict /key get currentdict definefont');
1375 WriteHeader(' end');
1376 WriteHeader('} bind def');
1377 WriteHeader('% dict patternpath -');
1378 WriteHeader('% dict matrix patternpath -');
1379 WriteHeader('/patternpath { %def');
1380 WriteHeader(' dup type /dicttype eq { %ifelse');
1381 WriteHeader(' begin FontDict /ctm get setmatrix');
1382 WriteHeader(' }{ %else');
1383 WriteHeader(' exch begin FontDict /ctm get setmatrix');
1384 WriteHeader(' concat');
1385 WriteHeader(' } ifelse');
1386 WriteHeader(' currentdict setfont');
1387 WriteHeader(' FontDict begin');
1388 WriteHeader(' FontMatrix concat');
1389 WriteHeader(' width 0 dtransform');
1390 WriteHeader(' round width div exch round width div exch');
1391 WriteHeader(' 0 height dtransform');
1392 WriteHeader(' round height div exch');
1393 WriteHeader(' round height div exch');
1394 WriteHeader(' 0 0 transform round exch round exch');
1395 WriteHeader(' ptm astore setmatrix');
1396 WriteHeader(' ');
1397 WriteHeader(' pathbbox');
1398 WriteHeader(' height div ceiling height mul 4 1 roll');
1399 WriteHeader(' width div ceiling width mul 4 1 roll');
1400 WriteHeader(' height div floor height mul 4 1 roll');
1401 WriteHeader(' width div floor width mul 4 1 roll');
1402 WriteHeader(' ');
1403 WriteHeader(' 2 index sub height div ceiling cvi exch');
1404 WriteHeader(' 3 index sub width div ceiling cvi exch');
1405 WriteHeader(' 4 2 roll moveto');
1406 WriteHeader(' ');
1407 WriteHeader(' FontMatrix ptm invertmatrix pop');
1408 WriteHeader(' { %repeat');
1409 WriteHeader(' gsave');
1410 WriteHeader(' ptm concat');
1411 WriteHeader(' dup str length idiv { %repeat');
1412 WriteHeader(' str show');
1413 WriteHeader(' } repeat');
1414 WriteHeader(' dup str length mod str exch');
1415 WriteHeader(' 0 exch getinterval show');
1416 WriteHeader(' grestore');
1417 WriteHeader(' 0 height rmoveto');
1418 WriteHeader(' } repeat');
1419 WriteHeader(' pop');
1420 WriteHeader(' end end');
1421 WriteHeader('} bind def');
1422 WriteHeader('');
1423 WriteHeader('% dict patternfill -');
1424 WriteHeader('% dict matrix patternfill -');
1425 WriteHeader('/patternfill { %def');
1426 WriteHeader(' gsave');
1427 WriteHeader(' clip patternpath');
1428 WriteHeader(' grestore');
1429 WriteHeader(' newpath');
1430 WriteHeader('} bind def');
1431 WriteHeader('');
1432 WriteHeader('% dict patterneofill -');
1433 WriteHeader('% dict matrix patterneofill -');
1434 WriteHeader('/patterneofill { %def');
1435 WriteHeader(' gsave');
1436 WriteHeader(' eoclip patternpath');
1437 WriteHeader(' grestore');
1438 WriteHeader(' newpath');
1439 WriteHeader('} bind def');
1440 WriteHeader('');
1441 WriteHeader('% dict patternstroke -');
1442 WriteHeader('% dict matrix patternstroke -');
1443 WriteHeader('/patternstroke { %def');
1444 WriteHeader(' gsave');
1445 WriteHeader(' strokepath clip patternpath');
1446 WriteHeader(' grestore');
1447 WriteHeader(' newpath');
1448 WriteHeader('} bind def');
1449 WriteHeader('');
1450 WriteHeader('% dict ax ay string patternashow -');
1451 WriteHeader('% dict matrix ax ay string patternashow -');
1452 WriteHeader('/patternashow { %def');
1453 WriteHeader(' (0) exch { %forall');
1454 WriteHeader(' 2 copy 0 exch put pop dup');
1455 WriteHeader(' false charpath ');
1456 WriteHeader(' currentpoint');
1457 WriteHeader(' 5 index type /dicttype eq { %ifelse');
1458 WriteHeader(' 5 index patternfill');
1459 WriteHeader(' }{ %else');
1460 WriteHeader(' 6 index 6 index patternfill');
1461 WriteHeader(' } ifelse');
1462 WriteHeader(' moveto');
1463 WriteHeader(' 3 copy pop rmoveto');
1464 WriteHeader(' } forall');
1465 WriteHeader(' pop pop pop');
1466 WriteHeader(' dup type /dicttype ne { pop } if pop');
1467 WriteHeader('} bind def');
1468 WriteHeader('');
1469 WriteHeader('% dict string patternshow -');
1470 WriteHeader('% dict matrix string patternshow -');
1471 WriteHeader('/patternshow { %def');
1472 WriteHeader(' 0 exch 0 exch patternashow');
1473 WriteHeader('} bind def');
1474 WriteHeader('');
1475 WriteHeader('/opaquepatternfill { %def');
1476 WriteHeader(' gsave');
1477 WriteHeader(' 1 setgray');
1478 WriteHeader(' fill');
1479 WriteHeader(' grestore');
1480 WriteHeader(' patternfill');
1481 WriteHeader('} bind def');
1482 WriteHeader('');
1483 WriteHeader('%%EndProcSet');
1484 WriteHeader('%%EndProlog');
1485 WriteHeader('');
1486 WriteHeader('%%BeginSetup');
1487 WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]');
1488 WriteHeader('{ %definepattern');
1489 WriteHeader(' 2 setlinecap');
1490 WriteHeader(' 7.5 0 moveto 15 7.5 lineto');
1491 WriteHeader(' 0 7.5 moveto 7.5 15 lineto');
1492 WriteHeader(' 2 setlinewidth stroke');
1493 WriteHeader('} bind');
1494 WriteHeader('/bsBDiagonal true definepattern pop');
1495 WriteHeader('');
1496 WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]');
1497 WriteHeader('{ %definepattern');
1498 WriteHeader(' 2 setlinecap');
1499 WriteHeader(' 7.5 0 moveto 0 7.5 lineto');
1500 WriteHeader(' 15 7.5 moveto 7.5 15 lineto');
1501 WriteHeader(' 2 setlinewidth stroke');
1502 WriteHeader('} bind');
1503 WriteHeader('/bsFDiagonal true definepattern pop');
1504 WriteHeader('30 30 [300 72 div 0 0 300 72 div 0 0]');
1505 WriteHeader('{ %definepattern');
1506 WriteHeader(' 2 2 scale');
1507 WriteHeader(' 2 setlinecap');
1508 WriteHeader(' 7.5 0 moveto 15 7.5 lineto');
1509 WriteHeader(' 0 7.5 moveto 7.5 15 lineto');
1510 WriteHeader(' 7.5 0 moveto 0 7.5 lineto');
1511 WriteHeader(' 15 7.5 moveto 7.5 15 lineto');
1512 WriteHeader(' 0.5 setlinewidth stroke');
1513 WriteHeader('} bind');
1514 WriteHeader('/bsDiagCross true definepattern pop');
1515 WriteHeader('');
1516 WriteHeader('30 30 [300 72 div 0 0 300 72 div 0 0]');
1517 WriteHeader('{ %definepattern');
1518 WriteHeader(' 2 setlinecap');
1519 WriteHeader(' 15 0 moveto 15 30 lineto');
1520 WriteHeader(' 0 15 moveto 30 15 lineto');
1521 WriteHeader(' 2 setlinewidth stroke');
1522 WriteHeader('} bind');
1523 WriteHeader('/bsCross true definepattern pop');
1524 WriteHeader('');
1525 WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]');
1526 WriteHeader('{ %definepattern');
1527 WriteHeader(' 2 setlinecap');
1528 WriteHeader(' 0 7.5 moveto 15 7.5 lineto');
1529 WriteHeader(' 2 setlinewidth stroke');
1530 WriteHeader('} bind');
1531 WriteHeader('/bsHorizontal true definepattern pop');
1532 WriteHeader('');
1533 WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]');
1534 WriteHeader('{ %definepattern');
1535 WriteHeader(' 2 setlinecap');
1536 WriteHeader(' 7.5 0 moveto 7.5 15 lineto');
1537 WriteHeader(' 2 setlinewidth stroke');
1538 WriteHeader('} bind');
1539 WriteHeader('/bsVertical true definepattern pop');
1540 WriteHeader('%%EndSetup');
1541 WriteHeader('%%====================== END SETUP =========================');
1542 WriteHeader('');
1543 WriteHeader('%%Page: 1 1');
1544 WritePageTransform;
1545
1546 if assigned(printer) then
1547 FLazClipRect:=printer.PaperSize.PaperRect.WorkRect;
1548 end;
1549
1550 procedure TPostScriptPrinterCanvas.EndDoc;
1551 var
1552 I: Integer;
1553 begin
1554 Inherited EndDoc;
1555
1556 Write('stroke');
1557 Write('showpage');
1558 Write('%%EOF');
1559
1560 // update number of pages in header
1561 I := FHeader.IndexOf('%%Pages: (atend)');
1562 if I <> -1 then
1563 FHeader[I] := '%%' + Format('Pages: %d', [PageNumber]);
1564
1565 if Trim(OutputFileName)<>'' then
1566 SaveToFile(ExpandFileNameUTF8(OutputFileName));
1567
1568 if Assigned(fPsUnicode) then
1569 FreeAndNil(fPsUnicode);
1570
1571 Self.fcPenWidth:=-2; // prevent cached line width affect new page
1572 end;
1573
1574 procedure TPostScriptPrinterCanvas.NewPage;
1575 begin
1576 inherited NewPage;
1577
1578 Write('stroke');
1579 Write('showpage');
1580 Write('%%'+Format('Page: %d %d',[PageNumber, PageNumber]));
1581 WriteBoundingBox(false);
1582 WriteOrientation(false);
1583 WritePageTransform;
1584 write('newpath');
1585
1586 Self.fcPenWidth:=-1; // prevent cached line width affect new page
1587 fSaveCount:=0;
1588 UpdateLineWidth;
1589 end;
1590
1591 //Move the current position
1592 procedure TPostScriptPrinterCanvas.DoMoveTo(X1, Y1: Integer);
1593 var
1594 pp:TpsPoint;
1595 begin
1596 RequiredState([csHandleValid]);
1597
1598 WriteComment(Format('DoMoveTo(%d,%d)',[x1,y1]));
1599
1600 SetPosition(X1,Y1);
1601 pp:=TranslateCoord(X1,Y1);
1602
1603 write(Format('%f %f moveto',[pp.fx,pp.fy],FFs));
1604
1605 Include(FStatus, pcsPosValid);
1606 end;
1607
1608 //Drawe line
1609 procedure TPostScriptPrinterCanvas.DoLineTo(X1, Y1: Integer);
1610 var
1611 pp:TpsPoint;
1612 begin
1613
1614 checkLastPos;
1615
1616 Changing;
1617 RequiredState([csHandleValid, csPenValid]);
1618 WriteComment(Format('DoLineTo(%d,%d)',[x1,y1]));
1619 SetPosition(X1,Y1);
1620 pp:=TranslateCoord(X1,Y1);
1621 UpdateLineColor(clNone);
1622 UpdateLineWidth;
1623 UpdateLineStyle;
1624 write(Format('%f %f lineto stroke',[pp.fx,pp.fy],FFs));
1625 changed;
1626
1627 Exclude(FStatus, pcsPosValid);
1628 end;
1629
1630 procedure TPostScriptPrinterCanvas.Polyline(Points: PPoint; NumPts: Integer);
1631 var
1632 i : LongInt;
1633 Lst: TStringList;
1634 Pt : TPoint;
1635 pp:TpsPoint;
1636 begin
1637 if (NumPts<=1) or not Assigned(Points) then Exit;
1638 Changing;
1639 RequiredState([csHandleValid, csPenValid]);
1640
1641 Lst:=TStringList.Create;
1642 try
1643 Pt:=Points[0];
1644 pp:=TranslateCoord(Pt.x,Pt.y);
1645 Write(Format('%f %f moveto',[pp.fx,pp.fy],FFs),Lst);
1646 for i:=1 to NumPts-1 do
1647 begin
1648 Pt:=Points[i];
1649 pp:=TranslateCoord(Pt.x,Pt.y);
1650 SetPosition(Pt.x,Pt.y);
1651 //TranslateCoord(Pt.x,Pt.y);
1652 Write(Format('%f %f lineto',[pp.fx,pp.fy],FFs),Lst);
1653 end;
1654
1655 UpdateLineColor(clNone);
1656 UpdateLineWidth;
1657 UpdateLineStyle;
1658
1659 write(Lst);
1660 write('stroke');
1661
1662 finally
1663 Lst.Free;
1664 end;
1665
1666 MoveToLastPos;
1667 Changed;
1668 end;
1669
1670 procedure TPostScriptPrinterCanvas.PolyBezier(Points: PPoint; NumPts: Integer;
1671 Filled: boolean; Continuous: boolean);
1672 var
1673 i : Integer;
1674 St : String;
1675 Pt : TPoint;
1676 pp:TpsPoint;
1677 begin
1678 Changing;
1679 RequiredState([csHandleValid, csBrushValid, csPenValid]);
1680
1681 if (NumPts>=4) then
1682 begin
1683 ClearBuffer;
1684
1685 St:='';
1686 Pt:=Points[0];
1687 pp:=TranslateCoord(Pt.x,Pt.y);
1688 if Continuous then
1689 WriteB('newpath');
1690 WriteB(Format('%f %f moveto',[pp.fx,pp.fy],FFs));
1691 for i:=1 to NumPts-1 do
1692 begin
1693 Pt:=Points[i];
1694 pp:=TranslateCoord(Pt.x,Pt.y);
1695 St:=St+Format(' %f %f',[pp.fx,pp.fy], FFs);
1696 end;
1697 WriteB(Format('%s curveto',[St]));
1698
1699 if Continuous then
1700 writeB('closepath');
1701 SetBrushFillPattern(True,Filled);
1702
1703 MoveToLastPos;
1704 end;
1705 Changed;
1706 end;
1707
1708
1709 // internal rect path
1710 procedure TPostScriptPrinterCanvas.psDrawRect(ARect:TRect);
1711 var
1712 pp1,pp2:TpsPoint;
1713 begin
1714 pp1:=TranslateCoord(Arect.Left,Arect.Top);
1715 pp2:=TranslateCoord(ARect.Right,Arect.Bottom);
1716
1717 ClearBuffer;
1718 //Tempo draw rect
1719 WriteB('newpath');
1720 writeB(Format(' %f %f moveto',[pp1.fx,pp1.fy],FFs));
1721 writeB(Format(' %f %f lineto',[pp2.fx,pp1.fy],FFs));
1722 writeB(Format(' %f %f lineto',[pp2.fx,pp2.fy],FFs));
1723 writeB(Format(' %f %f lineto',[pp1.fx,pp2.fy],FFs));
1724 writeB('closepath');
1725
1726 end;
1727
1728 //Draw an Rectangle
1729 procedure TPostScriptPrinterCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
1730 begin
1731 Changing;
1732 RequiredState([csHandleValid, csBrushValid, csPenValid]);
1733
1734 writecomment(Format('Rectangle(%d,%d,%d,%d)',[x1,y1,x2,y2]));
1735
1736 psDrawRect(Types.Rect(x1,y1,x2,y2));
1737
1738 SetBrushFillPattern(True,True);
1739
1740 MoveToLastPos;
1741
1742 Changed;
1743 end;
1744
1745 procedure TPostScriptPrinterCanvas.Frame(const ARect: TRect);
1746 begin
1747 Changing;
1748 RequiredState([csHandleValid, csPenValid]);
1749
1750 psDrawRect(ARect);
1751
1752 SetBrushFillPattern(True,False);
1753
1754 MoveToLastPos;
1755
1756 Changed;
1757 end;
1758
1759 procedure TPostScriptPrinterCanvas.FrameRect(const ARect: TRect);
1760 var
1761 CL : TColor;
1762 begin
1763 Changing;
1764 RequiredState([csHandleValid, csBrushValid]);
1765
1766 CL:=Pen.Color;
1767 try
1768 Pen.Color:=Brush.Color;
1769 Frame(aRect);
1770 finally
1771 Pen.Color:=CL;
1772 end;
1773
1774 Changed;
1775 end;
1776
1777 //Fill an Rectangular region
1778 procedure TPostScriptPrinterCanvas.FillRect(const ARect: TRect);
1779 begin
1780 Changing;
1781 RequiredState([csHandleValid, csBrushValid]);
1782
1783
1784 Writecomment(Format('FillRect(%d,%d,%d,%d)',[Arect.Left,ARect.Top,Arect.Right,ARect.Bottom]));
1785
1786 psDrawRect(ARect);
1787
1788 SetBrushFillPattern(False,True);
1789
1790 MoveToLastPos;
1791
1792 Changed;
1793 end;
1794
1795 procedure TPostScriptPrinterCanvas.RoundRect(X1, Y1, X2, Y2: Integer; RX,
1796 RY: Integer);
1797 var
1798 ellipsePath : string;
1799 //fs:TFormatSettings;
1800 pp1,pp2,r:TpsPoint;
1801 begin
1802 Changing;
1803 RequiredState([csHandleValid, csBrushValid, csPenValid]);
1804
1805 //fs.DecimalSeparator:='.';
1806 //fs.ThousandSeparator:=#0;
1807
1808 X1:=Min(X1,X2);
1809 X2:=Max(X1,X2);
1810 Y1:=Min(Y1,Y2);
1811 Y2:=Max(Y1,Y2);
1812
1813 writecomment(Format('RoundRect(%d,%d,%d,%d,%d,%d)',[x1,y1,x2,y2,Rx,Ry]));
1814 pp1:=TranslateCoord(X1,Y1);
1815 pp2:=TranslateCoord(X2,Y2);
1816
1817 ClearBuffer;
1818
1819 {Note: arcto command draws a line from current point to beginning of arc
1820 save current matrix, translate to center of ellipse, scale by rx ry, and draw
1821 a circle of unit radius in counterclockwise dir, return to original matrix
1822 arguments are (cx, cy, rx, ry, startAngle, endAngle)}
1823 ellipsePath:='matrix currentmatrix %f %f translate %f %f scale 0 0 1 %d %d arc setmatrix';
1824
1825 PixelsToPoints(RX,RY,r.fx,r.fy);
1826 WriteB('newpath');
1827 WriteB(Format(ellipsePath,[pp1.fx+r.fx,pp1.fy-r.fy,r.fx,r.fy,90,180],FFs));
1828 WriteB(Format(ellipsePath,[pp1.fx+r.fx,pp2.fy+r.fy,r.fx,r.fy,180,270],FFs));
1829 WriteB(Format(ellipsePath,[pp2.fx-r.fx,pp2.fy+r.fy,r.fx,r.fy,270,360],FFs));
1830 WriteB(Format(ellipsePath,[pp2.fx-r.fx,pp1.fy-r.fy,r.fx,r.fy,0,90],FFs));
1831 WriteB('closepath');
1832
1833 SetBrushFillPattern(True,True);
1834
1835 MoveToLastPos;
1836 Changed;
1837 end;
1838
1839 procedure TPostScriptPrinterCanvas.Polygon(Points: PPoint; NumPts: Integer;
1840 Winding: boolean);
1841 var
1842 i : LongInt;
1843 Pt : TPoint;
1844 pp:TpsPoint;
1845 begin
1846 if (NumPts<=1) or not Assigned(Points) then Exit;
1847 Changing;
1848 RequiredState([csHandleValid, csBrushValid, csPenValid]);
1849
1850 ClearBuffer;
1851
1852 Pt:=Points[0];
1853 pp:=TranslateCoord(Pt.x,Pt.y);
1854 WriteB('newpath');
1855 WriteB(Format('%f %f moveto',[pp.fx,pp.fy],FFs));
1856 for i:=1 to NumPts-1 do
1857 begin
1858 Pt:=Points[i];
1859 pp:=TranslateCoord(Pt.x,Pt.y);
1860 WriteB(Format('%f %f lineto',[pp.fx,pp.fy], FFs));
1861 end;
1862 WriteB('closepath');
1863
1864 SetBrushFillPattern(True,True);
1865
1866 MoveToLastPos;
1867 Changed;
1868 end;
1869
1870 //Draw an Ellipse
1871 procedure TPostScriptPrinterCanvas.Ellipse(x1, y1, x2, y2: Integer);
1872 var xScale : Real;
1873 yScale : Real;
1874 cX, cY : Real;
1875 rX,Ry : Real;
1876 Code : string;
1877 stAng : Integer;
1878 ang : Integer;
1879 //fs:TFormatSettings;
1880 pp1,pp2:TpsPoint;
1881 begin
1882 Changing;
1883 RequiredState([csHandleValid, csBrushValid, csPenValid]);
1884
1885 //fs.DecimalSeparator:='.';
1886 //fs.ThousandSeparator:=#0;
1887
1888 writecomment(Format('Ellipse(%d,%d,%d,%d)',[x1,y1,x2,y2]));
1889 pp1:=TranslateCoord(X1,Y1);
1890 pp2:=TranslateCoord(X2,Y2);
1891
1892 //Init
1893 StAng:=0;
1894 Ang:=360;
1895
1896 //calculate centre of ellipse
1897 cx:=(pp1.fx+pp2.fx)/2;
1898 cy:=(pp1.fy+pp2.fy)/2;
1899 rx:=(pp2.fx-pp1.fx)/2;
1900 ry:=(pp2.fy-pp1.fy)/2;
1901
1902 //calculate semi-minor and semi-major axes of ellipse
1903 xScale:=Abs((pp2.fx-pp1.fx)/2.0);
1904 yScale:=Abs((pp2.fy-pp1.fy)/2.0);
1905
1906 Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %d %d %s setmatrix',
1907 [cX,cY,xScale,yScale,StAng,Ang,'arc'],FFs);
1908
1909 ClearBuffer;
1910 WriteB(Format('%.3f %.3f moveto',[cX,cY],FFs)); //move to center of circle
1911 WriteB(Code);
1912 SetBrushFillPattern(False,True);
1913
1914 //move current point to start of arc, note negative
1915 //angle because y increases down
1916 ClearBuffer;
1917 WriteB(Format('%.3f %.3f moveto',[cX+(rX*Cos(StAng*-1)),cY+(rY*Sin(StAng*-1))],FFs));
1918 WriteB(Code);
1919 SetBrushFillPattern(True,False);
1920
1921 MoveToLastPos;
1922 Changed;
1923 end;
1924
1925 //Draw an Arc
1926 procedure TPostScriptPrinterCanvas.Arc(Left,Top,Right,Bottom, angle1,
1927 angle2: Integer);
1928 var xScale : Real;
1929 yScale : Real;
1930 cX, cY : Real;
1931 rX,Ry : Real;
1932 Code : string;
1933 ang : string;
1934 //fs:TFormatSettings;
1935 pp1,pp2:TpsPoint;
1936 begin
1937 Changing;
1938 RequiredState([csHandleValid, csBrushValid, csPenValid]);
1939 //fs.DecimalSeparator:='.';
1940 //fs.ThousandSeparator:=#0;
1941
1942 pp1:=TranslateCoord(Left,Top);
1943 pp2:=TranslateCoord(Right,Bottom);
1944 TranslateCoord(Right,Bottom);
1945
1946 //calculate centre of ellipse
1947 cx:=pp1.fx;
1948 cy:=pp1.fy;
1949 rx:=pp2.fx-pp1.fx;
1950 ry:=pp2.fy-pp1.fy;
1951
1952 if Angle2>=0 then
1953 Ang:='arc'
1954 else
1955 Ang:='arcn';
1956
1957 //calculate semi-minor and semi-major axes of ellipse
1958 xScale:=Abs((Right-Left)/2.0);
1959 yScale:=Abs((Bottom-Top)/2.0);
1960
1961 Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %.3f %.3f %s setmatrix',
1962 [cX,cY,xScale,yScale,Angle1/16,Angle2/16,ang], FFs);
1963
1964 if (Pen.Color<>clNone) and ((Pen.Color<>Brush.Color) or (Brush.Style<>bsSolid)) then
1965 begin
1966 UpdateLineColor(clNone);
1967 UpdateLineWidth;
1968 UpdateLineStyle;
1969
1970 //move current point to start of arc, note negative
1971 //angle because y increases down
1972 write(Format('%.3f %.3f moveto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))],FFs));
1973 Write(Code);
1974 write('stroke');
1975 end;
1976
1977 MoveToLastPos;
1978 Changed;
1979 end;
1980
1981 procedure TPostScriptPrinterCanvas.RadialPie(Left, Top, Right, Bottom, angle1,
1982 angle2: Integer);
1983 var xScale : Real;
1984 yScale : Real;
1985 cX, cY : Real;
1986 rX,Ry : Real;
1987 Code : string;
1988 ang : string;
1989 begin
1990 Changing;
1991 RequiredState([csHandleValid, csBrushValid, csPenValid]);
1992
1993 writecomment(Format('RadialPie(%d,%d,%d,%d,%d,%d)',[Left,Top,Right-Left,Bottom-Top,Angle1,Angle2]));
1994 TranslateCoord(Left,Top);
1995
1996 //calculate centre of ellipse
1997 cx:=Left;
1998 cy:=Top;
1999 rx:=Right-Left;
2000 ry:=Bottom-Top;
2001
2002 if Angle2>=0 then
2003 Ang:='arc'
2004 else
2005 Ang:='arcn';
2006
2007 //calculate semi-minor and semi-major axes of ellipse
2008 xScale:=Abs(rx);
2009 yScale:=Abs(ry);
2010
2011 Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %.3f %.3f %s setmatrix',
2012 [cX,cY,xScale,yScale,Angle1/16,Angle2/16,ang],FFs);
2013
2014 //move current point to start of arc, note negative
2015 //angle because y increases down
2016 ClearBuffer;
2017 writeB(Format('%.3f %.3f moveto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))],FFs));
2018 WriteB(Code);
2019 writeB(Format('%d %d lineto',[Left,Top]));
2020 writeB(Format('%.3f %.3f lineto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))],FFs));
2021 SetBrushFillPattern(False,True);
2022
2023 //move current point to start of arc, note negative
2024 //angle because y increases down
2025 ClearBuffer;
2026 writeB(Format('%.3f %.3f moveto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))],FFs));
2027 WriteB(Code);
2028 writeB(Format('%d %d lineto',[Left,Top]));
2029 writeB(Format('%.3f %.3f lineto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))],FFs));
2030 SetBrushFillPattern(True,False);
2031
2032 MoveToLastPos;
2033 Changed;
2034 end;
2035
FontStyleToIntnull2036 function FontStyleToInt(AStyles: TFontStyles): Integer;
2037 begin
2038 result := 0;
2039 if fsBold in AStyles then
2040 result := result or (1 shl ord(fsBold));
2041 if fsItalic in AStyles then
2042 result := result or (1 shl ord(fsItalic));
2043 if fsStrikeOut in AStyles then
2044 result := result or (1 shl ord(fsStrikeout));
2045 if fsUnderline in AStyles then
2046 result := result or (1 shl ord(fsUnderline));
2047 end;
2048
2049 //Out the text at the X,Y coord. Set the font
2050 procedure TPostScriptPrinterCanvas.TextOut(X, Y: Integer; const Text: String);
2051 var
2052 PenUnder : Double;
2053 PosUnder : Integer;
2054 pp:TpsPoint;
2055 saved:boolean;
2056 FontIndex: Integer;
2057
2058 procedure rotate;
2059 begin
2060 write('gsave');
2061 inc(fSaveCount);
2062 Self.FPsUnicode.ResetLastFont;
2063 saved:=true;
2064 write(format('%.2f rotate',[Font.Orientation / 10],fFS));
2065 end;
2066
2067 begin
2068 pp:=TranslateCoord(X,Y);
2069
2070 UpdateFont;
2071
2072 FPSUnicode.Font:=MappedFontName;
2073 FPSUnicode.FontSize:=Abs(GetFontSize);
2074 FPSUnicode.FontStyle:=FontStyleToInt(Font.Style);
2075
2076 //The Y origin for ps text it's Left bottom corner (only if not rotated)
2077 if Font.Orientation=0 then
2078 pp.fy := pp.fy - abs(GetFontSize) // in points
2079 else
2080 pp.fx := pp.fx + abs(GetFontSize); // apply to X axis if rotated
2081
2082 saved:=false;
2083
2084 if fsUnderline in Font.Style then
2085 begin
2086 FontIndex := GetFontIndex;
2087
2088 PosUnder := FontUnitsToPixelsY(cFontPSMetrics[FontIndex].ULPos);
2089
2090 // The current heuristics produces better underline thickness
2091 {$IFDEF UseFontUnderlineThickness}
2092 PenUnder := FontUnitsToPixelsY(cFontPSMetrics[FontIndex].ULThickness);
2093 {$else}
2094 PenUnder:=0.5;
2095 if fsBold in Font.Style then
2096 PenUnder:=1.0;
2097 {$endif}
2098
2099 Write(format('%f %f uli',[pp.fx,pp.fy],FFs));
2100 if Font.Orientation<>0 then
2101 rotate();
2102 FPSUnicode.OutputString(Text);
2103 write(Format('%.3f %d ule',[PenUnder,PosUnder],FFs));
2104 end
2105 else
2106 begin
2107 write(Format('%f %f moveto',[pp.fx,pp.fy],FFs));
2108 if Font.Orientation<>0 then
2109 rotate();
2110 FPSUnicode.OutputString(Text);
2111 end;
2112
2113 if saved then
2114 begin
2115 write('grestore');
2116 dec(fSaveCount);
2117 end;
2118
2119 MoveToLastPos;
2120 end;
2121
TextExtentnull2122 function TPostScriptPrinterCanvas.TextExtent(const Text: string): TSize;
2123 var
2124 IndexFont,i : Integer;
2125 c: Char;
2126 begin
2127 Result.cX := 0;
2128 Result.cY := 0;
2129 if Text='' then Exit;
2130 RequiredState([csHandleValid, csFontValid]);
2131 Result.cY:=round((Abs(GetFontSize)/72)*YDPI); // points to inches and then to pixels
2132 // Abs is not right - should also take internal leading into account
2133 IndexFont := GetFontIndex;
2134 for i:=1 to Length(Text) do
2135 begin
2136 c:=Text[i];
2137 if (c in [#32..#255]) then
2138 Inc(Result.cX,cFontPSMetrics[IndexFont].Widths[Ord(c)]);
2139 end;
2140 Result.cX:=FontUnitsToPixelsX(Result.cX);
2141 end;
2142
2143 //Draw an Picture
2144 procedure TPostScriptPrinterCanvas.Draw(X, Y: Integer; SrcGraphic: TGraphic);
2145 begin
2146 if not Assigned(SrcGraphic) then exit;
2147 StretchDraw(Rect(X,Y,X+SrcGraphic.Width,Y+SrcGraphic.Height),SrcGraphic);
2148 end;
2149
2150 //Draw an picture with scale size
2151 procedure TPostScriptPrinterCanvas.StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic);
2152 var X1,Y1,X2,Y2 : Integer;
2153 DrawWidth : single;
2154 DrawHeight: single;
2155 ImgWidth : Integer;
2156 ImgHeight : Integer;
2157 pp1,pp2:TpsPoint;
2158 begin
2159 if not Assigned(SrcGraphic) then exit;
2160 Changing;
2161 RequiredState([csHandleValid]);
2162
2163 X1:=DestRect.Left;
2164 Y1:=DestRect.Top;
2165 X2:=DestRect.Right;
2166 Y2:=DestRect.Bottom;
2167
2168 pp1:=TranslateCoord(X1,Y1);
2169 pp2:=TransLateCoord(X2,Y2);
2170
2171 ImgWidth:=SrcGraphic.Width;
2172 ImgHeight:=SrcGraphic.Height;
2173
2174 //if not FPImage then draw ab Rectangle because other wise PostScript
2175 //interpreter wait infinite some RGB datas
2176 DrawWidth:=pp2.fx-pp1.fx;
2177 DrawHeight:=pp1.fy-pp2.fy;
2178 ClearBuffer;
2179
2180 WriteB('gsave');
2181 WriteB('/DeviceRGB setcolorspace');
2182 writeB(Format('%f %f translate',[pp1.fx,pp1.fy-DrawHeight],FFs));
2183 WriteB(Format('%f %f scale',[DrawWidth,DrawHeight],FFs));
2184 {$IFDEF ASCII85}
2185 WriteB('<<');
2186 WriteB(' /ImageType 1');
2187 WriteB(' /Width '+IntToStr(ImgWidth));
2188 WriteB(' /Height '+IntToStr(ImgHeight));
2189 WriteB(' /BitsPerComponent 8');
2190 WriteB(' /Decode [0 1 0 1 0 1]');
2191 WriteB(' /ImageMatrix '+Format('[%d %d %d %d %d %d]',[ImgWidth,0,0,-ImgHeight,0,ImgHeight]));
2192 WriteB(' /DataSource currentfile /ASCII85Decode filter');
2193 WriteB('>>');
2194 WriteB('image');
2195 Write(fBuffer);
2196 ClearBuffer;
2197 GetRGBImage(SrcGraphic,fBuffer);
2198 {$ELSE}
2199 WriteB(Format('/scanline %d 3 mul string def',[ImgWidth]));
2200 // colorimage width height bits/comp matrix data0..dataN-1 multi? ncomp colorimage
2201 WriteB(Format('%d %d %d',[ImgWidth,ImgHeight,8]));
2202 WriteB(Format('[%d %d %d %d %d %d]',[ImgWidth,0,0,-ImgHeight,0,ImgHeight]));
2203 WriteB('{ currentfile scanline readhexstring pop } false 3');
2204 WriteB('colorimage');
2205 GetRGBImage(SrcGraphic,fBuffer);
2206 {$ENDIF}
2207 WriteB('% end of image data');
2208 WriteB('grestore');
2209
2210 Write(fBuffer);
2211
2212 Changed;
2213 end;
2214
GetTextMetricsnull2215 function TPostScriptPrinterCanvas.GetTextMetrics(out TM: TLCLTextMetric): boolean;
2216 var
2217 FontIndex: Integer;
2218 begin
2219 FontIndex := GetFontIndex;
2220 Result := FontIndex>=0;
2221 if Result then
2222 with CFontPSMetrics[FontIndex] do begin
2223 TM.Ascender := FontUnitsToPixelsY( Ascender );
2224 TM.Descender := FontUnitsToPixelsY( -Descender );
2225 TM.Height := TM.Ascender + TM.Descender;
2226 end;
2227 end;
2228
2229 procedure TPostScriptPrinterCanvas.Arc(x, y, Right, Bottom, SX, SY, EX,
2230 EY: Integer);
2231 begin
2232 //Not implemented
2233 end;
2234
2235 procedure TPostScriptPrinterCanvas.Chord(x1, y1, x2, y2, angle1,angle2: Integer);
2236 var xScale : Real;
2237 yScale : Real;
2238 cX, cY : Real;
2239 rX,Ry : Real;
2240 Code : string;
2241 ang : string;
2242 //pp:TpsPoint;
2243 begin
2244 Changing;
2245 RequiredState([csHandleValid, csBrushValid, csPenValid]);
2246
2247 writecomment(Format('Chord(%d,%d,%d,%d,%d,%d)',[x1,y1,x2-x1,y2-y1,Angle1,Angle2]));
2248 //pp:=TranslateCoord(x1, y1);
2249
2250 //calculate centre of ellipse
2251 cx:=x1;
2252 cy:=y1;
2253 rx:=x2-x1;
2254 ry:=y2-y1;
2255
2256 if Angle2>=0 then
2257 Ang:='arc'
2258 else
2259 Ang:='arcn';
2260
2261 //calculate semi-minor and semi-major axes of ellipse
2262 xScale:=Abs(rx);
2263 yScale:=Abs(ry);
2264
2265 Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %.3f %.3f %s setmatrix',
2266 [cX,cY,xScale,yScale,Angle1/16,Angle2/16,ang],FFs);
2267
2268 //move current point to start of arc, note negative
2269 //angle because y increases down.ClosePath for draw chord
2270 ClearBuffer;
2271 writeB('newpath');
2272 writeB(Format('%.3f %.3f moveto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))],FFs));
2273 WriteB(Code);
2274 writeB('closepath');
2275 SetBrushFillPattern(True,True);
2276
2277 MoveToLastPos;
2278 Changed;
2279 end;
2280
2281 procedure TPostScriptPrinterCanvas.Chord(x1, y1, x2, y2, SX, SY, EX, EY: Integer);
2282 begin
2283 //Not implemented
2284 end;
2285
2286 procedure TPostScriptPrinterCanvas.Frame3d(var ARect: TRect;
2287 const FrameWidth: integer; const Style: TGraphicsBevelCut);
2288 begin
2289 //Not implemented
2290 end;
2291
2292 procedure TPostScriptPrinterCanvas.Pie(EllipseX1, EllipseY1, EllipseX2,
2293 EllipseY2, StartX, StartY, EndX, EndY: Integer);
2294 begin
2295 //Not implemented
2296 end;
2297
2298 procedure TPostScriptPrinterCanvas.SetPixel(X, Y: Integer; Value: TColor);
2299 begin
2300 //Not implemented
2301 end;
2302
2303 procedure TPostScriptPrinterCanvas.TextRect(ARect: TRect; X, Y: integer;
2304 const Text: string; const Style: TTextStyle);
2305 var
2306 OldClip: TRect;
2307 Options: longint;
2308 ReqState: TCanvasState;
2309 fRect: TRect;
2310 Offset: Integer;
2311
2312 procedure WordWrap(AText: PChar; MaxWidthInPixel: integer;
2313 out Lines: PPChar; out LineCount: integer);
2314
2315 function FindLineEnd(LineStart: integer): integer;
2316 var
2317 CharLen, LineStop, LineWidth, WordWidth, WordEnd, CharWidth: integer;
2318 begin
2319 // first search line break or text break
2320 Result := LineStart;
2321 while not (AText[Result] in [#0, #10, #13]) do
2322 Inc(Result);
2323 if Result <= LineStart + 1 then
2324 exit;
2325 lineStop := Result;
2326
2327 // get current line width in pixel
2328 LineWidth := TextWidth(AText);
2329 if LineWidth > MaxWidthInPixel then
2330 begin
2331 // line too long -> add words till line size reached
2332 LineWidth := 0;
2333 WordEnd := LineStart;
2334 WordWidth := 0;
2335 repeat
2336 Result := WordEnd;
2337 Inc(LineWidth, WordWidth);
2338 // find word start
2339 while AText[WordEnd] in [' ', #9] do
2340 Inc(WordEnd);
2341 // find word end
2342 while not (AText[WordEnd] in [#0, ' ', #9, #10, #13]) do
2343 Inc(WordEnd);
2344 // calculate word width
2345 if wordEnd = Result then break;
2346 WordWidth := TextWidth(MidStr(AText, Result, WordEnd - Result));
2347 until LineWidth + WordWidth > MaxWidthInPixel;
2348 if LineWidth = 0 then
2349 begin
2350 // the first word is longer than the maximum width
2351 // -> add chars till line size reached
2352 Result := LineStart;
2353 LineWidth := 0;
2354 repeat
2355 charLen := UTF8CodepointSize(@AText[Result]);
2356 CharWidth := TextWidth(MidStr(AText, Result, charLen));
2357 Inc(LineWidth, CharWidth);
2358 if LineWidth > MaxWidthInPixel then
2359 break;
2360 if Result >= lineStop then
2361 break;
2362 Inc(Result, charLen);
2363 until False;
2364 // at least one char
2365 if Result = LineStart then
2366 begin
2367 charLen := UTF8CodepointSize(@AText[Result]);
2368 Inc(Result, charLen);
2369 end;
2370 end;
2371 end;
2372 end;
2373
2374 function IsEmptyText: boolean;
2375 begin
2376 if (AText = nil) or (AText[0] = #0) then
2377 begin
2378 // no text
2379 GetMem(Lines, SizeOf(PChar));
2380 Lines[0] := nil;
2381 LineCount := 0;
2382 Result := True;
2383 end
2384 else
2385 Result := False;
2386 end;
2387
2388 var
2389 LinesList: TIntegerList;
2390 LineStart, LineEnd, LineLen: integer;
2391 ArraySize, TotalSize: integer;
2392 i: integer;
2393 CurLineEntry: PPChar;
2394 CurLineStart: PChar;
2395 begin
2396 if IsEmptyText then
2397 begin
2398 Lines := nil;
2399 LineCount := 0;
2400 exit;
2401 end;
2402 LinesList := TIntegerList.Create;
2403 LineStart := 0;
2404
2405 // find all line starts and line ends
2406 repeat
2407 LinesList.Add(LineStart);
2408 // find line end
2409 LineEnd := FindLineEnd(LineStart);
2410 LinesList.Add(LineEnd);
2411 // find next line start
2412 LineStart := LineEnd;
2413 if AText[LineStart] in [#10, #13] then
2414 begin
2415 // skip new line chars
2416 Inc(LineStart);
2417 if (AText[LineStart] in [#10, #13]) and
2418 (AText[LineStart] <> AText[LineStart - 1]) then
2419 Inc(LineStart);
2420 end
2421 else if AText[LineStart] in [' ', #9] then
2422 begin
2423 // skip space
2424 while AText[LineStart] in [' ', #9] do
2425 Inc(LineStart);
2426 end;
2427 until AText[LineStart] = #0;
2428
2429 // create mem block for 'Lines': array of PChar + all lines
2430 LineCount := LinesList.Count shr 1;
2431 ArraySize := (LineCount + 1) * SizeOf(PChar);
2432 TotalSize := ArraySize;
2433 i := 0;
2434 while i < LinesList.Count do
2435 begin
2436 // add LineEnd - LineStart + 1 for the #0
2437 LineLen := LinesList[i + 1] - LinesList[i] + 1;
2438 Inc(TotalSize, LineLen);
2439 Inc(i, 2);
2440 end;
2441 GetMem(Lines, TotalSize);
2442 FillChar(Lines^, TotalSize, 0);
2443
2444 // create Lines
2445 CurLineEntry := Lines;
2446 CurLineStart := PChar(CurLineEntry) + ArraySize;
2447 i := 0;
2448 while i < LinesList.Count do
2449 begin
2450 // set the pointer to the start of the current line
2451 CurLineEntry[i shr 1] := CurLineStart;
2452 // copy the line
2453 LineStart := LinesList[i];
2454 LineEnd := LinesList[i + 1];
2455 LineLen := LineEnd - LineStart;
2456 if LineLen > 0 then
2457 Move(AText[LineStart], CurLineStart^, LineLen);
2458 Inc(CurLineStart, LineLen);
2459 // add #0 as line end
2460 CurLineStart^ := #0;
2461 Inc(CurLineStart);
2462 // next line
2463 Inc(i, 2);
2464 end;
2465 CurLineEntry[i shr 1] := nil;
2466
2467 LinesList.Free;
2468 end;
2469
2470 function DrawText(Str: PChar; Count: integer; var Rect: TRect;
2471 Flags: cardinal): integer;
2472 const
2473 TabString = ' ';
2474 var
2475 pIndex: longint;
2476 AStr: string;
2477
2478 TM: TLCLTextmetric;
2479 theRect: TRect;
2480 Lines: PPChar;
2481 I, NumLines: longint;
2482
2483 l: longint;
2484 Pt: TPoint;
2485 SavedRect: TRect; // if font orientation <> 0
2486
2487 function LeftOffset: longint;
2488 begin
2489 if (Flags and DT_RIGHT) = DT_RIGHT then
2490 Result := DT_RIGHT
2491 else
2492 if (Flags and DT_CENTER) = DT_CENTER then
2493 Result := DT_CENTER
2494 else
2495 Result := DT_LEFT;
2496 end;
2497
2498 function TopOffset: longint;
2499 begin
2500 if (Flags and DT_BOTTOM) = DT_BOTTOM then
2501 Result := DT_BOTTOM
2502 else
2503 if (Flags and DT_VCENTER) = DT_VCENTER then
2504 Result := DT_VCENTER
2505 else
2506 Result := DT_TOP;
2507 end;
2508
2509 function CalcRect: boolean;
2510 begin
2511 Result := (Flags and DT_CALCRECT) = DT_CALCRECT;
2512 end;
2513
2514
2515 procedure DoCalcRect;
2516 var
2517 AP: TSize;
2518 J, MaxWidth, LineWidth: integer;
2519 begin
2520 theRect := Rect;
2521
2522 MaxWidth := theRect.Right - theRect.Left;
2523
2524 if (Flags and DT_SINGLELINE) > 0 then
2525 begin
2526 // ignore word and line breaks
2527 AP := TextExtent(PChar(AStr));
2528 theRect.Bottom := theRect.Top + TM.Height;
2529 if (Flags and DT_CALCRECT) <> 0 then
2530 theRect.Right := theRect.Left + AP.cX
2531 else
2532 begin
2533 theRect.Right := theRect.Left + Min(MaxWidth, AP.cX);
2534 if (Flags and DT_VCENTER) > 0 then
2535 begin
2536 OffsetRect(theRect, 0, ((Rect.Bottom - Rect.Top) -
2537 (theRect.Bottom - theRect.Top)) div 2);
2538 end
2539 else
2540 if (Flags and DT_BOTTOM) > 0 then
2541 begin
2542 OffsetRect(theRect, 0, (Rect.Bottom - Rect.Top) -
2543 (theRect.Bottom - theRect.Top));
2544 end;
2545 end;
2546 end
2547 else
2548 begin
2549 // consider line breaks
2550 if (Flags and DT_WORDBREAK) = 0 then
2551 begin
2552 // do not break at word boundaries
2553 AP := TextExtent(PChar(AStr));
2554 MaxWidth := AP.cX;
2555 end;
2556 WordWrap(PChar(AStr), MaxWidth, Lines, NumLines);
2557
2558 if (Flags and DT_CALCRECT) <> 0 then
2559 begin
2560 LineWidth := 0;
2561 if (Lines <> nil) then
2562 begin
2563 for J := 0 to NumLines - 1 do
2564 begin
2565 AP := TextExtent(Lines[J]);
2566 LineWidth := Max(LineWidth, AP.cX);
2567 end;
2568 end;
2569 LineWidth := Min(MaxWidth, LineWidth);
2570 end
2571 else
2572 LineWidth := MaxWidth;
2573
2574 theRect.Right := theRect.Left + LineWidth;
2575 theRect.Bottom := theRect.Top + NumLines * TM.Height;
2576 if NumLines > 1 then
2577 Inc(theRect.Bottom, ((NumLines - 1) * TM.Descender));// space between lines
2578 end;
2579
2580 if not CalcRect then
2581 case LeftOffset of
2582 DT_CENTER:
2583 begin
2584 Offset := (Rect.Right - theRect.Right) div 2;
2585 OffsetRect(theRect, offset, 0);
2586 end;
2587 DT_RIGHT:
2588 begin
2589 Offset := Rect.Right - theRect.Right;
2590 OffsetRect(theRect, offset, 0);
2591 end;
2592 end;
2593 end;
2594
2595 // if our Font.Orientation <> 0 we must recalculate X,Y offset
2596 // also it works only with DT_TOP DT_LEFT.
2597 procedure CalculateOffsetWithAngle(const AFontAngle: integer;
2598 var TextLeft, TextTop: integer);
2599 var
2600 OffsX, OffsY: integer;
2601 Angle: integer;
2602 Size: TSize;
2603 R: TRect;
2604 begin
2605 R := SavedRect;
2606 OffsX := R.Right - R.Left;
2607 OffsY := R.Bottom - R.Top;
2608 Size.cX := OffsX;
2609 Size.cy := OffsY;
2610 Angle := AFontAngle div 10;
2611 if Angle < 0 then
2612 Angle := 360 + Angle;
2613
2614 if Angle <= 90 then
2615 begin
2616 OffsX := 0;
2617 OffsY := Trunc(Size.cx * sin(Angle * Pi / 180));
2618 end
2619 else
2620 if Angle <= 180 then
2621 begin
2622 OffsX := Trunc(Size.cx * -cos(Angle * Pi / 180));
2623 OffsY := Trunc(Size.cx * sin(Angle * Pi / 180) + Size.cy *
2624 cos((180 - Angle) * Pi / 180));
2625 end
2626 else
2627 if Angle <= 270 then
2628 begin
2629 OffsX := Trunc(Size.cx * -cos(Angle * Pi / 180) + Size.cy *
2630 sin((Angle - 180) * Pi / 180));
2631 OffsY := Trunc(Size.cy * sin((270 - Angle) * Pi / 180));
2632 end
2633 else
2634 if Angle <= 360 then
2635 begin
2636 OffsX := Trunc(Size.cy * sin((360 - Angle) * Pi / 180));
2637 OffsY := 0;
2638 end;
2639 TextTop := OffsY;
2640 TextLeft := OffsX;
2641 end;
2642
2643 function NeedOffsetCalc: boolean;
2644 begin
2645 Result := (Font.Orientation <> 0) and (Flags and DT_SINGLELINE <> 0) and
2646 (Flags and DT_VCENTER = 0) and (Flags and DT_CENTER = 0) and
2647 (Flags and DT_RIGHT = 0) and (Flags and DT_BOTTOM = 0) and
2648 (Flags and DT_CALCRECT = 0) and not IsRectEmpty(SavedRect);
2649 end;
2650
2651
2652 procedure DrawLineRaw(theLine: PChar; LineLength, TopPos: longint);
2653 var
2654 Points: array[0..1] of TSize;
2655 LeftPos: longint;
2656 begin
2657 if LeftOffset <> DT_LEFT then
2658 Points[0] := TextExtent(theLine)
2659 else begin
2660 Points[0].cx := 0;
2661 Points[0].cy := 0;
2662 end;
2663
2664 case LeftOffset of
2665 DT_LEFT:
2666 LeftPos := theRect.Left;
2667 DT_CENTER:
2668 LeftPos := theRect.Left + (theRect.Right - theRect.Left) div
2669 2 - Points[0].cX div 2;
2670 DT_RIGHT:
2671 LeftPos := theRect.Right - Points[0].cX;
2672 else
2673 LeftPos := 0;
2674 end;
2675
2676 Pt := Point(0, 0);
2677 // Draw line of Text
2678 if NeedOffsetCalc then
2679 begin
2680 Pt.X := SavedRect.Left;
2681 Pt.Y := SavedRect.Top;
2682 CalculateOffsetWithAngle(Font.Orientation, Pt.X, Pt.Y);
2683 end;
2684 TextOut(LeftPos + Pt.X, TopPos + Pt.Y, theLine);
2685 end;
2686
2687 procedure DrawLine(theLine: PChar; LineLength, TopPos: longint);
2688 var
2689 Points: array[0..1] of TSize;
2690 //LogP: TLogPen;
2691 LeftPos: longint;
2692 begin
2693 FillByte({%H-}Points[0], SizeOf(Points[0]) * 2, 0);
2694 if LeftOffset <> DT_Left then
2695 Points[0] := TextExtent(theLine);
2696
2697 case LeftOffset of
2698 DT_LEFT:
2699 LeftPos := theRect.Left;
2700 DT_CENTER:
2701 LeftPos := theRect.Left + (theRect.Right - theRect.Left) div
2702 2 - Points[0].cX div 2;
2703 DT_RIGHT:
2704 LeftPos := theRect.Right - Points[0].cX;
2705 else
2706 LeftPos := 0;
2707 end;
2708
2709 Pt := Point(0, 0);
2710 if NeedOffsetCalc then
2711 begin
2712 Pt.X := SavedRect.Left;
2713 Pt.Y := SavedRect.Top;
2714 CalculateOffsetWithAngle(Font.Orientation, Pt.X, Pt.Y);
2715 end;
2716 // Draw line of Text
2717 TextOut(LeftPos + Pt.X, TopPos + Pt.Y, theLine);
2718
2719 // Draw Prefix
2720 if (pIndex > 0) and (pIndex <= LineLength) then
2721 begin
2722 //LogP.lopnStyle := PS_SOLID;
2723 //LogP.lopnWidth.X := 1;
2724 //LogP.lopnColor := FcPenColor; // FIXME is this required?
2725
2726 {Get prefix line position}
2727 Points[0] := TextExtent(theLine);
2728 Points[0].cX := LeftPos + Points[0].cX;
2729 Points[0].cY := TopPos + tm.Height - TM.Descender + 1;
2730
2731 Points[0] := TextExtent(aStr[pIndex]);
2732 Points[1].cX := Points[0].cX + Points[1].cX;
2733 Points[1].cY := Points[0].cY;
2734
2735 {Draw prefix line}
2736 Polyline(PPoint(@Points[0]), 2);
2737 end;
2738 end;
2739
2740 begin
2741 if (Str = nil) or (Str[0] = #0) then
2742 Exit(0);
2743
2744 if (Count < -1) or (IsRectEmpty(Rect) and
2745 ((Flags and DT_CALCRECT = 0) and (Flags and DT_NOCLIP = 0))) then
2746 Exit(0);
2747
2748 // Don't try to use StrLen(Str) in cases count >= 0
2749 // In those cases str is NOT required to have a null terminator !
2750 if Count = -1 then
2751 Count := StrLen(Str);
2752
2753 Lines := nil;
2754 NumLines := 0;
2755
2756 try
2757 if (Flags and (DT_SINGLELINE or DT_CALCRECT or DT_NOPREFIX or
2758 DT_NOCLIP or DT_EXPANDTABS)) = (DT_SINGLELINE or DT_NOPREFIX or
2759 DT_NOCLIP) then
2760 begin
2761 LCLIntf.CopyRect(theRect, Rect);
2762 SavedRect := Rect;
2763 DrawLineRaw(Str, Count, Rect.Top);
2764 Result := Rect.Bottom - Rect.Top;
2765 Exit;
2766 end;
2767
2768 SetLength(AStr, Count);
2769 if Count > 0 then
2770 System.Move(Str^, AStr[1], Count);
2771
2772 if (Flags and DT_EXPANDTABS) <> 0 then
2773 AStr := StringReplace(AStr, #9, TabString, [rfReplaceAll]);
2774
2775
2776 if (Flags and DT_NOPREFIX) <> DT_NOPREFIX then
2777 begin
2778 pIndex := DeleteAmpersands(AStr);
2779 if pIndex > Length(AStr) then
2780 pIndex := -1; // String ended in '&', which was deleted
2781 end
2782 else
2783 pIndex := -1;
2784
2785
2786 GetTextMetrics(TM{%H-});
2787 DoCalcRect;
2788 Result := theRect.Bottom - theRect.Top;
2789 if (Flags and DT_CALCRECT) = DT_CALCRECT then
2790 begin
2791 LCLIntf.CopyRect(Rect, theRect);
2792 exit;
2793 end;
2794
2795 if (Flags and DT_NOCLIP) <> DT_NOCLIP then
2796 begin
2797 if theRect.Right > Rect.Right then
2798 theRect.Right := Rect.Right;
2799 if theRect.Bottom > Rect.Bottom then
2800 theRect.Bottom := Rect.Bottom;
2801 // FIXME I don't know what to do here
2802 // IntersectClipRect( theRect.Left, theRect.Top,
2803 // theRect.Right, theRect.Bottom);
2804 end;
2805
2806 if (Flags and DT_SINGLELINE) = DT_SINGLELINE then
2807 begin
2808 SavedRect := TheRect;
2809 DrawLine(PChar(AStr), length(AStr), theRect.Top);
2810 Exit;
2811 end;
2812
2813 // multiple lines
2814 if Lines = nil then
2815 Exit; // nothing to do
2816 if NumLines = 0 then
2817 Exit;
2818
2819 SavedRect := Classes.Rect(0, 0, 0, 0);
2820 // no font orientation change if multilined text
2821 for i := 0 to NumLines - 1 do
2822 begin
2823 if theRect.Top > theRect.Bottom then
2824 Break;
2825
2826 if ((Flags and DT_EDITCONTROL) = DT_EDITCONTROL) and
2827 (tm.Height > (theRect.Bottom - theRect.Top)) then
2828 Break;
2829
2830 if Lines[i] <> nil then
2831 begin
2832 l := StrLen(Lines[i]);
2833 DrawLine(Lines[i], l, theRect.Top);
2834 Dec(pIndex, l + length(LineEnding));
2835 end;
2836 Inc(theRect.Top, (TM.Descender + TM.Height));// space between lines
2837 end;
2838
2839 finally
2840 Reallocmem(Lines, 0);
2841 end;
2842 end;
2843
2844 begin
2845 //TODO: layout, etc.
2846 Changing;
2847
2848 Options := 0;
2849 case Style.Alignment of
2850 taRightJustify:
2851 Options := DT_RIGHT;
2852 taCenter:
2853 Options := DT_CENTER;
2854 end;
2855 case Style.Layout of
2856 tlCenter:
2857 Options := Options or DT_VCENTER;
2858 tlBottom:
2859 Options := Options or DT_BOTTOM;
2860 end;
2861 if Style.EndEllipsis then
2862 Options := Options or DT_END_ELLIPSIS;
2863 if Style.WordBreak then
2864 begin
2865 Options := Options or DT_WORDBREAK;
2866 if Style.EndEllipsis then
2867 Options := Options and not DT_END_ELLIPSIS;
2868 end;
2869
2870 if Style.SingleLine then
2871 Options := Options or DT_SINGLELINE;
2872
2873 if not Style.Clipping then
2874 Options := Options or DT_NOCLIP;
2875
2876 if Style.ExpandTabs then
2877 Options := Options or DT_EXPANDTABS;
2878
2879 if not Style.ShowPrefix then
2880 Options := Options or DT_NOPREFIX;
2881
2882 if Style.RightToLeft then
2883 Options := Options or DT_RTLREADING;
2884
2885 ReqState := [csHandleValid];
2886 if not Style.SystemFont then
2887 Include(ReqState, csFontValid);
2888 if Style.Opaque then
2889 Include(ReqState, csBrushValid);
2890
2891 // calculate text rectangle
2892 fRect := ARect;
2893 if Style.Alignment = taLeftJustify then
2894 fRect.Left := X;
2895 if Style.Layout = tlTop then
2896 fRect.Top := Y;
2897
2898 if (Style.Alignment in [taRightJustify, taCenter]) or
2899 (Style.Layout in [tlCenter, tlBottom]) then
2900 begin
2901 DrawText( pChar(Text), Length(Text), fRect, DT_CALCRECT or Options);
2902 case Style.Alignment of
2903 taRightJustify:
2904 begin
2905 Offset := ARect.Right - fRect.Right;
2906 LCLIntf.OffsetRect(fRect, Offset, 0);
2907 end;
2908 taCenter:
2909 begin
2910 Offset := (ARect.Right - fRect.Right) div 2;
2911 LCLIntf.OffsetRect(fRect, offset, 0);
2912 end;
2913 end;
2914 case Style.Layout of
2915 tlCenter:
2916 begin
2917 Offset := ((ARect.Bottom - ARect.Top) - (fRect.Bottom - fRect.Top)) div 2;
2918 LCLIntf.OffsetRect(fRect, 0, offset);
2919 end;
2920 tlBottom:
2921 begin
2922 Offset := ARect.Bottom - fRect.Bottom;
2923 LCLIntf.OffsetRect(fRect, 0, offset);
2924 end;
2925 end;
2926 end;
2927
2928 if Style.Clipping then begin
2929 OldClip := GetClipRect;
2930 SetClipRect(ARect);
2931 Options := Options or DT_NOCLIP; // no clipping as we are handling it here
2932 end;
2933
2934 if Style.Opaque then
2935 begin
2936 FillRect(fRect)
2937 end;
2938
2939 if Style.SystemFont then
2940 UpdateFont();
2941
2942 DrawText(PChar(Text), Length(Text), fRect, Options);
2943
2944 if Style.Clipping then
2945 SetClipRect(OldClip);
2946
2947 Changed;
2948
2949 end;
2950
2951
2952 function IsMaxClip(ARect:TRect):boolean;
2953 begin
2954 Result:=(Arect.Right=MaxInt) and (ARect.Bottom=MaxInt) and (Arect.Left=0) and (ARect.Top=0);
2955 end;
2956
2957 procedure TPostScriptPrinterCanvas.SetClipRect(const ARect:TRect);
2958 begin
2959 if pcsClipping in FStatus then
2960 RestoreClip;
2961
2962 FLazClipRect := ARect;
2963
2964 if pcsClipping in FStatus then
2965 SaveClip;
2966 end;
2967
GetClippingnull2968 function TPostScriptPrinterCanvas.GetClipping: Boolean;
2969 begin
2970 result := (pcsClipping in FStatus);
2971 end;
2972
2973 procedure TPostScriptPrinterCanvas.SetClipping(const AValue: boolean);
2974 begin
2975 if GetClipping<>AValue then
2976 begin
2977 if GetClipping then
2978 RestoreClip
2979 else
2980 SaveClip;
2981 if AValue then
2982 Include(FStatus, pcsClipping)
2983 else
2984 Exclude(FStatus, pcsClipping);
2985 end;
2986 end;
2987
2988 procedure TPostScriptPrinterCanvas.FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle);
2989 begin
2990 //Not implemented
2991 end;
2992
2993 procedure TPostScriptPrinterCanvas.CopyRect(const Dest: TRect;
2994 SrcCanvas: TCanvas; const Source: TRect);
2995 begin
2996 //Not implemented
2997 end;
2998
2999 { TPostScriptCanvas }
3000
3001 constructor TPostScriptCanvas.Create;
3002 begin
3003 Inherited Create(nil);
3004 end;
3005
3006 procedure TPostScriptCanvas.BeginDoc;
3007 begin
3008 inherited BeginDoc;
3009 end;
3010
3011 procedure TPostScriptCanvas.EndDoc;
3012 begin
3013 inherited EndDoc;
3014 end;
3015
3016 procedure TPostScriptCanvas.NewPage;
3017 begin
3018 inherited NewPage;
3019 end;
3020
3021 end.
3022