← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/fpvectorial/epsvectorialreader.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/fpvectorial/epsvectorialreader.pas
 
1
{
 
2
Reads EPS files
 
3
 
 
4
License: The same modified LGPL as the Free Pascal RTL
 
5
         See the file COPYING.modifiedLGPL for more details
 
6
 
 
7
AUTHORS: Felipe Monteiro de Carvalho
 
8
 
 
9
Documentation: http://www.tailrecursive.org/postscript/postscript.html
 
10
 
 
11
Good reference: http://atrey.karlin.mff.cuni.cz/~milanek/PostScript/Reference/PSL2e.html
 
12
}
 
13
unit epsvectorialreader;
 
14
 
 
15
{$mode objfpc}{$H+}
 
16
 
 
17
{.$define FPVECTORIALDEBUG_PATHS}
 
18
{.$define FPVECTORIALDEBUG_COLORS}
 
19
{.$define FPVECTORIALDEBUG_ROLL}
 
20
{.$define FPVECTORIALDEBUG_CODEFLOW}
 
21
{.$define FPVECTORIALDEBUG_INDEX}
 
22
{.$define FPVECTORIALDEBUG_DICTIONARY}
 
23
{.$define FPVECTORIALDEBUG_CONTROL}
 
24
{.$define FPVECTORIALDEBUG_ARITHMETIC}
 
25
{.$define FPVECTORIALDEBUG_CLIP_REGION}
 
26
 
 
27
interface
 
28
 
 
29
uses
 
30
  Classes, SysUtils, Math, contnrs,
 
31
  fpimage, fpcanvas,
 
32
  fpvectorial, fpvutils;
 
33
 
 
34
type
 
35
  TPSTokenType = (ttComment, ttFloat);
 
36
 
 
37
  TPSTokens = TFPList;// TPSToken;
 
38
 
 
39
  TPSToken = class
 
40
    StrValue: string;
 
41
    FloatValue: double;
 
42
    IntValue: Integer;
 
43
    BoolValue: Boolean;
 
44
    Line: Integer; // To help debugging
 
45
    function Duplicate: TPSToken; virtual;
 
46
  end;
 
47
 
 
48
  TCommentToken = class(TPSToken)
 
49
  end;
 
50
 
 
51
  { TProcedureToken }
 
52
 
 
53
  TProcedureToken = class(TPSToken)
 
54
    Levels: Integer; // Used to count groups inside groups and find the end of a top-level group
 
55
    Childs: TPSTokens;
 
56
    Parsed: Boolean;
 
57
    constructor Create;
 
58
    destructor Destroy; override;
 
59
  end;
 
60
 
 
61
  TETType = (ettNamedElement, ettOperand, ettOperator, ettDictionary);
 
62
 
 
63
  { TExpressionToken }
 
64
 
 
65
  TExpressionToken = class(TPSToken)
 
66
  public
 
67
    ETType: TETType;
 
68
    function IsExpressionOperand: Boolean;
 
69
    procedure PrepareFloatValue;
 
70
    function Duplicate: TPSToken; override;
 
71
  end;
 
72
 
 
73
  TPostScriptScannerState = (ssSearchingToken, ssInComment, ssInDefinition, ssInGroup, ssInExpressionElement);
 
74
 
 
75
  { TGraphicState }
 
76
 
 
77
  TGraphicState = class
 
78
  public
 
79
    Color: TFPColor;
 
80
    TranslateX, TranslateY: Double;
 
81
    ScaleX, ScaleY: Double; // not used currently
 
82
    ClipPath: TPath;
 
83
    ClipMode: TvClipMode;
 
84
    OverPrint: Boolean; // not used currently
 
85
    //
 
86
    PenWidth: Integer;
 
87
    //
 
88
    function Duplicate: TGraphicState;
 
89
  end;
 
90
 
 
91
  { TPSTokenizer }
 
92
 
 
93
  TPSTokenizer = class
 
94
  public
 
95
    Tokens: TPSTokens;
 
96
    FCurLine: Integer;
 
97
    constructor Create(ACurLine: Integer = -1);
 
98
    destructor Destroy; override;
 
99
    procedure ReadFromStream(AStream: TStream);
 
100
    procedure DebugOut();
 
101
    function IsValidPostScriptChar(AChar: Byte): Boolean;
 
102
    function IsPostScriptSpace(AChar: Byte): Boolean;
 
103
    function IsEndOfLine(ACurChar: Byte; AStream: TStream): Boolean;
 
104
  end;
 
105
 
 
106
  { TvEPSVectorialReader }
 
107
 
 
108
  TvEPSVectorialReader = class(TvCustomVectorialReader)
 
109
  private
 
110
    Stack: TObjectStack;
 
111
    GraphicStateStack: TObjectStack; // TGraphicState
 
112
    Dictionary: TStringList;
 
113
    ExitCalled: Boolean;
 
114
    CurrentGraphicState: TGraphicState;
 
115
    //
 
116
    procedure DebugStack();
 
117
    //
 
118
    procedure RunPostScript(ATokens: TPsTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument);
 
119
    //
 
120
    procedure ExecuteProcedureToken(AToken: TProcedureToken; AData: TvVectorialPage; ADoc: TvVectorialDocument);
 
121
    procedure ExecuteOperatorToken(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument);
 
122
    function  ExecuteArithmeticAndMathOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
123
    function  ExecutePathConstructionOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
124
    function  ExecuteGraphicStateOperatorsDI(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
125
    function  ExecuteGraphicStateOperatorsDD(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
126
    function  ExecuteDictionaryOperators(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
127
    function  ExecuteMiscellaneousOperators(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
128
    function  ExecuteStackManipulationOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
129
    function  ExecuteControlOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
130
    function  ExecutePaintingOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
131
    function  ExecuteDeviceSetupAndOutputOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
132
    function  ExecuteArrayOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
133
    function  ExecuteStringOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
134
    //
 
135
    procedure PostScriptCoordsToFPVectorialCoords(AParam1, AParam2: TPSToken; var APosX, APosY: Double);
 
136
    function DictionarySubstituteOperator(ADictionary: TStringList; var ACurToken: TPSToken): Boolean;
 
137
  public
 
138
    { General reading methods }
 
139
    Tokenizer: TPSTokenizer;
 
140
    constructor Create; override;
 
141
    Destructor Destroy; override;
 
142
    procedure ReadFromStream(AStream: TStream; AData: TvVectorialDocument); override;
 
143
  end;
 
144
 
 
145
implementation
 
146
 
 
147
type
 
148
  TStackAccess = class(TObjectStack)
 
149
  end;
 
150
 
 
151
var
 
152
  FPointSeparator: TFormatSettings;
 
153
 
 
154
{ TGraphicState }
 
155
 
 
156
function TGraphicState.Duplicate: TGraphicState;
 
157
begin
 
158
  Result := TGraphicState(Self.ClassType.Create);
 
159
  Result.Color := Color;
 
160
  Result.TranslateX := TranslateX;
 
161
  Result.TranslateY := TranslateY;
 
162
  Result.ScaleX := ScaleX;
 
163
  Result.ScaleY := ScaleY;
 
164
  Result.ClipPath := ClipPath;
 
165
  Result.ClipMode := ClipMode;
 
166
  Result.OverPrint := OverPrint;
 
167
  Result.PenWidth := PenWidth;
 
168
end;
 
169
 
 
170
{ TPSToken }
 
171
 
 
172
function TPSToken.Duplicate: TPSToken;
 
173
begin
 
174
  Result := TPSToken(Self.ClassType.Create);
 
175
  Result.StrValue := StrValue;
 
176
  Result.FloatValue := FloatValue;
 
177
  Result.IntValue := IntValue;
 
178
  Result.Line := Line;
 
179
end;
 
180
 
 
181
{ TProcedureToken }
 
182
 
 
183
constructor TProcedureToken.Create;
 
184
begin
 
185
  inherited Create;
 
186
 
 
187
  Childs := TPSTokens.Create;
 
188
end;
 
189
 
 
190
destructor TProcedureToken.Destroy;
 
191
begin
 
192
  Childs.Free;
 
193
 
 
194
  inherited Destroy;
 
195
end;
 
196
 
 
197
{ TExpressionToken }
 
198
 
 
199
function TExpressionToken.IsExpressionOperand: Boolean;
 
200
begin
 
201
  if StrValue = '' then Exit(False);
 
202
  Result := StrValue[1] in ['0'..'9','-'];
 
203
end;
 
204
 
 
205
procedure TExpressionToken.PrepareFloatValue;
 
206
begin
 
207
  //if not IsExpressionOperand() then Exit;
 
208
  if ETType <> ettOperand then Exit; // faster, because this field should already be filled
 
209
 
 
210
  FloatValue := StrToFloat(StrValue, FPointSeparator);
 
211
end;
 
212
 
 
213
function TExpressionToken.Duplicate: TPSToken;
 
214
begin
 
215
  Result:=inherited Duplicate;
 
216
  TExpressionToken(Result).ETType := ETType;
 
217
end;
 
218
 
 
219
{$DEFINE FPVECTORIALDEBUG}
 
220
 
 
221
{ TPSTokenizer }
 
222
 
 
223
// ACurLine < 0 indicates that we should use the line of this list of strings
 
224
// else we use ACurLine
 
225
constructor TPSTokenizer.Create(ACurLine: Integer);
 
226
begin
 
227
  inherited Create;
 
228
  Tokens := TPSTokens.Create;
 
229
  FCurLine := ACurLine;
 
230
end;
 
231
 
 
232
destructor TPSTokenizer.Destroy;
 
233
begin
 
234
  Tokens.Free;
 
235
  inherited Destroy;
 
236
end;
 
237
 
 
238
{@@ Rules for parsing PostScript files:
 
239
 
 
240
* Coments go from the first occurence of % outside a line to the next new line
 
241
* The only accepted characters are printable ASCII ones, plus spacing ASCII chars
 
242
  See IsValidPostScriptChar about that
 
243
}
 
244
procedure TPSTokenizer.ReadFromStream(AStream: TStream);
 
245
var
 
246
  i: Integer;
 
247
  CurChar: Char;
 
248
  CurLine: Integer = 1;
 
249
  State: TPostScriptScannerState = ssSearchingToken;
 
250
  CommentToken: TCommentToken;
 
251
  ProcedureToken: TProcedureToken;
 
252
  ExpressionToken: TExpressionToken;
 
253
  Len: Integer;
 
254
  lIsEndOfLine: Boolean;
 
255
begin
 
256
  while AStream.Position < AStream.Size do
 
257
  begin
 
258
    CurChar := Char(AStream.ReadByte());
 
259
//    {$ifdef FPVECTORIALDEBUG}
 
260
//    WriteLn(Format('Obtained token %s', [CurChar]));
 
261
//    {$endif}
 
262
    if not IsValidPostScriptChar(Byte(CurChar)) then
 
263
      raise Exception.Create('[TPSTokenizer.ReadFromStream] Invalid char: ' + IntToHex(Byte(CurChar), 2));
 
264
 
 
265
    lIsEndOfLine := IsEndOfLine(Byte(CurChar), AStream);
 
266
    if lIsEndOfLine then Inc(CurLine);
 
267
    if FCurLine >= 0 then CurLine := FCurLine;
 
268
 
 
269
    case State of
 
270
      { Searching for a token }
 
271
      ssSearchingToken:
 
272
      begin
 
273
        if CurChar = '%' then
 
274
        begin
 
275
          CommentToken := TCommentToken.Create;
 
276
          CommentToken.Line := CurLine;
 
277
          State := ssInComment;
 
278
//          {$ifdef FPVECTORIALDEBUG}
 
279
//          WriteLn(Format('Starting Comment at Line %d', [CurLine]));
 
280
//          {$endif}
 
281
        end
 
282
        else if CurChar = '{' then
 
283
        begin
 
284
          ProcedureToken := TProcedureToken.Create;
 
285
          ProcedureToken.Levels := 1;
 
286
          ProcedureToken.Line := CurLine;
 
287
          State := ssInGroup;
 
288
        end
 
289
        else if CurChar in ['a'..'z','A'..'Z','0'..'9','-','/'] then
 
290
        begin
 
291
          ExpressionToken := TExpressionToken.Create;
 
292
          ExpressionToken.Line := CurLine;
 
293
          ExpressionToken.StrValue := '';
 
294
          if CurChar = '/' then
 
295
            ExpressionToken.ETType := ettNamedElement
 
296
          else
 
297
          begin
 
298
            ExpressionToken.StrValue := CurChar;
 
299
            if ExpressionToken.IsExpressionOperand() then
 
300
              ExpressionToken.ETType := ettOperand
 
301
            else
 
302
              ExpressionToken.ETType := ettOperator;
 
303
          end;
 
304
          State := ssInExpressionElement;
 
305
        end
 
306
        else if lIsEndOfLine then Continue
 
307
        else if IsPostScriptSpace(Byte(CurChar)) then Continue
 
308
        else
 
309
          raise Exception.Create(Format('[TPSTokenizer.ReadFromStream] Unexpected char while searching for token: $%s in Line %d',
 
310
           [IntToHex(Byte(CurChar), 2), CurLine]));
 
311
      end;
 
312
 
 
313
      { Passing by comments }
 
314
      ssInComment:
 
315
      begin
 
316
        CommentToken.StrValue := CommentToken.StrValue + CurChar;
 
317
        if lIsEndOfLine then
 
318
        begin
 
319
          Tokens.Add(CommentToken);
 
320
          State := ssSearchingToken;
 
321
//          {$ifdef FPVECTORIALDEBUG}
 
322
//          WriteLn(Format('Adding Comment "%s" at Line %d', [CommentToken.StrValue, CurLine]));
 
323
//          {$endif}
 
324
        end;
 
325
      end; // ssInComment
 
326
 
 
327
      // Starts at { and ends in }, passing over nested groups
 
328
      ssInGroup:
 
329
      begin
 
330
        if (CurChar = '{') then ProcedureToken.Levels := ProcedureToken.Levels + 1;
 
331
        if (CurChar = '}') then ProcedureToken.Levels := ProcedureToken.Levels - 1;
 
332
 
 
333
        if ProcedureToken.Levels = 0 then
 
334
        begin
 
335
          Tokens.Add(ProcedureToken);
 
336
          State := ssSearchingToken;
 
337
        end
 
338
        else
 
339
        begin
 
340
          // Don't add line ends, because they cause problems when outputing the debug info
 
341
          // but in this case we need to add spaces to compensate, or else items separates only
 
342
          // by line end might get glued together
 
343
          if CurChar in [#10, #13] then
 
344
            ProcedureToken.StrValue := ProcedureToken.StrValue + ' '
 
345
          else
 
346
            ProcedureToken.StrValue := ProcedureToken.StrValue + CurChar;
 
347
        end;
 
348
      end;
 
349
 
 
350
      // Goes until a space comes, or {
 
351
      ssInExpressionElement:
 
352
      begin
 
353
        if IsPostScriptSpace(Byte(CurChar)) or (CurChar = '{') then
 
354
        begin
 
355
          ExpressionToken.PrepareFloatValue();
 
356
          Tokens.Add(ExpressionToken);
 
357
          State := ssSearchingToken;
 
358
          if (CurChar = '{') then AStream.Seek(-1, soFromCurrent);
 
359
        end
 
360
        else
 
361
          ExpressionToken.StrValue := ExpressionToken.StrValue + CurChar;
 
362
      end;
 
363
 
 
364
    end; // case
 
365
  end; // while
 
366
 
 
367
  // If the stream finished, there might be a token still being built
 
368
  // so lets finish it
 
369
  if State = ssInExpressionElement then
 
370
  begin
 
371
    Tokens.Add(ExpressionToken);
 
372
  end;
 
373
end;
 
374
 
 
375
procedure TPSTokenizer.DebugOut();
 
376
var
 
377
  i: Integer;
 
378
  Token: TPSToken;
 
379
begin
 
380
  for i := 0 to Tokens.Count - 1 do
 
381
  begin
 
382
    Token := TPSToken(Tokens.Items[i]);
 
383
 
 
384
    if Token is TCommentToken then
 
385
    begin
 
386
      WriteLn(Format('TCommentToken StrValue=%s', [Token.StrValue]));
 
387
    end
 
388
    else if Token is TProcedureToken then
 
389
    begin
 
390
      WriteLn(Format('TProcedureToken StrValue=%s', [Token.StrValue]));
 
391
    end
 
392
    else if Token is TExpressionToken then
 
393
    begin
 
394
      WriteLn(Format('TExpressionToken StrValue=%s', [Token.StrValue]));
 
395
    end;
 
396
  end;
 
397
end;
 
398
 
 
399
{@@ Valid PostScript Chars:
 
400
 
 
401
All printable ASCII: a..zA..Z0..9 plus punctuation
 
402
 
 
403
Plus the following white spaces
 
404
000 00 0 Null (nul)
 
405
011 09 9 Tab (tab)
 
406
012 0A 10 Line feed (LF)
 
407
014 0C 12 Form feed (FF)
 
408
015 0D 13 Carriage return (CR)
 
409
040 20 32 Space (SP)
 
410
}
 
411
function TPSTokenizer.IsValidPostScriptChar(AChar: Byte): Boolean;
 
412
begin
 
413
  Result := ((AChar > 32) and (AChar < 127)) or (AChar in [0, 9, 10, 12, 13, 32]);
 
414
end;
 
415
 
 
416
function TPSTokenizer.IsPostScriptSpace(AChar: Byte): Boolean;
 
417
begin
 
418
  Result := AChar in [0, 9, 10, 12, 13, 32];
 
419
end;
 
420
 
 
421
function TPSTokenizer.IsEndOfLine(ACurChar: Byte; AStream: TStream): Boolean;
 
422
var
 
423
  HasNextChar: Boolean = False;
 
424
  NextChar: Byte;
 
425
begin
 
426
  Result := False;
 
427
 
 
428
  if ACurChar = 13 then
 
429
  begin
 
430
    if AStream.Position < AStream.Size then
 
431
    begin
 
432
      HasNextChar := True;
 
433
      NextChar := AStream.ReadByte();
 
434
      if NextChar <> 10 then AStream.Seek(-1, soFromCurrent); // Go back if it wasnt a #13#10
 
435
      Exit(True);
 
436
    end;
 
437
  end;
 
438
 
 
439
  if ACurChar = 10 then Result := True;
 
440
end;
 
441
 
 
442
{$ifndef Windows}
 
443
{$define FPVECTORIALDEBUG}
 
444
{$endif}
 
445
 
 
446
{ TvEPSVectorialReader }
 
447
 
 
448
procedure TvEPSVectorialReader.DebugStack();
 
449
var
 
450
  i: Integer;
 
451
  lToken: TPSToken;
 
452
begin
 
453
  WriteLn('====================');
 
454
  WriteLn('Stack dump');
 
455
  WriteLn('====================');
 
456
  for i := 0 to TStackAccess(Stack).List.Count - 1 do
 
457
  begin
 
458
    lToken := TPSToken(TStackAccess(Stack).List.Items[i]);
 
459
    WriteLn(Format('Stack #%d : %s', [i, lToken.StrValue]));
 
460
  end;
 
461
end;
 
462
 
 
463
procedure TvEPSVectorialReader.RunPostScript(ATokens: TPsTokens;
 
464
  AData: TvVectorialPage; ADoc: TvVectorialDocument);
 
465
var
 
466
  i: Integer;
 
467
  lSubstituted: Boolean;
 
468
  CurToken: TPSToken;
 
469
begin
 
470
  {$ifdef FPVECTORIALDEBUG_CODEFLOW}
 
471
  WriteLn('[TvEPSVectorialReader.RunPostScript] START');
 
472
  {$endif}
 
473
  if ExitCalled then
 
474
  begin
 
475
    {$ifdef FPVECTORIALDEBUG_CODEFLOW}
 
476
    WriteLn('[TvEPSVectorialReader.RunPostScript] ExitCalled');
 
477
    {$endif}
 
478
    Exit;
 
479
  end;
 
480
  for i := 0 to ATokens.Count - 1 do
 
481
  begin
 
482
    CurToken := TPSToken(ATokens.Items[i]);
 
483
 
 
484
{    if CurToken.StrValue = 'setrgbcolor' then
 
485
    begin
 
486
      WriteLn('===================');
 
487
      WriteLn('CMYK__');
 
488
      WriteLn('===================');
 
489
      DebugStack();
 
490
    end;}
 
491
 
 
492
    if CurToken is TCommentToken then
 
493
    begin
 
494
      {$ifdef FPVECTORIALDEBUG_CODEFLOW}
 
495
      WriteLn(Format('[TvEPSVectorialReader.RunPostScript] Type: TCommentToken Token: %s', [CurToken.StrValue]));
 
496
      {$endif}
 
497
//      ProcessCommentToken(CurToken as TCommentToken, AData);
 
498
      Continue;
 
499
    end;
 
500
 
 
501
    if CurToken is TProcedureToken then
 
502
    begin
 
503
      {$ifdef FPVECTORIALDEBUG_CODEFLOW}
 
504
      WriteLn(Format('[TvEPSVectorialReader.RunPostScript] Type: TProcedureToken Token: %s', [CurToken.StrValue]));
 
505
      {$endif}
 
506
      Stack.Push(CurToken);
 
507
      Continue;
 
508
    end;
 
509
 
 
510
    if CurToken is TExpressionToken then
 
511
    begin
 
512
      {$ifdef FPVECTORIALDEBUG_CODEFLOW}
 
513
      WriteLn(Format('[TvEPSVectorialReader.RunPostScript] Type: TExpressionToken Token: %s', [CurToken.StrValue]));
 
514
      {$endif}
 
515
 
 
516
      if TExpressionToken(CurToken).ETType = ettOperand then
 
517
      begin
 
518
        Stack.Push(CurToken);
 
519
        Continue;
 
520
      end;
 
521
 
 
522
      // Now we need to verify if the operator should be substituted in the dictionary
 
523
      lSubstituted := DictionarySubstituteOperator(Dictionary, CurToken);
 
524
 
 
525
      // Check if this is the first time that a named element appears, if yes, don't try to execute it
 
526
      // just put it into the stack
 
527
      if (not lSubstituted) and (TExpressionToken(CurToken).ETType = ettNamedElement) then
 
528
      begin
 
529
        Stack.Push(CurToken);
 
530
        Continue;
 
531
      end;
 
532
 
 
533
      if CurToken is TProcedureToken then ExecuteProcedureToken(TProcedureToken(CurToken), AData, ADoc)
 
534
      else ExecuteOperatorToken(TExpressionToken(CurToken), AData, ADoc);
 
535
 
 
536
      if ExitCalled then Break;
 
537
    end;
 
538
  end;
 
539
  {$ifdef FPVECTORIALDEBUG_CODEFLOW}
 
540
  WriteLn('[TvEPSVectorialReader.RunPostScript] END');
 
541
  {$endif}
 
542
end;
 
543
 
 
544
procedure TvEPSVectorialReader.ExecuteProcedureToken(AToken: TProcedureToken;
 
545
  AData: TvVectorialPage; ADoc: TvVectorialDocument);
 
546
var
 
547
  ProcTokenizer: TPSTokenizer;
 
548
  lStream: TMemoryStream;
 
549
  lOldTokens: TPSTokens;
 
550
  i: Integer;
 
551
begin
 
552
  {$ifdef FPVECTORIALDEBUG_CODEFLOW}
 
553
  WriteLn('[TvEPSVectorialReader.ExecuteProcedureToken] START');
 
554
  {$endif}
 
555
  if ExitCalled then
 
556
  begin
 
557
    {$ifdef FPVECTORIALDEBUG_CODEFLOW}
 
558
    WriteLn('[TvEPSVectorialReader.ExecuteProcedureToken] ExitCalled');
 
559
    {$endif}
 
560
    Exit;
 
561
  end;
 
562
 
 
563
  if not AToken.Parsed then
 
564
  begin
 
565
    ProcTokenizer := TPSTokenizer.Create(AToken.Line);
 
566
    lStream := TMemoryStream.Create;
 
567
    try
 
568
      // Copy the string to a Stream
 
569
      for i := 1 to Length(AToken.StrValue) do
 
570
        lStream.WriteByte(Byte(AToken.StrValue[i]));
 
571
 
 
572
      // Change the Tokens so that it writes directly to AToken.Childs
 
573
      lOldTokens := ProcTokenizer.Tokens;
 
574
      ProcTokenizer.Tokens := AToken.Childs;
 
575
 
 
576
      // Now parse the procedure code
 
577
      lStream.Position := 0;
 
578
      ProcTokenizer.ReadFromStream(lStream);
 
579
 
 
580
      // Recover the old tokens for usage in .Free
 
581
      ProcTokenizer.Tokens := lOldTokens;
 
582
    finally
 
583
      lStream.Free;
 
584
      ProcTokenizer.Free;
 
585
    end;
 
586
 
 
587
    AToken.Parsed := True;
 
588
  end;
 
589
 
 
590
  // Now run the procedure
 
591
  RunPostScript(AToken.Childs, AData, ADoc);
 
592
  {$ifdef FPVECTORIALDEBUG_CODEFLOW}
 
593
  WriteLn('[TvEPSVectorialReader.ExecuteProcedureToken] END');
 
594
  {$endif}
 
595
end;
 
596
 
 
597
procedure TvEPSVectorialReader.ExecuteOperatorToken(AToken: TExpressionToken;
 
598
  AData: TvVectorialPage; ADoc: TvVectorialDocument);
 
599
var
 
600
  Param1, Param2: TPSToken;
 
601
begin
 
602
  if AToken.StrValue = '' then raise Exception.Create('[TvEPSVectorialReader.ProcessExpressionToken] Empty operator');
 
603
 
 
604
  if ExecuteDictionaryOperators(AToken, AData, ADoc) then Exit;
 
605
 
 
606
  if ExecuteArithmeticAndMathOperator(AToken, AData, ADoc) then Exit;
 
607
 
 
608
  if ExecutePathConstructionOperator(AToken, AData, ADoc) then Exit;
 
609
 
 
610
  if ExecuteGraphicStateOperatorsDI(AToken, AData, ADoc) then Exit;
 
611
 
 
612
  if ExecuteGraphicStateOperatorsDD(AToken, AData, ADoc) then Exit;
 
613
 
 
614
  if ExecuteControlOperator(AToken, AData, ADoc) then Exit;
 
615
 
 
616
  if ExecuteStackManipulationOperator(AToken, AData, ADoc) then Exit;
 
617
 
 
618
  if ExecuteMiscellaneousOperators(AToken, AData, ADoc) then Exit;
 
619
 
 
620
  if ExecutePaintingOperator(AToken, AData, ADoc) then Exit;
 
621
 
 
622
  if ExecuteDeviceSetupAndOutputOperator(AToken, AData, ADoc) then Exit;
 
623
 
 
624
  if ExecuteArrayOperator(AToken, AData, ADoc) then Exit;
 
625
 
 
626
  if ExecuteStringOperator(AToken, AData, ADoc) then Exit;
 
627
 
 
628
  // If we got here, there the command not yet implemented
 
629
  raise Exception.Create(Format('[TvEPSVectorialReader.ProcessExpressionToken] Unknown PostScript Command "%s" in Line %d',
 
630
    [AToken.StrValue, AToken.Line]));
 
631
 
 
632
{  File Operators
 
633
 
 
634
  filename access file file Open named file with specified access
 
635
  datasrc|datatgt dict
 
636
  param1 … paramn filtername filter file Establish filtered file
 
637
  file closefile – Close file
 
638
  file read int true Read one character from file
 
639
  or false
 
640
  file int write – Write one character to file
 
641
  file string readhexstring substring bool Read hexadecimal numbers from file into
 
642
  string
 
643
  file string writehexstring – Write string to file as hexadecimal
 
644
  file string readstring substring bool Read string from file
 
645
  file string writestring – Write string to file
 
646
  file string readline substring bool Read line from file into string
 
647
  file token any true Read token from file
 
648
  or false
 
649
  file bytesavailable int Return number of bytes available to read
 
650
  – flush – Send buffered data to standard output file
 
651
  file flushfile – Send buffered data or read to EOF
 
652
  file resetfile – Discard buffered characters
 
653
  file status bool Return status of file (true = valid)
 
654
  filename status pages bytes referenced created true
 
655
  or false Return information about named file
 
656
  filename run – Execute contents of named file
 
657
  – currentfile file Return file currently being executed
 
658
  filename deletefile – Delete named file
 
659
  filename1 filename2 renamefile – Rename file filename1 to filename2
 
660
  template proc scratch filenameforall – Execute proc for each file name matching
 
661
  template
 
662
  file position setfileposition – Set file to specified position
 
663
  file fileposition position Return current position in file
 
664
  string print – Write string to standard output file
 
665
  any = – Write text representation of any to standard
 
666
  output file
 
667
  any == – Write syntactic representation of any to
 
668
  standard output file
 
669
  any1 … anyn stack any1 … anyn Print stack nondestructively using =
 
670
  any1 … anyn pstack any1 … anyn Print stack nondestructively using ==
 
671
  obj tag printobject – Write binary object to standard output file,
 
672
  using tag
 
673
  file obj tag writeobject – Write binary object to file, using tag
 
674
  int setobjectformat – Set binary object format (0 = disable,
 
675
  1 = IEEE high, 2 = IEEE low, 3 = native
 
676
  high, 4 = native low)
 
677
  – currentobjectformat int Return binary object format
 
678
}
 
679
{ Resource Operators
 
680
 
 
681
  key instance category defineresource instance Register named resource instance in category
 
682
  key category undefineresource – Remove resource registration
 
683
  key category findresource instance Return resource instance identified by key in
 
684
  category
 
685
  renderingintent findcolorrendering name bool Select CIE-based color rendering dictionary
 
686
  by rendering intent
 
687
  key category resourcestatus status size true Return status of resource instance
 
688
  or false
 
689
  template proc scratch category resourceforall – Enumerate resource instances in category
 
690
}
 
691
{ Virtual Memory Operators
 
692
 
 
693
  – save save Create VM snapshot
 
694
  save restore – Restore VM snapshot
 
695
  bool setglobal – Set VM allocation mode (false = local,
 
696
  true = global)
 
697
  – currentglobal bool Return current VM allocation mode
 
698
  any gcheck bool Return true if any is simple or in global VM,
 
699
  false if in local VM
 
700
  bool1 password startjob bool2 Start new job that will alter initial VM if
 
701
  bool1 is true
 
702
  index any defineuserobject – Define user object associated with index
 
703
  index execuserobject – Execute user object associated with index
 
704
  index undefineuserobject – Remove user object associated with index
 
705
  – UserObjects array Return current UserObjects array defined in
 
706
  userdict
 
707
}
 
708
{ Errors
 
709
 
 
710
  configurationerror setpagedevice or setdevparams request
 
711
  cannot be satisfied
 
712
  dictfull No more room in dictionary
 
713
  dictstackoverflow Too many begin operators
 
714
  dictstackunderflow Too many end operators
 
715
  execstackoverflow Executive stack nesting too deep
 
716
  handleerror Called to report error information
 
717
  interrupt External interrupt request (for example,
 
718
  Control-C)
 
719
  invalidaccess Attempt to violate access attribute
 
720
  invalidexit exit not in loop
 
721
  invalidfileaccess Unacceptable access string
 
722
  invalidfont Invalid Font resource name or font or
 
723
  CIDFont dictionary
 
724
  invalidrestore Improper restore
 
725
  ioerror Input/output error
 
726
  limitcheck Implementation limit exceeded
 
727
  nocurrentpoint Current point undefined
 
728
  rangecheck Operand out of bounds
 
729
  stackoverflow Operand stack overflow
 
730
  stackunderflow Operand stack underflow
 
731
  syntaxerror PostScript language syntax error
 
732
  timeout Time limit exceeded
 
733
  typecheck Operand of wrong type
 
734
  undefined Name not known
 
735
  undefinedfilename File not found
 
736
  undefinedresource Resource instance not found
 
737
  undefinedresult Overflow, underflow, or meaningless result
 
738
  unmatchedmark Expected mark not on stack
 
739
  unregistered Internal error
 
740
  VMerror Virtual memory exhausted
 
741
}
 
742
end;
 
743
 
 
744
{ Operand Stack Manipulation Operators
 
745
 
 
746
  any pop –                    Discard top element
 
747
  any1 any2 exch ==> any2 any1 Exchange top two elements
 
748
  any dup ==> any any          Duplicate top element
 
749
  any1 … anyn n copy any1 … anyn any1 … anyn
 
750
                               Duplicate top n elements
 
751
  anyn … any0 n index anyn … any0 anyn
 
752
                               Duplicate arbitrary element
 
753
  anyn-1 … any0 n j roll any(j-1) mod n … any0 anyn-1 … anyj mod n
 
754
                               Roll n elements up j times
 
755
  any1 … anyn clear            Discard all elements
 
756
  any1 … anyn count any1 … anyn n
 
757
                               Count elements on stack
 
758
  – mark mark                  Push mark on stack
 
759
  mark obj1 … objn cleartomark –
 
760
                               Discard elements down through mark
 
761
  mark obj1 … objn counttomark mark obj1 … objn n
 
762
                               Count elements down to mark
 
763
}
 
764
function TvEPSVectorialReader.ExecuteStackManipulationOperator(
 
765
  AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
766
var
 
767
  Param1, Param2, NewToken: TPSToken;
 
768
  lIndexN, lIndexJ: Integer;
 
769
  lTokens: array of TPSToken;
 
770
  i: Integer;
 
771
begin
 
772
  Result := False;
 
773
 
 
774
  // Discard top element
 
775
  if AToken.StrValue = 'pop' then
 
776
  begin
 
777
    Param1 := TPSToken(Stack.Pop);
 
778
    Exit(True);
 
779
  end;
 
780
  // Exchange top two elements
 
781
  if AToken.StrValue = 'exch' then
 
782
  begin
 
783
    Param1 := TPSToken(Stack.Pop);
 
784
    Param2 := TPSToken(Stack.Pop);
 
785
    Stack.Push(Param1);
 
786
    Stack.Push(Param2);
 
787
    Exit(True);
 
788
  end;
 
789
  // Duplicate top element
 
790
  if AToken.StrValue = 'dup' then
 
791
  begin
 
792
    Param1 := TPSToken(Stack.Pop);
 
793
    NewToken := Param1.Duplicate();
 
794
    Stack.Push(Param1);
 
795
    Stack.Push(NewToken);
 
796
    Exit(True);
 
797
  end;
 
798
  // anyn … any0 n index anyn … any0 anyn
 
799
  // Duplicate arbitrary element
 
800
  if AToken.StrValue = 'index' then
 
801
  begin
 
802
    {$ifdef FPVECTORIALDEBUG_INDEX}
 
803
    WriteLn('[TvEPSVectorialReader.ExecuteStackManipulationOperator] index');
 
804
//    DebugStack();
 
805
    {$endif}
 
806
 
 
807
    Param1 := TPSToken(Stack.Pop);
 
808
    lIndexN := Round(Param1.FloatValue);
 
809
    SetLength(lTokens, lIndexN+1);
 
810
 
 
811
    if lIndexN < 0 then raise Exception.Create('[TvEPSVectorialReader.ExecuteStackManipulationOperator] index operator: n must be positive or zero');
 
812
 
 
813
    // Unroll all elements necessary
 
814
 
 
815
    for i := 0 to lIndexN do
 
816
    begin
 
817
      lTokens[i] := TPSToken(Stack.Pop);
 
818
      Param2 := lTokens[i];
 
819
      if Param2 = nil then
 
820
      begin
 
821
        raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteStackManipulationOperator] Stack underflow in operation "index". Error at line %d', [AToken.Line]));
 
822
      end;
 
823
    end;
 
824
 
 
825
    // Duplicate the disired token
 
826
 
 
827
    NewToken := lTokens[lIndexN].Duplicate();
 
828
 
 
829
    // Roll them back
 
830
 
 
831
    for i := lIndexN downto 0 do
 
832
    begin
 
833
      Stack.Push(lTokens[i]);
 
834
    end;
 
835
 
 
836
    // Roll the duplicated element too
 
837
 
 
838
    Stack.Push(NewToken);
 
839
 
 
840
    Exit(True);
 
841
  end;
 
842
  // anyn-1 … any0 n j roll any(j-1) mod n … any0 anyn-1 … anyj mod n
 
843
  //
 
844
  // performs a circular shift of the objects anyn-1 through any0 on the operand stack
 
845
  // by the amount j. Positive j indicates upward motion on the stack, whereas negative
 
846
  // j indicates downward motion.
 
847
  // n must be a nonnegative integer and j must be an integer. roll first removes these
 
848
  // operands from the stack; there must be at least n additional elements. It then performs
 
849
  // a circular shift of these n elements by j positions.
 
850
  // If j is positive, each shift consists of removing an element from the top of the stack
 
851
  // and inserting it between element n - 1 and element n of the stack, moving all in8.2
 
852
  // tervening elements one level higher on the stack. If j is negative, each shift consists
 
853
  // of removing element n - 1 of the stack and pushing it on the top of the stack,
 
854
  // moving all intervening elements one level lower on the stack.
 
855
  //
 
856
  // Examples    N J
 
857
  // (a) (b) (c) 3 -1 roll => (b) (c) (a)
 
858
  // (a) (b) (c) 3 1 roll  => (c) (a) (b)
 
859
  // (a) (b) (c) 3 0 roll  => (a) (b) (c)
 
860
  if AToken.StrValue = 'roll' then
 
861
  begin
 
862
    Param1 := TPSToken(Stack.Pop);
 
863
    Param2 := TPSToken(Stack.Pop);
 
864
    lIndexJ := Round(Param1.FloatValue);
 
865
    lIndexN := Round(Param2.FloatValue);
 
866
 
 
867
    {$ifdef FPVECTORIALDEBUG_ROLL}
 
868
    WriteLn(Format('[TvEPSVectorialReader] roll: N=%d J=%d', [lIndexN, lIndexJ]));
 
869
    {$endif}
 
870
 
 
871
    if lIndexN < 0 then raise Exception.Create('[TvEPSVectorialReader.ExecuteStackManipulationOperator] rool operator: n must be positive or zero');
 
872
 
 
873
    if lIndexJ = 0 then Exit;
 
874
 
 
875
    SetLength(lTokens, lIndexN);
 
876
 
 
877
    // Unroll all elements necessary
 
878
 
 
879
    for i := 0 to lIndexN-1 do
 
880
    begin
 
881
      lTokens[i] := TPSToken(Stack.Pop());
 
882
      Param2 := lTokens[i];
 
883
      if Param2 = nil then
 
884
      begin
 
885
        raise Exception.Create('[TvEPSVectorialReader.ExecuteStackManipulationOperator] nil element poped in operator index');
 
886
        //Exit(True);
 
887
      end;
 
888
    end;
 
889
 
 
890
    // Roll them back
 
891
 
 
892
    if lIndexJ > 0 then
 
893
    begin
 
894
      for i := lIndexJ-1 downto 0 do
 
895
      begin
 
896
        Stack.Push(lTokens[i]);
 
897
      end;
 
898
      for i := lIndexN-1 downto lIndexJ do
 
899
      begin
 
900
        Stack.Push(lTokens[i]);
 
901
      end;
 
902
    end
 
903
    else
 
904
    begin
 
905
      lIndexJ := -lIndexJ;
 
906
 
 
907
      for i := lIndexN-lIndexJ-1 downto 0 do
 
908
      begin
 
909
        Stack.Push(lTokens[i]);
 
910
      end;
 
911
      for i := lIndexN-1 downto lIndexN-lIndexJ do
 
912
      begin
 
913
        Stack.Push(lTokens[i]);
 
914
      end;
 
915
    end;
 
916
 
 
917
    Exit(True);
 
918
  end;
 
919
end;
 
920
 
 
921
{  Control Operators
 
922
 
 
923
  any exec –          Execute arbitrary object
 
924
  bool proc if –      Execute proc if bool is true
 
925
  bool proc1 proc2 ifelse –
 
926
                      Execute proc1 if bool is true, proc2 if false
 
927
  initial increment limit proc for –
 
928
                      Execute proc with values from initial by steps
 
929
                      of increment to limit
 
930
  int proc repeat –   Execute proc int times
 
931
  proc loop –         Execute proc an indefinite number of times
 
932
  – exit –            Exit innermost active loop
 
933
  – stop –            Terminate stopped context
 
934
  any stopped bool    Establish context for catching stop
 
935
  – countexecstack int Count elements on execution stack
 
936
  array execstack subarray Copy execution stack into array
 
937
  – quit – Terminate interpreter
 
938
  – start – Executed at interpreter startup
 
939
  Type, Attribute, and Conversion Operators
 
940
  any type name Return type of any
 
941
  any cvlit any Make object literal
 
942
  any cvx any Make object executable
 
943
  any xcheck bool     Test executable attribute
 
944
  array|packedarray|file|string executeonly array|packedarray|file|string
 
945
  Reduce access to execute-only
 
946
  array|packedarray|dict|file|string noaccess array|packedarray|dict|file|string
 
947
  Disallow any access
 
948
  array|packedarray|dict|file|string readonly array|packedarray|dict|file|string
 
949
  Reduce access to read-only
 
950
  array|packedarray|dict|file|string rcheck bool Test read access
 
951
  array|packedarray|dict|file|string wcheck bool Test write access
 
952
  num|string cvi int Convert to integer
 
953
  string cvn name Convert to name
 
954
  num|string cvr real Convert to real
 
955
  num radix string cvrs substring Convert with radix to string
 
956
  any string cvs substring Convert to string
 
957
}
 
958
function TvEPSVectorialReader.ExecuteControlOperator(AToken: TExpressionToken;
 
959
  AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
960
var
 
961
  Param1, Param2, Param3, Param4, CounterToken: TPSToken;
 
962
  NewToken: TExpressionToken;
 
963
  FloatCounter: Double;
 
964
begin
 
965
  Result := False;
 
966
 
 
967
  // Execute proc if bool is true
 
968
  if AToken.StrValue = 'if' then
 
969
  begin
 
970
    Param1 := TPSToken(Stack.Pop); // proc
 
971
    Param2 := TPSToken(Stack.Pop); // bool
 
972
 
 
973
    if not (Param1 is TProcedureToken) then
 
974
      raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteControlOperator] The operator if requires a procedure. Error at line %d', [AToken.Line]));
 
975
 
 
976
    if Param2.BoolValue then ExecuteProcedureToken(TProcedureToken(Param1), AData, ADoc);
 
977
 
 
978
    Exit(True);
 
979
  end;
 
980
  // Execute proc1 if bool is true, proc2 if false
 
981
  if AToken.StrValue = 'ifelse' then
 
982
  begin
 
983
    Param1 := TPSToken(Stack.Pop); // proc2
 
984
    Param2 := TPSToken(Stack.Pop); // proc1
 
985
    Param3 := TPSToken(Stack.Pop); // bool
 
986
 
 
987
    if not (Param1 is TProcedureToken) then
 
988
      raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteControlOperator] The operator ifelse requires a procedure. Error at line %d', [AToken.Line]));
 
989
    if not (Param2 is TProcedureToken) then
 
990
      raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteControlOperator] The operator ifelse requires a procedure. Error at line %d', [AToken.Line]));
 
991
 
 
992
    if Param3.BoolValue then ExecuteProcedureToken(TProcedureToken(Param2), AData, ADoc)
 
993
    else ExecuteProcedureToken(TProcedureToken(Param1), AData, ADoc);
 
994
 
 
995
    Exit(True);
 
996
  end;
 
997
  // Exit innermost active loop
 
998
  if AToken.StrValue = 'exit' then
 
999
  begin
 
1000
    ExitCalled := True;
 
1001
 
 
1002
    Exit(True);
 
1003
  end;
 
1004
  {
 
1005
    Establish context for catching stop
 
1006
 
 
1007
     executes any, which is typically, but not necessarily, a procedure, executable file,
 
1008
     or executable string object. If any runs to completion normally, stopped returns false on the operand stack.
 
1009
 
 
1010
     If any terminates prematurely as a result of executing stop, stopped returns
 
1011
     true on the operand stack. Regardless of the outcome, the interpreter resumes execution at the next object in normal sequence after stopped.
 
1012
     This mechanism provides an effective way for a PostScript language program
 
1013
     to "catch" errors or other premature terminations, retain control, and perhaps perform its own error recovery.
 
1014
 
 
1015
     EXAMPLE:
 
1016
     { ... } stopped {handleerror} if
 
1017
 
 
1018
     If execution of the procedure {...} causes an error,
 
1019
     the default error-reporting procedure is invoked (by handleerror).
 
1020
     In any event, normal execution continues at the token following the if.
 
1021
 
 
1022
     ERRORS: stackunderflow
 
1023
  }
 
1024
  if AToken.StrValue = 'stopped' then
 
1025
  begin
 
1026
    {$ifdef FPVECTORIALDEBUG_CONTROL}
 
1027
    WriteLn('[TvEPSVectorialReader.ExecuteControlOperator] stopped');
 
1028
//    DebugStack();
 
1029
    {$endif}
 
1030
 
 
1031
    Param1 := TPSToken(Stack.Pop);
 
1032
 
 
1033
    if not (Param1 is TProcedureToken) then
 
1034
      raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteControlOperator] The operator stopped requires a procedure. Error at line %d', [AToken.Line]));
 
1035
 
 
1036
    ExecuteProcedureToken(TProcedureToken(Param1), AData, ADoc);
 
1037
 
 
1038
    NewToken := TExpressionToken.Create;
 
1039
    NewToken.ETType := ettOperand;
 
1040
    NewToken.BoolValue := False;
 
1041
    NewToken.StrValue := 'false';
 
1042
    Stack.Push(NewToken);
 
1043
 
 
1044
    Exit(True);
 
1045
  end;
 
1046
  // Execute proc an indefinite number of times
 
1047
  if AToken.StrValue = 'loop' then
 
1048
  begin
 
1049
    Param1 := TPSToken(Stack.Pop);
 
1050
 
 
1051
    if not (Param1 is TProcedureToken) then
 
1052
      raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteControlOperator] The operator loop requires a procedure. Error at line %d', [AToken.Line]));
 
1053
 
 
1054
    while True do
 
1055
    begin
 
1056
      ExecuteProcedureToken(TProcedureToken(Param1), AData, ADoc);
 
1057
 
 
1058
      if ExitCalled then
 
1059
      begin
 
1060
        ExitCalled := False;
 
1061
        Break;
 
1062
      end;
 
1063
    end;
 
1064
 
 
1065
    Exit(True);
 
1066
  end;
 
1067
  { initial increment limit proc for -
 
1068
 
 
1069
   executes proc repeatedly, passing it a sequence of values from initial
 
1070
   by steps of increment to limit. The for operator expects initial, increment,
 
1071
   and limit to be numbers. It maintains a temporary internal variable, known as
 
1072
   the control variable, which it first sets to initial. Then, before each
 
1073
   repetition, it compares the control variable with the termination value limit.
 
1074
   If limit has not been exceeded, it pushes the control variable on the operand
 
1075
   stack, executes proc, and adds increment to the control variable.
 
1076
 
 
1077
   The termination condition depends on whether increment is positive or negative.
 
1078
   If increment is positive, for terminates when the control variable becomes
 
1079
   greater than limit. If increment is negative, for terminates when the control
 
1080
   variable becomes less than limit. If initial meets the termination condition,
 
1081
   for does not execute proc at all. If proc executes the exit operator,
 
1082
   for terminates prematurely.
 
1083
 
 
1084
   Usually, proc will use the value on the operand stack for some purpose.
 
1085
   However, if proc does not remove the value, it will remain there.
 
1086
   Successive executions of proc will cause successive values of the control
 
1087
   variable to accumulate on the operand stack.
 
1088
 
 
1089
   EXAMPLE:
 
1090
   0 1 1 4 {add} for -> 10
 
1091
   1 2 6 { } for -> 1 3 5
 
1092
   3 -.5 1 {-> } for -> 3.0 2.5 2.0 1.5 1.0
 
1093
 
 
1094
   In the first example, the value of the control variable is added to whatever
 
1095
   is on the stack, so 1, 2, 3, and 4 are added in turn to a running sum whose
 
1096
   initial value is 0. The second example has an empty procedure, so the
 
1097
   successive values of the control variable are left on the stack. The
 
1098
   last example counts backward from 3 to 1 by halves, leaving the successive
 
1099
   values on the stack.
 
1100
 
 
1101
   Beware of using reals instead of integers for any of the first three operands.
 
1102
   Most real numbers are not represented exactly. This can cause an error to
 
1103
   accumulate in the value of the control variable, with possibly surprising results.
 
1104
   In particular, if the difference between initial and limit is a multiple of
 
1105
   increment, as in the third line of the example, the control variable may not
 
1106
   achieve the limit value.
 
1107
 
 
1108
   ERRORS: stackoverflow stackunderflow, typecheck
 
1109
 
 
1110
   SEE ALSO: repeat, loop, forall, exit
 
1111
  }
 
1112
  if AToken.StrValue = 'for' then
 
1113
  begin
 
1114
    Param1 := TPSToken(Stack.Pop);
 
1115
    Param2 := TPSToken(Stack.Pop);
 
1116
    Param3 := TPSToken(Stack.Pop);
 
1117
    Param4 := TPSToken(Stack.Pop);
 
1118
 
 
1119
    if not (Param1 is TProcedureToken) then
 
1120
      raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteControlOperator] The operator for requires a procedure. Error at line %d', [AToken.Line]));
 
1121
 
 
1122
    FloatCounter := Param4.FloatValue;
 
1123
    while FloatCounter < Param2.FloatValue do
 
1124
    begin
 
1125
      CounterToken := Param4.Duplicate();
 
1126
      CounterToken.FloatValue := FloatCounter;
 
1127
      Stack.Push(CounterToken);
 
1128
 
 
1129
      ExecuteProcedureToken(TProcedureToken(Param1), AData, ADoc);
 
1130
 
 
1131
      FloatCounter := FloatCounter + Param3.FloatValue;
 
1132
 
 
1133
      if ExitCalled then
 
1134
      begin
 
1135
        ExitCalled := False;
 
1136
        Break;
 
1137
      end;
 
1138
    end;
 
1139
 
 
1140
    Exit(True);
 
1141
  end;
 
1142
  // tests whether the operand has the executable or the literal attribute, returning true
 
1143
  // if it is executable or false if it is literal
 
1144
  if AToken.StrValue = 'xcheck' then
 
1145
  begin
 
1146
//    {$ifdef FPVECTORIALDEBUG_CONTROL}
 
1147
//    WriteLn('[TvEPSVectorialReader.ExecuteControlOperator] xcheck');
 
1148
//    DebugStack();
 
1149
//    {$endif}
 
1150
 
 
1151
    Param1 := TPSToken(Stack.Pop);
 
1152
 
 
1153
    NewToken := TExpressionToken.Create;
 
1154
    NewToken.ETType := ettOperand;
 
1155
    NewToken.BoolValue := (Param1 is TProcedureToken) or
 
1156
      ((Param1 is TExpressionToken) and (TExpressionToken(Param1).ETType = ettOperator));
 
1157
    if NewToken.BoolValue then NewToken.StrValue := 'true'
 
1158
    else NewToken.StrValue := 'false';
 
1159
    Stack.Push(NewToken);
 
1160
 
 
1161
    Exit(True);
 
1162
  end;
 
1163
end;
 
1164
 
 
1165
{  Painting Operators
 
1166
 
 
1167
  – erasepage –   Paint current page white
 
1168
  – stroke –      Draw line along current path
 
1169
  – fill –        Fill current path with current color
 
1170
  – eofill –      Fill using even-odd rule
 
1171
  x y width height rectstroke – Define rectangular path and stroke
 
1172
  x y width height matrix rectstroke – Define rectangular path, concatenate matrix,
 
1173
                                       and stroke
 
1174
  numarray|numstring rectstroke – Define rectangular paths and stroke
 
1175
  numarray|numstring matrix rectstroke – Define rectangular paths, concatenate
 
1176
                                         matrix, and stroke
 
1177
  x y width height rectfill – Fill rectangular path
 
1178
  numarray|numstring rectfill – Fill rectangular paths
 
1179
  userpath ustroke – Interpret and stroke userpath
 
1180
  userpath matrix ustroke – Interpret userpath, concatenate matrix, and
 
1181
                            stroke
 
1182
  userpath ufill – Interpret and fill userpath
 
1183
  userpath ueofill – Fill userpath using even-odd rule
 
1184
  dict shfill – Fill area defined by shading pattern
 
1185
  dict image – Paint any sampled image
 
1186
  width height bits/sample matrix datasrc image – Paint monochrome sampled image
 
1187
  width height bits/comp matrix
 
1188
  datasrc0 … datasrcncomp-1 multi ncomp colorimage – Paint color sampled image
 
1189
  dict imagemask – Paint current color through mask
 
1190
  width height polarity matrix datasrc imagemask – Paint current color through mask
 
1191
  Insideness-Testing Operators
 
1192
  x y infill bool Test whether (x, y) would be painted by fill
 
1193
  userpath infill bool Test whether pixels in userpath would be
 
1194
  painted by fill
 
1195
  x y ineofill bool Test whether (x, y) would be painted by eofill
 
1196
  userpath ineofill bool Test whether pixels in userpath would be
 
1197
  painted by eofill
 
1198
  x y userpath inufill bool Test whether (x, y) would be painted by ufill
 
1199
  of userpath
 
1200
  userpath1 userpath2 inufill bool Test whether pixels in userpath1 would be
 
1201
  painted by ufill of userpath2
 
1202
  x y userpath inueofill bool Test whether (x, y) would be painted by
 
1203
  ueofill of userpath
 
1204
  userpath1 userpath2 inueofill bool Test whether pixels in userpath1 would be
 
1205
  painted by ueofill of userpath2
 
1206
  x y instroke bool Test whether (x, y) would be painted by
 
1207
  stroke
 
1208
  x y userpath inustroke bool Test whether (x, y) would be painted by
 
1209
  ustroke of userpath
 
1210
  x y userpath matrix inustroke bool Test whether (x, y) would be painted by
 
1211
  ustroke of userpath
 
1212
  userpath1 userpath2 inustroke bool Test whether pixels in userpath1 would be
 
1213
  painted by ustroke of userpath2
 
1214
  userpath1 userpath2 matrix inustroke bool Test whether pixels in userpath1 would be
 
1215
  painted by ustroke of userpath2
 
1216
  Form and Pattern Operators
 
1217
  pattern matrix makepattern pattern’ Create pattern instance from prototype
 
1218
  pattern setpattern – Install pattern as current color
 
1219
  comp1 … compn pattern setpattern – Install pattern as current color
 
1220
  form execform – Paint form
 
1221
}
 
1222
function TvEPSVectorialReader.ExecutePaintingOperator(AToken: TExpressionToken;
 
1223
  AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
1224
var
 
1225
  Param1, Param2: TPSToken;
 
1226
begin
 
1227
  Result := False;
 
1228
 
 
1229
  if AToken.StrValue = 'stroke' then
 
1230
  begin
 
1231
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
1232
    WriteLn('[TvEPSVectorialReader.ExecutePaintingOperator] stroke');
 
1233
    {$endif}
 
1234
    AData.SetPenStyle(psSolid);
 
1235
    AData.SetBrushStyle(bsClear);
 
1236
    AData.SetPenColor(CurrentGraphicState.Color);
 
1237
    AData.SetClipPath(CurrentGraphicState.ClipPath, CurrentGraphicState.ClipMode);
 
1238
    AData.SetPenWidth(CurrentGraphicState.PenWidth);
 
1239
    AData.EndPath();
 
1240
    Exit(True);
 
1241
  end;
 
1242
 
 
1243
  if AToken.StrValue = 'eofill' then
 
1244
  begin
 
1245
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
1246
    WriteLn('[TvEPSVectorialReader.ExecutePaintingOperator] eofill');
 
1247
    {$endif}
 
1248
    AData.SetBrushStyle(bsSolid);
 
1249
    AData.SetPenStyle(psSolid);
 
1250
    AData.SetClipPath(CurrentGraphicState.ClipPath, CurrentGraphicState.ClipMode);
 
1251
    AData.SetPenWidth(CurrentGraphicState.PenWidth);
 
1252
    AData.EndPath();
 
1253
 
 
1254
    Exit(True);
 
1255
  end;
 
1256
end;
 
1257
 
 
1258
{ Device Setup and Output Operators
 
1259
 
 
1260
  – showpage – Transmit and reset current page
 
1261
  – copypage – Transmit current page
 
1262
  dict setpagedevice – Install page-oriented output device
 
1263
  – currentpagedevice dict Return current page device parameters
 
1264
  – nulldevice – Install no-output device
 
1265
  Glyph and Font Operators
 
1266
  key font|cidfont definefont font|cidfont Register font|cidfont in Font resource
 
1267
  category
 
1268
  key name|string|dict array composefont font Register composite font dictionary created
 
1269
  from CMap and array of CIDFonts or fonts
 
1270
  key undefinefont – Remove Font resource registration
 
1271
  key findfont font|cidfont Return Font resource instance identified by
 
1272
  key
 
1273
  font|cidfont scale scalefont font¢|cidfont¢ Scale font|cidfont by scale to produce
 
1274
  font¢|cidfont¢
 
1275
  font|cidfont matrix makefont font¢|cidfont¢ Transform font|cidfont by matrix to produce
 
1276
  font¢|cidfont¢
 
1277
  font|cidfont setfont – Set font or CIDFont in graphics state
 
1278
  – rootfont font|cidfont Return last set font or CIDFont
 
1279
  – currentfont font|cidfont Return current font or CIDFont, possibly a
 
1280
  descendant of rootfont
 
1281
  key scale|matrix selectfont – Set font or CIDFont given name and
 
1282
  transform
 
1283
  string show – Paint glyphs for string in current font
 
1284
  ax ay string ashow – Add (ax , ay) to width of each glyph while
 
1285
  showing string
 
1286
  cx cy char string widthshow – Add (cx , cy) to width of glyph for char while
 
1287
  showing string
 
1288
  cx cy char ax ay string awidthshow – Combine effects of ashow and widthshow
 
1289
  string numarray|numstring xshow – Paint glyphs for string using x widths in
 
1290
  numarray|numstring
 
1291
  string numarray|numstring xyshow – Paint glyphs for string using x and y widths
 
1292
  in numarray|numstring
 
1293
  string numarray|numstring yshow – Paint glyphs for string using y widths in
 
1294
  numarray|numstring
 
1295
  name|cid glyphshow – Paint glyph for character identified by
 
1296
  name|cid
 
1297
  string stringwidth wx wy Return width of glyphs for string in current
 
1298
  font
 
1299
  proc string cshow – Invoke character mapping algorithm and
 
1300
  call proc
 
1301
  proc string kshow – Execute proc between characters shown from
 
1302
  string
 
1303
  – FontDirectory dict Return dictionary of Font resource instances
 
1304
  – GlobalFontDirectory dict Return dictionary of Font resource instances
 
1305
  in global VM
 
1306
  – StandardEncoding array Return Adobe standard font encoding vector
 
1307
  – ISOLatin1Encoding array Return ISO Latin-1 font encoding vector
 
1308
  key findencoding array Find encoding vector
 
1309
  wx wy llx lly urx ury setcachedevice – Declare cached glyph metrics
 
1310
  w0x w0y llx lly urx ury
 
1311
  w1x w1y vx vy setcachedevice2 – Declare cached glyph metrics
 
1312
  wx wy setcharwidth – Declare uncached glyph metrics
 
1313
  Interpreter Parameter Operators
 
1314
  dict setsystemparams – Set systemwide interpreter parameters
 
1315
  – currentsystemparams dict Return systemwide interpreter parameters
 
1316
  dict setuserparams – Set per-context interpreter parameters
 
1317
  – currentuserparams dict Return per-context interpreter parameters
 
1318
  string dict setdevparams – Set parameters for input/output device
 
1319
  string currentdevparams dict Return device parameters
 
1320
  int vmreclaim – Control garbage collector
 
1321
  int setvmthreshold – Control garbage collector
 
1322
  – vmstatus level used maximum
 
1323
  Report VM status
 
1324
  – cachestatus bsize bmax msize mmax csize cmax blimit
 
1325
  Return font cache status and parameters
 
1326
  int setcachelimit – Set maximum bytes in cached glyph
 
1327
  mark size lower upper setcacheparams – Set font cache parameters
 
1328
  – currentcacheparams mark size lower upper
 
1329
  Return current font cache parameters
 
1330
  mark blimit setucacheparams – Set user path cache parameters
 
1331
  – ucachestatus mark bsize bmax rsize rmax blimit
 
1332
  Return user path cache status and
 
1333
  parameters
 
1334
}
 
1335
function TvEPSVectorialReader.ExecuteDeviceSetupAndOutputOperator(
 
1336
  AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
1337
var
 
1338
  Param1, Param2: TPSToken;
 
1339
begin
 
1340
  Result := False;
 
1341
 
 
1342
  if AToken.StrValue = 'showpage' then
 
1343
  begin
 
1344
    Exit(True);
 
1345
  end;
 
1346
end;
 
1347
 
 
1348
{ Array Operators
 
1349
 
 
1350
  int array array Create array of length int
 
1351
  – [ mark Start array construction
 
1352
  mark obj0 … objn-1 ] array End array construction
 
1353
  array length int Return number of elements in array
 
1354
  array index get any Return array element indexed by index
 
1355
  array index any put – Put any into array at index
 
1356
  array index count getinterval subarray Return subarray of array starting at index for
 
1357
  count elements
 
1358
  array1 index array2|packedarray2 putinterval – Replace subarray of array1 starting at index
 
1359
  by array2|packedarray2
 
1360
  any0 … anyn-1 array astore array Pop elements from stack into array
 
1361
  array aload any0 … anyn-1 array Push all elements of array on stack
 
1362
  array1 array2 copy subarray2 Copy elements of array1 to initial subarray of
 
1363
  array2
 
1364
  array proc forall – Execute proc for each element of array
 
1365
  Packed Array Operators
 
1366
  any0 … anyn-1 n packedarray packedarray Create packed array consisting of n elements
 
1367
  from stack
 
1368
  bool setpacking – Set array packing mode for { … } syntax
 
1369
  (true = packed array)
 
1370
  – currentpacking bool Return array packing mode
 
1371
  packedarray length int Return number of elements in packedarray
 
1372
  packedarray index get any Return packedarray element indexed by index
 
1373
  packedarray index count getinterval subarray Return subarray of packedarray starting at
 
1374
  index for count elements
 
1375
  packedarray aload any0 … anyn-1 packedarray
 
1376
  Push all elements of packedarray on stack
 
1377
  packedarray1 array2 copy subarray2 Copy elements of packedarray1 to initial
 
1378
  subarray of array2
 
1379
  packedarray proc forall – Execute proc for each element of packedarray
 
1380
}
 
1381
function TvEPSVectorialReader.ExecuteArrayOperator(AToken: TExpressionToken;
 
1382
  AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
1383
begin
 
1384
  Result := False;
 
1385
 
 
1386
end;
 
1387
 
 
1388
{ String Operators
 
1389
 
 
1390
  int string string Create string of length int
 
1391
  string length int Return number of elements in string
 
1392
  string index get int Return string element indexed by index
 
1393
  string index int put – Put int into string at index
 
1394
  string index count getinterval substring Return substring of string starting at index
 
1395
  for count elements
 
1396
  string1 index string2 putinterval – Replace substring of string1 starting at index
 
1397
  by string2
 
1398
  string1 string2 copy substring2 Copy elements of string1 to initial substring
 
1399
  of string2
 
1400
  string proc forall – Execute proc for each element of string
 
1401
  string seek anchorsearch post match true Search for seek at start of string
 
1402
  or string false
 
1403
  string seek search post match pre true Search for seek in string
 
1404
  or string false
 
1405
  string token post any true Read token from start of string
 
1406
  or false
 
1407
  Relational, Boolean, and Bitwise Operators
 
1408
  any1 any2 eq bool Test equal
 
1409
  any1 any2 ne bool Test not equal
 
1410
  num1|str1 num2|str2 ge bool Test greater than or equal
 
1411
  num1|str1 num2|str2 gt bool Test greater than
 
1412
  num1|str1 num2|str2 le bool Test less than or equal
 
1413
  num1|str1 num2|str2 lt bool Test less than
 
1414
  bool1|int1 bool2|int2 and bool3|int3 Perform logical|bitwise and
 
1415
  bool1|int1 not bool2|int2 Perform logical|bitwise not
 
1416
  bool1|int1 bool2|int2 or bool3|int3 Perform logical|bitwise inclusive or
 
1417
  bool1|int1 bool2|int2 xor bool3|int3 Perform logical|bitwise exclusive or
 
1418
  – true true Return boolean value true
 
1419
  – false false Return boolean value false
 
1420
  int1 shift bitshift int2 Perform bitwise shift of int1 (positive is left)
 
1421
}
 
1422
function TvEPSVectorialReader.ExecuteStringOperator(AToken: TExpressionToken;
 
1423
  AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
1424
var
 
1425
  Param1, Param2: TPSToken;
 
1426
  NewToken: TExpressionToken;
 
1427
begin
 
1428
  Result := False;
 
1429
 
 
1430
  // any1 any2 ne bool Test not equal
 
1431
  if AToken.StrValue = 'ne' then
 
1432
  begin
 
1433
    Param1 := TPSToken(Stack.Pop);
 
1434
    Param2 := TPSToken(Stack.Pop);
 
1435
 
 
1436
    NewToken := TExpressionToken.Create;
 
1437
    NewToken.ETType := ettOperand;
 
1438
    NewToken.BoolValue := Param1.StrValue = Param2.StrValue;
 
1439
    if NewToken.BoolValue then NewToken.StrValue := 'true'
 
1440
    else NewToken.StrValue := 'false';
 
1441
    Stack.Push(NewToken);
 
1442
 
 
1443
    Exit(True);
 
1444
  end;
 
1445
  // num1 num2 lt bool
 
1446
  // string1 string2 lt bool
 
1447
  // pops two objects from the operand stack and pushes true if the first operand is less
 
1448
  // than the second, or false otherwise. If both operands are numbers, lt compares
 
1449
  // their mathematical values. If both operands are strings, lt compares them element
 
1450
  // by element, treating the elements as integers in the range 0 to 255, to determine
 
1451
  // whether the first string is lexically less than the second. If the operands are of
 
1452
  // other types or one is a string and the other is a number, a typecheck error occurs.
 
1453
  if AToken.StrValue = 'lt' then
 
1454
  begin
 
1455
    Param1 := TPSToken(Stack.Pop);
 
1456
    Param2 := TPSToken(Stack.Pop);
 
1457
 
 
1458
    NewToken := TExpressionToken.Create;
 
1459
    NewToken.ETType := ettOperand;
 
1460
    NewToken.BoolValue := Param1.FloatValue > Param2.FloatValue;
 
1461
    if NewToken.BoolValue then NewToken.StrValue := 'true'
 
1462
    else NewToken.StrValue := 'false';
 
1463
    Stack.Push(NewToken);
 
1464
 
 
1465
    Exit(True);
 
1466
  end;
 
1467
end;
 
1468
 
 
1469
{  Arithmetic and Math Operators
 
1470
 
 
1471
  num1 num2 add sum        Return num1 plus num2
 
1472
  num1 num2 div quotient   Return num1 divided by num2
 
1473
  int1 int2 idiv quotient  Return int1 divided by int2
 
1474
  int1 int2 mod remainder  Return remainder after dividing int1 by int2
 
1475
  num1 num2 mul product    Return num1 times num2
 
1476
  num1 num2 sub difference Return num1 minus num2
 
1477
  num1 abs num2            Return absolute value of num1
 
1478
  num1 neg num2            Return negative of num1
 
1479
  num1 ceiling num2        Return ceiling of num1
 
1480
  num1 floor num2          Return floor of num1
 
1481
  num1 round num2          Round num1 to nearest integer
 
1482
  num1 truncate num2       Remove fractional part of num1
 
1483
  num sqrt real            Return square root of num
 
1484
  num den atan angle       Return arctangent of num/den in degrees
 
1485
  angle cos real           Return cosine of angle degrees
 
1486
  angle sin real           Return sine of angle degrees
 
1487
  base exponent exp real   Raise base to exponent power
 
1488
  num ln real              Return natural logarithm (base e)
 
1489
  num log real             Return common logarithm (base 10)
 
1490
  – rand int               Generate pseudo-random integer
 
1491
  int srand –              Set random number seed
 
1492
  – rrand int              Return random number seed
 
1493
}
 
1494
function TvEPSVectorialReader.ExecuteArithmeticAndMathOperator(
 
1495
  AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
1496
var
 
1497
  Param1, Param2: TPSToken;
 
1498
  NewToken: TExpressionToken;
 
1499
begin
 
1500
  Result := False;
 
1501
 
 
1502
  // Division
 
1503
  // Param2 Param1 div ==> (Param2 div Param1)
 
1504
  if AToken.StrValue = 'div' then
 
1505
  begin
 
1506
    Param1 := TPSToken(Stack.Pop);
 
1507
    Param2 := TPSToken(Stack.Pop);
 
1508
    NewToken := TExpressionToken.Create;
 
1509
    NewToken.ETType := ettOperand;
 
1510
    NewToken.FloatValue := Param2.FloatValue / Param1.FloatValue;
 
1511
    NewToken.StrValue := FloatToStr(NewToken.FloatValue);
 
1512
    Stack.Push(NewToken);
 
1513
    {$ifdef FPVECTORIALDEBUG_ARITHMETIC}
 
1514
    WriteLn(Format('[TvEPSVectorialReader.ExecuteArithmeticAndMathOperator] %f %f div %f', [Param2.FloatValue, Param1.FloatValue, NewToken.FloatValue]));
 
1515
    {$endif}
 
1516
    Exit(True);
 
1517
  end;
 
1518
 
 
1519
  // Param2 Param1 mul ==> (Param2 mul Param1)
 
1520
  if AToken.StrValue = 'mul' then
 
1521
  begin
 
1522
    Param1 := TPSToken(Stack.Pop);
 
1523
    Param2 := TPSToken(Stack.Pop);
 
1524
    NewToken := TExpressionToken.Create;
 
1525
    NewToken.ETType := ettOperand;
 
1526
    NewToken.FloatValue := Param2.FloatValue * Param1.FloatValue;
 
1527
    NewToken.StrValue := FloatToStr(NewToken.FloatValue);
 
1528
    Stack.Push(NewToken);
 
1529
    Exit(True);
 
1530
  end;
 
1531
  // num1 num2 sub difference Return num1 minus num2
 
1532
  if AToken.StrValue = 'sub' then
 
1533
  begin
 
1534
    NewToken := TExpressionToken.Create;
 
1535
    NewToken.ETType := ettOperand;
 
1536
    Param1 := TPSToken(Stack.Pop); // num2
 
1537
    Param2 := TPSToken(Stack.Pop); // num1
 
1538
    NewToken.FloatValue := Param2.FloatValue - Param1.FloatValue;
 
1539
    NewToken.StrValue := FloatToStr(NewToken.FloatValue);
 
1540
    Stack.Push(NewToken);
 
1541
    Exit(True);
 
1542
  end;
 
1543
end;
 
1544
 
 
1545
{ Path Construction Operators
 
1546
 
 
1547
  – newpath –              Initialize current path to be empty
 
1548
  – currentpoint x y       Return current point coordinates
 
1549
  x y moveto –             Set current point to (x, y)
 
1550
  dx dy rmoveto –          Perform relative moveto
 
1551
  x y lineto –             Append straight line to (x, y)
 
1552
  dx dy rlineto –          Perform relative lineto
 
1553
  x y r angle1 angle2 arc – Append counterclockwise arc
 
1554
  x y r angle1 angle2 arcn – Append clockwise arc
 
1555
  x1 y1 x2 y2 r arct –     Append tangent arc
 
1556
  x1 y1 x2 y2 r arcto xt1 yt1 xt2 yt2 Append tangent arc
 
1557
  x1 y1 x2 y2 x3 y3 curveto – Append Bézier cubic section
 
1558
  dx1 dy1 dx2 dy2 dx3 dy3 rcurveto – Perform relative curveto
 
1559
  – closepath –            Connect subpath back to its starting point
 
1560
  – flattenpath –          Convert curves to sequences of straight lines
 
1561
  – reversepath –          Reverse direction of current path
 
1562
  – strokepath –           Compute outline of stroked path
 
1563
  userpath ustrokepath – Compute outline of stroked userpath
 
1564
  userpath matrix ustrokepath – Compute outline of stroked userpath
 
1565
  string bool charpath – Append glyph outline to current path
 
1566
  userpath uappend – Interpret userpath and append to current
 
1567
  path
 
1568
  – clippath – Set current path to clipping path
 
1569
  llx lly urx ury setbbox – Set bounding box for current path
 
1570
  – pathbbox llx lly urx ury Return bounding box of current path
 
1571
  move line curve close pathforall – Enumerate current path
 
1572
  bool upath userpath Create userpath for current path; include
 
1573
  ucache if bool is true
 
1574
  – initclip – Set clipping path to device default
 
1575
  – clip – Clip using nonzero winding number rule
 
1576
  – eoclip – Clip using even-odd rule
 
1577
  x y width height rectclip – Clip with rectangular path
 
1578
  numarray|numstring rectclip – Clip with rectangular paths
 
1579
  – ucache – Declare that user path is to be cached
 
1580
}
 
1581
function TvEPSVectorialReader.ExecutePathConstructionOperator(
 
1582
  AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
1583
var
 
1584
  Param1, Param2, Param3, Param4, Param5, Param6: TPSToken;
 
1585
  PosX, PosY, PosX2, PosY2, PosX3, PosY3, BaseX, BaseY: Double;
 
1586
  // For Arc
 
1587
  P1, P2, P3, P4: T3DPoint;
 
1588
  startAngle, endAngle: Double;
 
1589
begin
 
1590
  Result := False;
 
1591
 
 
1592
  // – newpath –              Initialize current path to be empty
 
1593
  if AToken.StrValue = 'newpath' then
 
1594
  begin
 
1595
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
1596
    WriteLn('[TvEPSVectorialReader.ExecutePathConstructionOperator] newpath');
 
1597
    {$endif}
 
1598
//    AData.SetClipPath(CurrentGraphicState.ClipPath, CurrentGraphicState.ClipMode);
 
1599
//    AData.SetPenWidth(CurrentGraphicState.PenWidth);
 
1600
//    AData.SetClipPath(CurrentGraphicState.ClipPath, CurrentGraphicState.ClipMode);
 
1601
    AData.SetBrushStyle(bsClear);
 
1602
    AData.SetPenStyle(psClear);
 
1603
    AData.EndPath();
 
1604
    AData.StartPath();
 
1605
 
 
1606
    AData.SetPenColor(CurrentGraphicState.Color);
 
1607
    AData.SetBrushColor(CurrentGraphicState.Color);
 
1608
    AData.SetPenStyle(psClear);
 
1609
 
 
1610
    Exit(True);
 
1611
  end;
 
1612
  // Param2 Param1 moveto - ===> moveto(X=Param2, Y=Param1);
 
1613
  if AToken.StrValue = 'moveto' then
 
1614
  begin
 
1615
    Param1 := TPSToken(Stack.Pop);
 
1616
    Param2 := TPSToken(Stack.Pop);
 
1617
    PostScriptCoordsToFPVectorialCoords(Param1, Param2, PosX, PosY);
 
1618
    PosX2 := PosX + CurrentGraphicState.TranslateX;
 
1619
    PosY2 := PosY + CurrentGraphicState.TranslateY;
 
1620
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
1621
    WriteLn(Format('[TvEPSVectorialReader.ExecutePathConstructionOperator] moveto %f, %f CurrentGraphicState.Translate %f, %f Resulting Value %f, %f',
 
1622
      [PosX, PosY, CurrentGraphicState.TranslateX, CurrentGraphicState.TranslateY, PosX2, PosY2]));
 
1623
    {$endif}
 
1624
    AData.AddMoveToPath(PosX2, PosY2);
 
1625
    Exit(True);
 
1626
  end;
 
1627
  // Absolute LineTo
 
1628
  // x y lineto –             Append straight line to (x, y)
 
1629
  if AToken.StrValue = 'lineto' then
 
1630
  begin
 
1631
    Param1 := TPSToken(Stack.Pop);
 
1632
    Param2 := TPSToken(Stack.Pop);
 
1633
    PostScriptCoordsToFPVectorialCoords(Param1, Param2, PosX, PosY);
 
1634
    PosX2 := PosX + CurrentGraphicState.TranslateX;
 
1635
    PosY2 := PosY + CurrentGraphicState.TranslateY;
 
1636
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
1637
    WriteLn(Format('[TvEPSVectorialReader.ExecutePathConstructionOperator] lineto %f, %f Resulting value %f, %f', [PosX, PosY, PosX2, PosY2]));
 
1638
    {$endif}
 
1639
    AData.AddLineToPath(PosX2, PosY2);
 
1640
    Exit(True);
 
1641
  end;
 
1642
  // Relative LineTo
 
1643
  // dx dy rlineto –          Perform relative lineto
 
1644
  if AToken.StrValue = 'rlineto' then
 
1645
  begin
 
1646
    Param1 := TPSToken(Stack.Pop);
 
1647
    Param2 := TPSToken(Stack.Pop);
 
1648
    PostScriptCoordsToFPVectorialCoords(Param1, Param2, PosX, PosY);
 
1649
    AData.GetCurrentPathPenPos(BaseX, BaseY);
 
1650
    PosX2 := PosX + BaseX;
 
1651
    PosY2 := PosY + BaseY;
 
1652
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
1653
    WriteLn(Format('[TvEPSVectorialReader.ExecutePathConstructionOperator] rlineto %f, %f Base %f, %f Resulting %f, %f',
 
1654
      [PosX, PosY, BaseX, BaseY, PosX2, PosY2]));
 
1655
    {$endif}
 
1656
    AData.AddLineToPath(PosX2, PosY2);
 
1657
    Exit(True);
 
1658
  end;
 
1659
  // dx1 dy1 dx2 dy2 dx3 dy3 rcurveto –
 
1660
  // (relative curveto) appends a section of a cubic Bézier curve to the current path in
 
1661
  // the same manner as curveto. However, the operands are interpreted as relative
 
1662
  // displacements from the current point rather than as absolute coordinates. That is,
 
1663
  // rcurveto constructs a curve between the current point (x0, y0) and the endpoint
 
1664
  // (x0 + dx3, y0 + dy3), using (x0 + dx1, y0 + dy1) and (x0 + dx2, y0 + dy2) as the Bézier
 
1665
  // control points. In all other respects, the behavior of rcurveto is identical to that of
 
1666
  // curveto.
 
1667
  if AToken.StrValue = 'rcurveto' then
 
1668
  begin
 
1669
    Param1 := TPSToken(Stack.Pop); // dy3
 
1670
    Param2 := TPSToken(Stack.Pop); // dx3
 
1671
    Param3 := TPSToken(Stack.Pop); // dy2
 
1672
    Param4 := TPSToken(Stack.Pop); // dx2
 
1673
    Param5 := TPSToken(Stack.Pop); // dy1
 
1674
    Param6 := TPSToken(Stack.Pop); // dx1
 
1675
    PostScriptCoordsToFPVectorialCoords(Param5, Param6, PosX, PosY);
 
1676
    PostScriptCoordsToFPVectorialCoords(Param3, Param4, PosX2, PosY2);
 
1677
    PostScriptCoordsToFPVectorialCoords(Param1, Param2, PosX3, PosY3);
 
1678
    AData.GetCurrentPathPenPos(BaseX, BaseY);
 
1679
    // First move to the start of the arc
 
1680
//    BaseX := BaseX + CurrentGraphicState.TranslateX;
 
1681
//    BaseY := BaseY + CurrentGraphicState.TranslateY;
 
1682
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
1683
    WriteLn(Format('[TvEPSVectorialReader.ExecutePathConstructionOperator] rcurveto translate %f, %f',
 
1684
      [CurrentGraphicState.TranslateX, CurrentGraphicState.TranslateY]));
 
1685
    WriteLn(Format('[TvEPSVectorialReader.ExecutePathConstructionOperator] rcurveto from %f, %f via %f, %f %f, %f to %f, %f',
 
1686
      [BaseX, BaseY, BaseX + PosX, BaseY + PosY, BaseX + PosX2, BaseY + PosY2, BaseX + PosX3, BaseY + PosY3]));
 
1687
    {$endif}
 
1688
    AData.AddBezierToPath(BaseX + PosX, BaseY + PosY, BaseX + PosX2, BaseY + PosY2, BaseX + PosX3, BaseY + PosY3);
 
1689
    Exit(True);
 
1690
  end;
 
1691
  // – closepath –
 
1692
  //
 
1693
  // Don't do anything, because a stroke or fill might come after closepath
 
1694
  // and newpath will be called after stroke and fill anyway
 
1695
  //
 
1696
  if AToken.StrValue = 'closepath' then
 
1697
  begin
 
1698
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
1699
    WriteLn('[TvEPSVectorialReader.ExecutePathConstructionOperator] closepath');
 
1700
    {$endif}
 
1701
 
 
1702
    Exit(True);
 
1703
  end;
 
1704
  {
 
1705
    x y r angle1 angle2 arc – Append counterclockwise arc
 
1706
 
 
1707
    Arcs in PostScript are described by a center (x, y), a radius r and
 
1708
    two angles, angle1 for the start and angle2 for the end. These two
 
1709
    angles are relative to the X axis growing to the right (positive direction).
 
1710
 
 
1711
  }
 
1712
  if AToken.StrValue = 'arc' then
 
1713
  begin
 
1714
    Param1 := TPSToken(Stack.Pop); // angle2
 
1715
    Param2 := TPSToken(Stack.Pop); // angle1
 
1716
    Param3 := TPSToken(Stack.Pop); // r
 
1717
    Param4 := TPSToken(Stack.Pop); // y
 
1718
    Param5 := TPSToken(Stack.Pop); // x
 
1719
    PostScriptCoordsToFPVectorialCoords(Param4, Param5, PosX, PosY);
 
1720
    PosX := PosX + CurrentGraphicState.TranslateX;
 
1721
    PosY := PosY + CurrentGraphicState.TranslateY;
 
1722
    startAngle := Param2.FloatValue * Pi / 180;
 
1723
    endAngle := Param1.FloatValue * Pi / 180;
 
1724
 
 
1725
    // If the angle is too big we need to use two beziers
 
1726
    if endAngle - startAngle > Pi then
 
1727
    begin
 
1728
      CircularArcToBezier(PosX, PosY, Param3.FloatValue, startAngle, endAngle - Pi, P1, P2, P3, P4);
 
1729
      AData.AddMoveToPath(P1.X, P1.Y);
 
1730
      AData.AddBezierToPath(P2.X, P2.Y, P3.X, P3.Y, P4.X, P4.Y);
 
1731
 
 
1732
      CircularArcToBezier(PosX, PosY, Param3.FloatValue, startAngle + Pi, endAngle, P1, P2, P3, P4);
 
1733
      AData.AddMoveToPath(P1.X, P1.Y);
 
1734
      AData.AddBezierToPath(P2.X, P2.Y, P3.X, P3.Y, P4.X, P4.Y);
 
1735
    end
 
1736
    else
 
1737
    begin
 
1738
      CircularArcToBezier(PosX, PosY, Param3.FloatValue, startAngle, endAngle, P1, P2, P3, P4);
 
1739
      AData.AddMoveToPath(P1.X, P1.Y);
 
1740
      AData.AddBezierToPath(P2.X, P2.Y, P3.X, P3.Y, P4.X, P4.Y);
 
1741
    end;
 
1742
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
1743
    WriteLn(Format('[TvEPSVectorialReader.ExecutePathConstructionOperator] arc X,Y=%f, %f Resulting X,Y=%f, %f R=%f Angles Start,End=%f,%f',
 
1744
      [Param5.FloatValue, Param4.FloatValue, PosX, PosY, Param3.FloatValue, Param2.FloatValue, Param1.FloatValue]));
 
1745
    {$endif}
 
1746
    Exit(True);
 
1747
  end;
 
1748
  // – eoclip – Clip using even-odd rule
 
1749
  //
 
1750
  // intersects the inside of the current clipping path with the inside
 
1751
  // of the current path to produce a new, smaller current clipping path.
 
1752
  // The inside of the current path is determined by the even-odd rule,
 
1753
  // while the inside of the current clipping path is determined by whatever
 
1754
  // rule was used at the time that path was created.
 
1755
  //
 
1756
  // Except for the choice of insideness rule, the behavior of eoclip is identical to that of clip.
 
1757
  //
 
1758
  // ERRORS: limitcheck
 
1759
  //
 
1760
  if AToken.StrValue = 'eoclip' then
 
1761
  begin
 
1762
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
1763
    WriteLn('[TvEPSVectorialReader.ExecutePathConstructionOperator] eoclip');
 
1764
    {$endif}
 
1765
    {$ifndef FPVECTORIALDEBUG_CLIP_REGION}
 
1766
    AData.SetPenStyle(psClear);
 
1767
    {$endif}
 
1768
    AData.SetBrushStyle(bsClear);
 
1769
    AData.EndPath();
 
1770
    CurrentGraphicState.ClipPath := AData.GetEntity(AData.GetEntitiesCount()-1) as TPath;
 
1771
    CurrentGraphicState.ClipMode := vcmEvenOddRule;
 
1772
    Exit(True);
 
1773
  end
 
1774
end;
 
1775
 
 
1776
{  Graphics State Operators (Device-Independent)
 
1777
 
 
1778
  – gsave –                    Push graphics state
 
1779
  – grestore –                 Pop graphics state
 
1780
  – clipsave –                 Push clipping path
 
1781
  – cliprestore –              Pop clipping path
 
1782
  – grestoreall –              Pop to bottommost graphics state
 
1783
  – initgraphics –             Reset graphics state parameters
 
1784
  – gstate gstate              Create graphics state object
 
1785
  gstate setgstate –           Set graphics state from gstate
 
1786
  gstate currentgstate gstate  Copy current graphics state into gstate
 
1787
  num setlinewidth –           Set line width
 
1788
  – currentlinewidth num       Return current line width
 
1789
  int setlinecap –             Set shape of line ends for stroke (0 = butt,
 
1790
                               1 = round, 2 = square)
 
1791
  – currentlinecap int         Return current line cap
 
1792
  int setlinejoin –            Set shape of corners for stroke (0 = miter,
 
1793
                               1 = round, 2 = bevel)
 
1794
  – currentlinejoin int Return current line join
 
1795
  num setmiterlimit – Set miter length limit
 
1796
  – currentmiterlimit num Return current miter limit
 
1797
  bool setstrokeadjust – Set stroke adjustment (false = disable,
 
1798
  true = enable)
 
1799
  – currentstrokeadjust bool Return current stroke adjustment
 
1800
  array offset setdash – Set dash pattern for stroking
 
1801
  – currentdash array offset Return current dash pattern
 
1802
  array|name setcolorspace – Set color space
 
1803
  – currentcolorspace array Return current color space
 
1804
  comp1 … compn setcolor – Set color components
 
1805
  pattern setcolor – Set colored tiling pattern as current color
 
1806
  comp1 … compn pattern setcolor – Set uncolored tiling pattern as current color
 
1807
  – currentcolor comp1 … compn Return current color components
 
1808
  num setgray – Set color space to DeviceGray and color to
 
1809
  specified gray value (0 = black, 1 = white)
 
1810
  – currentgray num Return current color as gray value
 
1811
  hue saturation brightness sethsbcolor – Set color space to DeviceRGB and color to
 
1812
  specified hue, saturation, brightness
 
1813
  – currenthsbcolor hue saturation brightness
 
1814
  Return current color as hue, saturation,
 
1815
  brightness
 
1816
  red green blue setrgbcolor – Set color space to DeviceRGB and color to
 
1817
                               specified red, green, blue
 
1818
  – currentrgbcolor red green blue Return current color as red, green, blue
 
1819
  cyan magenta yellow black setcmykcolor – Set color space to DeviceCMYK and color to
 
1820
  specified cyan, magenta, yellow, black
 
1821
  – currentcmykcolor cyan magenta yellow black
 
1822
  Return current color as cyan, magenta,
 
1823
  yellow, black
 
1824
}
 
1825
function TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI(
 
1826
  AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
1827
var
 
1828
  Param1, Param2, Param3: TPSToken;
 
1829
  lRed, lGreen, lBlue: Double;
 
1830
  lGraphicState: TGraphicState;
 
1831
begin
 
1832
  Result := False;
 
1833
 
 
1834
  // – gsave – Push graphics state
 
1835
  if AToken.StrValue = 'gsave' then
 
1836
  begin
 
1837
    GraphicStateStack.Push(CurrentGraphicState.Duplicate());
 
1838
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
1839
    WriteLn('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] gsave');
 
1840
    {$endif}
 
1841
    Exit(True);
 
1842
  end;
 
1843
  // – grestore -                 Pop graphics state
 
1844
  if AToken.StrValue = 'grestore' then
 
1845
  begin
 
1846
    lGraphicState := TGraphicState(GraphicStateStack.Pop());
 
1847
    if lGraphicState = nil then raise Exception.Create('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] grestore: call to grestore without corresponding gsave');
 
1848
    CurrentGraphicState.Free;
 
1849
    CurrentGraphicState := lGraphicState;
 
1850
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
1851
    WriteLn('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] grestore');
 
1852
    {$endif}
 
1853
    Exit(True);
 
1854
  end;
 
1855
  // num setlinewidth –           Set line width
 
1856
  if AToken.StrValue = 'setlinewidth' then
 
1857
  begin
 
1858
    Param1 := TPSToken(Stack.Pop);
 
1859
    CurrentGraphicState.PenWidth := Round(Param1.FloatValue);
 
1860
    Exit(True);
 
1861
  end;
 
1862
  // int setlinecap –             Set shape of line ends for stroke (0 = butt,
 
1863
  //                             1 = round, 2 = square)
 
1864
  if AToken.StrValue = 'setlinecap' then
 
1865
  begin
 
1866
    Param1 := TPSToken(Stack.Pop);
 
1867
    Exit(True);
 
1868
  end;
 
1869
  // int setlinejoin –            Set shape of corners for stroke (0 = miter,
 
1870
  //                             1 = round, 2 = bevel)
 
1871
  if AToken.StrValue = 'setlinejoin' then
 
1872
  begin
 
1873
    Param1 := TPSToken(Stack.Pop);
 
1874
    Exit(True);
 
1875
  end;
 
1876
  // red green blue setrgbcolor –
 
1877
  // sets the current color space in the graphics state to DeviceRGB and the current color
 
1878
  // to the component values specified by red, green, and blue. Each component
 
1879
  // must be a number in the range 0.0 to 1.0. If any of the operands is outside this
 
1880
  // range, the nearest valid value is substituted without error indication.
 
1881
  if AToken.StrValue = 'setrgbcolor' then
 
1882
  begin
 
1883
    Param1 := TPSToken(Stack.Pop);
 
1884
    Param2 := TPSToken(Stack.Pop);
 
1885
    Param3 := TPSToken(Stack.Pop);
 
1886
 
 
1887
    lRed := EnsureRange(Param3.FloatValue, 0, 1);
 
1888
    lGreen := EnsureRange(Param2.FloatValue, 0, 1);
 
1889
    lBlue := EnsureRange(Param1.FloatValue, 0, 1);
 
1890
 
 
1891
    CurrentGraphicState.Color.Red := Round(lRed * $FFFF);
 
1892
    CurrentGraphicState.Color.Green := Round(lGreen * $FFFF);
 
1893
    CurrentGraphicState.Color.Blue := Round(lBlue * $FFFF);
 
1894
    CurrentGraphicState.Color.alpha := alphaOpaque;
 
1895
 
 
1896
    AData.SetPenColor(CurrentGraphicState.Color);
 
1897
 
 
1898
    {$ifdef FPVECTORIALDEBUG_COLORS}
 
1899
    WriteLn(Format('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] setrgbcolor r=%f g=%f b=%f',
 
1900
      [Param3.FloatValue, Param2.FloatValue, Param1.FloatValue]));
 
1901
    {$endif}
 
1902
 
 
1903
    Exit(True);
 
1904
  end;
 
1905
end;
 
1906
 
 
1907
{  Graphics State Operators (Device-Dependent)
 
1908
 
 
1909
  halftone sethalftone – Set halftone dictionary
 
1910
  – currenthalftone halftone
 
1911
  Return current halftone dictionary
 
1912
  frequency angle proc setscreen – Set gray halftone screen by frequency, angle,
 
1913
  and spot function
 
1914
  frequency angle halftone setscreen – Set gray halftone screen from halftone
 
1915
  dictionary
 
1916
  – currentscreen frequency angle proc|halftone
 
1917
  Return current gray halftone screen
 
1918
  redfreq redang redproc|redhalftone
 
1919
  greenfreq greenang greenproc|greenhalftone
 
1920
  bluefreq blueang blueproc|bluehalftone
 
1921
  grayfreq grayang grayproc|grayhalftone setcolorscreen – Set all four halftone screens
 
1922
  – currentcolorscreen redfreq redang redproc|redhalftone
 
1923
  greenfreq greenang greenproc|greenhalftone
 
1924
  bluefreq blueang blueproc|bluehalftone
 
1925
  grayfreq grayang grayproc|grayhalftone
 
1926
  Return all four halftone screens
 
1927
  proc settransfer – Set gray transfer function
 
1928
  – currenttransfer proc
 
1929
  Return current gray transfer function
 
1930
  redproc greenproc blueproc grayproc setcolortransfer – Set all four transfer functions
 
1931
  – currentcolortransfer redproc greenproc blueproc grayproc
 
1932
  Return current transfer functions
 
1933
  proc setblackgeneration – Set black-generation function
 
1934
  – currentblackgeneration proc
 
1935
  Return current black-generation function
 
1936
  proc setundercolorremoval – Set undercolor-removal function
 
1937
  – currentundercolorremoval proc
 
1938
  Return current undercolor-removal
 
1939
  function
 
1940
  dict setcolorrendering – Set CIE-based color rendering dictionary
 
1941
  – currentcolorrendering dict
 
1942
  Return current CIE-based color rendering
 
1943
  dictionary
 
1944
  num setflat – Set flatness tolerance
 
1945
  – currentflat num Return current flatness
 
1946
  bool setoverprint – Set overprint parameter
 
1947
  – currentoverprint bool Return current overprint parameter
 
1948
  num setsmoothness – Set smoothness parameter
 
1949
  – currentsmoothness num Return current smoothness parameter
 
1950
  Coordinate System and Matrix Operators
 
1951
  – matrix matrix Create identity matrix
 
1952
  – initmatrix – Set CTM to device default
 
1953
  matrix identmatrix matrix Fill matrix with identity transform
 
1954
  matrix defaultmatrix matrix Fill matrix with device default matrix
 
1955
  matrix currentmatrix matrix Fill matrix with CTM
 
1956
  matrix setmatrix –       Replace CTM by matrix
 
1957
  tx ty translate –        Translate user space by (tx , ty)
 
1958
  tx ty matrix translate matrix Define translation by (tx , ty)
 
1959
  sx sy scale – Scale user space by sx and sy
 
1960
  sx sy matrix scale matrix Define scaling by sx and sy
 
1961
  angle rotate – Rotate user space by angle degrees
 
1962
  angle matrix rotate matrix Define rotation by angle degrees
 
1963
  matrix concat – Replace CTM by matrix ´ CTM
 
1964
  matrix1 matrix2 matrix3 concatmatrix matrix3 Fill matrix3 with matrix1 ´ matrix2
 
1965
  x y transform x¢ y¢ Transform (x, y) by CTM
 
1966
  x y matrix transform x¢ y¢ Transform (x, y) by matrix
 
1967
  dx dy dtransform dx¢ dy¢ Transform distance (dx, dy) by CTM
 
1968
  dx dy matrix dtransform dx¢ dy¢ Transform distance (dx, dy) by matrix
 
1969
  x¢ y¢ itransform x y Perform inverse transform of (x¢, y¢) by
 
1970
  CTM
 
1971
  x¢ y¢ matrix itransform x y Perform inverse transform of (x¢, y¢) by
 
1972
  matrix
 
1973
  dx¢ dy¢ idtransform dx dy Perform inverse transform of distance
 
1974
  (dx¢, dy¢) by CTM
 
1975
  dx¢ dy¢ matrix idtransform dx dy Perform inverse transform of distance
 
1976
  (dx¢, dy¢) by matrix
 
1977
  matrix1 matrix2 invertmatrix matrix2 Fill matrix2 with inverse of matrix1
 
1978
}
 
1979
function TvEPSVectorialReader.ExecuteGraphicStateOperatorsDD(
 
1980
  AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
1981
var
 
1982
  Param1, Param2: TPSToken;
 
1983
begin
 
1984
  Result := False;
 
1985
 
 
1986
  // bool setoverprint – Set overprint parameter
 
1987
  if AToken.StrValue = 'setoverprint' then
 
1988
  begin
 
1989
    Param1 := TPSToken(Stack.Pop);
 
1990
 
 
1991
    CurrentGraphicState.OverPrint := Param1.BoolValue;
 
1992
 
 
1993
    Exit(True);
 
1994
  end;
 
1995
  // sx sy scale – Scale user space by sx and sy
 
1996
  if AToken.StrValue = 'scale' then
 
1997
  begin
 
1998
    Param1 := TPSToken(Stack.Pop);
 
1999
    Param2 := TPSToken(Stack.Pop);
 
2000
 
 
2001
    if Param2 = nil then
 
2002
    begin
 
2003
      Exit(True);
 
2004
    end;
 
2005
 
 
2006
    CurrentGraphicState.ScaleX := Param2.FloatValue;
 
2007
    CurrentGraphicState.ScaleY := Param1.FloatValue;
 
2008
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
2009
    WriteLn(Format('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] scale %f %f',
 
2010
     [CurrentGraphicState.ScaleX, CurrentGraphicState.ScaleY]));
 
2011
    {$endif}
 
2012
 
 
2013
    Exit(True);
 
2014
  end;
 
2015
  {
 
2016
    translate tx ty translate
 
2017
    - tx ty matrix translate matrix
 
2018
 
 
2019
    With no matrix operand, translate builds a temporary matrix and concatenates
 
2020
    this matrix with the current transformation matrix (CTM). Precisely, translate
 
2021
    replaces the CTM by T x CTM. The effect of this is to move the origin of the
 
2022
    user coordinate system by tx units in the x direction and ty units in the y
 
2023
    direction relative to the former user coordinate system. The sizes of the x
 
2024
    and y units and the orientation of the axes are unchanged.
 
2025
 
 
2026
    If the matrix operand is supplied, translate replaces the value of matrix by
 
2027
    T and pushes the modified matrix back on the operand stack.
 
2028
    In this case, translate does not affect the CTM.
 
2029
  }
 
2030
  if AToken.StrValue = 'translate' then
 
2031
  begin
 
2032
    Param1 := TPSToken(Stack.Pop); // ty
 
2033
    Param2 := TPSToken(Stack.Pop); // tx
 
2034
 
 
2035
    if Param2 = nil then
 
2036
    begin
 
2037
      raise Exception.Create('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] Stack underflow in operator "translate"');
 
2038
    end;
 
2039
 
 
2040
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
2041
    WriteLn(Format('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] translate %f, %f CurrentGraphicState.Translate %f %f',
 
2042
      [Param2.FloatValue, Param1.FloatValue, CurrentGraphicState.TranslateX, CurrentGraphicState.TranslateY]));
 
2043
    {$endif}
 
2044
 
 
2045
    CurrentGraphicState.TranslateX := CurrentGraphicState.TranslateX + Param2.FloatValue;
 
2046
    CurrentGraphicState.TranslateY := CurrentGraphicState.TranslateY + Param1.FloatValue;
 
2047
 
 
2048
    Exit(True);
 
2049
  end;
 
2050
  // angle rotate – Rotate user space by angle degrees
 
2051
  if AToken.StrValue = 'rotate' then
 
2052
  begin
 
2053
    Param1 := TPSToken(Stack.Pop);
 
2054
 
 
2055
    {$ifdef FPVECTORIALDEBUG_PATHS}
 
2056
    WriteLn(Format('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] rotate angle=%f', [Param1.FloatValue]));
 
2057
    DebugStack();
 
2058
    {$endif}
 
2059
 
 
2060
    Exit(True);
 
2061
  end;
 
2062
end;
 
2063
 
 
2064
{  Dictionary Operators
 
2065
 
 
2066
  int dict dict Create dictionary with capacity for int
 
2067
  elements
 
2068
  – << mark             Start dictionary construction
 
2069
  mark key1 value1 … keyn valuen >> dict
 
2070
                        End dictionary construction
 
2071
  dict length int       Return number of entries in dict
 
2072
  dict maxlength int    Return current capacity of dict
 
2073
  dict begin –          Push dict on dictionary stack
 
2074
  – end –               Pop current dictionary off dictionary stack
 
2075
  key value def –       Associate key and value in current dictionary
 
2076
  key load value        Search dictionary stack for key and return
 
2077
                        associated value
 
2078
  key value store –     Replace topmost definition of key
 
2079
  dict key get any      Return value associated with key in dict
 
2080
  dict key value put –  Associate key with value in dict
 
2081
  dict key undef –      Remove key and its value from dict
 
2082
  dict key known bool Test whether key is in dict
 
2083
  key where dict true   Find dictionary in which key is defined
 
2084
             or false
 
2085
  dict1 dict2 copy dict2 Copy contents of dict1 to dict2
 
2086
  dict proc forall – Execute proc for each entry in dict
 
2087
  – currentdict dict Return current dictionary
 
2088
  – errordict dict Return error handler dictionary
 
2089
  – $error dict Return error control and status dictionary
 
2090
  – systemdict dict Return system dictionary
 
2091
  – userdict dict Return writeable dictionary in local VM
 
2092
  – globaldict dict Return writeable dictionary in global VM
 
2093
  – statusdict dict Return product-dependent dictionary
 
2094
  – countdictstack int Count elements on dictionary stack
 
2095
  array dictstack subarray Copy dictionary stack into array
 
2096
  – cleardictstack – Pop all nonpermanent dictionaries off
 
2097
  dictionary stack
 
2098
}
 
2099
function TvEPSVectorialReader.ExecuteDictionaryOperators(
 
2100
  AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
2101
var
 
2102
  Param1, Param2: TPSToken;
 
2103
  NewToken: TExpressionToken;
 
2104
begin
 
2105
  Result := False;
 
2106
 
 
2107
  // Adds a dictionary definition
 
2108
  // key value def –       Associate key and value in current dictionary
 
2109
  if AToken.StrValue = 'def' then
 
2110
  begin
 
2111
    Param1 := TPSToken(Stack.Pop);
 
2112
    Param2 := TPSToken(Stack.Pop);
 
2113
    Dictionary.AddObject(Param2.StrValue, Param1);
 
2114
    Exit(True);
 
2115
  end;
 
2116
 
 
2117
  // Can be ignored, because in the files found it only loads
 
2118
  // standard routines, like /moveto ...
 
2119
  //
 
2120
  // key load value        Search dictionary stack for key and return
 
2121
  //                      associated value
 
2122
  if AToken.StrValue = 'load' then
 
2123
  begin
 
2124
//    {$ifdef FPVECTORIALDEBUG_DICTIONARY}
 
2125
//    WriteLn('[TvEPSVectorialReader.ExecuteDictionaryOperators] load');
 
2126
//    DebugStack();
 
2127
//    {$endif}
 
2128
 
 
2129
    Exit(True);
 
2130
  end;
 
2131
 
 
2132
  // Find dictionary in which key is defined
 
2133
  //key where dict true   Find dictionary in which key is defined
 
2134
  //           or false
 
2135
  if AToken.StrValue = 'where' then
 
2136
  begin
 
2137
    {$ifdef FPVECTORIALDEBUG_DICTIONARY}
 
2138
    WriteLn('[TvEPSVectorialReader.ExecuteDictionaryOperators] where');
 
2139
    DebugStack();
 
2140
    {$endif}
 
2141
 
 
2142
    Param1 := TPSToken(Stack.Pop);
 
2143
 
 
2144
    if Dictionary.IndexOf(Param1.StrValue) >= 0 then
 
2145
    begin
 
2146
      // We use only 1 dictionary, so this is just a representation of our single dictionary
 
2147
      NewToken := TExpressionToken.Create;
 
2148
      NewToken.ETType := ettDictionary;
 
2149
      Stack.Push(NewToken);
 
2150
 
 
2151
      NewToken := TExpressionToken.Create;
 
2152
      NewToken.ETType := ettOperand;
 
2153
      NewToken.BoolValue := True;
 
2154
      Stack.Push(NewToken);
 
2155
 
 
2156
      {$ifdef FPVECTORIALDEBUG_DICTIONARY}
 
2157
      WriteLn('[TvEPSVectorialReader.ExecuteDictionaryOperators] where True');
 
2158
      {$endif}
 
2159
    end
 
2160
    else
 
2161
    begin
 
2162
      NewToken := TExpressionToken.Create;
 
2163
      NewToken.ETType := ettOperand;
 
2164
      NewToken.BoolValue := False;
 
2165
      Stack.Push(NewToken);
 
2166
 
 
2167
      {$ifdef FPVECTORIALDEBUG_DICTIONARY}
 
2168
      WriteLn('[TvEPSVectorialReader.ExecuteDictionaryOperators] where False');
 
2169
      {$endif}
 
2170
    end;
 
2171
 
 
2172
    Exit(True);
 
2173
  end;
 
2174
end;
 
2175
 
 
2176
{  Miscellaneous Operators
 
2177
 
 
2178
  proc bind proc Replace operator names in proc with
 
2179
  operators; perform idiom recognition
 
2180
  – null null Push null on stack
 
2181
  – version string Return interpreter version
 
2182
  – realtime int Return real time in milliseconds
 
2183
  – usertime int Return execution time in milliseconds
 
2184
  – languagelevel int Return LanguageLevel
 
2185
  – product string Return product name
 
2186
  – revision int Return product revision level
 
2187
  – serialnumber int Return machine serial number
 
2188
  – executive – Invoke interactive executive
 
2189
  bool echo – Turn echoing on or off
 
2190
  – prompt – Executed when ready for interactive input
 
2191
}
 
2192
function TvEPSVectorialReader.ExecuteMiscellaneousOperators(
 
2193
  AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean;
 
2194
begin
 
2195
  Result := False;
 
2196
 
 
2197
  // Just a hint for more efficient parsing, we can ignore
 
2198
  //
 
2199
  // proc bind proc Replace operator names in proc with
 
2200
  // operators; perform idiom recognition
 
2201
  if AToken.StrValue = 'bind' then
 
2202
  begin
 
2203
    {$ifdef FPVECTORIALDEBUG_CONTROL}
 
2204
    WriteLn('[TvEPSVectorialReader.ExecuteControlOperator] bind');
 
2205
    DebugStack();
 
2206
    {$endif}
 
2207
 
 
2208
    Exit(True);
 
2209
  end;
 
2210
end;
 
2211
 
 
2212
procedure TvEPSVectorialReader.PostScriptCoordsToFPVectorialCoords(AParam1,
 
2213
  AParam2: TPSToken; var APosX, APosY: Double);
 
2214
begin
 
2215
  APosX := AParam2.FloatValue;
 
2216
  APosY := AParam1.FloatValue;
 
2217
end;
 
2218
 
 
2219
// Returns true if a dictionary substitution was executed
 
2220
function TvEPSVectorialReader.DictionarySubstituteOperator(
 
2221
  ADictionary: TStringList; var ACurToken: TPSToken): Boolean;
 
2222
var
 
2223
  lIndex: Integer;
 
2224
  SubstituteToken, NewToken: TPSToken;
 
2225
begin
 
2226
  Result := False;
 
2227
  lIndex := ADictionary.IndexOf(ACurToken.StrValue);
 
2228
  if lIndex >= 0 then
 
2229
  begin
 
2230
    Result := True;
 
2231
 
 
2232
    SubstituteToken := TPSToken(ADictionary.Objects[lIndex]);
 
2233
 
 
2234
    if SubstituteToken is TExpressionToken then
 
2235
    begin
 
2236
      ACurToken.StrValue := SubstituteToken.StrValue;
 
2237
      ACurToken.FloatValue := SubstituteToken.FloatValue;
 
2238
    end
 
2239
    else if SubstituteToken is TProcedureToken then
 
2240
    begin
 
2241
      ACurToken := SubstituteToken;
 
2242
    end;
 
2243
    if ACurToken.StrValue = '' then raise Exception.Create('[TvEPSVectorialReader.DictionarySubstituteOperator] The Dictionary substitution resulted in an empty value');
 
2244
  end;
 
2245
end;
 
2246
 
 
2247
constructor TvEPSVectorialReader.Create;
 
2248
begin
 
2249
  inherited Create;
 
2250
 
 
2251
  FPointSeparator := SysUtils.DefaultFormatSettings;
 
2252
  FPointSeparator.DecimalSeparator := '.';
 
2253
  FPointSeparator.ThousandSeparator := ',';
 
2254
 
 
2255
  Tokenizer := TPSTokenizer.Create(-1);
 
2256
  Stack := TObjectStack.Create;
 
2257
  GraphicStateStack := TObjectStack.Create;
 
2258
  Dictionary := TStringList.Create;
 
2259
  Dictionary.CaseSensitive := True;
 
2260
  CurrentGraphicState := TGraphicState.Create;
 
2261
end;
 
2262
 
 
2263
destructor TvEPSVectorialReader.Destroy;
 
2264
begin
 
2265
  Tokenizer.Free;
 
2266
  Stack.Free;
 
2267
  GraphicStateStack.Free;
 
2268
  Dictionary.Free;
 
2269
  CurrentGraphicState.Free;
 
2270
 
 
2271
  inherited Destroy;
 
2272
end;
 
2273
 
 
2274
procedure TvEPSVectorialReader.ReadFromStream(AStream: TStream;
 
2275
  AData: TvVectorialDocument);
 
2276
var
 
2277
  lPage: TvVectorialPage;
 
2278
begin
 
2279
  Tokenizer.ReadFromStream(AStream);
 
2280
//  Tokenizer.DebugOut();
 
2281
 
 
2282
  // Make sure we have at least one path
 
2283
  lPage := AData.AddPage();
 
2284
  lPage.StartPath();
 
2285
 
 
2286
  RunPostScript(Tokenizer.Tokens, lPage, AData);
 
2287
 
 
2288
  // Make sure we have at least one path
 
2289
  lPage.EndPath();
 
2290
 
 
2291
  // PostScript has no document size information, so lets calculate it ourselves
 
2292
  AData.GuessDocumentSize();
 
2293
  AData.GuessGoodZoomLevel()
 
2294
end;
 
2295
 
 
2296
initialization
 
2297
 
 
2298
  RegisterVectorialReader(TvEPSVectorialReader, vfEncapsulatedPostScript);
 
2299
 
 
2300
end.
 
2301