%----------------------------------------------------------------------------

% Text support
%----------------------------------------------------------------------------

%----------------------------------------------------------------------------
% Proc: z
% Stack: fontname size z -
% Desc: sets current font, ptsize
%----------------------------------------------------------------------------
/z
{
exch findfont exch scalefont
setfont % set the current
font
} bd

%----------------------------------------------------------------------------
% Proc: ZB
% Stack: fontname default_metrics_entry FontBBox FontMatrix ZB
% Desc: define raster font
%----------------------------------------------------------------------------
/ZB
{
9 dict %:
fontname default_metrics_entry FontBBox

%... FontMatrix fontdict

dup begin
4 1 roll %: fontname
fontdict default_metrics_entry

%... FontBBox FontMatrix

/FontType 3 def
/FontMatrix xd
/FontBBox xd

%: fontname fontdict default_metrics_entry

/Encoding 256 array def
0 1 255
{
Encoding exch /.notdef put
} for
/CharStrings 256 dict def
CharStrings /.notdef {} put

/Metrics 256 dict def %: fontname fontdict

default_metrics_entry

Metrics /.notdef 3 -1 roll put

% stack: fontname fontdict

/BuildChar
{ %
stack: font char
exch %
stack: char font
dup /$char exch /Encoding get 3 index get def % Get character name.

% stack: char font

 % Get origin of next char relative to current char and bounding box
% for current char and call setcachedevice.

dup /Metrics get $char get aload pop setcachedevice

begin
Encoding exch get CharStrings exch get
end
exec
} def
end %
stack: fontname fontdict

definefont pop
} bd

%----------------------------------------------------------------------------
% Proc: ZBAddChar
% Stack: metrics_entry char_proc char_code char_name fontname ZBAddChar
% Desc:
%----------------------------------------------------------------------------
/ZBAddChar
{
findfont begin %: metrics_entry
char_proc char_code char_name
dup 4 1 roll dup 6 1 roll %: char_name metrics_entry char_name char_proc
char_code char_name
Encoding 3 1 roll put %: char_name metrics_entry char_name
char_proc
CharStrings 3 1 roll put %: char_name metrics_entry
Metrics 3 1 roll put
end
} bd

%----------------------------------------------------------------------------
% Proc: Z
% Stack: width-array encode-array newfontname fontname Z -
% Desc: re-encode font
%----------------------------------------------------------------------------
/Z
{
findfont % get font
dictionary on stack
dup maxlength 2 add dict exch % get its size & create new font dictionary

%: width-array encode-array newfontname

%... new-dict old-dict

dup % copy
entries from old dict to the new dict
{
1 index /FID ne % avoid copying the FID key
{
3 index %: ... newdict olddict
key value newdict
3 1 roll put % store entry in dict
}
{
 pop pop
} ifelse
} forall % for all entries
in the old dict

% Now, get the new encoding array into the new dictionary
% stack: width-array encode-array newfontname new-dict old-dict

pop % don't need old dict

anymore
dup dup /Encoding get %: width-array encode-array newfontname

%... newdict newdict Encoding

256 array copy % get a copy of original encoding
array (to modify)
dup /$fe xd % prepare a pointer to the dest Encoding
array
/Encoding exch put % store copy of original in encoding vect

%: width-array encode-array newfontname

%... new-dict
dup /Fontname 3 index put % store it's own new name in that font

%: width-array encode-array newfontname

%... new-dict

% store the new encoding array into the copy

3 -1 roll %: width-array newname
newdict encode-array
dup length 0 ne
{
0 exch
{ % initialize
counter
dup type 0 type eq % check for numbers
{
exch pop % throw the old number
away
}
{ % else, must be a char name
$fe exch 2 index exch put % put it into array
1 add % get ready for next
} ifelse
} forall
pop % remove counter
} if %:
width-array newname newfontdict

dup 256 dict %: width-array

newname newfontdict newfontdict

%... metricsdict
dup /$met xd % prepare a pointer to the dest
Metrics dict
/Metrics exch put %stack: width-array newname
newfontdict
 % Character widths in width-array are for a 1000 unit character coordinate
% system. If this is not the coordinate system used for this font, the
% character widths have to be scaled appropriately. This scale factor
% is being calculated here.

dup /FontMatrix get

0 get
1000 mul
1 exch div

%stack: width-array newname newfontdict scale-factor

% Add character widths in width-array to the font if width-array contains
% 256 entries.

3 index length 256 eq

{
0 1 255
{
%: width-array newname newfontdict

%... scale-factor index

dup $fe exch get %: width-array newname
newfontdict

%... scale-factor index char

dup /.notdef eq
{
pop pop
}
{ %: width-
array newname newfontdict

%... scale-factor index char

5 index
3 -1 roll get %: width-array newname
newfontdict

%... scale-factor char char-width

2 index mul
$met 3 1 roll put
} ifelse
} for
} if

pop %:
width-array newname newfontdict
definefont pop % then, record that new font
in the font list

%: width-array
pop
} bd

%----------------------------------------------------------------------------
% Proc: CorelIsValidCharpath
% Stack: @ftx bool
% Desc: checks current path if it has points or is bogus. Used mainly to
% weed out space characters which only have a moveto in their
path.
% NOTE : can't just check if width or height = 0, even with 1
moveto as the
% current path, interpreters will return a box with width and/or
height
%----------------------------------------------------------------------------
/CorelIsValidCharpath
{
pathbbox
3 -1 roll

sub abs 0.5 ge % see if we have a width

3 1 roll
sub abs 0.5 ge % see if we have a height
and
} bd

%----------------------------------------------------------------------------
% Proc: @ftx
% Stack: string @ftx -
% Desc: fill text with pattern or fountain
%----------------------------------------------------------------------------
/@ftx
{
{ % loop
for each character in the string
currentpoint 3 -1 roll %
(0) dup 3 -1 roll 0 exch put % convert integer into a string
dup
@gs
true charpath % get character outline in
path
$ctm setmatrix % set matrix for pattern
filling
CorelIsValidCharpath % check if we have a valid
charpath
{@@txt} if % pattern fill or fountain
@gr
@np
% set current point for next character
stringwidth pop 3 -1 roll add exch m
} forall
} bd

%----------------------------------------------------------------------------
% Proc: @ft
% Stack: string @ft -
% Desc: fill current text object
%----------------------------------------------------------------------------
/@ft
{
matrix currentmatrix exch % save current transfo matrix on stack
$sdf {$scf $sca $scp @ss} if % alternate halftone screen?
$fil 1 eq % pattern fill?
{/@@txt /@pf ld @ftx} % pattern fill on text
{
$fil 2 eq % fountain fill?
{/@@txt /gradient_fill ld @ftx} % fountain fill on text
{
$fil 3 eq % Postscript fill?
 {/@@txt /@Pf ld @ftx} % PS fill on text
{
$fil 4 eq
{/@@txt /output_shading_gradient ld @ftx} % Level3 shaded fill on text
{
FillOverprint safe_setoverprint
FillColor /separate_set_color dexec % separate and set
fill color, returns TRUE if we fill, FALSE if not
{show} % show text
{pop} ifelse
} ifelse
} ifelse
} ifelse
} ifelse
$sdf {$dsf $dsa $dsp @ss} if % reset default halftone screen
setmatrix % reset original transfo matrix on stack
} bd

%----------------------------------------------------------------------------
% Proc: @st
% Stack: string @st -
% Desc: stroke current text object
%----------------------------------------------------------------------------
/@st
{
matrix currentmatrix exch % save current transfo matrix on
stack
$SDF {$SCF $SCA $SCP @ss} if % alternate halftone screen?
OutlineOverprint safe_setoverprint
OutlineColor /separate_set_color dexec % separate and set current stroke
color, returns TRUE if we paint, FALSE if not
{
{ % loop
for each character in the string
currentpoint 3 -1 roll
(0) dup 3 -1 roll 0 exch put % convert integer into a string
dup
@gs
true charpath % get character outline in path
$ctm setmatrix $ptm concat % set matrix for stroking
stroke % stroke it
@gr
@np

% set current point for next character

stringwidth pop 3 -1 roll add exch m
} forall
}
{pop} ifelse % @scc_5
$SDF {$dsf $dsa $dsp @ss} if % reset default halftone screen
setmatrix % reset original transfo matrix on stack
} bd

%----------------------------------------------------------------------------
% Proc: @te
% Stack: string @te -
% Desc: prints text as filled only
%----------------------------------------------------------------------------
/@te
{
@ft % fill that text
} bd

%----------------------------------------------------------------------------
% Proc: @tr
% Stack: string @tr -
% Desc: prints text as stroked only
%----------------------------------------------------------------------------
/@tr % prints
text as stroked only
{
@st % stroke that text
} bd

%----------------------------------------------------------------------------
% Proc: @ta
% Stack: string @ta -
% Desc: prints text as filled & stroked
%----------------------------------------------------------------------------
/@ta
{
dup
@gs @ft @gr % fill the text
@st % then stroke text
} bd

%----------------------------------------------------------------------------
% Proc: @t@a
% Stack: string @t@a -
% Desc: prints text as stroked & filled
%----------------------------------------------------------------------------
/@t@a
{
dup
@gs @st @gr % stroke the text
@ft % then fill text
} bd

%----------------------------------------------------------------------------
% Proc: @tm
% Stack: matrix @tm -
% Desc: set text matrix
%----------------------------------------------------------------------------
/@tm
{
@sm % save current
matrix
concat
} bd

%----------------------------------------------------------------------------
% Proc: e
% Stack: - e -
% Desc: filled tex
%----------------------------------------------------------------------------
/e
{
/t {@te} def % define operator t as @te
} bd

%----------------------------------------------------------------------------
% Proc: r
% Stack: - r -
% Desc: stroked text
%----------------------------------------------------------------------------
/r
{
/t {@tr} def % define operator t as @tr
} bd

%----------------------------------------------------------------------------
% Proc: o
% Stack: - o -
% Desc: invisible text
%----------------------------------------------------------------------------
/o
{
/t {pop} def % define operator t as
nothing
} bd

%----------------------------------------------------------------------------
% Proc: a
% Stack: - a -
% Desc: fill&stroke text
%----------------------------------------------------------------------------
/a
{
/t {@ta} def % define operator t as @ta
} bd

%----------------------------------------------------------------------------
% Proc: @a
% Stack: - @a -
% Desc: stroke&fill text
%----------------------------------------------------------------------------
/@a
{
/t {@t@a} def % define operator t as @t@a
} bd

%----------------------------------------------------------------------------
% Proc: t
% Stack: string t -
% Desc: text body
%----------------------------------------------------------------------------
/t {@te} def % default value: will be
redefined by a,e,o,r, and I

%----------------------------------------------------------------------------
% Proc: T
% Stack: - T -
% Desc: end text (restore)
%----------------------------------------------------------------------------
/T
{
 @np % Clear path.
$ctm setmatrix % Reset current matrix.
/$ttm matrix def % Reset extended text matrix.
} bd

%----------------------------------------------------------------------------
% Proc: ddt
% Stack:
% Desc:
%----------------------------------------------------------------------------
/ddt
{
t
} def % NO "bind
def" because of t (can be modified)

%----------------------------------------------------------------------------
% Proc: @t
% Stack: xpos ypos string @t -
% Desc: paints a 1-character string at desired position
%----------------------------------------------------------------------------
/@t % paints a 1-
character string at desired position
{
/$stm $stm currentmatrix def % save current matrix
3 1 roll % send string to bottom
m % move to character position
$ttm concat % add text matrix
ddt % draw the character (current t operator)
$stm setmatrix % restore saved matrix
} bd

%----------------------------------------------------------------------------
% Proc: @n
% Stack: angle @n -
% Desc: paints a 1-character string at desired position
%----------------------------------------------------------------------------
/@n
{
/$ttm exch matrix rotate def % modify current text matrix accordingly
} bd

%----------------------------------------------------------------------------
% Proc: @s
% Stack: - @s -
% Desc: Mark a space
%----------------------------------------------------------------------------
/@s {} bd % mark a
space character in extended text

%----------------------------------------------------------------------------
% Proc: @l
% Stack: - @l -
% Desc: Mark an end of line
%----------------------------------------------------------------------------
/@l {} bd % mark an end of line in
extended text

%----------------------------------------------------------------------------
% Initalizations for CJK fonts
%----------------------------------------------------------------------------
/_lineorientation 0 def
/_bitfont null def
/_bitlobyte 0 def
/_bitkey null def
/_bithibyte 0 def