1 {
2 /***************************************************************************
3 postscriptprinter.pas
4 ---------------------
5
6 Printer object
7 Initial Revision : Mon Nov 05 2002
8
9 ***************************************************************************/
10
11 *****************************************************************************
12 This file is part of the Lazarus Component Library (LCL)
13
14 See the file COPYING.modifiedLGPL.txt, included in this distribution,
15 for details about the license.
16 *****************************************************************************
17
18 Author: Tony Maro
19 }
20
21 unit PostScriptPrinter;
22
23 {$mode objfpc}{$H+}
24
25 interface
26
27 uses
28 Classes, SysUtils, LCLProc, Graphics, GraphMath, LCLIntf, Forms;
29
30 // uses lcllinux or winapi for RGB conversions and FORMS for application object
31
32 {
33 Defines a special canvas type object and override drawing methods to make
34 the postscript code...
35
36 Defines a TPSPattern object that handles creation of patterns to be used
37 in fills and paints
38
39 TPostScript manages a list of patterns and inserts the definitions into the
40 postscript code and manages when they are changed
41
42 A pattern definition can access pattern definitions within the same
43 postscript object, as long as the TPSPattern object pointer is placed into
44 the canvas pen/brush at the time the new pattern is made
45 }
46
47 type
48 TPostScript = class;
49
50 TPSPaintType = (ptColored, ptUncolored);
51 TPSTileType = (ttConstant, ttNoDistortion, ttFast);
52 TPostScriptCanvas = class; // forward reference
53
54 { Remember, modifying a pattern affects that pattern for the ENTIRE document! }
55 TPSPattern = class(TObject)
56 private
57 FOldName: String;
58 FOnChange: TNotifyEvent;
59 FBBox: TRect;
60 FCanvas: TPostScriptCanvas;
61 FName: String;
62 FPaintType: TPSPaintType;
63 FPostScript: TStringList;
64 FTilingType: TPSTileType;
65 FXStep: Real;
66 FYStep: Real;
GetpostScriptnull67 function GetpostScript: TStringList;
68 procedure SetBBox(const AValue: TRect);
69 procedure SetName(const AValue: String);
70 procedure SetPaintType(const AValue: TPSPaintType);
71 procedure SetTilingType(const AValue: TPSTileType);
72 procedure SetXStep(const AValue: Real);
73 procedure SetYStep(const AValue: Real);
74 protected
75 public
76 constructor Create;
77 destructor Destroy; override;
78 procedure Changed;
79 property BBox: TRect read FBBox write SetBBox;
80 property PaintType: TPSPaintType read FPaintType write SetPaintType;
81 property TilingType: TPSTileType read FTilingType write SetTilingType;
82 property XStep: Real read FXStep write SetXStep;
83 property YStep: Real read FYStep write SetYStep;
84 property Name: String read FName write SetName;
85 property Canvas: TPostScriptCanvas read FCanvas;
86 property GetPS: TStringList read GetPostscript;
87 property OldName: string read FOldName write FOldName; // used when notifying that name Changed
88 property OnChange: TNotifyEvent read FOnChange write FOnChange;
89 end;
90 PPSPattern = ^TPSPattern; // used for array
91
92 { basic pen object - modify later for better splitting of brush object }
93 TPSObject = class(TObject)
94 private
95 FOnChange: TNotifyEvent;
96 protected
97 procedure Changed; virtual;
98 procedure Lock;
99 procedure UnLock;
100 public
101 property OnChange: TNotifyEvent read FOnChange write FOnChange;
102 end;
103
104 { Pen and brush object both right now...}
105 TPSPen = class(TPSObject)
106 private
107 FColor: TColor;
108 FPattern: TPSPattern;
109 FWidth: Real;
110 procedure SetPattern(const AValue: TPSPattern);
111 protected
112 procedure SetColor(Value : TColor);
113 procedure Setwidth(value : Real);
114 public
115 constructor Create;
116 destructor Destroy; override;
117 procedure Assign(Source: TPSPen);
118 property Color: TColor read FColor write SetColor;
119 property Pattern: TPSPattern read FPattern write SetPattern;
120 property Width: Real read FWidth write SetWidth;
AsStringnull121 function AsString: String;
122 end;
123
124
125 { Custom canvas-like object that handles postscript code }
126 TPostScriptCanvas = class(TObject)
127 private
128 FBrush: TPSPen;
129 FFontFace: String;
130 FFontSize: Integer;
131 FHeight: Integer;
132 FLineSpacing: Integer;
133 FColor: TColor; // canvas color - implement later
134 FPen: TPSPen;
135 LastX: Integer;
136 LastY: Integer;
137 FPostScript: TStringList;
GetColornull138 function GetColor: TColor;
139 procedure SetBrush(const AValue: TPSPen);
140 procedure SetColor(const AValue: TColor);
141 procedure SetFontFace(const AValue: String);
142 procedure SetFontSize(const AValue: Integer);
143 procedure SetPen(const AValue: TPSPen);
TranslateYnull144 function TranslateY(Ycoord: Integer): Integer; // Y axis is backwards in postscript
145 procedure AddFill;
146 procedure ResetPos; // reset back to last moveto location
147 procedure PenChanged(Sender: TObject);
148 public
149 MPostScript: TPostScript;
150 constructor Create(APostScript: TPostScript);
151 destructor Destroy; override;
152 procedure Clear;
153 property PostScript: TStringList read FPostScript write FPostScript;
154 property FontFace: String read FFontFace write SetFontFace;
155 property FontSize: Integer read FFontSize write SetFontSize;
156 property LineSpacing: Integer read FLineSpacing write FLineSpacing;
157 procedure MoveTo(X1,Y1 : Integer);
158 procedure LineTo(X1,Y1 : Integer);
159 procedure Line(X1,Y1,X2,Y2 : Integer);
160 procedure Rectangle(X1,Y1,X2,Y2 : Integer);
161 procedure Rectangle(const Rect: TRect);
162 procedure Polyline(Points: PPoint; NumPts: Integer);
163 procedure Ellipse(x1, y1, x2, y2: Integer);
164 procedure Ellipse(const Rect: TRect);
165 procedure RadialPie(x,y,width,mheight,angle1,angle2 : Integer);
166 //procedure Pie(x,y,width,height,SX,SY,EX,EY : Integer);
167 procedure Writeln(const AString: String);
168 procedure TextOut(X,Y: Integer; const Text: String);
169 //procedure Chord(x,y,width,height,angle1,angle2 : Integer);
170 //procedure Chord(x,y,width,height,SX,SY,EX,EY : Integer);
171 //procedure PolyBezier(Points: PPoint; NumPts: Integer;
172 // Filled: boolean{$IFNDEF VER1_0} = False{$ENDIF};
173 // Continuous: boolean{$IFNDEF VER1_0} = False{$ENDIF});
174 //procedure PolyBezier(const Points: array of TPoint;
175 // Filled: boolean{$IFNDEF VER1_0} = False{$ENDIF};
176 // Continuous: boolean{$IFNDEF VER1_0} = False{$ENDIF});
177 //procedure PolyBezier(const Points: array of TPoint);
178 //procedure Polygon(const Points: array of TPoint;
179 // Winding: Boolean{$IFNDEF VER1_0} = False{$ENDIF};
180 // StartIndex: Integer{$IFNDEF VER1_0} = 0{$ENDIF};
181 // NumPts: Integer {$IFNDEF VER1_0} = -1{$ENDIF});
182 //procedure Polygon(Points: PPoint; NumPts: Integer;
183 // Winding: boolean{$IFNDEF VER1_0} = False{$ENDIF});
184 //procedure Polygon(const Points: array of TPoint);
185 //procedure FillRect(const Rect : TRect);
186 //procedure FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle);
187 //procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY : Integer);
188 //procedure RoundRect(const Rect : TRect; RX,RY : Integer);
189 property Height: Integer read FHeight write FHeight; // set so we can translate Y coords
190 property Color: TColor read GetColor write SetColor;
191 property Pen: TPSPen read FPen write SetPen;
192 property Brush: TPSPen read FBrush write SetBrush;
193 end;
194
195 { Encapsulates ALL the postscript and uses the TPostScriptCanvas object for a single page }
196 TPostScript = class(TObject)
197 private
198 FCanvas: TPostScriptCanvas;
199 FHeight: Integer;
200 FLineSpacing: Integer;
201 FPageNumber: Integer;
202 FTitle: String;
203 FWidth: Integer;
204 FDocument: TStringList;
205 Patterns: PPSPattern; // array of pointers to pattern objects
206 NumPatterns: Integer; // number of patterns in array
207 procedure SetHeight(const AValue: Integer);
208 procedure SetLineSpacing(const AValue: Integer);
209 procedure SetTitle(const AValue: String);
210 procedure SetWidth(const AValue: Integer);
211 procedure GrabCanvas;
212 procedure UpdateBoundingBox;
213 procedure PatternChanged(Sender: TObject);
214 procedure InsertPattern(APattern: TPSPattern); // adds the pattern to the postscript
215 procedure RemovePattern(APattern: TPSPattern); // remove the pattern from the postscript
216 public
217 constructor Create;
218 destructor Destroy; override;
219 procedure AddPattern(APSPattern: TPSPattern);
FindPatternnull220 function FindPattern(AName: String): TPSPattern;
DelPatternnull221 function DelPattern(AName: String): Boolean;
NewPatternnull222 function NewPattern(AName: String): TPSPattern;
223 property Canvas: TPostScriptCanvas read FCanvas;
224 property Height: Integer read FHeight write SetHeight;
225 property Width: Integer read FWidth write SetWidth;
226 property Document: TStringList read FDocument;
227 property PageNumber: Integer read FPageNumber;
228 property Title: String read FTitle write SetTitle;
229 property LineSpacing: Integer read FLineSpacing write SetLineSpacing;
230 procedure BeginDoc;
231 procedure NewPage;
232 procedure EndDoc;
233 end;
234
235
236 implementation
237
238
239 { TPostScriptCanvas ----------------------------------------------------------}
240
241 { Y coords in postscript are backwards... }
TranslateYnull242 function TPostScriptCanvas.TranslateY(Ycoord: Integer): Integer;
243 begin
244 Result := FHeight - Ycoord;
245 end;
246
247 { Adds a fill finishing line to any path we desire to fill }
248 procedure TPostScriptCanvas.AddFill;
249 begin
250 FPostScript.Add('gsave '+FBrush.AsString+' fill grestore');
251 end;
252
253 { Sets the current font face}
254 procedure TPostScriptCanvas.SetFontFace(const AValue: String);
255 var
256 MyString: String;
257 begin
258 if FFontFace=AValue then exit;
259 if pos(' ',AValue) > 0 then
260 FFontFace := '('+AValue+')'
261 else FFontFace:=AValue;
262
263 MyString := '/'+FFontFace+' '+IntToStr(FFontSize)+' selectfont';
264 // set the pen info
265
266 FPostScript.Add(MyString);
267 end;
268
269
GetColornull270 function TPostScriptCanvas.GetColor: TColor;
271 begin
272 Result := FColor;
273 end;
274
275 procedure TPostScriptCanvas.SetBrush(const AValue: TPSPen);
276 begin
277 if FBrush=AValue then exit;
278 FBrush:=AValue;
279 end;
280
281 procedure TPostScriptCanvas.SetColor(const AValue: TColor);
282 begin
283 FColor := AValue;
284 end;
285
286 procedure TPostScriptCanvas.SetFontSize(const AValue: Integer);
287 begin
288 if FFontSize=AValue then exit;
289 FFontSize:=AValue;
290 FPostScript.Add('/'+FFontFace+' '+IntToStr(AValue)+' selectfont');
291 end;
292
293 procedure TPostScriptCanvas.SetPen(const AValue: TPSPen);
294 begin
295 // change to ASSIGN method?
296 if FPen=AValue then exit;
297 FPen:=AValue;
298 end;
299
300
301 { Return to last moveto location }
302 procedure TPostScriptCanvas.ResetPos;
303 begin
304 // any routines that you specify a start location when calling such as
305 // textout, ellipse, etc. should not affect the default cursor location.
306
307 FPostScript.Add(IntToStr(LastX)+' '+IntToStr(TranslateY(LastY))+' moveto');
308 end;
309
310 { This is called when drawing pen is Changed but NOT when brush changes }
311 procedure TPostScriptCanvas.PenChanged(Sender: TObject);
312 begin
313 if FPostScript[FPostScript.Count-2] = '%%PEN' then begin
314 // last operation was a pen, so delete it
315 FPostScript.Delete(FPostScript.Count-1);
316 FPostScript.Delete(FPostScript.Count-1);
317 end;
318 FPostScript.Add('%%PEN');
319 FPostScript.Add(FPen.AsString);
320 end;
321
322 constructor TPostScriptCanvas.Create(APostScript: TPostScript);
323 begin
324 MPostScript := APostScript;
325
326 FPostScript := TStringList.Create;
327 FHeight := 792; // length of page in points at 72 ppi
328
329 // Choose a standard font in case the user doesn't
330 FFontFace := 'AvantGarde-Book';
331 SetFontSize(10);
332
333 if Assigned(MPostScript) then begin
334 FLineSpacing := MPostScript.LineSpacing;
335 end;
336
337 FPen := TPSPen.Create;
338 FPen.Width := 1;
339 FPen.Color := 0;
340 FPen.OnChange := @PenChanged;
341
342 FBrush := TPSPen.Create;
343 FBrush.Width := 1;
344 FBrush.Color := -1;
345 // don't notify us that the brush Changed...
346 end;
347
348 destructor TPostScriptCanvas.Destroy;
349 begin
350 FPostScript.Free;
351 FPen.Free;
352 FBrush.Free;
353 inherited Destroy;
354 end;
355
356 { Clear the postscript canvas AND the graphic canvas (Add later) }
357 procedure TPostScriptCanvas.clear;
358 begin
359 // clear the canvas for the next page
360 FPostScript.Clear;
361 // Choose a standard font in case the user doesn't
362 FPostScript.Add('/AvantGarde-Book findfont');
363 FPostScript.Add('10 scalefont');
364 FPostScript.Add('setfont');
365
366 // also clear the canvas itself if we plan to embed the bitmap into
367 // the postscript
368
369 // also grab the latest canvas height just in case it's Changed
370 FHeight := 792;
371 if Assigned(MPostScript) then FHeight := MPostScript.Height;
372 end;
373
374 { Move draw location }
375 procedure TPostScriptCanvas.MoveTo(X1, Y1: Integer);
376 var
377 Y: Integer;
378 begin
379 Y := TranslateY(Y1);
380 FPostScript.Add(IntToStr(X1)+' '+IntToStr(Y)+' moveto');
381 LastX := X1;
382 LastY := Y1;
383 end;
384
385 { Draw a line from current location to these coords }
386 procedure TPostScriptCanvas.LineTo(X1, Y1: Integer);
387 var
388 Y: Integer;
389 begin
390 Y := TranslateY(Y1);
391 FPostScript.Add(IntToStr(X1)+' '+IntToStr(Y)+' lineto');
392 LastX := X1;
393 LastY := Y1;
394 end;
395
396 procedure TPostScriptCanvas.Line(X1, Y1, X2, Y2: Integer);
397 var
398 Y12, Y22: Integer;
399 begin
400 Y12 := TranslateY(Y1);
401 Y22 := TranslateY(Y2);
402
403 FPostScript.Add('newpath '+IntToStr(X1)+' '+IntToStr(Y12)+' moveto '+
404 IntToStr(X2)+' '+IntToStr(Y22)+' lineto closepath stroke');
405
406 // go back to last moveto position
407 ResetPos;
408 end;
409
410 procedure TPostScriptCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
411 var
412 Y12, Y22: Integer;
413 begin
414 Y12 := TranslateY(Y1);
415 Y22 := TranslateY(Y2);
416
417 FPostScript.Add('stroke newpath');
418 FPostScript.Add(IntToStr(X1)+' '+IntToStr(Y12)+' moveto');
419 FPostScript.Add(IntToStr(X2)+' '+IntToStr(Y12)+' lineto');
420 FPostScript.Add(IntToStr(X2)+' '+IntToStr(Y22)+' lineto');
421 FPostScript.Add(IntToStr(X1)+' '+IntToStr(Y22)+' lineto');
422 FPostScript.Add('closepath');
423 if FBrush.Color > -1 then AddFill;
424 FPostScript.Add('stroke');
425 ResetPos;
426 end;
427
428 { Draw a rectangle }
429 procedure TPostScriptCanvas.Rectangle(const Rect: TRect);
430 var
431 Y12, Y22: Integer;
432 begin
433 Y12 := TranslateY(Rect.Top);
434 Y22 := TranslateY(Rect.Bottom);
435
436 FPostScript.Add('stroke newpath');
437 FPostScript.Add(IntToStr(Rect.Left)+' '+IntToStr(Y12)+' moveto');
438 FPostScript.Add(IntToStr(Rect.Right)+' '+IntToStr(Y12)+' lineto');
439 FPostScript.Add(IntToStr(Rect.Right)+' '+IntToStr(Y22)+' lineto');
440 FPostScript.Add(IntToStr(Rect.Left)+' '+IntToStr(Y22)+' lineto');
441 FPostScript.Add('closepath');
442 if FBrush.Color > -1 then AddFill;
443 FPostScript.Add('stroke');
444 ResetPos;
445 end;
446
447 { Draw a series of lines }
448 procedure TPostScriptCanvas.Polyline(Points: PPoint; NumPts: Integer);
449 var
450 i : Longint;
451 begin
452 If (NumPts <= 1) or (Points = nil) then exit;
453
454 MoveTo(Points[0].X, Points[0].Y);
455 For i := 1 to NumPts - 1 do
456 LineTo(Points[i].X, Points[i].Y);
457
458 ResetPos;
459 end;
460
461 { This was a pain to figure out... }
462 procedure TPostScriptCanvas.Ellipse(x1, y1, x2, y2: Integer);
463 var
464 radius: Integer;
465 YRatio: Real;
466 centerX, centerY: Integer;
467 begin
468 // set radius to half the width
469 radius := (x2 - x1) div 2;
470
471 //calculate ratios
472 if radius <1 then exit; // do nothing
473 YRatio := real(Y2 - Y1) / (X2-X1);
474
475 // find center
476 CenterX := ((X2 - X1) div 2) + X1;
477 CenterY := ((Y2 - Y1) div 2) + Y1;
478
479 FPostScript.Add('newpath '+IntToStr(CenterX)+' '+IntToStr(TranslateY(CenterY))+' translate');
480
481 // move to edge
482 FPostScript.Add(IntToStr(radius)+' 0 moveto');
483
484 // now draw it
485 FPostScript.Add('gsave 1 '+format('%.3f',[YRatio])+' scale');
486 FPostScript.Add('0 0 '+IntToStr(radius)+' 0 360 arc');
487 if FBrush.Color > -1 then AddFill;
488
489 // reset scale for drawing line thickness so it doesn't warp
490 YRatio := 1 / YRatio;
491 FPostScript.Add('1 '+format('%.2f',[YRatio])+' scale stroke grestore');
492
493 // move origin back
494 FPostScript.Add(IntToStr(-CenterX)+' '+IntToStr(-TranslateY(CenterY))+' translate closepath stroke');
495 ResetPos;
496 end;
497
498 procedure TPostScriptCanvas.Ellipse(const Rect: TRect);
499 begin
500 self.Ellipse(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
501 end;
502
503 procedure TPostScriptCanvas.RadialPie(x, y, width, mheight, angle1, angle2: Integer);
504 begin
505 // set zero at center
506 FPostScript.Add('newpath '+IntToStr(X)+' '+IntToStr(TranslateY(Y))+' translate');
507
508 // scale it
509 FPostScript.Add('gsave '+IntToStr(width)+' '+IntToStr(mheight)+' scale');
510 //FPostScript.Add('gsave 1 1 scale');
511
512 // draw line to edge
513 FPostScript.Add('0 0 moveto');
514 FPostScript.Add('0 0 1 '+IntToStr(angle1)+' '+IntToStr(angle2)+' arc closepath');
515
516 if FBrush.Color > -1 then AddFill;
517
518 // reset scale so we don't change the line thickness
519 // adding 0.01 to compensate for scaling error - there may be a deeper problem here...
520 FPostScript.Add(format('%.6f',[(real(1) / X)+0.01])+' '+format('%.6f',[(real(1) / Y)+0.01])+' scale stroke grestore');
521
522 // close out and return origin
523 FPostScript.Add(IntToStr(-X)+' '+IntToStr(-TranslateY(Y))+' translate closepath stroke');
524
525 ResetPos;
526 end;
527
528 { Writes text with a carriage return }
529 procedure TPostScriptCanvas.Writeln(const AString: String);
530 begin
531 TextOut(LastX, LastY, AString);
532 LastY := LastY+FFontSize+FLineSpacing;
533 MoveTo(LastX, LastY);
534 end;
535
536
537 { Output text, restoring draw location }
538 procedure TPostScriptCanvas.TextOut(X, Y: Integer; const Text: String);
539 var
540 Y1: Integer;
541 begin
542 Y1 := TranslateY(Y);
543 FPostScript.Add(IntToStr(X)+' '+IntToStr(Y1)+' moveto');
544 FPostScript.Add('('+Text+') show');
545 ResetPos; // move back to last moveto location
546 end;
547
548 { TPostScript -------------------------------------------------------------- }
549
550 procedure TPostScript.SetHeight(const AValue: Integer);
551 begin
552 if FHeight=AValue then exit;
553 FHeight:=AValue;
554 UpdateBoundingBox;
555 // filter down to the canvas height property
556 if assigned(FCanvas) then FCanvas.Height := FHeight;
557 end;
558
559 procedure TPostScript.SetLineSpacing(const AValue: Integer);
560 begin
561 if FLineSpacing=AValue then exit;
562 FLineSpacing:=AValue;
563 // filter down to the canvas
564 if assigned(FCanvas) then FCanvas.LineSpacing := AValue;
565 end;
566
567 procedure TPostScript.SetTitle(const AValue: String);
568 begin
569 if FTitle=AValue then exit;
570 FTitle:=AValue;
571
572 // need to not hard-link these...
573 FDocument[3] := '%%Title: '+AValue;
574 end;
575
576 procedure TPostScript.SetWidth(const AValue: Integer);
577 begin
578 if FWidth=AValue then exit;
579 FWidth:=AValue;
580 UpdateBoundingBox;
581 end;
582
583 { Places the current canvas object into the document }
584 procedure TPostScript.GrabCanvas;
585 var
586 I: Integer;
587 begin
588 // internally calls this at the end of a page...
589
590 I := 0;
591 while I < FCanvas.PostScript.Count do begin
592 Document.Add(FCanvas.PostScript[I]);
593 I := I+1;
594 end;
595 end;
596
597 { Take our sizes and change the boundingbox line }
598 procedure TPostScript.UpdateBoundingBox;
599 begin
600 // need to not hard-link this to line 1
601 FDocument[1] := '%%BoundingBox: 0 0 '+IntToStr(FWidth)+' '+IntToStr(FHeight);
602 end;
603
604 { Pattern Changed so update the postscript code }
605 procedure TPostScript.PatternChanged(Sender: TObject);
606 begin
607 // called anytime a pattern changes. Update the postscript code.
608 // look for and delete the current postscript code for this pattern
609 // then paste the pattern back into the code before the first page
610 RemovePattern(Sender As TPSPattern);
611 InsertPattern(Sender As TPSPattern);
612 end;
613
614 { Places a pattern definition into the bottom of the header in postscript }
615 procedure TPostScript.InsertPattern(APattern: TPSPattern);
616 var
617 I, J: Integer;
618 MyStrings: TStringList;
619 begin
620 I := 0;
621 if FDocument.Count < 1 then begin
622 // added pattern when no postscript exists - this shouldn't happen
623 raise exception.create('Pattern inserted with no postscript existing');
624 exit;
625 end;
626
627 for I := 0 to FDocument.count - 1 do begin
628 if (FDocument[I] = '%%Page: 1 1') then begin
629 // found it!
630 // insert into just before that
631 MyStrings := APattern.GetPS;
632 for J := 0 to MyStrings.Count - 1 do begin
633 FDocument.Insert(I-1+J, MyStrings[j]);
634 end;
635 exit;
636 end;
637 end;
638 end;
639
640 {Remove a pattern from the postscript code }
641 procedure TPostScript.RemovePattern(APattern: TPSPattern);
642 var
643 I: Integer;
644 MyName: String;
645 begin
646 // this does NOT destroy the object, just removes from postscript
647
648 if APattern.OldName <> '' then MyName := APattern.OldName
649 else MyName := APattern.name;
650
651 I := 0;
652 if FDocument.Count < 1 then begin
653 // added pattern when no postscript exists - this shouldn't happen
654 raise exception.create('Pattern removed with no postscript existing');
655 exit;
656 end;
657
658 for I := 0 to FDocument.Count - 1 do begin
659 if (FDocument[I] = '%% PATTERN '+MyName) then begin
660 // found it...
661 // delete until gone
662 while I < FDocument.Count - 1 do begin
663 // stay within our limites
664 if (FDocument[I] = '%% END PATTERN '+MyName) then begin
665 FDocument.Delete(I);
666 APattern.oldName := '';
667 exit;
668 end else FDocument.Delete(I);
669 end;
670 end;
671 end;
672 end;
673
674 constructor TPostScript.Create;
675 begin
676 inherited create;
677
678 FDocument := TStringList.Create;
679
680 // Set some defaults
681 FHeight := 792; // 11 inches at 72 dpi
682 FWidth := 612; // 8 1/2 inches at 72 dpi
683 FCanvas := TPostScriptCanvas.Create(Self);
684
685 FDocument.Clear;
686 FDocument.Add('%!PS-Adobe-3.0');
687 FDocument.Add('%%BoundingBox: 0 0 612 792');
688 FDocument.Add('%%Creator: '+Application.ExeName);
689 FDocument.Add('%%Title: '+FTitle);
690 FDocument.Add('%%Pages: (atend)');
691 FDocument.Add('%%PageOrder: Ascend');
692
693 // Choose a standard font in case the user doesn't
694 FDocument.Add('/AvantGarde-Book findfont');
695 FDocument.Add('10 scalefont');
696 FDocument.Add('setfont');
697
698 // start our first page
699 FPageNumber := 1;
700 FDocument.Add('%%Page: 1 1'); // I'm still not sure why u put the page # twice
701 FDocument.Add('newpath');
702
703 end;
704
705 destructor TPostScript.Destroy;
706 var
707 I: Integer;
708 begin
709
710 FCanvas.Free;
711 FDocument.Free;
712
713 // destroy the patterns
714 if NumPatterns > 0 then begin
715 for I := 0 to NuMPatterns-1 do begin
716 Patterns[i].Free;
717 end;
718 end;
719
720 // free the pattern pointer memory
721 Reallocmem(Patterns, 0);
722
723 inherited Destroy;
724
725 end;
726
727 { Add a pattern to the array }
728 procedure TPostScript.AddPattern(APSPattern: TPSPattern);
729 begin
730 // does NOT create the pattern, just insert in the array of patterns
731
732 NumPatterns := NumPatterns+1;
733
734 reallocmem(Patterns, sizeof(TPSPattern) * NumPatterns);
735
736 Patterns[NumPatterns-1] := APSPattern;
737 end;
738
739 { Find a pattern object by it's name }
FindPatternnull740 function TPostScript.FindPattern(AName: String): TPSPattern;
741 var
742 I: Integer;
743 begin
744 Result := nil;
745 if NumPatterns < 1 then exit;
746 for I := 0 to NumPatterns-1 do begin
747 if Patterns[I].Name = AName then begin
748 result := Patterns[i];
749 exit;
750 end;
751 end;
752 end;
753
DelPatternnull754 function TPostScript.DelPattern(AName: String): Boolean;
755 begin
756 {$IFNDEF DisableChecks}
757 if AName<>'' then
758 DebugLn('[TPostScript.DelPattern] ToDo ');
759 {$ENDIF}
760
761 // can't do that yet...
762 Result:=false;
763 end;
764
765 { Create a new pattern and inserts it into the array for safe keeping }
NewPatternnull766 function TPostScript.NewPattern(AName: String): TPSPattern;
767 var
768 MyPattern: TPSPattern;
769 begin
770 MyPattern := TPSPattern.Create;
771 AddPattern(MyPattern);
772 MyPattern.Name := AName;
773 MyPattern.OnChange := @PatternChanged;
774 MyPattern.OldName := '';
775
776 // Add this to the postscript now...
777
778 InsertPattern(MyPattern);
779 result := MyPattern;
780 end;
781
782 { Start a new document }
783 procedure TPostScript.BeginDoc;
784 var
785 I: Integer;
786 begin
787 FCanvas.Clear;
788 FDocument.Clear;
789
790 // destroy the patterns
791 if NumPatterns > 0 then
792 begin
793 for I := 0 to NuMPatterns-1 do
794 begin
795 Patterns[i].Free;
796 Patterns[i]:=nil;
797 end;
798 NumPatterns:=0;
799 end;
800
801 // free the pattern pointer memory
802 Reallocmem(Patterns, 0);
803
804 FDocument.Add('%!PS-Adobe-3.0');
805 FDocument.Add('%%BoundingBox: 0 0 612 792');
806 FDocument.Add('%%Creator: '+Application.ExeName);
807 FDocument.Add('%%Title: '+FTitle);
808 FDocument.Add('%%Pages: (atend)');
809 FDocument.Add('%%PageOrder: Ascend');
810
811 // Choose a standard font in case the user doesn't
812 FDocument.Add('/AvantGarde-Book findfont');
813 FDocument.Add('10 scalefont');
814 FDocument.Add('setfont');
815
816 // start our first page
817 FPageNumber := 1;
818 FDocument.Add('%%Page: 1 1'); // I'm still not sure why u put the page # twice
819 FDocument.Add('newpath');
820
821 UpdateBoundingBox;
822 end;
823
824 { Copy current page into the postscript and start a new one }
825 procedure TPostScript.NewPage;
826 begin
827 // dump the current page into our postscript first
828 GrabCanvas;
829
830 // put end page definition...
831 FDocument.Add('stroke');
832 FDocument.Add('showpage');
833 FPageNumber := FPageNumber+1;
834 // start new page definition...
835 FDocument.Add('%%Page: '+IntToStr(FPageNumber)+' '+IntToStr(FPageNumber));
836 FDocument.Add('newpath');
837 FCanvas.Clear;
838 end;
839
840 { Finish off the document }
841 procedure TPostScript.EndDoc;
842 begin
843 // dump the canvas into the postscript code
844 GrabCanvas;
845
846 // Start printing the document after closing out the pages
847 FDocument.Add('stroke');
848 FDocument.Add('showpage');
849 FDocument.Add('%%Pages: '+IntToStr(FPageNumber));
850
851 // okay, the postscript is all ready, so dump it to the text file
852 // or to the printer
853 FPageNumber := 0;
854 end;
855
856 { TPSObject }
857
858 procedure TPSObject.Changed;
859 begin
860 if Assigned(FOnChange) then FOnChange(Self);
861 end;
862
863 procedure TPSObject.Lock;
864 begin
865
866 end;
867
868 procedure TPSObject.UnLock;
869 begin
870
871 end;
872
873 { TPSPen }
874
875 procedure TPSPen.SetPattern(const AValue: TPSPattern);
876 begin
877 if FPattern=AValue then exit;
878 FPattern:=AValue;
879 Changed;
880 end;
881
882
883 procedure TPSPen.SetColor(Value: TColor);
884 begin
885 FColor := Value;
886 Changed;
887 end;
888
889 procedure TPSPen.Setwidth(value: Real);
890 begin
891 FWidth := Value;
892 Changed;
893 end;
894
895 constructor TPSPen.Create;
896 begin
897 FPattern := nil;
898 end;
899
900 destructor TPSPen.Destroy;
901 begin
902 // Do NOT free the pattern object from here...
903 inherited Destroy;
904 end;
905
906 procedure TPSPen.Assign(Source: TPSPen);
907 begin
908 if source = nil then exit;
909
910 FWidth := Source.Width;
911 FColor := Source.Color;
912 FPattern := Source.Pattern;
913 end;
914
915 { Return the pen definition as a postscript string }
AsStringnull916 function TPSPen.AsString: String;
917 var
918 MyOut: String;
919 begin
920 MyOut := '';
921
922 // set all the features of this pen...
923 if FPattern <> nil then begin
924 // we have a pattern
925 // uh... let's make it work for both colored and uncolored patterns
926 // first for colored:
927
928 if FPattern.PaintType = ptColored then
929 MyOut := '/Pattern setcolorspace '+FPattern.Name+' setcolor '
930 else begin
931 // now for uncolored, use color from pen
932 MyOut := '[/Pattern /DeviceRGB] setcolorspace '+IntToStr(GetRValue(FColor))+' '+IntToStr(GetGValue(FColor))+' '+
933 IntToStr(GetBValue(FColor))+' '+FPattern.Name+' setcolor ';
934 end;
935
936 end else // no pattern do this:
937 MyOut := IntToStr(GetRValue(FColor))+' '+IntToStr(GetGValue(FColor))+' '+
938 IntToStr(GetBValue(FColor))+' setrgbcolor ';
939
940 MyOut := MyOut + format('%f',[FWidth])+' setlinewidth ';
941 Result := MyOut;
942 end;
943
944 { TPSPattern }
945
946 { Returns the pattern definition as postscript }
GetpostScriptnull947 function TPSPattern.GetpostScript: TStringList;
948 var
949 I: Integer;
950 begin
951 // If nothing in the canvas, error
952 if FCanvas.Postscript.Count < 1 then begin
953 raise exception.create('Empty pattern');
954 exit;
955 end;
956
957 FPostScript.Clear;
958 With FPostScript do begin
959 Add('%% PATTERN '+FName);
960 Add('/'+FName+'proto 12 dict def '+FName+'proto begin');
961 Add('/PatternType 1 def');
962 case FPaintType of
963 ptColored: Add('/PaintType 1 def');
964 ptUncolored: Add('/PaintType 2 def');
965 end;
966 case FTilingType of
967 ttConstant: Add('/TilingType 1 def');
968 ttNoDistortion: Add('/TilingType 2 def');
969 ttFast: Add('/TilingType 3 def');
970 end;
971 Add('/BBox ['+IntToStr(FBBox.Left)+' '+IntToStr(FBBox.Top)+' '+IntToStr(FBBox.Right)+' '+IntToStr(FBBox.Bottom)+'] def');
972 Add('/XStep '+format('%f',[FXStep])+' def');
973 Add('/YStep '+format('%f',[FYstep])+' def');
974 Add('/PaintProc { begin');
975
976 // insert the canvas
977 for I := 0 to FCanvas.PostScript.Count - 1 do begin
978 Add(FCanvas.PostScript[I]);
979 end;
980
981 // Add support for custom matrix later
982 Add('end } def end '+FName+'proto [1 0 0 1 0 0] makepattern /'+FName+' exch def');
983 Add('%% END PATTERN '+FName);
984 end;
985 Result := FPostScript;
986 end;
987
988 procedure TPSPattern.SetBBox(const AValue: TRect);
989 begin
990 if FBBox=AValue then exit;
991 FBBox:=AValue;
992 //FCanvas.Width := FBBox.Right - FBBox.Left;
993 FCanvas.Height := FBBox.Bottom - FBBox.Top;
994 Changed;
995 end;
996
997 procedure TPSPattern.SetName(const AValue: String);
998 begin
999 FOldName := FName;
1000 if FName=AValue then exit;
1001 FName:=AValue;
1002 Changed;
1003 end;
1004
1005 procedure TPSPattern.Changed;
1006 begin
1007 if Assigned(FOnChange) then FOnChange(Self);
1008 end;
1009
1010 procedure TPSPattern.SetPaintType(const AValue: TPSPaintType);
1011 begin
1012 if FPaintType=AValue then exit;
1013 FPaintType:=AValue;
1014 Changed;
1015 end;
1016
1017 procedure TPSPattern.SetTilingType(const AValue: TPSTileType);
1018 begin
1019 if FTilingType=AValue then exit;
1020 FTilingType:=AValue;
1021 Changed;
1022 end;
1023
1024 procedure TPSPattern.SetXStep(const AValue: Real);
1025 begin
1026 if FXStep=AValue then exit;
1027 FXStep:=AValue;
1028 Changed;
1029 end;
1030
1031 procedure TPSPattern.SetYStep(const AValue: Real);
1032 begin
1033 if FYStep=AValue then exit;
1034 FYStep:=AValue;
1035 Changed;
1036 end;
1037
1038 constructor TPSPattern.Create;
1039 begin
1040 FPostScript := TStringList.Create;
1041 FPaintType := ptColored;
1042 FTilingType := ttConstant;
1043 FCanvas := TPostScriptCanvas.Create(nil);
1044 FName := 'Pattern1';
1045 end;
1046
1047 destructor TPSPattern.Destroy;
1048 begin
1049 FPostScript.Free;
1050 FCanvas.Free;
1051 inherited Destroy;
1052 end;
1053
1054 end.
1055