home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 10 / 10.iso / m / m051 / 5.img / PROLOG.PS_ / PROLOG.bin
Encoding:
Text File  |  1992-05-15  |  54.9 KB  |  1,981 lines
  1. % -------------- POSTSCRIPT PROLOG FOR CORELDRAW 3.X ------
  2. % Copyright 1992 Corel Corporation.  All rights reserved.
  3.  
  4. /wCorelDict 300 dict def    % define our own dictionary
  5. wCorelDict begin                % everything is defined in our own dictionary
  6.  
  7. % -- general definition operators
  8. /bd {bind def} bind def
  9. /ld {load def} bd
  10. /xd {exch def} bd
  11. /_ null def                            % null object
  12.  
  13.  
  14. % ----- Global Color variables ---------
  15. % Current object's Fill color
  16. /$c 0 def         % Cyan component
  17. /$m 0 def        % Magenta component
  18. /$y 0 def        % yellow component
  19. /$k 0 def        % Black component
  20. /$t 1 def        % color Tint
  21. /$n _ def        % Color name(non-null for special colors only)
  22. /$o 0 def        % fill overprint flag
  23. /$fil 0 def        % current fill type: 0: solid, 1:pattern, 2: fountain, 3:PS-fill
  24.  
  25. /$bkg false def
  26.  
  27. % Current object's outline color
  28. /$C 0 def         % Cyan component
  29. /$M 0 def        % Magenta component
  30. /$Y 0 def        % yellow component
  31. /$K 0 def        % Black component
  32. /$T 1 def        % color Tint
  33. /$N _ def        % Color name(non-null for special colors only)
  34. /$O 0 def        % stroke overprint flag
  35. /$PF false def    % pattern stroke flag(0 no pattern, 1 pattern)
  36.  
  37. %--current transfo matrices--
  38. /$ctm matrix currentmatrix def    % initial general transfo matrix
  39. /$ptm matrix def                        % pen stroking matrix(defaults identity)
  40. /$ttm matrix def                        % text transfo matrix(Corel extensions)
  41. /$stm matrix def                        % "save" matrix in extended text(Corel extensions)
  42.  
  43. %--pattern parameters --
  44. % fill pattern:
  45. %/$pn () def                        % current fill pattern name
  46. %/$pm matrix def                % current pattern matrix
  47. %/$px 0 def                        % pattern x pos 
  48. %/$py 0 def                        % pattern y pos
  49. %/$pxf 0 def                        % pattern x offset 
  50. %/$pyf 0 def                        % pattern y offset
  51. %/$psx 10 def                     % current X shift between rows or tiles
  52. %/$psy 0 def                      % current Y shift between columns or tiles
  53. %/$pd [] def                        % current pattern description array
  54. %/$tx 0 def                        % current tile x pos 
  55. %/$ty 0 def                        % current tile y pos
  56.  
  57. %-- info about current path when painting the pattern    
  58. %/$llx 0 def                        % current path's bbox(used by patterns only)
  59. %/$lly 0 def                        % also used for each fountain stripes
  60. %/$urx 0 def
  61. %/$ury 0 def
  62.  
  63. %/Bbllx 0 def                    % current object's bbox(in absolute space)
  64. %/Bblly 0 def
  65. %/Bburx 0 def
  66. %/Bbury 0 def
  67.  
  68. %/$tllx 0 def                    % current OBJECT's bbox(in current Pattern space)
  69. %/$tlly 0 def
  70. %/$turx 0 def
  71. %/$tury 0 def
  72.  
  73. %-- Postscript fill variables
  74. %/$Psn null def                    % current PS-fill function name(literal)
  75. %/$Prm null def                    % current PS-fill parms(array of n params)
  76.  
  77. %-- fountain fill variables
  78. /$fst 128 def             % default # of steps in a fountain fill(can be redefined later)
  79. %/$fty 0 def             % current fountain type:0 linear, 1 radial
  80. %/$fan 0 def             % current fountain angle(if linear)
  81. /$pad 0 def                % edge pad around fountain (between 0 & 1.0)
  82. /$rox 0 def                % radial center x offset relative to bbox width
  83. /$roy 0 def                % radial center y offset relative to bbox height
  84.  
  85. %/$toc 0 def                    % TO anf FROM color components
  86. %/$tom 0 def
  87. %/$toy 0 def
  88. %/$tok 0 def
  89. %/$ton _ def                    % TO color name
  90. %/$tot    0 def                    % TO tint
  91. %/$frc 0 def
  92. %/$frm 0 def
  93. %/$fry 0 def
  94. %/$frk 0 def
  95. %/$frn _ def                    % FROM color name
  96. %/$frt    0 def                    % FROM tint
  97.  
  98. %/$dc 0 def                    % delta colors between fountain steps
  99. %/$dm 0 def 
  100. %/$dy 0 def
  101. %/$dk 0 def
  102.  
  103. % ---- Halftone screen support (black only)----------------------
  104. % NOTE: Unless modified later in the setup(generated code)section, the
  105. %           default halftone screens for fill & outline will be the    
  106. %          current device's setting.
  107. currentscreen             % establish document's default halftone screen
  108. /@dsp xd                    % default spot func
  109. /$dsp /@dsp def        % default spot func name
  110. /$dsa xd                    % default screen angle
  111. /$dsf xd                    % default screen frequency function
  112. %-- and other screen-related vars
  113. /$sdf    false def        % FLAG: non-default halftone screen for fill when true
  114. /$SDF    false def        % FLAG: non-defaul halftone screen for stroke when true
  115. %/$scp /$dsp def            % Current spot func for fill
  116. %/$sca $dsa def            % Current screen angle for fill
  117. %/$scf $dsf def            % Current screen frequency for fill
  118. %/$SCP /$dsp def            % Current spot func for stroke
  119. %/$SCA $dsa def            % Current screen angle for stroke
  120. %/$SCF $dsf def            % Current screen frequency for stroke
  121. /$Scra 0.0 def             % screen adjustment (-90 if printing landscape)
  122.  
  123. % ---- Internal operators ----------------------
  124. /$sv 0 def                % variable for save snapshots
  125. /@cp /closepath ld
  126. /@gs /gsave ld
  127. /@gr /grestore ld
  128. /@np /newpath ld
  129. /@sv {/$sv save def}bd
  130. /@rs {$sv restore}bd
  131. /@ss
  132. {
  133.     % Increment screen angle by $Scra which is 0 for portrait printing,
  134.     % -90 for landscape printing.
  135.  
  136.     exch $Scra add exch load setscreen
  137. } bd
  138.  
  139. %-- ERROR Handling  : Autoflatness for paths too complex
  140. % The next section is to avoid the limitcheck error of typesetters.
  141. % The painting operators of PostScript are rewritten to increase
  142. % flatness until either the object can be printed, or a flatness
  143. % of 10 more than the initial flatness setting has been reached.
  144. % In this case an error message is displayed and printing continues with
  145. % the next object.
  146.  
  147. % The auto-flatness will be enabled only if the value of the "AutoFlatness"
  148. % variable is true.  The code to set this variable is output by WALDO.
  149.  
  150. AutoFlatness
  151. {
  152.         % error message if path can really not be printed
  153.     /$cpx ([Error: PathTooComplex; OffendingCommand: AnyPaintingOperator]\n) def
  154.     %-- @cpx Path too complex error message function     - @cpx -
  155.     %%%%%%%%%/@err1 {$cpx print flush stop}bd % displays message and stops program
  156.  
  157.     /@err1 {$cpx print flush newpath} bd % displays message and stops program
  158.  
  159.     %-- @ifl Increase flatness             initial_flatness @ifl initial_flatness
  160.     /@ifl
  161.     {
  162.         dup currentflat exch sub 10 gt        % Is current flatness increase > 10?
  163.         {
  164.             @err1 exit
  165.         }
  166.         {
  167.             currentflat 2 add setflat
  168.         } ifelse
  169.     } bd 
  170.  
  171.     % --- Then redefine fill, eofill, clip, eoclip, & stroke
  172.     /@fill /fill ld
  173.     /fill
  174.     {
  175.         currentflat
  176.         {
  177.             {@fill}
  178.             stopped
  179.             {
  180.                 @ifl
  181.             }
  182.             {
  183.                 exit
  184.             } ifelse
  185.         } bind loop
  186.         setflat
  187.     } bd
  188.  
  189.     /@eofill /eofill ld
  190.     /eofill
  191.     {
  192.         currentflat
  193.         {
  194.             {@eofill}
  195.             stopped
  196.             {
  197.                 @ifl
  198.             }
  199.             {
  200.                 exit
  201.             } ifelse
  202.         } bind loop
  203.         setflat
  204.     } bd
  205.  
  206.     /@clip /clip ld
  207.     /clip
  208.     {
  209.         currentflat
  210.         {
  211.             {@clip}
  212.             stopped
  213.             {
  214.                 initclip @ifl
  215.             }
  216.             {
  217.                 exit
  218.             } ifelse
  219.         } bind loop
  220.         setflat
  221.     } bd
  222.  
  223.     /@eoclip /eoclip ld
  224.     /eoclip
  225.     {
  226.         currentflat
  227.         {
  228.             {@eoclip}
  229.             stopped
  230.             {
  231.                 initclip @ifl
  232.             }
  233.             {
  234.                 exit
  235.             } ifelse
  236.         } bind loop
  237.         setflat
  238.     } bd
  239.  
  240.     /@stroke /stroke ld
  241.     /stroke
  242.     {
  243.         currentflat
  244.         {
  245.             {@stroke}
  246.             stopped
  247.             {
  248.                 @ifl
  249.             }
  250.             {
  251.                 exit
  252.             } ifelse
  253.         } bind loop
  254.         setflat
  255.     } bd
  256. } if
  257.  
  258. /InRange
  259. { %def -- FORCE VALUE BETWEEN TWO LIMITS -- STACK: value minimum maximum
  260.     % if value not in range, modifies the value to be between min and max
  261.     3 -1 roll                                % get value on top
  262.     2 copy le {pop}{exch pop}ifelse    % val = min(val,MAXVAL)
  263.     2 copy ge {pop}{exch pop}ifelse    % val = max(val,MINVAL)
  264. } bd  % --- NEEDED by functions in USERPROC.TXT
  265.  
  266. /wDstChck
  267. { % RETURN THE MAXVALUE CHANGE OR UNCHANGE. MORE DOC. IN USERPROC.TXT FILE. 
  268.   2 1 roll dup 3 -1 roll
  269.   eq { 1 add } if
  270.  } bd    % --- NEEDED by functions in USERPROC.TXT
  271.  
  272. %-- @dot dot spot function      x y @dot num
  273. /@dot
  274. {    % implementation of a dot spot function for halftoning(see setscreen)
  275.     dup mul exch dup mul add 1 exch sub 2 div
  276. } bd
  277.  
  278. %-- @lin line spot function      x y @lin num
  279. /@lin
  280. {    % implementation of a line spot function for halftoning(see setscreen)
  281.     exch pop abs 1 exch sub
  282. } bd
  283.  
  284. %-- @MN    Minimum            val1 val2 @MN value
  285. /@MN
  286. {
  287.     2 copy le
  288.     {pop}
  289.     {exch pop} ifelse    % get minimum of both values
  290. } bd
  291.  
  292. % -- define the setcmykcolor operator if not already defined
  293. /setcmykcolor where    {pop}
  294. {
  295.     /setcmykcolor                     % cyan magenta yellow black setcmykcolor -
  296.     {
  297.         4 1 roll                        % send black below cyan
  298.         3 {3 index add 1 @MN 1 exch sub 3 1 roll} repeat    % convert to BLUE, GREEN and RED
  299.         setrgbcolor
  300.         pop                            % get rid of black
  301.   } bd
  302. } ifelse
  303.  
  304. /setoverprint                % boolean setoverprint
  305. {
  306.     /$op xd
  307. } bd
  308.  
  309.  
  310. /currentoverprint        % - currentoverprint boolean
  311. {
  312.     $op
  313. } bd
  314.  
  315. /setsepcolor                % greyvalue setsepcolor -
  316. {
  317.     1 exch sub setgray                % convert to ps gray
  318. } bd
  319.  
  320. /checksepcolor                % overprint greyvalue setsepcolor boolean
  321. {
  322.     1 exch sub dup setgray                % convert to ps gray
  323.  
  324.     % if white(1) and overprint(1), do not print at all (return false)
  325.     1 eq exch 1 eq and not
  326. } bd
  327.  
  328. /setprocesscolor        % cyan magenta yellow black setprocesscolor -
  329. {
  330.     ColorSeparationMode 0 eq        % Check if not performing color seps.
  331.     {
  332.         setcmykcolor
  333.     }
  334.     {
  335.         0 4 $ink sub index    % Fetch the relevant layer
  336.         exch pop                        % or zero for $ink == 4.
  337.                                                 % |- C M Y K greyvalue
  338.         5 1 roll 4 { pop } repeat        % |- greyvalue
  339.         setsepcolor
  340.     } ifelse
  341. } bd
  342.     
  343.     
  344. % -- define the findcmykcustomcolor operator if not already defined
  345. /findcmykcustomcolor    % cyan magenta yellow black name findcmykcustomcolor array
  346. {
  347.     5 array astore
  348. } bd
  349.  
  350. % -- define the setcustomcolor operator if not already defined
  351. % NOTE: We do not want to redefine this operator if it is defined so that
  352. %       other apps (e.g. Ventura Publisher) can separate our EPS files.
  353.  
  354. /setcustomcolor where    {pop}
  355. {
  356.     /setcustomcolor                     % array tint setcustomcolor -
  357.     {
  358.         ColorSeparationMode 0 eq    % Check if not performing color seps.
  359.         {
  360.             exch                                        % tint array
  361.             aload pop pop                        % |- tint cyan magenta yellow black
  362.             4
  363.             {
  364.                 4 index mul 4 1 roll    % Multiply colour by tint.
  365.             } repeat
  366.             5 -1 roll pop                        % |- cyan magenta yellow black
  367.             setcmykcolor
  368.         }
  369.         {
  370.             exch aload pop                    % |- tint cyan magenta yellow black name
  371.             CurrentInkName eq                % Check if this is the ink currently being separated.
  372.             {
  373.                 4 index                                % Fetch the tint.
  374.             }
  375.             {
  376.                 0                                            % No match, use 0.
  377.             } ifelse                                % |- tint cyan magenta yellow black greyvalue
  378.             6 1 roll
  379.             5 { pop } repeat                % |- greyvalue
  380.             setsepcolor
  381.         } ifelse
  382.     } bd
  383. } ifelse
  384.  
  385. % -- define the colorimage operator if not already defined
  386. % -- NOTE: We know we always call colorimage with ONE procedure
  387. % -- It should call the "image" operator instead
  388. % NOTE ####### Now , just skips the color info
  389. /colorimage where    {pop}
  390. {
  391.     /colorimage                         % wid hei bits matrix proc bool ncolors colorimage -
  392.     {
  393.         pop            % # of colors
  394.         pop            % BOOL always assumed false
  395.         pop            % data aquisition must be different
  396.         pop            % matrix not needed
  397.         pop            % # bits not needed
  398.  
  399.         {currentfile $dat readhexstring pop pop}        % read each row of data
  400.         repeat                                                % until all rows are read
  401.         pop                % clear the rest of the stack
  402.     } bd
  403. }ifelse
  404.  
  405.  
  406. %-- @tc tint color                cyan mag yel blk tint @tc cyan1 mag1 yel1 blk1 
  407. /@tc     % Tint current color (basically multiply 4 components with given tint)
  408. {
  409.     dup 1 ge                % see if tint >= 1
  410.     {pop}                % if it is, pop it
  411.     {                    % otherwise, multiply all 4 components
  412.         4
  413.         {
  414.             dup            % duplicate the tint
  415.             6 -1 roll    % get next component
  416.             mul            % multiply with current tint
  417.             exch            % tint back on top
  418.         } repeat
  419.         pop                % no need for tint anymore
  420.     } ifelse
  421. } bd
  422.  
  423. %-- @scc set current color        tint C M Y K name overprint @scc boolean
  424. /@scc        % -- set current color --
  425. { 
  426.     1 eq setoverprint            % Set overprint parameter.
  427.     dup _ eq                            % Check if process colour.
  428.     {
  429.         pop
  430.         setprocesscolor
  431.         pop
  432.     }
  433.     {                                            % Spot colour.
  434.         findcmykcustomcolor
  435.         exch
  436.         setcustomcolor
  437.     } ifelse
  438.  
  439.     ColorSeparationMode 0 eq    % If not doing color seps, ...
  440.     {
  441.         true
  442.     }
  443.     {
  444.         % if white(1) and overprint, do not print at all(return false)
  445.         currentgray 1 eq currentoverprint and not
  446.     } ifelse
  447. } bd
  448.  
  449. % -------------------- pattern support -----------------------
  450. %-- @sft    set first tile position  - @sft -
  451. /@sft                %set first tile position into $tx $ty (top left corners)
  452. {
  453. %    /$tx $tllx $pxf add dup $tllx gt {$pwid $psx add sub}if def    % first tile's x position(left)
  454. %    /$ty $tury $pyf sub dup $tury lt {$phei $psy add add}if def    % first tile's y position(top) 
  455.  
  456. % 3-Apr-91:KB:Adjusted position of starting tile to make PS Output match
  457. % preview and non-PS printers
  458.     /$tx $tllx $pxf add dup $tllx gt {$pwid sub}if def    % first tile's x position(left)
  459.     /$ty $tury $pyf sub dup $tury lt {$phei add}if def    % first tile's y position(top) 
  460. } bd
  461.  
  462. %-- @stb    set current bbox            - @stb -
  463. /@stb            % stores the current path's bbox into globals $llx,$lly, $urx, $ury
  464. {
  465.     pathbbox /$ury xd /$urx xd /$lly xd /$llx xd         % path's bbox
  466. } bd
  467.  
  468. %-- @ep Execute Pattern        array @ep -
  469. /@ep            % gets a pattern description from the stack and executes it
  470. {
  471.     {
  472.         cvx exec
  473.     } forall
  474. } bd
  475.  
  476. %/@ep            % gets a pattern description from the stack and executes it
  477. %{
  478. %    /$vc 0 def
  479. %    dup length /$vt xd
  480. %    {
  481. %        $vc $vt ge
  482. %        {
  483. %            exit
  484. %        }
  485. %        {
  486. %            dup $vc get
  487. %            cvx exec
  488. %            /$vc $vc 1 add def
  489. %        } ifelse
  490. %    } loop
  491. %    pop
  492. %} bd
  493.  
  494.  
  495. %-- @tp Tile pattern            xpos ypos @tp -
  496. /@tp    % creates a tile at specified position and plays the current
  497. {    % pattern into that tile
  498.       % first, make sure the tile woul be in the clipping path    
  499.     @sv                % save current settings
  500.     /$in true def
  501.     2 copy 
  502.     dup $lly le {/$in false def}if                % below current path?
  503.     $phei sub $ury ge {/$in false def}if        % above current path?
  504.     dup $urx ge {/$in false def}if                % right current path?
  505.     $pwid add $llx le {/$in false def}if        % left current path?
  506.     $in
  507.     {
  508.         @np
  509.         2 copy moveto 
  510.         $pwid 0 rlineto             % Create a rectangle clip box for the tile
  511.         0 $phei neg rlineto 
  512.         $pwid neg 0 rlineto 
  513.         0 $phei rlineto 
  514.         clip @np
  515.                         % translate pattern into new tile
  516.         $pn cvlit load aload pop     % get the current pattern
  517.         7 -1 roll                        % get x tile position on top
  518.         5 index sub                        % tile llx - pattern xpos
  519.         7 -1 roll                        % get the y tile pos on top
  520.         3 index sub                        % tile ury - pattern ypos
  521.         translate
  522.         /$ctm matrix currentmatrix def    % transfo matrix changed for that tile
  523.         @ep                                % execute the pattern description into that tile
  524.         pop pop pop pop
  525.     }
  526.     {pop pop}ifelse    % current tile not visible through current clipping path
  527.     @rs                                    % restore VM
  528. } bd
  529.  
  530. %-- @th Tile pattern    horizontally    - @th -
  531. /@th                % perform tiling when inter-tile shift is only in the x direction
  532. {
  533.     @sft                %set first tile position into $tx $ty
  534.     0 1 $tly 1 sub                        % compute each tile position(in $xp, $yp)
  535.     {    
  536.         dup $psx mul $tx add                    % X position of this row
  537.         {
  538.             dup $llx gt {$pwid sub}{exit}ifelse    % make sure first x is at the left boundary
  539.         } loop
  540.         exch $phei mul $ty exch sub         % first Y position in this row
  541.                                                     % stack: first X and Y in row
  542.         0 1 $tlx 1 sub
  543.         {
  544.             $pwid mul 
  545.             3 copy
  546.             3 -1 roll add exch                        % current tile position(x increased)
  547.             @tp                                    % create a tile and play the pattern into that tile
  548.             pop
  549.         } for
  550.         pop pop                                    % end of column 1
  551.     } for
  552. } bd
  553.  
  554. %-- @tv Tile pattern    vertically    - @tv -
  555. /@tv                % perform tiling when inter-tile shift is only in the y direction
  556. {
  557.     @sft                %set first tile position into $tx $ty
  558.     0 1 $tlx 1 sub                        % compute each tile position(in $xp, $yp)
  559.     {    
  560.         dup $pwid mul $tx add                    % X position of this column
  561.         exch $psy mul $ty exch sub                % first Y position in this column
  562.         {
  563.             dup $ury lt {$phei add}{exit}ifelse    % make sure first Y is at the top boundary
  564.         } loop
  565.                                                         % stack: top X and Y in column
  566.         0 1 $tly 1 sub
  567.         {
  568.             $phei mul 
  569.             3 copy sub                            % current tile position(y decreased)
  570.             @tp                                    % create a tile and play the pattern into that tile
  571.             pop
  572.         } for
  573.         pop pop                                    % end of column 1
  574.     } for
  575. } bd
  576.  
  577. %-- @pf Pattern fill    - @pf -
  578. /@pf        % fills the current path with the current fill pattern
  579. {
  580.     @gs
  581.     $ctm setmatrix           % reset normal ctm
  582.     $pm concat                % concatenate current pattern matrix
  583.     @stb                        % current path bbox(not object bbox)
  584.     @gs 
  585.         % fill background with white ; watch for colorseps % overprinting
  586.     $vectpat
  587.     {
  588.         1 0 0 0 0 _ $o @scc        % fill a white background
  589.         {
  590.             eofill
  591.         } if
  592.     }
  593.     {                                                % For bitmap fills, fill the background now
  594.                                                     % and not for each tile to avoid seams.
  595.         $t $c $m $y $k $n $o @scc
  596.         {
  597.             eofill
  598.             /$bkg true def
  599.         } if
  600.     } ifelse
  601.     @gr        
  602.     eoclip                     % current object shape is the clipping path
  603.     Bburx Bbury $pm itransform /$tury xd /$turx xd        % get object's bbox in transformed space
  604.     Bbllx Bblly $pm itransform /$tlly xd /$tllx xd        % get object's bbox in transformed space
  605.     /$wid $turx $tllx sub def        % current path width
  606.     /$hei $tury $tlly sub def        % current path height
  607.     $wid 0 gt $hei 0 gt and        % make sure current path bbox not NULL
  608.     {
  609.         $pn cvlit load aload pop         % get pattern parms on stack
  610.         /$pd xd                                % $pd = Current pattern description
  611.         3 -1 roll sub /$phei xd            % pattern width
  612.         exch sub /$pwid xd                % pattern height    
  613.         /$tlx $wid $pwid div ceiling 1 add def     %    # of tiles in the X direction
  614.         /$tly $hei $phei div ceiling 1 add def     %    # of tiles in the Y direction
  615.         $psx 0 eq                            % pattern x shift
  616.         {            
  617.             @tv                                % then tile vertically
  618.         }
  619.         {
  620.             @th                                % otherwise tile horizontally
  621.         } ifelse        
  622.     } if             % if pattern size not null
  623.  
  624.     @gr                        % restore initial graphic state
  625.     @np                        % clear the current path
  626.  
  627.     /$bkg false def
  628.  
  629. } bd
  630.  
  631. % --- fountain fill support ------------------
  632. %-- @dlt    compute deltas         - $dlt bprint -    
  633. /@dlt
  634. {                         % step 1 : get deltas between stripes into $dc $dm $dy $dk,
  635.                                  % # of steps in $fst
  636.                                  % also sets initial color values into $c $m $y $k
  637.                                  % returns bool: print or do not print
  638.     ColorSeparationMode 0 eq
  639.     {    % color separation is not active
  640.         /$dc $toc $tot mul $frc $frt mul dup /$c xd sub $fst 1 sub div def        % compute deltas  % original values
  641.         /$dm $tom $tot mul $frm $frt mul dup /$m xd sub $fst 1 sub div def
  642.         /$dy $toy $tot mul $fry $frt mul dup /$y xd sub $fst 1 sub div def
  643.         /$dk $tok $tot mul $frk $frt mul dup /$k xd sub $fst 1 sub div def
  644.         true
  645.     }
  646.     {    % color separation is active
  647.         $frt $frc $frm $fry $frk $frn $o @scc         % set gray to current FROM color 
  648.         dup
  649.         {        % store that gray value
  650.             /$frk 1 currentgray sub def
  651.         }
  652.         {
  653.             /$frk 0 def
  654.         } ifelse
  655.  
  656.         $tot $toc $tom $toy $tok $ton $o @scc        % set gray to current TO color
  657.         dup
  658.         {        % store that gray value
  659.             /$tok 1 currentgray sub def
  660.         }
  661.         {
  662.             /$tok 0 def
  663.         } ifelse
  664.         or            % leaves boolean on stack: True if either from or to colors are to be
  665.                     % printed        
  666.         dup
  667.         {        % if it is to be printed, compute deltas (in black plane only)
  668.             /$c 0 def /$m 0 def /$y 0 def /$k $frk def
  669.             /$dc 0 def /$dm 0 def /$dy 0 def 
  670.             /$dk $tok $frk sub $fst 1 sub div def        % delta gray between steps
  671.         } if        
  672.     }ifelse
  673. } bd
  674.  
  675.  
  676. %-- @ftl fountain fill linear            llx lly urx ury  @ftl -
  677. /@ftl        % generates linear fountain stripes to fill given bbox
  678. {        
  679.     1 index 4 index sub                             % Total width of bbox
  680.     dup $pad mul dup /$pdw xd                    % Store width of each pad in $pdw.
  681.  
  682.     % stack: llx lly urx ury bbox-width $pdw
  683.  
  684.     2 mul sub                                                % width of gradation
  685.     $fst div /$wid xd                                % width of each stripe
  686.     2 index sub /$hei xd                        % compute height
  687.     pop                                                         % stack: llx, lly
  688.     translate
  689.     $c $m $y $k             % starting color
  690.     
  691.     4 copy                                             % 4 colors on stack
  692.     ColorSeparationMode 0 ne                    % Doing color seps?
  693.         { 1 exch sub setgray pop pop pop}    % only use the gray component if so
  694.         {setcmykcolor}ifelse                        % otherwise, use them all
  695.     0 0 moveto 0 $hei lineto $pdw $hei lineto $pdw 0 lineto 0 0 lineto fill    % draw starting pad
  696.      $pdw 0 translate                                % next band position
  697.  
  698.     $fst                         % loop for each band
  699.     {
  700.         4 copy                 % 4 colors on stack
  701.         ColorSeparationMode 0 ne                    % Doing color seps?
  702.             { 1 exch sub setgray pop pop pop}    % only use the gray component if so
  703.             {setcmykcolor}ifelse                        % otherwise, use them all
  704.         0 0 moveto 0 $hei lineto $wid $hei lineto $wid 0 lineto 0 0 lineto fill    % draw band
  705.         $wid 0 translate            % next band position
  706.         $dk add 4 1 roll             % set colors for next band
  707.         $dy add 4 1 roll 
  708.         $dm add 4 1 roll 
  709.         $dc add 4 1 roll 
  710.     } repeat
  711.  
  712.     $dk sub 4 1 roll             % come back to last color for ending pad
  713.     $dy sub 4 1 roll 
  714.     $dm sub 4 1 roll 
  715.     $dc sub 4 1 roll 
  716.     ColorSeparationMode 0 ne                    % Doing color seps?
  717.         { 1 exch sub setgray pop pop pop}    % only use the gray component if so
  718.         {setcmykcolor}ifelse                        % otherwise, use them all
  719.     0 0 moveto 0 $hei lineto $pdw $hei lineto $pdw 0 lineto 0 0 lineto fill    % draw ending pad
  720. } bd
  721.  
  722. %-- @ftr fountain fill radial            llx lly urx ury  @ftr -
  723. /@ftr        % generates radial fountain stripes to fill given bbox
  724. {        
  725.      % get radius
  726.     1 index 4 index sub             % bbox width on stack
  727.     dup $rox mul /$row xd            % Store width of center offset in $row
  728.  
  729.     % stack: llx lly urx ury bbox-width
  730.  
  731.     2 div                                            % half bbox width 
  732.     1 index 4 index sub              % bbox height on stack
  733.  
  734.     % stack: llx lly urx ury bbox-width/2 bbox-height
  735.  
  736.     dup $roy mul /$roh xd            % Store height of center offset in $roh
  737.     2 div                                            % half bbox height 
  738.  
  739.     % stack: llx lly urx ury bbox-width/2 bbox-height/2
  740.  
  741.     2 copy dup mul exch dup mul add sqrt            % total radius on stack
  742.     $row dup mul $roh dup mul add sqrt add        % add offset to radius
  743.     
  744.     dup /$hei xd $fst div /$wid xd    % width of each band(delta radius)in $wid
  745.                                                                     % original radius in $hei
  746.                                                                     % on stack: llx lly urx ury w/2 h/2
  747.     4 index add    $roh add                    % y center with offset
  748.     exch
  749.     5 index add $row add                    % x center with offset
  750.     
  751.     exch translate                              % origin in center of bbox
  752.     pop pop pop pop                        % don't need bbox anymore
  753.  
  754.     currentflat dup 5 mul setflat             % no need for extra precision on fountain circles
  755.     $c $m $y $k             % starting color
  756.  
  757.     % Draw the background pad
  758.  
  759.     4 copy 
  760.     ColorSeparationMode 0 ne                    % Doing color seps?
  761.         { 1 exch sub setgray pop pop pop}    % only use the gray component if so
  762.         {setcmykcolor}ifelse                        % otherwise, use them all
  763.     $wid 0 moveto 0 0 $hei 0 360 arc fill    % draw circle at new center of bbox
  764.             % then scale according to the pad size
  765.     1.0 $pad 2 mul sub dup scale                    % scale around new center for pad
  766.     
  767.     $fst                         % loop for each band
  768.     {
  769.         4 copy 
  770.         ColorSeparationMode 0 ne                    % Doing color seps?
  771.             { 1 exch sub setgray pop pop pop}    % only use the gray component if so
  772.             {setcmykcolor}ifelse                        % otherwise, use them all
  773.         $wid 0 moveto 0 0 $hei 0 360 arc fill            % draw circle at new center of bbox
  774.         /$hei $hei $wid sub def        % next band radius in $hei
  775.         $dk add 4 1 roll                 % set colors for next band
  776.         $dy add 4 1 roll 
  777.         $dm add 4 1 roll 
  778.         $dc add 4 1 roll 
  779.     } repeat
  780.     pop pop pop pop     
  781.     setflat
  782. } bd
  783.  
  784. %-- @ff fountain fill current path    - @ff -
  785. /@ff
  786. {
  787.     @gs
  788.     @dlt                    % step 1 : get deltas between stripes into $dc $dm $dy $dk,
  789.                                 % # of steps in $fst
  790.                                 % also sets initial color values into $c $m $y $k
  791.                                 % puts a bool on the stack, same meaning as for @scc
  792.     {
  793.         $ctm setmatrix             % reset normal ctm
  794.         eoclip                     % current path is clipping path
  795.         newpath
  796.         Bbllx Bblly moveto    % compute size of box around current object
  797.         Bbllx Bbury lineto
  798.         Bburx Bbury lineto
  799.         Bburx Bblly lineto
  800.         $fan rotate
  801.         pathbbox
  802.         newpath
  803.  
  804.         $fty 1 eq            % fountain type ?
  805.         {@ftr}            % radial fountain
  806.         {@ftl} ifelse    % linear fountain
  807.     } if
  808.     @gr
  809.     @np
  810. } bd
  811.  
  812. %--@Pf Postscript Fill        - @Pf -
  813. /@Pf
  814. {    % Call user-defined Postscript fill with current parameters
  815.     @sv            % don't take chances, save current state
  816.                     % 20dec90:MB: Print PS fill only in composite
  817.                     %                     or in black plane of color seps.
  818.     ColorSeparationMode 0 eq  $ink 3 eq or
  819.     {            % PS fills can be printed
  820.         0 J 0 j [] 0 d                        % reset stroke attributes (all PS fills set line width)
  821.  
  822.         $t $c $m $y $k $n $o @scc    pop        % set colour
  823.  
  824.         $ctm setmatrix                        % reset matrix for PS-filling
  825.             % --- NOTE: All PS fills expect the current UNIT to be MIL (1/1000 inch)
  826.             % --- and Bburx, .. need to be specified in that unit as well.
  827.         72 1000 div dup matrix scale    % scaling matrix
  828.         dup concat                            % change current ctm
  829.         dup Bburx exch Bbury exch itransform 
  830.             ceiling cvi /Bbury xd 
  831.             ceiling cvi /Bburx xd        % change unit of BBox
  832.         Bbllx exch Bblly exch itransform 
  833.             floor cvi /Bblly xd 
  834.             floor cvi /Bbllx xd
  835.  
  836.         $Prm aload pop                        % Bring the parameters on stack
  837.         $Psn load exec                        % execute the ps fill as desired
  838.     }                
  839.     {            % Not proper color plane, fill in white instead.
  840.         1 setgray eofill
  841.     } ifelse
  842.     @rs                                    % restore original state
  843.     @np                                    % and clear the path
  844. } bd
  845.  
  846. % -------------------------------------------------------------------
  847. % -- painting attributes operators 
  848.  
  849. %-- g    Fill gray                gray g -            
  850. /g
  851. {
  852.     1 exch sub /$k xd                        % get black component
  853.     /$c 0 def /$m 0 def /$y 0 def /$t 1 def /$n _ def /$fil 0 def 
  854. } bd
  855.  
  856. %-- G    Stroke gray                gray G - 
  857. /G
  858. {
  859.     1 exch sub /$K xd                        % get black component
  860.     /$C 0 def /$M 0 def /$Y 0 def /$T 1 def /$N _ def    
  861. } bd
  862.  
  863. %-- k    Fill color                 cyan mag yel blk k -
  864. /k
  865. {
  866.     /$k xd /$y xd /$m xd /$c xd
  867.     /$t 1 def /$n _ def /$fil 0 def 
  868. } bd
  869.  
  870. %-- K    Stroke color            cyan mag yel blk K -
  871. /K
  872. {
  873.     /$K xd /$Y xd /$M xd /$C xd
  874.     /$T 1 def /$N _ def 
  875. } bd
  876.  
  877. %-- x    Fill custom color        cyan mag yel blk strname tint x -
  878. /x
  879. {
  880.     % Tint 0 is no ink; 1 is Full ink.
  881.     /$t xd /$n xd 
  882.     /$k xd /$y xd /$m xd /$c xd /$fil 0 def
  883. } bd
  884.  
  885. %-- X    Stroke custom color    cyan mag yel blk strname tint X -
  886. /X
  887. {
  888.     % Tint 0 is no ink; 1 is Full ink.
  889.     /$T xd /$N xd 
  890.     /$K xd /$Y xd /$M xd /$C xd
  891. } bd
  892.  
  893. %-- d    setdash                    array offset d -
  894. /d /setdash ld
  895.  
  896. %-- i    set current flat        flat    i -
  897. /i
  898. {
  899.     dup 0 ne {setflat} {pop} ifelse
  900. } bd
  901.  
  902. %-- j    set line join            join j -
  903. /j /setlinejoin ld
  904.  
  905. %-- J set line cap            cap J -
  906. /J /setlinecap ld
  907.  
  908. %-- M    set miter limit        value    M -
  909. /M /setmiterlimit ld
  910.  
  911. %-- w    set line width            width w -
  912. /w /setlinewidth ld
  913.  
  914. %-- O    set overprint fill    flag O -
  915. /O
  916. {
  917.     /$o xd
  918. } bd
  919.  
  920. %-- R    set overprint stroke    flag R -
  921. /R
  922. {
  923.     /$O xd
  924. } bd
  925.  
  926. %------------------------------------------------------------------------
  927. %-- path construction operators
  928.  
  929. %-- c    curveto smooth            x1 y1 x2 y2 x3 y3 c -
  930. /c /curveto ld
  931.  
  932. %-- C    curveto corner            x1 y1 x2 y2 x3 y3 C -
  933. /C /c ld
  934.  
  935. %-- v    curveto smooth            x12 y12 x3 y3 v -
  936. /v
  937. {
  938.     4 -2 roll                     % get x12 y12 on top
  939.     2 copy                        % duplicate them
  940.     6 -2 roll curveto            % move x3 y3 back to the end
  941. } bd
  942.  
  943. %-- V    curveto corner            x12 y12 x3 y3 V -
  944. /V /v ld
  945.  
  946. %-- y    curveto smooth            x1 y1 x23 y23 y -
  947. /y
  948. {
  949.     2 copy curveto                % duplicate last point 
  950. } bd
  951.  
  952. %-- Y    curveto corner            x1 y1 x23 y23 Y -
  953. /Y /y ld
  954.  
  955. %-- l    lineto smooth            x y l -
  956. /l /lineto ld
  957.  
  958. %-- L    lineto corner            x y L -
  959. /L /l ld
  960.  
  961. %-- rl rlineto                x y rl
  962. /rl /rlineto ld
  963.  
  964. %-- m    moveto                    x y m -
  965. /m /moveto ld
  966.  
  967.  
  968. %------------------------------------------------------------------------
  969. % -- Painting operators
  970.  
  971. %-- n    newpath                    - n -
  972. /n /newpath ld
  973.  
  974. %-- N    newpath                    - N -
  975. /N /newpath ld
  976.  
  977. %-- F    fill                        - F -
  978. /F
  979. {
  980.     matrix currentmatrix        % save current transfo matrix on stack
  981.     $sdf {$scf $sca $scp @ss} if        % alternate halftone screen?
  982.     $fil 1 eq
  983.     {@pf}                     % pattern fill
  984.     {                             % 
  985.         $fil 2 eq                % fountain fill?
  986.         {@ff}                    % fountain fill path
  987.         {
  988.             $fil 3 eq            % Postscript fill?
  989.             {@Pf}                % PS fill
  990.             {
  991.                 $t $c $m $y $k $n $o @scc                            % set FILL color, returns TRUE if we fill, FALSE if not
  992.                 {eofill}
  993.                 {@np} ifelse
  994.             } ifelse
  995.         } ifelse
  996.     } ifelse
  997.     $sdf {$dsf $dsa $dsp @ss} if        % reset default halftone screen
  998.     setmatrix                     % reset original transfo matrix on stack
  999. } bd
  1000.  
  1001. %-- f    closepath fill            - f -
  1002. /f
  1003. {
  1004.     @cp F
  1005. } bd
  1006.  
  1007. %-- S    stroke                    - s -
  1008. /S
  1009. {
  1010.     matrix currentmatrix        % save current transfo matrix on stack
  1011.     $ctm setmatrix                 % reset normal ctm
  1012.     $SDF {$SCF $SCA $SCP @ss}if        % alternate halftone screen?
  1013.     $T $C $M $Y $K $N $O @scc                            % set current stroke color, returns TRUE if we paint, FALSE if not
  1014.     {
  1015.         matrix currentmatrix
  1016.         $ptm concat            % set the pen matrix
  1017.         stroke
  1018.         setmatrix                % reset the original matrix(from stack)
  1019.     }
  1020.     {@np}ifelse
  1021.     $SDF {$dsf $dsa $dsp @ss}if        % reset default halftone screen
  1022.     setmatrix                    % reset original matrix set on stack
  1023. } bd
  1024.  
  1025. %-- s    closepath stroke         - s -
  1026. /s
  1027. {
  1028.     @cp
  1029.     S
  1030. } bd
  1031.  
  1032. %-- B    fill, then stroke        - B -
  1033. /B
  1034. {
  1035.     @gs F    @gr                    % fill
  1036.     S                                % stroke
  1037. } bd
  1038.  
  1039. %-- b    closepath, fill, stroke    - b -
  1040. /b
  1041. {
  1042.     @cp B
  1043. } bd
  1044.  
  1045. %-- W    clip path                - W -
  1046. /W
  1047. {
  1048.     eoclip                 % clip to current path
  1049. } bd
  1050.  
  1051. %-- p    pattern fill            name xpos ypos xmag ymag angle reflect_flag 
  1052. %--                                reflect_angle skew_angle skew_imposed_angle 
  1053. %--                                matrix - p -
  1054. /p
  1055. {
  1056.     /$pm xd                        % current pattern matrix
  1057.     7 {pop} repeat                % get rid of undesired parms(not implemented)
  1058.     /$pyf xd /$pxf xd            % remember X Y original offests
  1059.     /$pn xd                        % remember pattern name    
  1060.     /$fil 1 def                    % set global for filling
  1061. } bd
  1062.  
  1063. %-- P    pattern stroke            (same as p)
  1064. /P
  1065. {                % NOT IMPLEMENTED
  1066.     11 {pop} repeat                % get rid of undesired parms(not implemented)
  1067. } bd            
  1068.  
  1069.  
  1070. %-------------------------------------------------------------------------
  1071.     % --- grouping information ---
  1072. %-- u    begin group                - u -
  1073. /u {} bd
  1074.  
  1075. %-- U    end group                - U -
  1076. /U {} bd
  1077.  
  1078. %-- A    locked object            flag A -
  1079. /A {pop} bd
  1080.  
  1081. %-- q    gsave                          - g -
  1082. /q /@gs ld
  1083.  
  1084. %-- Q    grestore                    - Q -
  1085. /Q /@gr ld
  1086.  
  1087.  
  1088. %--------------------------------------------------------------------
  1089. %--- pattern operators
  1090.  
  1091. %-- E    define pattern            name llx lly urx ury description E -
  1092. % a pattern will be defined as an array of 5 entries:
  1093. %     (0)llx (1)lly (2)urx (3)ury (4)descrition
  1094. % the description is also an array of executable strings
  1095. /E
  1096. {
  1097.     5 array astore              % -- parms are in an array
  1098.     exch cvlit exch def        % -- defined with key equal to the name(string)
  1099. } bd
  1100.  
  1101. %-- `    place marker            - ` -
  1102. /` {}bd
  1103.  
  1104. %-- ~    end place                - ~ -
  1105. /~ {}bd
  1106.     
  1107. %-- @    pattern marker            - @ -    
  1108. /@ {}bd
  1109.  
  1110. %-- &    pattern marker            - & -    
  1111. /& {}bd
  1112.  
  1113. % ------------------------------------------------------------------------
  1114. % -- CORELDRAW 2.X re-encoding vector for characters above 128
  1115. /CorelDrawReencodeVect [
  1116. 16#80/grave/circumflex/tilde/dotlessi/florin/quotedblleft/quotedblright/guilsinglleft
  1117. 16#88/guilsinglright/fi/fl/dagger/daggerdbl/endash/periodcentered/breve
  1118. 16#90/quotedblbase/ellipsis/perthousand/trademark/Pt/fractionbar
  1119. 16#98/divide
  1120. 16#a1/exclamdown/cent/sterling/currency/yen/bar/section
  1121. 16#a8/dieresis/copyright/ordfeminine/guillemotleft/logicalnot/emdash/registered/overbar
  1122. 16#b0/ring/plusminus/twosuperior/threesuperior/acute/mu/paragraph/bullet
  1123. 16#b8/cedilla/onesuperior/ordmasculine/guillemotright/onequarter/onehalf/threequarters/questiondown
  1124. 16#c0/Agrave/Aacute/Acircumflex/Atilde/Adieresis/Aring/AE/Ccedilla
  1125. 16#c8/Egrave/Eacute/Ecircumflex/Edieresis/Igrave/Iacute/Icircumflex/Idieresis
  1126. 16#d0/Eth/Ntilde/Ograve/Oacute/Ocircumflex/Otilde/Odieresis/OE  
  1127. 16#d8/Oslash/Ugrave/Uacute/Ucircumflex/Udieresis/Yacute/Thorn/germandbls
  1128. 16#e0/agrave/aacute/acircumflex/atilde/adieresis/aring/ae/ccedilla
  1129. 16#e8/egrave/eacute/ecircumflex/edieresis/igrave/iacute/icircumflex/idieresis
  1130. 16#f0/eth/ntilde/ograve/oacute/ocircumflex/otilde/odieresis/oe
  1131. 16#f8/oslash/ugrave/uacute/ucircumflex/udieresis/yacute/thorn/ydieresis
  1132. ] def
  1133.  
  1134. % -- @cc    collect bitmap data        - @cc string
  1135. % -- NOTE: Can be temporarily redefined by @N operator
  1136. /@cc
  1137. {    % collect bitmap information from current file (used by @C)
  1138.     currentfile $dat readhexstring pop
  1139. } bd
  1140.  
  1141. % --------------------------- COREL EXTENSIONS ---------------------
  1142. % --Definitions of COREL extensions to the official AI language
  1143. % --All operators start with a @ followed by ONE letter.
  1144.  
  1145. %-- @sm save currentmatrix         - @sm -
  1146. /@sm        % save current transfo matrix into global $ctm
  1147. {    
  1148.     /$ctm $ctm currentmatrix def
  1149. } bd
  1150.  
  1151. %-- @E Define Object's bbox   bbllx bblly bburx bbury matrix @E -
  1152. /@E
  1153. {    % must be called before painting if PATTERNS, PSFILLS, or FOUNTAINS are used
  1154.     /Bbury xd /Bburx xd         % upper right of OBJECT's bbox in absolute space
  1155.     /Bblly xd /Bbllx xd        % lower left of OBJECT's bbox in absolute space
  1156. } bd
  1157.  
  1158. %-- @c Close sub Path
  1159. /@c
  1160. {    % must be called during the path description
  1161.     @cp
  1162. } bd
  1163.  
  1164. %-- @p COREL Tiled pattern fill      name xoffset yoffset xshift yshift matrix pattern_type @p -
  1165. /@p
  1166. {
  1167.     /$fil 1 def                    % set global for pattern filling
  1168.     1 eq /$vectpat xd        % pattern type: 0 - bitmap, 1 - vector
  1169.     /$pm xd                            % current pattern matrix
  1170.     /$psy xd                       % current Y shift before transformation(x & y exclusives)
  1171.     /$psx xd                      % current X shift before transformation(x & y exclusives)
  1172.     /$pyf xd /$pxf xd        % remember X Y original offests (before transformation)
  1173.     /$pn xd                            % remember pattern name    
  1174. } bd
  1175.  
  1176. %-- @P COREL Postscript Fill     parm1 .. parmn n fillname @P -
  1177. /@P
  1178. {     % COREL Postscript fill # of parms can vary 
  1179.     /$fil 3 def                % set global for filling
  1180.     /$Psn xd                    % PS-fill name
  1181.     array astore            % build array for PS-fill parms
  1182.     /$Prm xd                    % parms in Prm
  1183. } bd
  1184.  
  1185. %-- @k Fountain fill CMYK-CMYK    cy ma ye bl cy ma ye bl angle type pad xoff yoff @k -
  1186. /@k
  1187. {        % specifies that the next object will be filled with a fountain
  1188.             % angle is in degrees , "type" is a flag (0 = linear, 1 radial)
  1189.             % pad is the amount of padding to be set around edges( between 0 and 1.0 )
  1190.             % xoff & yoff indicate the radial center offset (relative to bbox size (-1 to 1))
  1191.     /$fil 2 def                % set global for filling
  1192.     /$roy xd /$rox xd /$pad xd
  1193.     /$fty    xd /$fan    xd
  1194.     $fty 1 eq {/$fan 0 def}if        % if radial fill, force angle to 0
  1195.     /$tok xd /$toy xd /$tom    xd /$toc xd
  1196.     /$frk xd /$fry xd /$frm xd /$frc xd
  1197.     /$frn _ def /$frt    1 def /$ton _ def /$tot    1 def
  1198. } bd
  1199.  
  1200. %-- @x Fountain fill custom-custom    cy ma ye bl name tint cy ma ye bl name tint angle type pad xoff yoff @x -
  1201. /@x
  1202. {        % specifies that the next object will be filled with a fountain
  1203.             % angle is in degrees , "type" is a flag (0 = linear, 1 radial)
  1204.             % pad is the amount of padding to be set around edges( between 0 and 1.0 )
  1205.             % xoff & yoff indicate the radial center offset (relative to bbox size (-1 to 1))
  1206.             % Tint 0 is no ink; 1 is Full ink.
  1207.     /$fil 2 def                % set global for filling
  1208.     /$roy xd /$rox xd /$pad xd
  1209.     /$fty    xd /$fan    xd
  1210.     /$tot    xd /$ton xd /$tok xd /$toy xd /$tom    xd /$toc xd
  1211.     /$frt    xd /$frn xd /$frk xd /$fry xd /$frm xd /$frc xd
  1212. } bd
  1213.  
  1214.  
  1215. %-- @ii image preparation         llx lly urx ury matrix @ii -
  1216. /@ii
  1217. {         % common bitmap code
  1218.     concat                    % integrate transo right away
  1219.     3 index 3 index m        % set clipping path(cropping rect)
  1220.     3 index 1 index l 
  1221.     2 copy l 
  1222.     1 index 3 index l
  1223.     3 index 3 index l
  1224.     clip                        % this is the clipping path
  1225.     pop pop pop pop        % pop cropping rect
  1226. } bd
  1227.  
  1228. % -- @i Gray/Mono bitmap        pxlwid pxlhei bits llx lly urx ury 
  1229. %                                        background foreground
  1230. %                                        cropllx croplly cropurx cropury 
  1231. %                                        matrix @i -
  1232. /@i    % gray/mono bitmap image
  1233.         % parms: pxlwid pxlhei : size of bitmap in pixels 
  1234.         %            bits : # of bits per sample
  1235.         %            llx lly urx ury : total size of bitmap(before transfos)
  1236.         %            background:    flag: 1: fill background with current fill attributes, 0: transparent background
  1237.         %            foreground:    flag: 1: mask foreground with current stroke attributes, 0: transparent foreground
  1238.         %            cropllx croplly cropurx cropury: cropping rectangle(before transfos)
  1239.         %            matrix: additional transfo matrix for stretching/rotating, etc..
  1240.         %    NOTE:    height can be negative if it comes from @N operator, in such a
  1241.         %            case, it must be printed upside down.
  1242. {
  1243.     @sm @gs                    % save current ctm and graphics state
  1244.     @ii                        % get common parameters
  1245.  
  1246.     % stack: pxlwid pxlhei bits llx lly urx ury background_flag foreground_flag
  1247.  
  1248.     6 index 1 ne                                            % grayscale bitmap
  1249.     {
  1250.         /$frg true def
  1251.         pop pop
  1252.     }
  1253.     {                                                                    % monochrome bitmap
  1254.         % When doing colour seps of a monochrome bitmap, if the background is
  1255.         % printed, then print the foreground also.
  1256.  
  1257.         1 eq                                                        % Check if foreground flag is set.
  1258.         {
  1259.             $T $C $M $Y $K $N $O @scc            % Set foreground color.
  1260.             /$frg xd
  1261.         }
  1262.         {
  1263.             /$frg false def
  1264.         } ifelse
  1265.  
  1266.         1 eq                                                        % Check if background flag is set.
  1267.         {
  1268.             @gs $ctm setmatrix
  1269.             $t $c $m $y $k $n $o @scc            % Check if background to be filled.
  1270.             {
  1271.                 eofill                                            % If bitmap to be painted, fill background.
  1272.             } if
  1273.             @gr
  1274.         } if
  1275.     } ifelse
  1276.  
  1277.     % If the background of a bitmap fill was painted in "@pf", always paint
  1278.     % the foreground.
  1279.  
  1280.     /$frg $frg $bkg or def
  1281.  
  1282.     @np                        % no path but clipping
  1283.  
  1284.     % stack: pxlwid pxlhei bits llx lly urx ury
  1285.  
  1286.     /$ury xd /$urx xd /$lly xd /$llx xd        % bitmap rectangle
  1287.     /$bts xd                                            % # of bits per sample
  1288.     /$hei xd /$wid xd                                % pixel size
  1289.  
  1290.     /$dat $wid $bts mul 8 div ceiling cvi string def                % string for data entry (each scan line)
  1291.  
  1292.     $frg                        % foreground to be printed?
  1293.     {
  1294.         $SDF {$SCF $SCA $SCP @ss}if        % alternate halftone screen? (determined by stroke attribs)
  1295.             % set params for the imagemask/image operator
  1296.         $llx $lly translate
  1297.         $urx $llx sub $ury $lly sub scale
  1298.         $wid $hei abs                                % if height is negative, print it upside down
  1299.         $bts 1 eq {false}{$bts}ifelse            % either false or #bits/sample 
  1300.         [ $wid 0 0 
  1301.           $hei neg 0 
  1302.           $hei 0 gt{$hei}{0}ifelse]     % matrix(upside down if $hei is negative)
  1303.         /@cc load                              %    @cc can be redefined by @N 
  1304.         $bts 1 eq {imagemask}{image}ifelse
  1305.         $SDF {$dsf $dsa $dsp @ss}if        % reset default halftone screen
  1306.     }
  1307.     {
  1308.         $hei abs {@cc pop} repeat            % skip all lines
  1309.     } ifelse        % in color seps, the foreground might not be printed
  1310.  
  1311.     @gr $ctm setmatrix                     % Restore graphics state & org matrix
  1312.  
  1313. } def      % not bd because @cc can be redefined by @N
  1314.  
  1315. %-- @M Short Bitmap data starts        - @M -
  1316. /@M
  1317. {    % called prior to defining a bitmap pattern/bitmap in vector pattern.
  1318.             % Immediately following this call, there are a sequence of binary
  1319.             % strings defining the bitmap data that will be put on the stack.
  1320.     @sv    % Save VM so that the space occupied by the string(s) is
  1321.             % freed at the end of @N (which performs a restore).
  1322.             % the @N operator must be called to free the stack from all those 
  1323.             % strings and to print the bitmap
  1324.             % BITMAP DATA MUST FIT IN 64K
  1325. }bd
  1326.  
  1327. %-- @N Short bitmap pattern or bitmap in a vector pattern.
  1328. %                string1 string2 ... stringn
  1329. %
  1330. %                pxlwid pxlhei bits llx lly urx ury background foreground
  1331. %                cropllx croplly cropurx cropury matrix 1 @N -
  1332. %
  1333. %                                        or
  1334. %
  1335. %                pxlwid pxlhei bits ncolors llx lly urx ury
  1336. %                cropllx croplly cropurx cropury matrix 0 @N -
  1337. %
  1338. /@N % parms: pxlwid pxlhei : size of bitmap in pixels
  1339.         %            bits : # of bits per sample
  1340.         %            ncolors : number of colors (if color bitmap)
  1341.         %            llx lly urx ury : total size of bitmap(before transfos)
  1342.         %            background:    flag: 1: fill background with current fill attributes, 0: transparent background
  1343.         %                (only for monochrome/grayscale bitmaps)
  1344.         %            foreground:    flag: 1: mask background with current stroke attributes, 0: transparent background
  1345.         %                (only for monochrome/grayscale bitmaps)
  1346.         %            cropllx croplly cropurx cropury: cropping rectangle(before transfos)
  1347.         %            matrix: additional transfo matrix for stretching/rotating, etc..
  1348.         %    NOTE:    height can be negative if it comes from @N operator, in such a
  1349.         %            case, it must be printed upside down.
  1350. {
  1351.     /@cc {} def
  1352.  
  1353.     % Make the bitmap pxl height negative, so that @i/@I knows that the data
  1354.     % is upside down.
  1355.  
  1356.     1 eq
  1357.     {
  1358.         12 -1 roll neg 12 1 roll    % height negative
  1359.         @I
  1360.     }
  1361.     {
  1362.         13 -1 roll neg 13 1 roll    % height negative
  1363.         @i
  1364.     } ifelse
  1365.     @rs
  1366. } bd
  1367.  
  1368. % -- @I Color bitmap                pxlwid pxlhei bits ncolors 
  1369. %                                        llx lly urx ury 
  1370. %                                        cropllx croplly cropurx cropury 
  1371. %                                        matrix @I -
  1372. /@I    % Color bitmap image
  1373.         % parms: pxlwid pxlhei : size of bitmap in pixels
  1374.         %            bits : # of bits per color component(24-bits color is 8 bits per component)
  1375.         %            ncolors: # of color components(RGB=3, CMYK=4)
  1376.         %            llx lly urx ury : total size of bitmap(before transfos)
  1377.         %            cropllx croplly cropurx cropury: cropping rectangle(before transfos)
  1378.         %            matrix: additional transfo matrix for stretching/rotating, etc..
  1379. {
  1380.     @sm @gs                     % save current ctm and graphics state
  1381.     @ii                        % get common parameters
  1382.     @np                        % no path but clipping
  1383.  
  1384.     % stack: pxlwid pxlhei bits ncolors llx lly urx ury
  1385.  
  1386.     /$ury xd /$urx xd /$lly xd /$llx xd        % bitmap rectangle
  1387.     /$ncl xd                                            % # of color components
  1388.     /$bts xd                                            % # of bits per color component
  1389.     /$hei xd /$wid xd                                % pixel size
  1390.     /$dat $wid $bts mul $ncl mul 8 div ceiling cvi string def    % string for data entry (each scan line)
  1391.  
  1392.     % set params for the colorimage operator
  1393.  
  1394.     $llx $lly translate
  1395.     $urx $llx sub $ury $lly sub scale        % set current scale for bitmap size
  1396.     $wid $hei abs                                        % parms for colorimage
  1397.     $bts 
  1398.     [ $wid 0 0 
  1399.       $hei neg 0  
  1400.       $hei 0 gt{$hei}{0}ifelse]     % matrix(upside down if $hei is negative)
  1401.     /@cc load     
  1402.     false $ncl
  1403.     colorimage                                        % colorimage redefined.
  1404.     @gr $ctm setmatrix                               % restore graphics state & original matrix
  1405. } bd
  1406.  
  1407. % -------------------- text support ----------------------------
  1408. %--------------------------------------------------------------------
  1409.     % -- text/font manipulation
  1410. %-- z    findfont                    fontname size z -
  1411. /z
  1412. {        % sets current font, ptsize
  1413.     exch findfont exch scalefont setfont        % set the current font
  1414. } bd
  1415.  
  1416. %-- ZB define raster font
  1417. /ZB         % fontname default_metrics_entry FontBBox FontMatrix ZB
  1418. {
  1419.     9 dict
  1420.  
  1421.     % stack: fontname default_metrics_entry FontBBox FontMatrix fontdict
  1422.  
  1423.     dup begin
  1424.  
  1425.     4 1 roll
  1426.  
  1427.     % stack: fontname fontdict default_metrics_entry FontBBox FontMatrix
  1428.  
  1429.     /FontType 3 def
  1430.     /FontMatrix xd
  1431.     /FontBBox xd
  1432.  
  1433.     % stack: fontname fontdict default_metrics_entry
  1434.  
  1435.     /Encoding 256 array def
  1436.     0 1 255
  1437.     {
  1438.         Encoding exch /.notdef put
  1439.     } for
  1440.  
  1441.     /CharStrings 256 dict def
  1442.     CharStrings /.notdef {} put
  1443.  
  1444.     /Metrics 256 dict def
  1445.  
  1446.     % stack: fontname fontdict default_metrics_entry
  1447.  
  1448.     Metrics /.notdef 3 -1 roll put
  1449.  
  1450.     % stack: fontname fontdict
  1451.  
  1452.     /BuildChar
  1453.     {
  1454.         % stack: font char
  1455.         exch
  1456.  
  1457.         % stack: char font
  1458.  
  1459.         dup /$char exch /Encoding get 3 index get def        % Get character name.
  1460.  
  1461.         % stack: char font
  1462.  
  1463.         % Get origin of next char relative to current char and bounding box
  1464.         % for current char and call setcachedevice.
  1465.  
  1466.         dup /Metrics get $char get aload pop setcachedevice
  1467.  
  1468.         begin
  1469.         Encoding exch get CharStrings exch get
  1470.         end
  1471.         exec
  1472.     } def
  1473.     end
  1474.  
  1475.     % stack: fontname fontdict
  1476.  
  1477.     definefont pop
  1478. } bd
  1479.  
  1480. /ZBAddChar    % metrics_entry char_proc char_code char_name fontname ZBAddChar
  1481. {
  1482.     findfont begin
  1483.  
  1484.     % stack: metrics_entry char_proc char_code char_name
  1485.  
  1486.     dup 4 1 roll dup 6 1 roll
  1487.  
  1488.     % stack: char_name metrics_entry char_name char_proc char_code char_name
  1489.  
  1490.     Encoding 3 1 roll put
  1491.  
  1492.     % stack: char_name metrics_entry char_name char_proc
  1493.  
  1494.     CharStrings 3 1 roll put
  1495.  
  1496.     % stack: char_name metrics_entry
  1497.  
  1498.     Metrics 3 1 roll put
  1499.     end
  1500. } bd
  1501.  
  1502. %-- Z    re-encode font            width-array encode-array newfontname fontname Z -
  1503. /Z
  1504. {
  1505.     % get font dictionary on stack
  1506.  
  1507.     findfont    
  1508.     dup maxlength 2 add dict exch        % get its size    & create new font dictionary
  1509.     % on stack: width-array encode-array newfontname new-dict old-dict
  1510.     
  1511.     % -- copy all entries from the old dict to the new dict
  1512.     dup    
  1513.     {
  1514.         1 index /FID ne                % avoid copying the FID key
  1515.         {                  
  1516.             3 index             % stack: ... newdict olddict key value newdict
  1517.             3 1 roll put    % store entry in dict
  1518.         }                
  1519.         {
  1520.             pop pop
  1521.         } ifelse
  1522.     } forall             % for all entries in the old dict
  1523.     
  1524.     % Now, get the new encoding array into the new dictionary
  1525.     % stack: width-array encode-array  newfontname new-dict old-dict
  1526.  
  1527.     pop                        % don't need old dict anymore    
  1528.  
  1529.     dup dup /Encoding get
  1530.  
  1531.     % stack: width-array encode-array newfontname newdict newdict Encoding
  1532.  
  1533.     256 array copy                % get a copy of original encoding array (to modify)
  1534.     dup /$fe xd                        % prepare a pointer to the dest Encoding array
  1535.     /Encoding exch put        % store copy of original in encoding vect
  1536.  
  1537.     % stack: width-array encode-array  newfontname new-dict
  1538.  
  1539.     dup /Fontname 3 index put    % store it's own new name in that font
  1540.  
  1541.     % stack: width-array encode-array  newfontname new-dict
  1542.  
  1543.     % store the new encoding array into the copy
  1544.  
  1545.     3 -1 roll        % |- width-array newname newdict encode-array
  1546.     dup length 0 ne
  1547.     {
  1548.         0 exch 
  1549.         {    % the array has either numbers or names; initialize counter
  1550.             dup type 0 type eq    % check for numbers
  1551.             {
  1552.                 exch pop            % throw the old number away
  1553.             }
  1554.             {                        % else, must be a char name
  1555.                 $fe exch 2 index exch put    % put it into array
  1556.                 1 add                    % get ready for next
  1557.             } ifelse
  1558.         } forall
  1559.         pop                % remove counter
  1560.     } if
  1561.  
  1562.     % stack: width-array newname newfontdict
  1563.  
  1564.     dup 256 dict
  1565.  
  1566.     %stack: width-array newname newfontdict newfontdict metricsdict
  1567.  
  1568.     dup /$met xd                % prepare a pointer to the dest Metrics dict
  1569.  
  1570.     /Metrics exch put
  1571.  
  1572.     %stack: width-array newname newfontdict
  1573.  
  1574.     % Character widths in width-array are for a 1000 unit character coordinate
  1575.     % system.  If this is not the coordinate system used for this font, the
  1576.     % character widths have to be scaled appropriately.  This scale factor
  1577.     % is being calculated here.
  1578.  
  1579.     dup /FontMatrix get
  1580.     0 get
  1581.     1000 mul
  1582.     1 exch div
  1583.  
  1584.     %stack: width-array newname newfontdict scale-factor
  1585.  
  1586.     % Add character widths in width-array to the font if width-array contains
  1587.     % 256 entries.
  1588.  
  1589.     3 index length 256 eq
  1590.     {
  1591.         0 1 255
  1592.         {
  1593.             %stack: width-array newname newfontdict scale-factor index
  1594.  
  1595.             dup $fe exch get
  1596.  
  1597.             %stack: width-array newname newfontdict scale-factor index char
  1598.  
  1599.             dup /.notdef eq
  1600.             {
  1601.                 pop pop
  1602.             }
  1603.             {
  1604.                 %stack: width-array newname newfontdict scale-factor index char
  1605.  
  1606.                 5 index
  1607.  
  1608.                 3 -1 roll get
  1609.  
  1610.                 % stack: width-array newname newfontdict scale-factor char char-width
  1611.  
  1612.                 2 index mul
  1613.  
  1614.                 $met 3 1 roll put
  1615.             } ifelse
  1616.         } for
  1617.     }    if
  1618.  
  1619.     pop
  1620.  
  1621.     %stack: width-array newname newfontdict
  1622.  
  1623.     definefont pop        % then, record that new font in the font list
  1624.  
  1625.     %stack: width-array
  1626.  
  1627.     pop
  1628.  
  1629. } bd
  1630.     
  1631. %-- @ftx Text fill(special)    string @ftx -
  1632. /@ftx     % fill text with pattern or fountain
  1633. {
  1634.     {        % loop for each character in the string
  1635.         (0) dup 3 -1 roll 0 exch put        % convert integer into a string
  1636.         @gs
  1637.         true charpath                         % get character outline in path
  1638.         $ctm setmatrix                        % set matrix for pattern filling
  1639.         @@txt                                            % pattern fill or fountain fill
  1640.         @gr
  1641.         @np
  1642.     } forall
  1643. } bd
  1644.  
  1645.  
  1646. %--@ft    fill text object        string @ft -
  1647. /@ft            % fill current text object
  1648. {
  1649.     matrix currentmatrix exch            % save current transfo matrix on stack
  1650.     $sdf {$scf $sca $scp @ss} if    % alternate halftone screen?
  1651.     $fil 1 eq                                     % pattern fill?
  1652.     {/@@txt /@pf ld @ftx}         % pattern fill on text
  1653.     {
  1654.         $fil 2 eq                                % fountain fill?
  1655.         {/@@txt /@ff ld @ftx}        % fountain fill on text
  1656.         {
  1657.             $fil 3 eq                            % Postscript fill?
  1658.             {/@@txt /@Pf ld @ftx}    % PS fill on text
  1659.             {
  1660.                 $t $c $m $y $k $n $o @scc                    % set FILL color, returns TRUE if we fill, FALSE if not
  1661.                 {show}                                                        % show text
  1662.                 {pop} ifelse
  1663.             } ifelse
  1664.         } ifelse
  1665.     } ifelse                        
  1666.     $sdf {$dsf $dsa $dsp @ss} if        % reset default halftone screen
  1667.     setmatrix                                             % reset original transfo matrix on stack
  1668. } bd
  1669.  
  1670. %--@st    stroke text object        string @st -
  1671. /@st            % stroke current text object
  1672. {
  1673.     matrix currentmatrix exch                    % save current transfo matrix on stack
  1674.     $SDF {$SCF $SCA $SCP @ss} if            % alternate halftone screen?
  1675.     $T $C $M $Y $K $N $O @scc                    % set STROKE color, returns TRUE if we stroke, FALSE if not
  1676.     {    
  1677.         {        % loop for each character in the string
  1678.             (0) dup 3 -1 roll 0 exch put    % convert integer into a string
  1679.             @gs
  1680.             true charpath                                 % get character outline in path
  1681.             $ctm setmatrix $ptm concat        % set matrix for stroking
  1682.             stroke                                                % stroke it
  1683.             @gr
  1684.         } forall
  1685.     }
  1686.     {pop} ifelse        % @scc
  1687.     $SDF {$dsf $dsa $dsp @ss} if        % reset default halftone screen
  1688.     setmatrix                                 % reset original transfo matrix on stack
  1689. } bd
  1690.  
  1691. %--@te    print filled text     string @te -
  1692. /@te        % prints text as filled only    
  1693. {
  1694.     @ft                        % fill that text
  1695. } bd
  1696.  
  1697. %--@tr    print stroked text     string @tr -
  1698. /@tr        % prints text as stroked only    
  1699. {
  1700.     @st                        % stroke that text
  1701. } bd
  1702.  
  1703. %--@ta    fill & stroke text      string @ta -
  1704. /@ta        % prints text as filled & stroked
  1705. {
  1706.     dup
  1707.     @gs @ft @gr                % fill the text
  1708.     @st                        % then stroke text
  1709. } bd
  1710.  
  1711. %--@t@a    stroke & fill text      string @t@a -
  1712. /@t@a        % prints text as stroked & filled 
  1713. {
  1714.     dup
  1715.     @gs @st @gr                % stroke the text
  1716.     @ft                         % then fill text
  1717. } bd
  1718.  
  1719. %-- @tm set text matrix            matrix @tm -
  1720. /@tm
  1721. {
  1722.     % Create a VM snapshot to be restored when the text object processing
  1723.     % is finished (See the T operator).  This allows memory consumed for
  1724.     % strings and matrices during processing of the text object to be freed.
  1725.  
  1726.     /$textsave save def
  1727.  
  1728.     @sm                % save current matrix
  1729.     concat
  1730. } bd
  1731.  
  1732. %-- e    filled text                - e -
  1733. /e
  1734. {
  1735.     /t {@te} def            % define operator t as @te
  1736. } bd
  1737.  
  1738. %-- r    stroked text            - r -
  1739. /r
  1740. {
  1741.     /t {@tr} def            % define operator t as @tr
  1742. } bd
  1743.  
  1744. %-- o    invisible text          - o -
  1745. /o
  1746. {
  1747.     /t {pop} def            % define operator t as nothing
  1748. } bd
  1749.  
  1750. %-- a    fill&stroke text        - a -
  1751. /a
  1752. {
  1753.     /t {@ta} def            % define operator t as @ta
  1754. } bd
  1755.  
  1756.  
  1757. %-- @a stroke&fill text        - @a -
  1758. %--@a 
  1759. /@a
  1760. {
  1761.     /t {@t@a} def            % define operator t as @t@a
  1762. } bd
  1763.  
  1764. %-- t    text body                string t -
  1765. /t {@te} def            % default value: will be redefined by a,e,o,r, and I
  1766.  
  1767. %-- T    end text (restore)        - T -
  1768. /T
  1769. {
  1770.     @np                                % Clear path.
  1771.     $ctm setmatrix        % Reset current matrix.
  1772.     /$ttm matrix def    % Reset extended text matrix.
  1773.  
  1774.     % Restore VM snapshot.
  1775.  
  1776.     $textsave restore
  1777. } bd
  1778.  
  1779.  
  1780. %-- @t 1-character text        xpos ypos string  @t -
  1781. /@t            % -- paints a 1-character string at desired position
  1782. {
  1783.     /$stm $stm currentmatrix def    % save current matrix
  1784.     3 1 roll                                            % send string to bottom
  1785.     moveto                                                % move to character position
  1786.     $ttm concat                                        % add text matrix
  1787.     t                                                          % draw the character (current t operator)
  1788.     $stm setmatrix                                % restore saved matrix
  1789. } def    % NO "bind def" because of t (can be modified)    
  1790.  
  1791. %-- @n character angle        angle @n -
  1792. /@n        % set current caracter angle (held in matrix $ttm)
  1793. {
  1794.     /$ttm exch matrix rotate def     % modify current text matrix accordingly
  1795. } bd
  1796.  
  1797. % -- @s : Mark a space        - @s -
  1798. /@s {} bd        % does nothing but mark a space character in extended text
  1799.  
  1800. % -- @l : Mark an end of line        - @l -
  1801. /@l {} bd        % does nothing but mark an end of line in extended text
  1802.  
  1803.  
  1804. %-- @B    stroke, then fill        - @B -
  1805. /@B
  1806. {
  1807.     @gs S    @gr                    % stroke
  1808.     F                                % fill
  1809. } bd
  1810.  
  1811. %-- @b closepath, stroke & fill path - @b -
  1812. /@b
  1813. {
  1814.     @cp @B
  1815. } bd
  1816.  
  1817. %-- @w  calligraphic pen matrix        [matrix] bscale width height angle @w -
  1818. /@w
  1819. {        % set pen matrix "$ptm" to desired settings
  1820.         % bscale is a flag: 1: "scale with object",  0 no scale
  1821.         % matrix is passed only if bscale is 1 (object total matrix)
  1822.  
  1823.     matrix rotate /$ptm xd        % define $ptm to be rotation matrix
  1824.     matrix scale                             % set pen shape
  1825.     $ptm dup concatmatrix /$ptm xd
  1826.     1 eq                        % if scale, concat object matrix
  1827.     {
  1828.         $ptm exch dup concatmatrix /$ptm xd
  1829.     } if
  1830.     1 w                                % basic thickness to be transformed by $ptm
  1831. } bd    
  1832.     
  1833. %-- @g setscreen for fill        freq ang spotproc 1 @g -
  1834. %or default screen for fill    0 @g -
  1835. /@g
  1836. {  % Set halftone screen for gray filling
  1837.          % parm spotproc is a spot procedure name (ex: /@dot or /@lin)
  1838.     1 eq dup /$sdf xd            % set global flag
  1839.     {    % next 3 parameters are set only if parm1 is 1
  1840.         /$scp xd                    % Current spot func for fill
  1841.  
  1842.         % 29-Jan-91:KB:Removed the negation of screen angle to make work like 1.21 did
  1843.         /$sca xd            % Current screen angle for fill
  1844.         /$scf xd                    % Current screen frequency for fill
  1845.     } if
  1846. } bd 
  1847.  
  1848. %-- @G setscreen for stroke        freq ang spotproc 1 @G -
  1849. %or default screen for stroke        0 @G -
  1850. /@G
  1851. {  % Set halftone screen for gray filling
  1852.          % parm spotproc is a spot procedure name (ex: /@dot ot /@lin)
  1853.     1 eq dup /$SDF xd            % set global flag
  1854.     {    % next 3 parameters are set only if parm1 is 1
  1855.         /$SCP xd                    % Current spot func for stroke
  1856.  
  1857.         % 29-Jan-91:KB:Removed the negation of screen angle to make work like 1.21 did
  1858.         /$SCA xd             % Current screen angle for stroke
  1859.         /$SCF xd                    % Current screen frequency for stroke
  1860.     } if
  1861. } bd
  1862.  
  1863. %-- @D setscreen for all document    freq ang spotproc @D -
  1864. /@D
  1865. {  % Set halftone screen for all document
  1866.     3 copy  @ss                % set that screen right now
  1867.     /$dsp xd                    % default spot func name
  1868.     /$dsa xd                    % default screen angle
  1869.     /$dsf xd                    % default screen frequency function
  1870. } bd
  1871.  
  1872. %-- @j Begin Arrow head            @j -
  1873. /@j
  1874. {    % -- DEF: BEGIN ARROW HEAD
  1875.             % -- Stack:  nothing  
  1876.     @sv        % this is just a save followed by a new path
  1877.     @np        % Look at @J for the corresponding restore
  1878. } bind def
  1879.  
  1880. %-- @J End Arrow head            @J -
  1881. /@J
  1882. {    % -- DEF: END ARROW HEAD
  1883.             % -- Stack:  nothing  
  1884.     @rs        % this is just a grestore; Look at @j for the corresponding save
  1885. } bind def
  1886.  
  1887. % --- color separation support---
  1888. % --@sep  Initialize color separation mode     - @sep -
  1889. /@sep
  1890. {
  1891.         %    ColorSeparationMode defines the current mode for color separation
  1892.         %  Possible values are:    0-composite(no color seps)
  1893.         %                                1-CMYK Only (maximum four colors, custom colors converted)
  1894.         %                                2-CMYK+Customs (four colors + each of the customs)
  1895.     /ColorSeparationMode where
  1896.     {pop}         
  1897.     {
  1898.         /ColorSeparationMode 0 def            % if not defined previously: composite
  1899.         /CurrentInkName (Composite) def    % if not defined previously: composite
  1900.     }ifelse
  1901.  
  1902.     ColorSeparationMode 0 eq                % if not defined previously: composite
  1903.     {
  1904.         /CurrentInkName (Composite) def
  1905.     } if
  1906.         
  1907.     %    CurrentInkName is a string defining the current color plane being 
  1908.     %  printed.  The possible values are: (case sensitive, not to be translated)
  1909.     %     (Composite), (Cyan), (Magenta), (Yellow), (Black), 
  1910.     %     or any of the custom colors defined in the document; e.g.: (Pantone 345)
  1911.     %  Custom color names are only valid when  "ColorSeparationMode" is 2.
  1912.  
  1913.     /CurrentInkName where
  1914.     {pop}         
  1915.     {
  1916.         /CurrentInkName (Composite) def        % if not defined previously: composite
  1917.     } ifelse
  1918.     
  1919.     %-- Internally, a numeric variable ($ink)    indicates the numeric value for the
  1920.     %    current ink, -1:composite, 0:cyan, 1:magenta, 2:yellow, 3:Black, 4: any custom
  1921.     CurrentInkName (Composite) eq 
  1922.     {/$ink -1 def}
  1923.     {
  1924.         CurrentInkName (Cyan) eq
  1925.         {/$ink 0 def}
  1926.         {
  1927.             CurrentInkName (Magenta) eq
  1928.             {/$ink 1 def}
  1929.             {
  1930.                 CurrentInkName (Yellow) eq
  1931.                 {/$ink 2 def}
  1932.                 {
  1933.                     CurrentInkName (Black) eq
  1934.                     {/$ink 3 def}
  1935.                     {
  1936.                         /$ink 4 def
  1937.                     } ifelse
  1938.                 } ifelse
  1939.             } ifelse
  1940.         } ifelse
  1941.     } ifelse
  1942. } bd
  1943. @sep    % -- And by default, call it (Can also be called in the setup section)
  1944.  
  1945. %-- @whi Fill Page white        - @whi -
  1946. /@whi
  1947. {    %- Fill everything white
  1948.     @gs
  1949.     -72000 dup moveto
  1950.     -72000 72000 lineto
  1951.     72000 dup lineto
  1952.     72000 -72000 lineto
  1953.     closepath 1 setgray fill
  1954.     @gr
  1955. } bd     
  1956.  
  1957. %-- @neg Print negative            - @neg -
  1958. /@neg
  1959. { %def -- MAKE ALL COLORS NEGATIVE  -- STACK: -
  1960.         % Only set the GRAY scale transfer function since WALDO only 
  1961.         % Uses negative for color separations.
  1962.     [{1 exch sub} /exec cvx currenttransfer /exec cvx] cvx settransfer
  1963.     @whi                            % fill page in white (Will be turned into white)
  1964. } bd
  1965.  
  1966. %-- @reg Print registration mark        x y @reg -
  1967. /@reg
  1968. {
  1969.     % 25-Apr-91:KB:Reset line type to solid
  1970.     [] 0 d
  1971.     0 setgray .3 setlinewidth
  1972.     2 copy 5.4 0 360 arc closepath
  1973.     2 copy moveto 9 0 rlineto 
  1974.     2 copy moveto -9 0 rlineto 
  1975.     2 copy moveto 0 9  rlineto 
  1976.     moveto 0 -9 rlineto stroke
  1977. } bd
  1978.  
  1979. /leftbracket {(\050)} def
  1980. /rightbracket {(\051)} def
  1981.