← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fcl/image/pscanvas.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fcl/image/pscanvas.pp
1
 
{
2
 
    $Id: pscanvas.pp,v 1.2 2003/11/03 12:44:52 daniel Exp $
3
 
    This file is part of the Free Pascal run time library.
4
 
    Copyright (c) 2003 by the Free Pascal development team
5
 
 
6
 
    TPostScriptCanvas implementation.
7
 
    
8
 
    See the file COPYING.FPC, included in this distribution,
9
 
    for details about the copyright.
10
 
 
11
 
    This program is distributed in the hope that it will be useful,
12
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
13
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
 
 
15
 
 **********************************************************************}
16
 
{ ---------------------------------------------------------------------
17
 
  This code is heavily based on Tony Maro's initial TPostScriptCanvas
18
 
  implementation in the LCL, but was adapted to work with the custom
19
 
  canvas code and to work with streams instead of strings.
20
 
  ---------------------------------------------------------------------}
21
 
  
22
 
 
23
 
{$mode objfpc}
24
 
{$H+}
25
 
 
26
 
unit pscanvas;
27
 
 
28
 
interface
29
 
 
30
 
uses
31
 
  Classes, SysUtils,fpimage,fpcanvas;
32
 
  
33
 
type
34
 
  TPostScript = class;
35
 
 
36
 
  TPSPaintType = (ptColored, ptUncolored);
37
 
  TPSTileType = (ttConstant, ttNoDistortion, ttFast);
38
 
  TPostScriptCanvas = class; // forward reference
39
 
 
40
 
  {Remember, modifying a pattern affects that pattern for the ENTIRE document!}
41
 
  TPSPattern = class(TFPCanvasHelper)
42
 
  private
43
 
    FStream : TMemoryStream;
44
 
    FPatternCanvas : TPostScriptCanvas;
45
 
    FOldName: String;
46
 
    FOnChange: TNotifyEvent;
47
 
    FBBox: TRect;
48
 
    FName: String;
49
 
    FPaintType: TPSPaintType;
50
 
    FPostScript: TStringList;
51
 
    FTilingType: TPSTileType;
52
 
    FXStep: Real;
53
 
    FYStep: Real;
54
 
    function GetpostScript: TStringList;
55
 
    procedure SetBBox(const AValue: TRect);
56
 
    procedure SetName(const AValue: String);
57
 
    procedure SetPaintType(const AValue: TPSPaintType);
58
 
    procedure SetTilingType(const AValue: TPSTileType);
59
 
    procedure SetXStep(const AValue: Real);
60
 
    procedure SetYStep(const AValue: Real);
61
 
  protected
62
 
  public
63
 
    constructor Create;
64
 
    destructor Destroy; override;
65
 
    procedure Changed;
66
 
    property BBox: TRect read FBBox write SetBBox;
67
 
    property PaintType: TPSPaintType read FPaintType write SetPaintType;
68
 
    property TilingType: TPSTileType read FTilingType write SetTilingType;
69
 
    property XStep: Real read FXStep write SetXStep;
70
 
    property YStep: Real read FYStep write SetYStep;
71
 
    property Name: String read FName write SetName;
72
 
    property GetPS: TStringList read GetPostscript;
73
 
    property OldName: string read FOldName write FOldName; // used when notifying that name changed
74
 
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
75
 
    Property PatternCanvas : TPostScriptCanvas Read FPatternCanvas;
76
 
  end;
77
 
  PPSPattern = ^TPSPattern; // used for array
78
 
 
79
 
  { Pen and brush object both right now...}
80
 
  TPSPen = class(TFPCustomPen)
81
 
  private
82
 
    FPattern: TPSPattern;
83
 
    procedure SetPattern(const AValue: TPSPattern);
84
 
  public
85
 
    destructor Destroy; override;
86
 
    property Pattern: TPSPattern read FPattern write SetPattern;
87
 
    function AsString: String;
88
 
  end;
89
 
 
90
 
  TPSBrush = Class(TFPCustomBrush)
91
 
  Private 
92
 
    Function GetAsString : String;
93
 
  Public
94
 
    Property AsString : String Read GetAsString;
95
 
  end;
96
 
 
97
 
  TPSFont = Class(TFPCustomFont)
98
 
  end;
99
 
 
100
 
  { Custom canvas-like object that handles postscript code }
101
 
  TPostScriptCanvas = class(TFPCustomCanvas)
102
 
  private
103
 
    FHeight,FWidth : Integer;
104
 
    FStream : TStream;
105
 
    FLineSpacing: Integer;
106
 
    LastX: Integer;
107
 
    LastY: Integer;
108
 
    function TranslateY(Ycoord: Integer): Integer; // Y axis is backwards in postscript
109
 
    procedure AddFill;
110
 
    procedure ResetPos; // reset back to last moveto location
111
 
    procedure SetWidth (AValue : integer); override;
112
 
    function  GetWidth : integer; override;
113
 
    procedure SetHeight (AValue : integer); override;
114
 
    function  GetHeight : integer; override;
115
 
  Protected
116
 
    Procedure WritePS(Const Cmd : String);
117
 
    Procedure WritePS(Const Fmt : String; Args : Array of Const);
118
 
    procedure DrawRectangle(const Bounds: TRect; DoFill : Boolean);
119
 
    procedure DrawEllipse(const Bounds: TRect; DoFill : Boolean);
120
 
  public
121
 
    constructor Create(AStream : TStream);
122
 
    destructor Destroy; override;
123
 
    function DoCreateDefaultFont : TFPCustomFont; override;
124
 
    function DoCreateDefaultPen : TFPCustomPen; override;
125
 
    function DoCreateDefaultBrush : TFPCustomBrush; override;
126
 
    property LineSpacing: Integer read FLineSpacing write FLineSpacing;
127
 
    Procedure DoMoveTo(X1,Y1 : Integer); override;
128
 
    Procedure DoLineTo(X1,Y1 : Integer); override;
129
 
    Procedure DoLine(X1,Y1,X2,Y2 : Integer); override;
130
 
    Procedure DoRectangle(Const Bounds : TRect); override;
131
 
    Procedure DoRectangleFill(Const Bounds : TRect); override;
132
 
    procedure DoPolyline(Const Points: Array of TPoint); override;
133
 
    procedure DoEllipse(const Bounds: TRect); override;
134
 
    procedure DoEllipseFill(const Bounds: TRect); override;
135
 
    procedure DoPie(x,y,awidth,aheight,angle1,angle2 : Integer);
136
 
    //procedure Pie(x,y,width,height,SX,SY,EX,EY : Integer);
137
 
    procedure Writeln(AString: String);
138
 
    procedure TextOut(X,Y: Integer; const Text: String);
139
 
    //procedure Chord(x,y,width,height,angle1,angle2 : Integer);
140
 
    //procedure Chord(x,y,width,height,SX,SY,EX,EY : Integer);
141
 
    //procedure PolyBezier(Points: PPoint; NumPts: Integer;
142
 
    //                     Filled: boolean{$IFDEF VER1_1} = False{$ENDIF};
143
 
    //                     Continuous: boolean{$IFDEF VER1_1} = False{$ENDIF});
144
 
    //procedure PolyBezier(const Points: array of TPoint;
145
 
    //                     Filled: boolean{$IFDEF VER1_1} = False{$ENDIF};
146
 
    //                     Continuous: boolean{$IFDEF VER1_1} = False{$ENDIF});
147
 
    //procedure PolyBezier(const Points: array of TPoint);
148
 
    //procedure Polygon(const Points: array of TPoint;
149
 
    //                  Winding: Boolean{$IFDEF VER1_1} = False{$ENDIF};
150
 
    //                  StartIndex: Integer{$IFDEF VER1_1} = 0{$ENDIF};
151
 
    //                  NumPts: Integer {$IFDEF VER1_1} = -1{$ENDIF});
152
 
    //procedure Polygon(Points: PPoint; NumPts: Integer;
153
 
    //                  Winding: boolean{$IFDEF VER1_1} = False{$ENDIF});
154
 
    //Procedure Polygon(const Points: array of TPoint);
155
 
    //Procedure FillRect(const Rect : TRect);
156
 
    //procedure FloodFill(X, Y: Integer; FillColor: TFPColor; FillStyle: TFillStyle);
157
 
    //Procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY : Integer);
158
 
    //Procedure RoundRect(const Rect : TRect; RX,RY : Integer);
159
 
    Property Stream : TStream read FStream;
160
 
  end;
161
 
 
162
 
  { Encapsulates ALL the postscript and uses the TPostScriptCanvas object for a single page }
163
 
  TPostScript = class(TComponent)
164
 
  private
165
 
    FDocStarted : Boolean;
166
 
    FCreator : String;
167
 
    FStream : TStream;
168
 
    FCanvas: TPostScriptCanvas;
169
 
    FHeight: Integer;
170
 
    FLineSpacing: Integer;
171
 
    FPageNumber: Integer;
172
 
    FTitle: String;
173
 
    FWidth: Integer;
174
 
    FPatterns: TList;   // array of pointers to pattern objects
175
 
    procedure SetHeight(const AValue: Integer);
176
 
    procedure SetLineSpacing(const AValue: Integer);
177
 
    procedure SetWidth(const AValue: Integer);
178
 
    procedure UpdateBoundingBox;
179
 
    procedure PatternChanged(Sender: TObject);
180
 
    procedure InsertPattern(APattern: TPSPattern); // adds the pattern to the postscript
181
 
    Procedure SetStream (Value : TStream);
182
 
    Function GetCreator : String;
183
 
  Protected
184
 
    Procedure WritePS(Const Cmd : String);
185
 
    Procedure WritePS(Const Fmt : String; Args : Array of Const);
186
 
    Procedure WriteDocumentHeader; virtual;
187
 
    Procedure WriteStandardFont; virtual;
188
 
    Procedure WritePage; virtual;
189
 
    Procedure FreePatterns;
190
 
    Procedure CheckStream;
191
 
  public
192
 
    Constructor Create(AOwner : TComponent);
193
 
    destructor Destroy; override;
194
 
   
195
 
    procedure AddPattern(APSPattern: TPSPattern);
196
 
    function FindPattern(AName: String): TPSPattern;
197
 
    function DelPattern(AName: String): Boolean;
198
 
    function NewPattern(AName: String): TPSPattern;
199
 
    property Canvas: TPostScriptCanvas read FCanvas;
200
 
    property Height: Integer read FHeight write SetHeight;
201
 
    property Width: Integer read FWidth write SetWidth;
202
 
    property PageNumber: Integer read FPageNumber;
203
 
    property Title: String read FTitle write FTitle;
204
 
    property LineSpacing: Integer read FLineSpacing write SetLineSpacing;
205
 
    procedure BeginDoc;
206
 
    procedure NewPage;
207
 
    procedure EndDoc;
208
 
    Property Stream : TStream Read FStream Write SetStream;
209
 
    Property Creator : String Read GetCreator Write FCreator;
210
 
  end;
211
 
 
212
 
implementation
213
 
 
214
 
Resourcestring
215
 
  SErrNoStreamAssigned = 'Invalid operation: No stream assigned';
216
 
  SErrDocumentAlreadyStarted = 'Cannot start document twice.';
217
 
 
218
 
{$ifdef ver1_0}
219
 
const   lineending=#10;
220
 
 
221
 
procedure freeandnil(var o:Tobject);
222
 
 
223
 
begin
224
 
  o.destroy;
225
 
  o:=nil;
226
 
end;
227
 
 
228
 
{$endif}
229
 
 
230
 
{ TPostScriptCanvas ----------------------------------------------------------}
231
 
 
232
 
Procedure TPostScriptCanvas.WritePS(const Cmd : String);
233
 
 
234
 
begin
235
 
  If length(Cmd)>0 then
236
 
    FStream.Write(Cmd[1],Length(Cmd));
237
 
  FStream.Write(LineEnding,SizeOf(LineEnding));
238
 
end;
239
 
 
240
 
Procedure TPostScriptCanvas.WritePS(Const Fmt : String; Args : Array of Const);
241
 
 
242
 
begin
243
 
  WritePS(Format(Fmt,Args));
244
 
end;
245
 
 
246
 
{ Y coords in postscript are backwards... }
247
 
function TPostScriptCanvas.TranslateY(Ycoord: Integer): Integer;
248
 
begin
249
 
  Result:=Height-Ycoord;
250
 
end;
251
 
 
252
 
{ Adds a fill finishing line to any path we desire to fill }
253
 
procedure TPostScriptCanvas.AddFill;
254
 
begin
255
 
  WritePs('gsave '+(Brush as TPSBrush).AsString+' fill grestore');
256
 
end;
257
 
 
258
 
{ Return to last moveto location }
259
 
procedure TPostScriptCanvas.ResetPos;
260
 
begin
261
 
  WritePS(inttostr(LastX)+' '+inttostr(TranslateY(LastY))+' moveto');
262
 
end;
263
 
 
264
 
constructor TPostScriptCanvas.Create(AStream : TStream);
265
 
 
266
 
begin
267
 
  inherited create;
268
 
  FStream:=AStream;
269
 
  Height := 792; // length of page in points at 72 ppi
270
 
  { // Choose a standard font in case the user doesn't
271
 
  FFontFace := 'AvantGarde-Book';
272
 
  SetFontSize(10);
273
 
    FLineSpacing := MPostScript.LineSpacing;
274
 
  end;
275
 
  FPen := TPSPen.Create;
276
 
  FPen.Width := 1;
277
 
  FPen.Color := 0;
278
 
  FPen.OnChange := @PenChanged;
279
 
     
280
 
  FBrush := TPSPen.Create;
281
 
  FBrush.Width := 1;
282
 
  FBrush.Color := -1;
283
 
  // don't notify us that the brush changed...
284
 
  }
285
 
end;
286
 
 
287
 
destructor TPostScriptCanvas.Destroy;
288
 
begin
289
 
{
290
 
  FPostScript.Free;
291
 
  FPen.Free;
292
 
  FBrush.Free;
293
 
}
294
 
  inherited Destroy;
295
 
end;
296
 
 
297
 
procedure TPostScriptCanvas.SetWidth (AValue : integer); 
298
 
 
299
 
begin
300
 
  FWidth:=AValue;
301
 
end;
302
 
 
303
 
function  TPostScriptCanvas.GetWidth : integer; 
304
 
 
305
 
begin
306
 
  Result:=FWidth;
307
 
end;
308
 
 
309
 
procedure TPostScriptCanvas.SetHeight (AValue : integer); 
310
 
 
311
 
begin
312
 
  FHeight:=AValue;
313
 
end;
314
 
 
315
 
function  TPostScriptCanvas.GetHeight : integer; 
316
 
 
317
 
begin
318
 
  Result:=FHeight;
319
 
end;
320
 
 
321
 
 
322
 
{ Move draw location }
323
 
procedure TPostScriptCanvas.DoMoveTo(X1, Y1: Integer);
324
 
 
325
 
var
326
 
  Y: Integer;
327
 
   
328
 
begin
329
 
  Y := TranslateY(Y1);
330
 
  WritePS(inttostr(X1)+' '+inttostr(Y)+' moveto');
331
 
  LastX := X1;
332
 
  LastY := Y1;
333
 
end;
334
 
 
335
 
{ Draw a line from current location to these coords }
336
 
procedure TPostScriptCanvas.DoLineTo(X1, Y1: Integer);
337
 
 
338
 
var
339
 
   Y: Integer;
340
 
   
341
 
begin
342
 
  Y := TranslateY(Y1);
343
 
  WritePS(inttostr(X1)+' '+inttostr(Y)+' lineto');
344
 
  LastX := X1;
345
 
  LastY := Y1;
346
 
end;
347
 
 
348
 
procedure TPostScriptCanvas.DoLine(X1, Y1, X2, Y2: Integer);
349
 
var
350
 
  Y12, Y22: Integer;
351
 
  
352
 
begin
353
 
  Y12 := TranslateY(Y1);
354
 
  Y22 := TranslateY(Y2);
355
 
  WritePS('newpath '+inttostr(X1)+' '+inttostr(Y12)+' moveto '+
356
 
          inttostr(X2)+' '+inttostr(Y22)+' lineto closepath stroke');
357
 
  // go back to last moveto position
358
 
  ResetPos;
359
 
end;
360
 
 
361
 
{ Draw a rectangle }
362
 
 
363
 
procedure TPostScriptCanvas.DoRectangleFill(const Bounds: TRect);
364
 
 
365
 
begin
366
 
  DrawRectangle(Bounds,true)
367
 
end;
368
 
 
369
 
procedure TPostScriptCanvas.DoRectangle(const Bounds: TRect);
370
 
 
371
 
begin
372
 
  DrawRectangle(Bounds,False);
373
 
end;
374
 
 
375
 
procedure TPostScriptCanvas.DrawRectangle(const Bounds: TRect; DoFill : Boolean);
376
 
 
377
 
var
378
 
   Y12, Y22: Integer;
379
 
   
380
 
begin
381
 
  Y12 := TranslateY(Bounds.Top);
382
 
  Y22 := TranslateY(Bounds.Bottom);
383
 
  WritePS('stroke newpath');
384
 
  With Bounds do
385
 
    begin
386
 
    WritePS(inttostr(Left)+' '+inttostr(Y12)+' moveto');
387
 
    WritePS(inttostr(Right)+' '+inttostr(Y12)+' lineto');
388
 
    WritePS(inttostr(Right)+' '+inttostr(Y22)+' lineto');
389
 
    WritePS(inttostr(Left)+' '+inttostr(Y22)+' lineto');
390
 
    end;
391
 
  WritePS('closepath');
392
 
  If DoFill and (Brush.Style<>bsClear) then 
393
 
    AddFill;
394
 
  WritePS('stroke');
395
 
  ResetPos;
396
 
end;
397
 
 
398
 
{ Draw a series of lines }
399
 
procedure TPostScriptCanvas.DoPolyline(Const Points: Array of TPoint);
400
 
var
401
 
  i : Longint;
402
 
begin
403
 
  MoveTo(Points[0].X, Points[0].Y);
404
 
  For i := 1 to High(Points) do
405
 
    LineTo(Points[i].X, Points[i].Y);
406
 
  ResetPos;
407
 
end;
408
 
 
409
 
{ This was a pain to figure out... }
410
 
 
411
 
procedure TPostScriptCanvas.DoEllipse(Const Bounds : TRect);
412
 
 
413
 
begin
414
 
  DrawEllipse(Bounds,False);
415
 
end;
416
 
 
417
 
procedure TPostScriptCanvas.DoEllipseFill(Const Bounds : TRect);
418
 
 
419
 
begin
420
 
  DrawEllipse(Bounds,true);
421
 
end;
422
 
 
423
 
procedure TPostScriptCanvas.DrawEllipse(Const Bounds : TRect; DoFill : Boolean);
424
 
 
425
 
var
426
 
  radius: Integer;
427
 
  YRatio: Real;
428
 
  centerX, centerY: Integer;
429
 
   
430
 
begin
431
 
  // set radius to half the width
432
 
  With Bounds do
433
 
    begin
434
 
    radius := (Right-Left) div 2;
435
 
    if radius <1 then 
436
 
      exit; 
437
 
    YRatio := (Bottom - Top) / (Right-Left);
438
 
    // find center
439
 
    CenterX := (Right+Left) div 2;
440
 
    CenterY := (Top+Bottom) div 2;
441
 
    end;
442
 
  WritePS('newpath '+inttostr(CenterX)+' '+inttostr(TranslateY(CenterY))+' translate');
443
 
  // move to edge
444
 
  WritePS(inttostr(radius)+' 0 moveto');
445
 
  // now draw it
446
 
  WritePS('gsave 1 '+format('%.3f',[YRatio])+' scale');
447
 
  WritePS('0 0 '+inttostr(radius)+' 0 360 arc');
448
 
  if DoFill and (Brush.Style<>bsClear) then 
449
 
    AddFill;
450
 
  // reset scale for drawing line thickness so it doesn't warp
451
 
  YRatio := 1 / YRatio;
452
 
  WritePS('1 '+format('%.2f',[YRatio])+' scale stroke grestore');
453
 
  // move origin back
454
 
  WritePS(inttostr(-CenterX)+' '+inttostr(-TranslateY(CenterY))+' translate closepath stroke');
455
 
  ResetPos;
456
 
end;
457
 
 
458
 
procedure TPostScriptCanvas.DoPie(x, y, AWidth, AHeight, angle1, angle2: Integer);
459
 
begin
460
 
  // set zero at center
461
 
  WritePS('newpath '+inttostr(X)+' '+inttostr(TranslateY(Y))+' translate');
462
 
  // scale it
463
 
  WritePS('gsave '+inttostr(AWidth)+' '+inttostr(Aheight)+' scale');
464
 
  //WritePS('gsave 1 1 scale');
465
 
  // draw line to edge
466
 
  WritePS('0 0 moveto');
467
 
  WritePS('0 0 1 '+inttostr(angle1)+' '+inttostr(angle2)+' arc closepath');
468
 
  if Brush.Style<>bsClear then 
469
 
    AddFill;
470
 
  // reset scale so we don't change the line thickness
471
 
  // adding 0.01 to compensate for scaling error - there may be a deeper problem here...
472
 
  WritePS(format('%.6f',[(real(1) / X)+0.01])+' '+format('%.6f',[(real(1) / Y)+0.01])+' scale stroke grestore');
473
 
  // close out and return origin
474
 
  WritePS(inttostr(-X)+' '+inttostr(-TranslateY(Y))+' translate closepath stroke');
475
 
  resetpos;
476
 
end;
477
 
 
478
 
{ Writes text with a carriage return }
479
 
procedure TPostScriptCanvas.Writeln(AString: String);
480
 
begin
481
 
  TextOut(LastX, LastY, AString);
482
 
  LastY := LastY+Font.Size+FLineSpacing;
483
 
  MoveTo(LastX, LastY);
484
 
end;
485
 
 
486
 
 
487
 
{ Output text, restoring draw location }
488
 
procedure TPostScriptCanvas.TextOut(X, Y: Integer; const Text: String);
489
 
var
490
 
   Y1: Integer;
491
 
begin
492
 
  Y1 := TranslateY(Y);
493
 
  WritePS(inttostr(X)+' '+inttostr(Y1)+' moveto');
494
 
  WritePS('('+Text+') show');
495
 
  ResetPos; // move back to last moveto location
496
 
end;
497
 
 
498
 
function TPostScriptCanvas.DoCreateDefaultFont : TFPCustomFont;
499
 
 
500
 
begin
501
 
  Result:=TPSFont.Create;
502
 
end;
503
 
 
504
 
 
505
 
function TPostScriptCanvas.DoCreateDefaultPen : TFPCustomPen;
506
 
 
507
 
begin
508
 
  Result:=TPSPen.Create;
509
 
end;
510
 
 
511
 
function TPostScriptCanvas.DoCreateDefaultBrush : TFPCustomBrush; 
512
 
 
513
 
begin
514
 
  Result:=TPSBrush.Create;
515
 
end;
516
 
 
517
 
 
518
 
 
519
 
{ TPostScript -------------------------------------------------------------- }
520
 
 
521
 
procedure TPostScript.SetHeight(const AValue: Integer);
522
 
begin
523
 
  if FHeight=AValue then exit;
524
 
  FHeight:=AValue;
525
 
  UpdateBoundingBox;
526
 
  // filter down to the canvas height property
527
 
  if assigned(FCanvas) then 
528
 
    FCanvas.Height := FHeight;
529
 
end;
530
 
 
531
 
procedure TPostScript.SetLineSpacing(const AValue: Integer);
532
 
begin
533
 
  if FLineSpacing=AValue then exit;
534
 
  FLineSpacing:=AValue;
535
 
  // filter down to the canvas
536
 
  if assigned(FCanvas) then FCanvas.LineSpacing := AValue;
537
 
end;
538
 
 
539
 
procedure TPostScript.SetWidth(const AValue: Integer);
540
 
begin
541
 
  if FWidth=AValue then exit;
542
 
    FWidth:=AValue;
543
 
  UpdateBoundingBox;
544
 
end;
545
 
 
546
 
{ Take our sizes and change the boundingbox line }
547
 
procedure TPostScript.UpdateBoundingBox;
548
 
begin
549
 
{
550
 
 
551
 
     // need to not hard-link this to line 1
552
 
     FDocument[1] := '%%BoundingBox: 0 0 '+inttostr(FWidth)+' '+inttostr(FHeight);
553
 
}
554
 
end;
555
 
 
556
 
{ Pattern changed so update the postscript code }
557
 
procedure TPostScript.PatternChanged(Sender: TObject);
558
 
begin
559
 
     // called anytime a pattern changes.  Update the postscript code.
560
 
     // look for and delete the current postscript code for this pattern
561
 
     // then paste the pattern back into the code before the first page
562
 
     InsertPattern(Sender As TPSPattern);
563
 
end;
564
 
 
565
 
{ Places a pattern definition into the bottom of the header in postscript }
566
 
procedure TPostScript.InsertPattern(APattern: TPSPattern);
567
 
var
568
 
   I, J: Integer;
569
 
   MyStrings: TStringList;
570
 
begin
571
 
{     I := 0;
572
 
     if FDocument.Count < 1 then begin
573
 
        // added pattern when no postscript exists - this shouldn't happen
574
 
        raise exception.create('Pattern inserted with no postscript existing');
575
 
        exit;
576
 
     end;
577
 
     
578
 
     for I := 0 to FDocument.count - 1 do begin
579
 
         if (FDocument[I] = '%%Page: 1 1') then begin
580
 
            // found it!
581
 
            // insert into just before that
582
 
            MyStrings := APattern.GetPS;
583
 
            for J := 0 to MyStrings.Count - 1 do begin
584
 
                FDocument.Insert(I-1+J, MyStrings[j]);
585
 
            end;
586
 
            exit;
587
 
         end;
588
 
     end;
589
 
}
590
 
end;
591
 
 
592
 
constructor TPostScript.Create(AOwner : TComponent);
593
 
begin
594
 
  inherited create(AOwner);
595
 
  // Set some defaults
596
 
  FHeight := 792; // 11 inches at 72 dpi
597
 
  FWidth := 612; // 8 1/2 inches at 72 dpi
598
 
end;
599
 
 
600
 
Procedure TPostScript.WritePS(const Cmd : String);
601
 
 
602
 
begin
603
 
  If length(Cmd)>0 then
604
 
    FStream.Write(Cmd[1],Length(Cmd));
605
 
  FStream.Write(LineEnding,SizeOf(LineEnding));
606
 
end;
607
 
 
608
 
Procedure TPostScript.WritePS(Const Fmt : String; Args : Array of Const);
609
 
 
610
 
begin
611
 
  WritePS(Format(Fmt,Args));
612
 
end;
613
 
 
614
 
Procedure TPostScript.WriteDocumentHeader;
615
 
 
616
 
begin
617
 
  WritePS('%!PS-Adobe-3.0');
618
 
  WritePS('%%BoundingBox: 0 0 612 792');
619
 
  WritePS('%%Creator: '+Creator);
620
 
  WritePS('%%Title: '+FTitle);
621
 
  WritePS('%%Pages: (atend)');
622
 
  WritePS('%%PageOrder: Ascend');
623
 
  WriteStandardFont;
624
 
end;
625
 
 
626
 
Procedure TPostScript.WriteStandardFont;
627
 
 
628
 
begin
629
 
  // Choose a standard font in case the user doesn't
630
 
  WritePS('/AvantGarde-Book findfont');
631
 
  WritePS('10 scalefont');
632
 
  WritePS('setfont');
633
 
end;
634
 
 
635
 
Procedure TPostScript.FreePatterns;
636
 
 
637
 
Var
638
 
  i : Integer;
639
 
 
640
 
begin
641
 
  If Assigned(FPatterns) then
642
 
    begin
643
 
    For I:=0 to FPatterns.Count-1 do
644
 
      TObject(FPatterns[i]).Free;
645
 
    FreeAndNil(FPatterns);
646
 
    end;
647
 
end;
648
 
 
649
 
destructor TPostScript.Destroy;
650
 
 
651
 
begin
652
 
  Stream:=Nil;
653
 
  FreePatterns;
654
 
  inherited Destroy;
655
 
end;
656
 
 
657
 
{ add a pattern to the array }
658
 
procedure TPostScript.AddPattern(APSPattern: TPSPattern);
659
 
begin
660
 
  If Not Assigned(FPatterns) then
661
 
    FPatterns:=Tlist.Create;
662
 
  FPatterns.Add(APSPattern);
663
 
end;
664
 
 
665
 
{ Find a pattern object by it's name }
666
 
 
667
 
function TPostScript.FindPattern(AName: String): TPSPattern;
668
 
 
669
 
var
670
 
   I: Integer;
671
 
   
672
 
begin
673
 
  Result := nil;
674
 
  If Assigned(FPatterns) then
675
 
    begin
676
 
    I:=Fpatterns.Count-1;
677
 
    While (Result=Nil) and (I>=0) do
678
 
      if TPSPattern(FPatterns[I]).Name = AName then 
679
 
        result := TPSPattern(FPatterns[i])
680
 
      else
681
 
        Dec(i)   
682
 
   end;
683
 
end;
684
 
 
685
 
function TPostScript.DelPattern(AName: String): Boolean;
686
 
begin
687
 
  // can't do that yet...
688
 
  Result:=false;
689
 
end;
690
 
 
691
 
 
692
 
{ Create a new pattern and inserts it into the array for safe keeping }
693
 
function TPostScript.NewPattern(AName: String): TPSPattern;
694
 
var
695
 
   MyPattern: TPSPattern;
696
 
begin
697
 
  MyPattern := TPSPattern.Create;
698
 
  AddPattern(MyPattern);
699
 
  MyPattern.Name := AName;
700
 
  MyPattern.OnChange := @PatternChanged;
701
 
  MyPattern.OldName := '';
702
 
  // add this to the postscript now...
703
 
  InsertPattern(MyPattern);
704
 
  result := MyPattern;
705
 
end;
706
 
 
707
 
{ Start a new document }
708
 
procedure TPostScript.BeginDoc;
709
 
 
710
 
var
711
 
   I: Integer;
712
 
   
713
 
begin
714
 
  CheckStream;
715
 
  If FDocStarted then
716
 
    Raise Exception.Create(SErrDocumentAlreadyStarted);
717
 
  FCanvas:=TPostScriptCanvas.Create(FStream);
718
 
  FCanvas.Height:=Self.Height;
719
 
  FCanvas.Width:=Self.width;
720
 
  FreePatterns;
721
 
  WriteDocumentHeader;    
722
 
  // start our first page
723
 
  FPageNumber := 1;
724
 
  WritePage;
725
 
  UpdateBoundingBox;
726
 
end;
727
 
 
728
 
Procedure TPostScript.WritePage;
729
 
 
730
 
begin
731
 
  WritePS('%%Page: '+inttostr(FPageNumber)+' '+inttostr(FPageNumber));
732
 
  WritePS('newpath');
733
 
end;
734
 
 
735
 
{ Copy current page into the postscript and start a new one }
736
 
procedure TPostScript.NewPage;
737
 
begin
738
 
  // dump the current page into our postscript first
739
 
  // put end page definition...
740
 
  WritePS('stroke');
741
 
  WritePS('showpage');
742
 
  FPageNumber := FPageNumber+1;
743
 
  WritePage;
744
 
end;
745
 
 
746
 
{ Finish off the document }
747
 
procedure TPostScript.EndDoc;
748
 
begin
749
 
  // Start printing the document after closing out the pages
750
 
  WritePS('stroke');
751
 
  WritePS('showpage');
752
 
  WritePS('%%Pages: '+inttostr(FPageNumber));
753
 
  // okay, the postscript is all ready, so dump it to the text file
754
 
  // or to the printer
755
 
  FDocStarted:=False;
756
 
  FreeAndNil(FCanvas);
757
 
end;
758
 
 
759
 
Function TPostScript.GetCreator : String;
760
 
 
761
 
begin
762
 
  If (FCreator='') then
763
 
    Result:=ClassName
764
 
  else  
765
 
    Result:=FCreator;
766
 
end;
767
 
 
768
 
 
769
 
Procedure TPostScript.SetStream (Value : TStream);
770
 
 
771
 
begin
772
 
  if (FStream<>Value) then
773
 
    begin
774
 
    If (FStream<>Nil) and FDocStarted then
775
 
      EndDoc;
776
 
    FStream:=Value;
777
 
    FDocStarted:=False;
778
 
    end;
779
 
end;
780
 
 
781
 
Procedure TPostScript.CheckStream;
782
 
 
783
 
begin
784
 
  If Not Assigned(FStream) then
785
 
    Raise Exception.Create(SErrNoStreamAssigned);
786
 
end;
787
 
 
788
 
{ TPSPen }
789
 
 
790
 
procedure TPSPen.SetPattern(const AValue: TPSPattern);
791
 
begin
792
 
  if FPattern<>AValue then 
793
 
    begin
794
 
    FPattern:=AValue;
795
 
    // NotifyCanvas;
796
 
    end;
797
 
end;
798
 
 
799
 
 
800
 
destructor TPSPen.Destroy;
801
 
begin
802
 
  // Do NOT free the pattern object from here...
803
 
  inherited Destroy;
804
 
end;
805
 
 
806
 
 
807
 
{ Return the pen definition as a postscript string }
808
 
function TPSPen.AsString: String;
809
 
 
810
 
begin
811
 
  Result:='';
812
 
  if FPattern <> nil then 
813
 
    begin
814
 
    if FPattern.PaintType = ptColored then
815
 
      Result:='/Pattern setcolorspace '+FPattern.Name+' setcolor '
816
 
    else 
817
 
      begin
818
 
      Result:='[/Pattern /DeviceRGB] setcolorspace '+inttostr(Color.Red)+' '+inttostr(Color.Green)+' '+
819
 
       inttostr(Color.Blue)+' '+FPattern.Name+' setcolor ';
820
 
      end;
821
 
    end 
822
 
  else // no pattern do this:
823
 
    Result:=inttostr(Color.Red)+' '+inttostr(Color.Green)+' '+
824
 
           inttostr(Color.Blue)+' setrgbcolor ';
825
 
  Result := Result + format('%f',[Width])+' setlinewidth ';
826
 
end;
827
 
 
828
 
{ TPSPattern }
829
 
 
830
 
{ Returns the pattern definition as postscript }
831
 
function TPSPattern.GetpostScript: TStringList;
832
 
 
833
 
var
834
 
   I: Integer;
835
 
   S : String;
836
 
   
837
 
begin
838
 
  // If nothing in the canvas, error
839
 
  if FStream.Size=0 then 
840
 
    raise exception.create('Empty pattern');
841
 
  FPostScript.Clear;
842
 
  With FPostScript do 
843
 
    begin
844
 
    add('%% PATTERN '+FName);
845
 
    add('/'+FName+'proto 12 dict def '+FName+'proto begin');
846
 
    add('/PatternType 1 def');
847
 
    add(Format('/PaintType %d def',[ord(FPaintType)+1]));
848
 
    add(Format('/TilingType %d def',[ord(FTilingType)+1]));
849
 
    add('/BBox ['+inttostr(FBBox.Left)+' '+inttostr(FBBox.Top)+' '+inttostr(FBBox.Right)+' '+inttostr(FBBox.Bottom)+'] def');
850
 
    add('/XStep '+format('%f',[FXStep])+' def');
851
 
    add('/YStep '+format('%f',[FYstep])+' def');
852
 
    add('/PaintProc { begin');
853
 
    // insert the canvas
854
 
    SetLength(S,FStream.Size);
855
 
    FStream.Seek(0,soFromBeginning);
856
 
    FStream.Read(S[1],FStream.Size);
857
 
    Add(S);
858
 
    // add support for custom matrix later
859
 
    add('end } def end '+FName+'proto [1 0 0 1 0 0] makepattern /'+FName+' exch def');
860
 
    add('%% END PATTERN '+FName);
861
 
    end;
862
 
  Result := FPostScript;
863
 
end;
864
 
 
865
 
procedure TPSPattern.SetBBox(const AValue: TRect);
866
 
begin
867
 
{  if FBBox<>AValue then 
868
 
    begin
869
 
    FBBox:=AValue;
870
 
    FPatternCanvas.Height := FBBox.Bottom - FBBox.Top;
871
 
//    NotifyCanvas;
872
 
    end;
873
 
}
874
 
end;
875
 
 
876
 
procedure TPSPattern.SetName(const AValue: String);
877
 
begin
878
 
  FOldName := FName;
879
 
  if (FName<>AValue) then 
880
 
    begin
881
 
    FName:=AValue;
882
 
    // NotifyCanvas;
883
 
    end;
884
 
end;
885
 
 
886
 
procedure TPSPattern.Changed;
887
 
begin
888
 
  if Assigned(FOnChange) then FOnChange(Self);
889
 
end;
890
 
 
891
 
procedure TPSPattern.SetPaintType(const AValue: TPSPaintType);
892
 
begin
893
 
  if FPaintType=AValue then exit;
894
 
  FPaintType:=AValue;
895
 
  changed;
896
 
end;
897
 
 
898
 
procedure TPSPattern.SetTilingType(const AValue: TPSTileType);
899
 
begin
900
 
  if FTilingType=AValue then exit;
901
 
  FTilingType:=AValue;
902
 
  changed;
903
 
end;
904
 
 
905
 
procedure TPSPattern.SetXStep(const AValue: Real);
906
 
begin
907
 
  if FXStep=AValue then exit;
908
 
  FXStep:=AValue;
909
 
  changed;
910
 
end;
911
 
 
912
 
procedure TPSPattern.SetYStep(const AValue: Real);
913
 
begin
914
 
  if FYStep=AValue then exit;
915
 
  FYStep:=AValue;
916
 
  changed;
917
 
end;
918
 
 
919
 
constructor TPSPattern.Create;
920
 
begin
921
 
  FPostScript := TStringList.Create;
922
 
  FPaintType := ptColored;
923
 
  FTilingType := ttConstant;
924
 
  FStream:=TmemoryStream.Create;
925
 
  FPatternCanvas := TPostScriptCanvas.Create(FStream);
926
 
  FName := 'Pattern1';
927
 
end;
928
 
 
929
 
destructor TPSPattern.Destroy;
930
 
begin
931
 
  FPostScript.Free;
932
 
  FPatternCanvas.Free;
933
 
  FStream.Free;
934
 
  inherited Destroy;
935
 
end;
936
 
 
937
 
{ ---------------------------------------------------------------------
938
 
    TPSBrush
939
 
  ---------------------------------------------------------------------}
940
 
  
941
 
 
942
 
Function TPSBrush.GetAsString : String;
943
 
 
944
 
begin
945
 
  Result:='';
946
 
end;
947
 
 
948
 
 
949
 
 
950
 
end.
951