lazarus-ccr/applications/fpvviewer/fpvectorialsrc/epsvectorialreader.pas

{
Reads EPS files

License: The same modified LGPL as the Free Pascal RTL
         See the file COPYING.modifiedLGPL for more details

AUTHORS: Felipe Monteiro de Carvalho

Documentation: http://www.tailrecursive.org/postscript/postscript.html
}
unit epsvectorialreader;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Math, contnrs,
  fpvectorial, fpimage, fpvutils;

type
  TPSTokenType = (ttComment, ttFloat);

  TPSTokens = TFPList;// TPSToken;

  TPSToken = class
    StrValue: string;
    FloatValue: double;
    IntValue: Integer;
    Childs: TPSTokens;
    Line: Integer; // To help debugging
  end;

  TCommentToken = class(TPSToken)
  end;

  TDefinitionToken = class(TPSToken)
  end;

  TGroupToken = class(TPSToken)
    Levels: Integer; // Used to count groups inside groups and find the end of a top-level group
  end;

  { TExpressionToken }

  TExpressionToken = class(TPSToken)
    function IsExpressionOperand: Boolean;
    procedure PrepareFloatValue;
  end;

  TPostScriptScannerState = (ssSearchingToken, ssInComment, ssInDefinition, ssInGroup, ssInExpressionElement);

  { TPSTokenizer }

  TPSTokenizer = class
  public
    Tokens: TPSTokens;
    constructor Create;
    destructor Destroy; override;
    procedure ReadFromStream(AStream: TStream);
    procedure DebugOut();
    function IsValidPostScriptChar(AChar: Byte): Boolean;
    function IsPostScriptSpace(AChar: Byte): Boolean;
    function IsEndOfLine(ACurChar: Byte; AStream: TStream): Boolean;
  end;

  { TvEPSVectorialReader }

  TvEPSVectorialReader = class(TvCustomVectorialReader)
  private
    Stack: TObjectStack;
    Dictionary: TStringList;
    procedure RunPostScript(ATokens: TPsTokens; AData: TvVectorialDocument);
    procedure ProcessExpressionToken(AToken: TExpressionToken; AData: TvVectorialDocument);
    function  ProcessArithmeticAndPathOperator(AToken: TExpressionToken; AData: TvVectorialDocument): Boolean;
    function  ProcessPathConstructionOperator(AToken: TExpressionToken; AData: TvVectorialDocument): Boolean;
    function  ProcessGraphicStateOperatorsDI(AToken: TExpressionToken; AData: TvVectorialDocument): Boolean;
    procedure PostScriptCoordsToFPVectorialCoords(AParam1, AParam2: TPSToken; var APosX, APosY: Double);
    procedure DictionarySubstituteOperator(ADictionary: TStringList; var ACurToken: TPSToken);
  public
    { General reading methods }
    Tokenizer: TPSTokenizer;
    constructor Create; override;
    Destructor Destroy; override;
    procedure ReadFromStream(AStream: TStream; AData: TvVectorialDocument); override;
  end;

implementation

var
  FPointSeparator: TFormatSettings;

{ TExpressionToken }

function TExpressionToken.IsExpressionOperand: Boolean;
begin
  if StrValue = '' then Exit(False);
  Result := StrValue[1] in ['0'..'9','-'];
end;

procedure TExpressionToken.PrepareFloatValue;
begin
  if not IsExpressionOperand() then Exit;

  FloatValue := StrToFloat(StrValue, FPointSeparator);
end;

{$DEFINE FPVECTORIALDEBUG}

{ TPSTokenizer }

constructor TPSTokenizer.Create;
begin
  inherited Create;
  Tokens := TPSTokens.Create;
end;

destructor TPSTokenizer.Destroy;
begin
  Tokens.Free;
  inherited Destroy;
end;

{@@ Rules for parsing PostScript files:

* Coments go from the first occurence of % outside a line to the next new line
* The only accepted characters are printable ASCII ones, plus spacing ASCII chars
  See IsValidPostScriptChar about that
}
procedure TPSTokenizer.ReadFromStream(AStream: TStream);
var
  i: Integer;
  CurChar: Char;
  CurLine: Integer = 1;
  State: TPostScriptScannerState = ssSearchingToken;
  CommentToken: TCommentToken;
  DefinitionToken: TDefinitionToken;
  GroupToken: TGroupToken;
  ExpressionToken: TExpressionToken;
  Len: Integer;
  lIsEndOfLine: Boolean;
begin
  while AStream.Position < AStream.Size do
  begin
    CurChar := Char(AStream.ReadByte());
//    {$ifdef FPVECTORIALDEBUG}
//    WriteLn(Format('Obtained token %s', [CurChar]));
//    {$endif}
    if not IsValidPostScriptChar(Byte(CurChar)) then
      raise Exception.Create('[TPSTokenizer.ReadFromStream] Invalid char: ' + IntToHex(Byte(CurChar), 2));

    lIsEndOfLine := IsEndOfLine(Byte(CurChar), AStream);
    if lIsEndOfLine then Inc(CurLine);

    case State of
      { Searching for a token }
      ssSearchingToken:
      begin
        if CurChar = '%' then
        begin
          CommentToken := TCommentToken.Create;
          CommentToken.Line := CurLine;
          State := ssInComment;
//          {$ifdef FPVECTORIALDEBUG}
//          WriteLn(Format('Starting Comment at Line %d', [CurLine]));
//          {$endif}
        end
        else if CurChar = '/' then
        begin
          DefinitionToken := TDefinitionToken.Create;
          DefinitionToken.Line := CurLine;
          State := ssInDefinition;
        end
        else if CurChar = '{' then
        begin
          GroupToken := TGroupToken.Create;
          GroupToken.Levels := 1;
          GroupToken.Line := CurLine;
          State := ssInGroup;
        end
        else if CurChar in ['a'..'z','A'..'Z','0'..'9','-'] then
        begin
          ExpressionToken := TExpressionToken.Create;
          ExpressionToken.Line := CurLine;
          ExpressionToken.StrValue := CurChar;
          State := ssInExpressionElement;
        end
        else if lIsEndOfLine then Continue
        else if IsPostScriptSpace(Byte(CurChar)) then Continue
        else
          raise Exception.Create(Format('[TPSTokenizer.ReadFromStream] Unexpected char while searching for token: $%s in Line %d',
           [IntToHex(Byte(CurChar), 2), CurLine]));
      end;

      { Passing by comments }
      ssInComment:
      begin
        CommentToken.StrValue := CommentToken.StrValue + CurChar;
        if lIsEndOfLine then
        begin
          Tokens.Add(CommentToken);
          State := ssSearchingToken;
//          {$ifdef FPVECTORIALDEBUG}
//          WriteLn(Format('Adding Comment "%s" at Line %d', [CommentToken.StrValue, CurLine]));
//          {$endif}
        end;
      end; // ssInComment

      // Definitions are names. They start in "/" and end in a PostScript white space
      // (space, tab, line ending, etc) or in "{"
      // Definitions simply mean that the token is the name of a dictionary entry
      ssInDefinition:
      begin
        if IsPostScriptSpace(Byte(CurChar)) or (CurChar = '{') then
        begin
          Tokens.Add(DefinitionToken);
          State := ssSearchingToken;
          if (CurChar = '{') then AStream.Seek(-1, soFromCurrent);
        end
        else
          DefinitionToken.StrValue := DefinitionToken.StrValue + CurChar;
      end;

      // Starts at { and ends in }, passing over nested groups
      ssInGroup:
      begin
        if (CurChar = '{') then GroupToken.Levels := GroupToken.Levels + 1;
        if (CurChar = '}') then GroupToken.Levels := GroupToken.Levels - 1;

        if GroupToken.Levels = 0 then
        begin
          Tokens.Add(GroupToken);
          State := ssSearchingToken;
        end
        else
          GroupToken.StrValue := GroupToken.StrValue + CurChar;
      end;

      // Goes until a space comes, or {
      ssInExpressionElement:
      begin
        if IsPostScriptSpace(Byte(CurChar)) or (CurChar = '{') then
        begin
          ExpressionToken.PrepareFloatValue();
          Tokens.Add(ExpressionToken);
          State := ssSearchingToken;
          if (CurChar = '{') then AStream.Seek(-1, soFromCurrent);
        end
        else
          ExpressionToken.StrValue := ExpressionToken.StrValue + CurChar;
      end;

    end; // case
  end; // while
end;

procedure TPSTokenizer.DebugOut();
var
  i: Integer;
  Token: TPSToken;
begin
  for i := 0 to Tokens.Count - 1 do
  begin
    Token := TPSToken(Tokens.Items[i]);

    if Token is TCommentToken then
    begin
      WriteLn(Format('TCommentToken StrValue=%s', [Token.StrValue]));
    end
    else if Token is TDefinitionToken then
    begin
      WriteLn(Format('TDefinitionToken StrValue=%s', [Token.StrValue]));
    end
    else if Token is TGroupToken then
    begin
      WriteLn(Format('TGroupToken StrValue=%s', [Token.StrValue]));
    end
    else if Token is TExpressionToken then
    begin
      WriteLn(Format('TExpressionToken StrValue=%s', [Token.StrValue]));
    end;
  end;
end;

{@@ Valid PostScript Chars:

All printable ASCII: a..zA..Z0..9 plus punctuation

Plus the following white spaces
000 00 0 Null (nul)
011 09 9 Tab (tab)
012 0A 10 Line feed (LF)
014 0C 12 Form feed (FF)
015 0D 13 Carriage return (CR)
040 20 32 Space (SP)
}
function TPSTokenizer.IsValidPostScriptChar(AChar: Byte): Boolean;
begin
  Result := ((AChar > 32) and (AChar < 127)) or (AChar in [0, 9, 10, 12, 13, 32]);
end;

function TPSTokenizer.IsPostScriptSpace(AChar: Byte): Boolean;
begin
  Result := AChar in [0, 9, 10, 12, 13, 32];
end;

function TPSTokenizer.IsEndOfLine(ACurChar: Byte; AStream: TStream): Boolean;
var
  HasNextChar: Boolean = False;
  NextChar: Byte;
begin
  Result := False;

  if ACurChar = 13 then
  begin
    if AStream.Position < AStream.Size then
    begin
      HasNextChar := True;
      NextChar := AStream.ReadByte();
      if NextChar <> 10 then AStream.Seek(-1, soFromCurrent); // Go back if it wasnt a #13#10
      Exit(True);
    end;
  end;

  if ACurChar = 10 then Result := True;
end;

{$ifndef Windows}
{$define FPVECTORIALDEBUG}
{$endif}

{ TvEPSVectorialReader }

procedure TvEPSVectorialReader.RunPostScript(ATokens: TPsTokens;
  AData: TvVectorialDocument);
var
  i: Integer;
  CurToken: TPSToken;
begin
  // Make sure we have at least one path
  AData.StartPath();

  for i := 0 to ATokens.Count - 1 do
  begin
    CurToken := TPSToken(ATokens.Items[i]);

    if CurToken is TCommentToken then
    begin
//      ProcessCommentToken(CurToken as TCommentToken, AData);
      Continue;
    end;

    if CurToken is TDefinitionToken then
    begin
      Stack.Push(CurToken);
      Continue;
    end;

    if CurToken is TGroupToken then
    begin
      Stack.Push(CurToken);
      Continue;
    end;

    if CurToken is TExpressionToken then
    begin
      if TExpressionToken(CurToken).IsExpressionOperand() then
      begin
        Stack.Push(CurToken);
        Continue;
      end;

      // Now we need to verify if the operator should be substituted in the dictionary
      DictionarySubstituteOperator(Dictionary, CurToken);

      ProcessExpressionToken(TExpressionToken(CurToken), AData);
    end;
  end;

  // Make sure we have at least one path
  AData.EndPath();
end;

procedure TvEPSVectorialReader.ProcessExpressionToken(AToken: TExpressionToken;
  AData: TvVectorialDocument);
var
  Param1, Param2: TPSToken;
  PosX, PosY: Double;
begin
  if AToken.StrValue = '' then raise Exception.Create('[TvEPSVectorialReader.ProcessExpressionToken] Empty operator');

  { Operand Stack Manipulation Operators

    any pop – Discard top element
    any1 any2 exch ==> any2 any1 Exchange top two elements
    any dup ==> any any Duplicate top element
    any1 … anyn n copy any1 … anyn any1 … anyn Duplicate top n elements
    anyn … any0 n index anyn … any0 anyn Duplicate arbitrary element
    anyn-1 … any0 n j roll any(j-1) mod n … any0 anyn-1 … anyj mod n
    Roll n elements up j times
    any1 … anyn clear Discard all elements
    any1 … anyn count any1 … anyn n Count elements on stack
    – mark mark Push mark on stack
    mark obj1 … objn cleartomark – Discard elements down through mark
    mark obj1 … objn counttomark mark obj1 … objn n Count elements down to mark
  }

  if ProcessArithmeticAndPathOperator(AToken, AData) then Exit;

  if ProcessPathConstructionOperator(AToken, AData) then Exit;

  if ProcessGraphicStateOperatorsDI(AToken, AData) then Exit;

  // Param2 Param1 moveto ===> moveto(X=Param2, Y=Param1);
  if AToken.StrValue = 'moveto' then
  begin
    Param1 := TPSToken(Stack.Pop);
    Param2 := TPSToken(Stack.Pop);
    PostScriptCoordsToFPVectorialCoords(Param1, Param2, PosX, PosY);
    AData.AddMoveToPath(PosX, PosY);
  end
  else if AToken.StrValue = 'lineto' then
  begin
    Param1 := TPSToken(Stack.Pop);
    Param2 := TPSToken(Stack.Pop);
    PostScriptCoordsToFPVectorialCoords(Param1, Param2, PosX, PosY);
    AData.AddLineToPath(PosX, PosY);
  end
  // – eoclip – Clip using even-odd rule
  else if AToken.StrValue = 'eoclip' then
  begin
  end
  // Adds a dictionary definition
  else if AToken.StrValue = 'def' then
  begin
    Param1 := TPSToken(Stack.Pop);
    Param2 := TPSToken(Stack.Pop);
    Dictionary.AddObject(Param2.StrValue, Param1);
  end
  // ???? Commands ignored for now
  else if (AToken.StrValue = 'ndf') or (AToken.StrValue = 'load') or (AToken.StrValue = 'dup') or (AToken.StrValue = 'scale') then
  begin
  end
  // bind can be ignored
  else if AToken.StrValue = 'bind' then
  begin
  end
  else
    raise Exception.Create(Format('[TvEPSVectorialReader.ProcessExpressionToken] Unknown PostScript Command "%s" in Line %d',
      [AToken.StrValue, AToken.Line]));


  { Array Operators

  int array array Create array of length int
  – [ mark Start array construction
  mark obj0 … objn-1 ] array End array construction
  array length int Return number of elements in array
  array index get any Return array element indexed by index
  array index any put – Put any into array at index
  array index count getinterval subarray Return subarray of array starting at index for
  count elements
  array1 index array2|packedarray2 putinterval – Replace subarray of array1 starting at index
  by array2|packedarray2
  any0 … anyn-1 array astore array Pop elements from stack into array
  array aload any0 … anyn-1 array Push all elements of array on stack
  array1 array2 copy subarray2 Copy elements of array1 to initial subarray of
  array2
  array proc forall – Execute proc for each element of array
  Packed Array Operators
  any0 … anyn-1 n packedarray packedarray Create packed array consisting of n elements
  from stack
  bool setpacking – Set array packing mode for { … } syntax
  (true = packed array)
  – currentpacking bool Return array packing mode
  packedarray length int Return number of elements in packedarray
  packedarray index get any Return packedarray element indexed by index
  packedarray index count getinterval subarray Return subarray of packedarray starting at
  index for count elements
  packedarray aload any0 … anyn-1 packedarray
  Push all elements of packedarray on stack
  packedarray1 array2 copy subarray2 Copy elements of packedarray1 to initial
  subarray of array2
  packedarray proc forall – Execute proc for each element of packedarray
  CHAPTER 8 Operators
  510
  Dictionary Operators
  int dict dict Create dictionary with capacity for int
  elements
  – << mark Start dictionary construction
  mark key1 value1 … keyn valuen >> dict End dictionary construction
  dict length int Return number of entries in dict
  dict maxlength int Return current capacity of dict
  dict begin – Push dict on dictionary stack
  – end – Pop current dictionary off dictionary stack
  key value def – Associate key and value in current dictionary
  key load value Search dictionary stack for key and return
  associated value
  key value store – Replace topmost definition of key
  dict key get any Return value associated with key in dict
  dict key value put – Associate key with value in dict
  dict key undef – Remove key and its value from dict
  dict key known bool Test whether key is in dict
  key where dict true Find dictionary in which key is defined
  or false
  dict1 dict2 copy dict2 Copy contents of dict1 to dict2
  dict proc forall – Execute proc for each entry in dict
  – currentdict dict Return current dictionary
  – errordict dict Return error handler dictionary
  – $error dict Return error control and status dictionary
  – systemdict dict Return system dictionary
  – userdict dict Return writeable dictionary in local VM
  – globaldict dict Return writeable dictionary in global VM
  – statusdict dict Return product-dependent dictionary
  – countdictstack int Count elements on dictionary stack
  array dictstack subarray Copy dictionary stack into array
  – cleardictstack – Pop all nonpermanent dictionaries off
  dictionary stack
  8.1 Operator Summary
  511
  String Operators
  int string string Create string of length int
  string length int Return number of elements in string
  string index get int Return string element indexed by index
  string index int put – Put int into string at index
  string index count getinterval substring Return substring of string starting at index
  for count elements
  string1 index string2 putinterval – Replace substring of string1 starting at index
  by string2
  string1 string2 copy substring2 Copy elements of string1 to initial substring
  of string2
  string proc forall – Execute proc for each element of string
  string seek anchorsearch post match true Search for seek at start of string
  or string false
  string seek search post match pre true Search for seek in string
  or string false
  string token post any true Read token from start of string
  or false
  Relational, Boolean, and Bitwise Operators
  any1 any2 eq bool Test equal
  any1 any2 ne bool Test not equal
  num1|str1 num2|str2 ge bool Test greater than or equal
  num1|str1 num2|str2 gt bool Test greater than
  num1|str1 num2|str2 le bool Test less than or equal
  num1|str1 num2|str2 lt bool Test less than
  bool1|int1 bool2|int2 and bool3|int3 Perform logical|bitwise and
  bool1|int1 not bool2|int2 Perform logical|bitwise not
  bool1|int1 bool2|int2 or bool3|int3 Perform logical|bitwise inclusive or
  bool1|int1 bool2|int2 xor bool3|int3 Perform logical|bitwise exclusive or
  – true true Return boolean value true
  – false false Return boolean value false
  int1 shift bitshift int2 Perform bitwise shift of int1 (positive is left)
  CHAPTER 8 Operators
  512
  Control Operators
  any exec – Execute arbitrary object
  bool proc if – Execute proc if bool is true
  bool proc1 proc2 ifelse – Execute proc1 if bool is true, proc2 if false
  initial increment limit proc for – Execute proc with values from initial by steps
  of increment to limit
  int proc repeat – Execute proc int times
  proc loop – Execute proc an indefinite number of times
  – exit – Exit innermost active loop
  – stop – Terminate stopped context
  any stopped bool Establish context for catching stop
  – countexecstack int Count elements on execution stack
  array execstack subarray Copy execution stack into array
  – quit – Terminate interpreter
  – start – Executed at interpreter startup
  Type, Attribute, and Conversion Operators
  any type name Return type of any
  any cvlit any Make object literal
  any cvx any Make object executable
  any xcheck bool Test executable attribute
  array|packedarray|file|string executeonly array|packedarray|file|string
  Reduce access to execute-only
  array|packedarray|dict|file|string noaccess array|packedarray|dict|file|string
  Disallow any access
  array|packedarray|dict|file|string readonly array|packedarray|dict|file|string
  Reduce access to read-only
  array|packedarray|dict|file|string rcheck bool Test read access
  array|packedarray|dict|file|string wcheck bool Test write access
  num|string cvi int Convert to integer
  string cvn name Convert to name
  num|string cvr real Convert to real
  num radix string cvrs substring Convert with radix to string
  any string cvs substring Convert to string
  8.1 Operator Summary
  513
  File Operators
  filename access file file Open named file with specified access
  datasrc|datatgt dict
  param1 … paramn filtername filter file Establish filtered file
  file closefile – Close file
  file read int true Read one character from file
  or false
  file int write – Write one character to file
  file string readhexstring substring bool Read hexadecimal numbers from file into
  string
  file string writehexstring – Write string to file as hexadecimal
  file string readstring substring bool Read string from file
  file string writestring – Write string to file
  file string readline substring bool Read line from file into string
  file token any true Read token from file
  or false
  file bytesavailable int Return number of bytes available to read
  – flush – Send buffered data to standard output file
  file flushfile – Send buffered data or read to EOF
  file resetfile – Discard buffered characters
  file status bool Return status of file (true = valid)
  filename status pages bytes referenced created true
  or false Return information about named file
  filename run – Execute contents of named file
  – currentfile file Return file currently being executed
  filename deletefile – Delete named file
  filename1 filename2 renamefile – Rename file filename1 to filename2
  template proc scratch filenameforall – Execute proc for each file name matching
  template
  file position setfileposition – Set file to specified position
  file fileposition position Return current position in file
  string print – Write string to standard output file
  any = – Write text representation of any to standard
  output file
  any == – Write syntactic representation of any to
  standard output file
  any1 … anyn stack any1 … anyn Print stack nondestructively using =
  any1 … anyn pstack any1 … anyn Print stack nondestructively using ==
  CHAPTER 8 Operators
  514
  obj tag printobject – Write binary object to standard output file,
  using tag
  file obj tag writeobject – Write binary object to file, using tag
  int setobjectformat – Set binary object format (0 = disable,
  1 = IEEE high, 2 = IEEE low, 3 = native
  high, 4 = native low)
  – currentobjectformat int Return binary object format
  Resource Operators
  key instance category defineresource instance Register named resource instance in category
  key category undefineresource – Remove resource registration
  key category findresource instance Return resource instance identified by key in
  category
  renderingintent findcolorrendering name bool Select CIE-based color rendering dictionary
  by rendering intent
  key category resourcestatus status size true Return status of resource instance
  or false
  template proc scratch category resourceforall – Enumerate resource instances in category
  Virtual Memory Operators
  – save save Create VM snapshot
  save restore – Restore VM snapshot
  bool setglobal – Set VM allocation mode (false = local,
  true = global)
  – currentglobal bool Return current VM allocation mode
  any gcheck bool Return true if any is simple or in global VM,
  false if in local VM
  bool1 password startjob bool2 Start new job that will alter initial VM if
  bool1 is true
  index any defineuserobject – Define user object associated with index
  index execuserobject – Execute user object associated with index
  index undefineuserobject – Remove user object associated with index
  – UserObjects array Return current UserObjects array defined in
  userdict
  8.1 Operator Summary
  515
  Miscellaneous Operators
  proc bind proc Replace operator names in proc with
  operators; perform idiom recognition
  – null null Push null on stack
  – version string Return interpreter version
  – realtime int Return real time in milliseconds
  – usertime int Return execution time in milliseconds
  – languagelevel int Return LanguageLevel
  – product string Return product name
  – revision int Return product revision level
  – serialnumber int Return machine serial number
  – executive – Invoke interactive executive
  bool echo – Turn echoing on or off
  – prompt – Executed when ready for interactive input

  Graphics State Operators (Device-Dependent)

  halftone sethalftone – Set halftone dictionary
  – currenthalftone halftone
  Return current halftone dictionary
  frequency angle proc setscreen – Set gray halftone screen by frequency, angle,
  and spot function
  frequency angle halftone setscreen – Set gray halftone screen from halftone
  dictionary
  – currentscreen frequency angle proc|halftone
  Return current gray halftone screen
  redfreq redang redproc|redhalftone
  greenfreq greenang greenproc|greenhalftone
  bluefreq blueang blueproc|bluehalftone
  grayfreq grayang grayproc|grayhalftone setcolorscreen – Set all four halftone screens
  8.1 Operator Summary
  517
  – currentcolorscreen redfreq redang redproc|redhalftone
  greenfreq greenang greenproc|greenhalftone
  bluefreq blueang blueproc|bluehalftone
  grayfreq grayang grayproc|grayhalftone
  Return all four halftone screens
  proc settransfer – Set gray transfer function
  – currenttransfer proc
  Return current gray transfer function
  redproc greenproc blueproc grayproc setcolortransfer – Set all four transfer functions
  – currentcolortransfer redproc greenproc blueproc grayproc
  Return current transfer functions
  proc setblackgeneration – Set black-generation function
  – currentblackgeneration proc
  Return current black-generation function
  proc setundercolorremoval – Set undercolor-removal function
  – currentundercolorremoval proc
  Return current undercolor-removal
  function
  dict setcolorrendering – Set CIE-based color rendering dictionary
  – currentcolorrendering dict
  Return current CIE-based color rendering
  dictionary
  num setflat – Set flatness tolerance
  – currentflat num Return current flatness
  bool setoverprint – Set overprint parameter
  – currentoverprint bool Return current overprint parameter
  num setsmoothness – Set smoothness parameter
  – currentsmoothness num Return current smoothness parameter
  Coordinate System and Matrix Operators
  – matrix matrix Create identity matrix
  – initmatrix – Set CTM to device default
  matrix identmatrix matrix Fill matrix with identity transform
  matrix defaultmatrix matrix Fill matrix with device default matrix
  matrix currentmatrix matrix Fill matrix with CTM
  matrix setmatrix – Replace CTM by matrix
  tx ty translate – Translate user space by (tx , ty)
  tx ty matrix translate matrix Define translation by (tx , ty)
  CHAPTER 8 Operators
  518
  sx sy scale – Scale user space by sx and sy
  sx sy matrix scale matrix Define scaling by sx and sy
  angle rotate – Rotate user space by angle degrees
  angle matrix rotate matrix Define rotation by angle degrees
  matrix concat – Replace CTM by matrix ´ CTM
  matrix1 matrix2 matrix3 concatmatrix matrix3 Fill matrix3 with matrix1 ´ matrix2
  x y transform x¢ y¢ Transform (x, y) by CTM
  x y matrix transform x¢ y¢ Transform (x, y) by matrix
  dx dy dtransform dx¢ dy¢ Transform distance (dx, dy) by CTM
  dx dy matrix dtransform dx¢ dy¢ Transform distance (dx, dy) by matrix
  x¢ y¢ itransform x y Perform inverse transform of (x¢, y¢) by
  CTM
  x¢ y¢ matrix itransform x y Perform inverse transform of (x¢, y¢) by
  matrix
  dx¢ dy¢ idtransform dx dy Perform inverse transform of distance
  (dx¢, dy¢) by CTM
  dx¢ dy¢ matrix idtransform dx dy Perform inverse transform of distance
  (dx¢, dy¢) by matrix
  matrix1 matrix2 invertmatrix matrix2 Fill matrix2 with inverse of matrix1

  Painting Operators

  – erasepage – Paint current page white
  – stroke – Draw line along current path
  – fill – Fill current path with current color
  – eofill – Fill using even-odd rule
  x y width height rectstroke – Define rectangular path and stroke
  x y width height matrix rectstroke – Define rectangular path, concatenate matrix,
  and stroke
  numarray|numstring rectstroke – Define rectangular paths and stroke
  numarray|numstring matrix rectstroke – Define rectangular paths, concatenate
  matrix, and stroke
  x y width height rectfill – Fill rectangular path
  numarray|numstring rectfill – Fill rectangular paths
  userpath ustroke – Interpret and stroke userpath
  userpath matrix ustroke – Interpret userpath, concatenate matrix, and
  stroke
  userpath ufill – Interpret and fill userpath
  userpath ueofill – Fill userpath using even-odd rule
  dict shfill – Fill area defined by shading pattern
  CHAPTER 8 Operators
  520
  dict image – Paint any sampled image
  width height bits/sample matrix datasrc image – Paint monochrome sampled image
  width height bits/comp matrix
  datasrc0 … datasrcncomp-1 multi ncomp colorimage – Paint color sampled image
  dict imagemask – Paint current color through mask
  width height polarity matrix datasrc imagemask – Paint current color through mask
  Insideness-Testing Operators
  x y infill bool Test whether (x, y) would be painted by fill
  userpath infill bool Test whether pixels in userpath would be
  painted by fill
  x y ineofill bool Test whether (x, y) would be painted by eofill
  userpath ineofill bool Test whether pixels in userpath would be
  painted by eofill
  x y userpath inufill bool Test whether (x, y) would be painted by ufill
  of userpath
  userpath1 userpath2 inufill bool Test whether pixels in userpath1 would be
  painted by ufill of userpath2
  x y userpath inueofill bool Test whether (x, y) would be painted by
  ueofill of userpath
  userpath1 userpath2 inueofill bool Test whether pixels in userpath1 would be
  painted by ueofill of userpath2
  x y instroke bool Test whether (x, y) would be painted by
  stroke
  x y userpath inustroke bool Test whether (x, y) would be painted by
  ustroke of userpath
  x y userpath matrix inustroke bool Test whether (x, y) would be painted by
  ustroke of userpath
  userpath1 userpath2 inustroke bool Test whether pixels in userpath1 would be
  painted by ustroke of userpath2
  userpath1 userpath2 matrix inustroke bool Test whether pixels in userpath1 would be
  painted by ustroke of userpath2
  Form and Pattern Operators
  pattern matrix makepattern pattern’ Create pattern instance from prototype
  pattern setpattern – Install pattern as current color
  comp1 … compn pattern setpattern – Install pattern as current color
  form execform – Paint form
  8.1 Operator Summary
  521
  Device Setup and Output Operators
  – showpage – Transmit and reset current page
  – copypage – Transmit current page
  dict setpagedevice – Install page-oriented output device
  – currentpagedevice dict Return current page device parameters
  – nulldevice – Install no-output device
  Glyph and Font Operators
  key font|cidfont definefont font|cidfont Register font|cidfont in Font resource
  category
  key name|string|dict array composefont font Register composite font dictionary created
  from CMap and array of CIDFonts or fonts
  key undefinefont – Remove Font resource registration
  key findfont font|cidfont Return Font resource instance identified by
  key
  font|cidfont scale scalefont font¢|cidfont¢ Scale font|cidfont by scale to produce
  font¢|cidfont¢
  font|cidfont matrix makefont font¢|cidfont¢ Transform font|cidfont by matrix to produce
  font¢|cidfont¢
  font|cidfont setfont – Set font or CIDFont in graphics state
  – rootfont font|cidfont Return last set font or CIDFont
  – currentfont font|cidfont Return current font or CIDFont, possibly a
  descendant of rootfont
  key scale|matrix selectfont – Set font or CIDFont given name and
  transform
  string show – Paint glyphs for string in current font
  ax ay string ashow – Add (ax , ay) to width of each glyph while
  showing string
  cx cy char string widthshow – Add (cx , cy) to width of glyph for char while
  showing string
  cx cy char ax ay string awidthshow – Combine effects of ashow and widthshow
  string numarray|numstring xshow – Paint glyphs for string using x widths in
  numarray|numstring
  string numarray|numstring xyshow – Paint glyphs for string using x and y widths
  in numarray|numstring
  string numarray|numstring yshow – Paint glyphs for string using y widths in
  numarray|numstring
  CHAPTER 8 Operators
  522
  name|cid glyphshow – Paint glyph for character identified by
  name|cid
  string stringwidth wx wy Return width of glyphs for string in current
  font
  proc string cshow – Invoke character mapping algorithm and
  call proc
  proc string kshow – Execute proc between characters shown from
  string
  – FontDirectory dict Return dictionary of Font resource instances
  – GlobalFontDirectory dict Return dictionary of Font resource instances
  in global VM
  – StandardEncoding array Return Adobe standard font encoding vector
  – ISOLatin1Encoding array Return ISO Latin-1 font encoding vector
  key findencoding array Find encoding vector
  wx wy llx lly urx ury setcachedevice – Declare cached glyph metrics
  w0x w0y llx lly urx ury
  w1x w1y vx vy setcachedevice2 – Declare cached glyph metrics
  wx wy setcharwidth – Declare uncached glyph metrics
  Interpreter Parameter Operators
  dict setsystemparams – Set systemwide interpreter parameters
  – currentsystemparams dict Return systemwide interpreter parameters
  dict setuserparams – Set per-context interpreter parameters
  – currentuserparams dict Return per-context interpreter parameters
  string dict setdevparams – Set parameters for input/output device
  string currentdevparams dict Return device parameters
  int vmreclaim – Control garbage collector
  int setvmthreshold – Control garbage collector
  – vmstatus level used maximum
  Report VM status
  – cachestatus bsize bmax msize mmax csize cmax blimit
  Return font cache status and parameters
  int setcachelimit – Set maximum bytes in cached glyph
  mark size lower upper setcacheparams – Set font cache parameters
  – currentcacheparams mark size lower upper
  Return current font cache parameters
  8.1 Operator Summary
  523
  mark blimit setucacheparams – Set user path cache parameters
  – ucachestatus mark bsize bmax rsize rmax blimit
  Return user path cache status and
  parameters
  Errors
  configurationerror setpagedevice or setdevparams request
  cannot be satisfied
  dictfull No more room in dictionary
  dictstackoverflow Too many begin operators
  dictstackunderflow Too many end operators
  execstackoverflow Executive stack nesting too deep
  handleerror Called to report error information
  interrupt External interrupt request (for example,
  Control-C)
  invalidaccess Attempt to violate access attribute
  invalidexit exit not in loop
  invalidfileaccess Unacceptable access string
  invalidfont Invalid Font resource name or font or
  CIDFont dictionary
  invalidrestore Improper restore
  ioerror Input/output error
  limitcheck Implementation limit exceeded
  nocurrentpoint Current point undefined
  rangecheck Operand out of bounds
  stackoverflow Operand stack overflow
  stackunderflow Operand stack underflow
  syntaxerror PostScript language syntax error
  timeout Time limit exceeded
  typecheck Operand of wrong type
  undefined Name not known
  undefinedfilename File not found
  undefinedresource Resource instance not found
  undefinedresult Overflow, underflow, or meaningless result
  unmatchedmark Expected mark not on stack
  unregistered Internal error
  VMerror Virtual memory exhausted
}
end;

{  Arithmetic and Math Operators

  num1 num2 add sum        Return num1 plus num2
  num1 num2 div quotient   Return num1 divided by num2
  int1 int2 idiv quotient  Return int1 divided by int2
  int1 int2 mod remainder  Return remainder after dividing int1 by int2
  num1 num2 mul product    Return num1 times num2
  num1 num2 sub difference Return num1 minus num2
  num1 abs num2            Return absolute value of num1
  num1 neg num2            Return negative of num1
  num1 ceiling num2        Return ceiling of num1
  num1 floor num2          Return floor of num1
  num1 round num2          Round num1 to nearest integer
  num1 truncate num2       Remove fractional part of num1
  num sqrt real            Return square root of num
  num den atan angle       Return arctangent of num/den in degrees
  angle cos real           Return cosine of angle degrees
  angle sin real           Return sine of angle degrees
  base exponent exp real   Raise base to exponent power
  num ln real              Return natural logarithm (base e)
  num log real             Return common logarithm (base 10)
  – rand int               Generate pseudo-random integer
  int srand –              Set random number seed
  – rrand int              Return random number seed
}
function TvEPSVectorialReader.ProcessArithmeticAndPathOperator(
  AToken: TExpressionToken; AData: TvVectorialDocument): Boolean;
var
  Param1, Param2: TPSToken;
begin
  Result := False;

  // Division
  // Param2 Param1 div ==> Param2 div Param1
  if AToken.StrValue = 'div' then
  begin
    Param1 := TPSToken(Stack.Pop);
    Param2 := TPSToken(Stack.Pop);
    Param1.FloatValue := Param2.FloatValue / Param1.FloatValue;
    Param1.StrValue := '00'; // Just to mark it as a number
    Stack.Push(Param1);
    Exit(True);
  end;

  // Param2 Param1 mul ==> Param2 mul Param1
  if AToken.StrValue = 'mul' then
  begin
    Param1 := TPSToken(Stack.Pop);
    Param2 := TPSToken(Stack.Pop);
    Param1.FloatValue := Param2.FloatValue * Param1.FloatValue;
    Param1.StrValue := '00'; // Just to mark it as a number
    Stack.Push(Param1);
    Exit(True);
  end;
end;

{ Path Construction Operators

  – newpath –              Initialize current path to be empty
  – currentpoint x y       Return current point coordinates
  x y moveto –             Set current point to (x, y)
  dx dy rmoveto – Perform relative moveto
  x y lineto – Append straight line to (x, y)
  dx dy rlineto – Perform relative lineto
  x y r angle1 angle2 arc – Append counterclockwise arc
  x y r angle1 angle2 arcn – Append clockwise arc
  x1 y1 x2 y2 r arct – Append tangent arc
  x1 y1 x2 y2 r arcto xt1 yt1 xt2 yt2 Append tangent arc
  x1 y1 x2 y2 x3 y3 curveto – Append Bézier cubic section
  dx1 dy1 dx2 dy2 dx3 dy3 rcurveto – Perform relative curveto
  – closepath – Connect subpath back to its starting point
  – flattenpath – Convert curves to sequences of straight lines
  – reversepath – Reverse direction of current path
  – strokepath – Compute outline of stroked path
  userpath ustrokepath – Compute outline of stroked userpath
  userpath matrix ustrokepath – Compute outline of stroked userpath
  string bool charpath – Append glyph outline to current path
  userpath uappend – Interpret userpath and append to current
  path
  – clippath – Set current path to clipping path
  llx lly urx ury setbbox – Set bounding box for current path
  – pathbbox llx lly urx ury Return bounding box of current path
  move line curve close pathforall – Enumerate current path
  bool upath userpath Create userpath for current path; include
  ucache if bool is true
  – initclip – Set clipping path to device default
  – clip – Clip using nonzero winding number rule
  – eoclip – Clip using even-odd rule
  x y width height rectclip – Clip with rectangular path
  numarray|numstring rectclip – Clip with rectangular paths
  – ucache – Declare that user path is to be cached
}
function TvEPSVectorialReader.ProcessPathConstructionOperator(
  AToken: TExpressionToken; AData: TvVectorialDocument): Boolean;
var
  Param1, Param2: TPSToken;
begin
  Result := False;

  //
  if AToken.StrValue = 'newpath' then
  begin
    AData.EndPath();
    AData.StartPath();
    Exit(True);
  end;
end;

{  Graphics State Operators (Device-Independent)

  – gsave –                    Push graphics state
  – grestore –                 Pop graphics state
  – clipsave –                 Push clipping path
  – cliprestore –              Pop clipping path
  – grestoreall –              Pop to bottommost graphics state
  – initgraphics –             Reset graphics state parameters
  – gstate gstate              Create graphics state object
  gstate setgstate –           Set graphics state from gstate
  gstate currentgstate gstate  Copy current graphics state into gstate
  num setlinewidth –           Set line width
  – currentlinewidth num       Return current line width
  int setlinecap –             Set shape of line ends for stroke (0 = butt,
                               1 = round, 2 = square)
  – currentlinecap int         Return current line cap
  int setlinejoin –            Set shape of corners for stroke (0 = miter,
                               1 = round, 2 = bevel)
  – currentlinejoin int Return current line join
  num setmiterlimit – Set miter length limit
  – currentmiterlimit num Return current miter limit
  bool setstrokeadjust – Set stroke adjustment (false = disable,
  true = enable)
  – currentstrokeadjust bool Return current stroke adjustment
  array offset setdash – Set dash pattern for stroking
  – currentdash array offset Return current dash pattern
  array|name setcolorspace – Set color space
  – currentcolorspace array Return current color space
  comp1 … compn setcolor – Set color components
  pattern setcolor – Set colored tiling pattern as current color
  comp1 … compn pattern setcolor – Set uncolored tiling pattern as current color
  – currentcolor comp1 … compn Return current color components
  num setgray – Set color space to DeviceGray and color to
  specified gray value (0 = black, 1 = white)
  – currentgray num Return current color as gray value
  hue saturation brightness sethsbcolor – Set color space to DeviceRGB and color to
  specified hue, saturation, brightness
  – currenthsbcolor hue saturation brightness
  Return current color as hue, saturation,
  brightness
  red green blue setrgbcolor – Set color space to DeviceRGB and color to
  specified red, green, blue
  – currentrgbcolor red green blue Return current color as red, green, blue
  cyan magenta yellow black setcmykcolor – Set color space to DeviceCMYK and color to
  specified cyan, magenta, yellow, black
  – currentcmykcolor cyan magenta yellow black
  Return current color as cyan, magenta,
  yellow, black
}
function TvEPSVectorialReader.ProcessGraphicStateOperatorsDI(
  AToken: TExpressionToken; AData: TvVectorialDocument): Boolean;
var
  Param1, Param2: TPSToken;
begin
  Result := False;

  //
  if AToken.StrValue = 'setlinewidth' then
  begin
    Param1 := TPSToken(Stack.Pop);
    Exit(True);
  end;
  //
  if AToken.StrValue = 'setlinejoin' then
  begin
    Param1 := TPSToken(Stack.Pop);
    Exit(True);
  end;
end;

procedure TvEPSVectorialReader.PostScriptCoordsToFPVectorialCoords(AParam1,
  AParam2: TPSToken; var APosX, APosY: Double);
begin
  APosX := AParam2.FloatValue;
  APosY := AParam1.FloatValue;
end;

procedure TvEPSVectorialReader.DictionarySubstituteOperator(
  ADictionary: TStringList; var ACurToken: TPSToken);
var
  lIndex: Integer;
  SubstituteToken: TPSToken;
begin
  If (ACurToken.StrValue = 'ndf') or (ACurToken.StrValue = 'div') or (ACurToken.StrValue = 'mul')
    or (ACurToken.StrValue = 'def') or (ACurToken.StrValue = 'moveto') then Exit;

  lIndex := ADictionary.IndexOf(ACurToken.StrValue);
  if lIndex > 0 then
  begin
    SubstituteToken := TPSToken(ADictionary.Objects[lIndex]);
    ACurToken.StrValue := SubstituteToken.StrValue;
    ACurToken.FloatValue := SubstituteToken.FloatValue;
    if ACurToken.StrValue = '' then raise Exception.Create('[TvEPSVectorialReader.DictionarySubstituteOperator] The Dictionary substitution resulted in an empty value');
  end;
end;

constructor TvEPSVectorialReader.Create;
begin
  inherited Create;

  FPointSeparator := SysUtils.DefaultFormatSettings;
  FPointSeparator.DecimalSeparator := '.';
  FPointSeparator.ThousandSeparator := ',';

  Tokenizer := TPSTokenizer.Create;
  Stack := TObjectStack.Create;
  Dictionary := TStringList.Create;
end;

destructor TvEPSVectorialReader.Destroy;
begin
  Tokenizer.Free;
  Stack.Free;
  Dictionary.Free;

  inherited Destroy;
end;

procedure TvEPSVectorialReader.ReadFromStream(AStream: TStream;
  AData: TvVectorialDocument);
begin
  Tokenizer.ReadFromStream(AStream);
  Tokenizer.DebugOut();
  RunPostScript(Tokenizer.Tokens, AData);
end;

initialization

  RegisterVectorialReader(TvEPSVectorialReader, vfEncapsulatedPostScript);

end.