% Expect PDdict to be at the top of dict stack and have room

% Some useful abbreviations

/BD { bind def } bind def                     % makes the output shorter
/LD { load def } BD                           % makes the output shorter
/GS /gsave LD
/GR /grestore LD
/M /moveto LD
/I /index LD
/SCM /setmatrix LD
/CCM /concatmatrix LD

/LookupFont {
   dup load findfont 3 -1 roll scalefont def
} bind def

/StartPage {
   save 7 1 roll
   neg /RH exch def
   /CW exch def
   dup dup dup
   /NF LookupFont
   /BF LookupFont
   /IF LookupFont
   /BIF LookupFont
   120 /TF LookupFont
   0.1 dup scale
   rotate
   translate
} bind def

/EndPage {
   restore
   showpage
} bind def

/MT {
   CW mul exch RH mul moveto
} bind def

/FI {
   /F0 exch def
   /FW 1 def
} bind def

/FS {
   F0 exch div /FW exch def
   0 () SS
} bind def

/SS {
   exch /BITS exch def
   BITS 64 and 0 ne
   {
      TF setfont show
   }
   {
      BITS 1 and 0 ne  % Bits 0 and 2 are Bold and Italic
      {
          BITS 4 and 0 ne { BIF } { BF } ifelse
      }
      { 
          BITS 4 and 0 ne { IF } { NF } ifelse
      } ifelse
      % Stack => (string) font
      [FW 0 0 1 0 0] makefont setfont
      BITS 56 and 0 ne
      {
         gsave
           newpath 0 0 moveto
           (I) true charpath flattenpath pathbbox
           /VH exch def pop pop pop
         grestore
      } if
      BITS 8 and 0 ne
      {
         currentpoint VH 0.3 mul sub /Y0 exch def /X0 exch def
      } if
      BITS 48 and 0 ne
      { 
         /VS VH 0.4 mul def
         BITS 16 and 0 eq { /VS VS neg def} if
         currentfont [1 0 0 .8 0 VS] makefont setfont
      } if
      show
      BITS 8 and 0 ne
      {
         currentpoint pop /X1 exch def
         gsave
           newpath VH 0.05 mul setlinewidth
           X0 Y0 moveto X1 X0 sub 0 rlineto stroke
         grestore
      } if
   } ifelse
} bind def

% %%%%%%%%%%%%%%%
% Procedures to do font remapping, matrix alteration and re-encoding.
% THESE ARE COPIED VERBATIM FROM Sources.PDModules.Sources.PDriverPS.Prologue.PSlongprol.
% DO NOT EDIT THESE; COPY THE LATEST VERSIONS FROM THERE.
% %%%%%%%%%%%%%%%


% Lookup table to see if an accent is valid
  /VALACC 14 dict dup begin
    /acute 1 def
    /grave 1 def
    /circumflex 1 def
    /dieresis 1 def
    /ring 1 def
    /tilde 1 def
    /breve 1 def
    /caron 1 def
    /cedilla 1 def
    /dotaccent 1 def
    /hungarumlaut 1 def
    /slash 1 def
    /macron 1 def
    /ogonek 1 def
  end def

% Is this glyph known, and is it a real charstring?

  /CKN                                          % charstringdict glyphname -- bool
  {
    2 copy known
    {
      get type /arraytype ne
    }
    { pop pop false } ifelse
  } def

% Should/can we auto-accent this character? Takes CharStrings dict and
% glyph name on the stack.

  /OKA                                          % csdict glyphname -- lettername accentname true (success)
                                                % csdict glyphname -- false (failure)
  {
    2 copy known
    { pop pop false }
    {
      dup length dup 1 gt                       % is it big enough?
      {                                         % csdict glyphname length 
        string cvs                              % csdict glyphstr
        dup 0 1 getinterval cvn                 % csdict glyphstr lettername
        exch
        1 1 I length 1 sub                      % csdict lettername glyphstr 1 len-1
        getinterval cvn                         % csdict lettername accentname

        % They must both be in CharStrings and both be real CharStrings
        % (not procs).

        3 -1 roll                               % lettername accentname csdict
        dup 2 I CKN                             % lettername accentname csdict bool
        exch 3 I CKN and                        % lettername accentname bool

        % Check that accentname is a valid accent char
        VALACC 2 I known and                % lettername accentname bool

        {
          true
        }
        { pop pop false }
        ifelse

        % Is the accent a valid one? INSERT TEST HERE
      }
      { pop pop pop false } ifelse
    } ifelse
  } def


  % RF copies a font, possibly applying an additional matrix.

  /RF                                           % newname matrix parentfont -- (font defined)
  {
      findfont false 3 1 roll _RFE
  } def


  /_RFE                                         % newname encoding matrix oldfontdict -- (font defined)
  {
    dup length dict begin                       % newname matrix olddict
      {
        1 I /FID ne
        { def } { pop pop } ifelse
      } forall                                  % newname matrix

      % Deal with the matrix

      dup type /arraytype eq
      { /FontMatrix FontMatrix 3 -1 roll 6 array CCM def }
      { pop } ifelse                            % newname

      % Deal with the encoding
      dup type /arraytype eq  currentdict /Encoding known and
      { /Encoding exch def } { pop } ifelse

    currentdict end
    definefont pop
  } def

  /RFE                                          % newname encoding matrix oldfontname -- (font defined)
  {
    findfont dup /CharStrings known
    { RFET1 } { _RFE } ifelse
  } def


  % RFE copies a font, possibly applying an additional matrix and a new encoding.
  % Adds auto-accent support. encoding may
  % be false, which means copy parent's encoding. matrix may be false
  % which means copy parent's matrix.

  /RFET1                                        % newname encoding matrix oldfontdict -- (font defined)
  {
    dup length 4 add dict begin                 % newname encoding matrix oldfontdict

    % Some useful routines - put them in the font dict itself
    % so that we're self-contained. Perhaps should be in a
    % subdictionary.

    % pathbbox returns too large a bbox if the path is rotated or skewed!
    % Do the sums in font coordinate system.

    /CBOX                                       % (s) -- bbox wx wy (alters path and point)
    {
      newpath 0 0 M
      GS ifm SCM
      false charpath matrix SCM pathbbox currentpoint GR
    } BD

    /CHEI                                       % (s) -- height (alters path and point)
    {
      CBOX pop pop 4 1 roll pop pop pop
    } BD

    % Could use far more efficient code if glyphshow could be relied upon
    % Try to make it conditional on "known", later on.

    /SRCH                                       % glyphname -- str true OR false false
    {
      -1 exch                                   % -1 name
      /Encoding load   0 1                      % -1 name enc 0 1
      2 I length 1 sub                          % -1 name enc 0 1 limit
      {                                         % -1 name enc I
        2 copy get                              % -1 name enc I name2
        3 I eq                                  % -1 name enc I bool
        {                                       % -1 name enc I
          4 -1 roll pop
          3 1 roll
          exit                                  % I name enc
        } {
          pop                                   % -1 name enc
        } ifelse                                % tag name enc
      } for
      pop pop
      dup -1 ne { 1 string dup 0 4 -1 roll put true } { pop false false } ifelse
    } BD


    /MKACC                                      % glyphname|code lettername accentname -- (paints char)
    {
      % Get their character codes from encoding.  Note that we can't
      % do this at re-encode time because we might have re-encoded again
      % in the meantime (also want to keep re-encoding fast).

      SRCH                                      % lettername accentstr bool
      3 -1 roll SRCH                            % accentstr bool letterstr bool
      3 -1 roll and
      {                                         % accentstr letterstr
      % Both chars available, so let's do it.

        3 dict begin
        /letter exch def
        /accent exch def                        % --
        /ifm /FontMatrix load matrix invertmatrix def

      % Centering: horizontally, we must calculate the actual
      % centre of the char, since they differ so much.  Vertically
      % we trust the type designer for lowercase letters, and
      % add the cap-height minus the x-height for letters which
      % extend above the x-height, UNLESS the bottom of the accent
      % is below the baseline, in which case don't adjust vertically. 

      % Ought to precalculate a lot of this!  (Would need to do it
      % all in character coord space, which is more fiddly).

      % Show "kindly" applied the font matrix; we don't want this
      % because the shows and charpaths below apply it again!

        GS

        matrix SCM
        letter CBOX                             % llx lly lux luy wx wy
        6 2 roll                                % wx wy llx lly lux luy
        accent CBOX pop pop                     % wx wy llx lly lux luy alx aly aux auy

      % X adjust is (Lw-Aw)/2 + (Llx - Alx)

        6 -1 roll 7 I sub                       % wx wy llx lly luy alx aly aux auy Lw
        3 -1 roll 4 I sub                       % wx wy llx lly luy alx aly auy Lw Aw
        sub 2 div                               % wx wy llx lly luy alx aly auy Dw/2
        7 -1 roll 5 -1 roll sub                 % wx wy lly luy aly auy Dw/2 xdelta
        add 7 1 roll                            % xadj wx wy lly luy aly auy

      % Y adjust: if top of accent is <= 0, then we don't touch it.
      % Otherwise, find height of letter, x and X.  If the height of letter is > (x+X)/2,
      % then move accent up by X-x.

        0 gt
        {
          (X) CHEI                              % xadj wx wy lly luy aly Xh
          (x) CHEI                              % xadj wx wy lly luy aly Xh xh
          2 copy add 2 div                      % xadj wx wy lly luy aly Xh xh av
          5 -1 roll le {sub} {pop pop 0} ifelse % xadj wx wy lly aly yadj
          5 1 roll pop pop                      % xadj yadj wx wy
        }
        {
          pop pop pop 0 3 1 roll                % xadj yadj wx wy
        } ifelse

        GR                                      % CTM is back to normal
        setcharwidth                            % xadj yadj

        0 0 M GS ifm concat letter show GR      % xadj yadj
        M    GS ifm concat accent show  GR      % -

        end                                     % of temp. dict for variables
      }
      {
        pop pop                                 % One or both chars were not in encoding; give up
      } ifelse
      pop                                       % don't care about glyph name
    } BD

    % Stack: newname encoding matrix oldfontdict

    % How many entries in Encoding are missing in CharStrings?
    dup /CharStrings get                        % name enc mat dict cs
    0 4 I                                       % name enc mat dict cs count enc
    {                                           % name enc mat dict cs count glyph
      2 I exch OKA
      { pop pop 1 add } if                      % name enc mat dict cs count
    } forall                                    % name enc mat dict cs count

    3 -1 roll                                   % name enc mat cs count dict
    {
      1 I /FID ne
      2 I /CharStrings ne and
      {def} {pop pop} ifelse
    } forall                                    % name enc mat cs count

    % Make a writeable copy of /CharStrings with extra space
    % and fill it in

    1 I length add dict                         % name enc mat cs newcs

    % Can't use copy because it transfers the readonly status across!
    exch
    {
      2 I 3 1 roll put
    } forall

    2 I                                         % name enc mat newcs enc
    {                                           % name enc mat newcs glyph
      2 copy OKA
      {                                         % name enc mat newcs glyph lettername accentname
        [ 3 1 roll                              % name enc mat newcs glyph mark lettername accentname
        /MKACC cvx ] cvx                        % name enc mat newcs glyph proc
        2 I 3 1 roll                            % name enc mat newcs newcs glyph proc
        put                                     % name enc mat newcs
      } { pop} ifelse                           % name enc mat newcs
    } forall                                    % name enc mat newcs


    /CharStrings exch def                       % name enc mat

    % Deal with the matrix. This can be false, meaning don't touch

    dup type /arraytype eq
    { /FontMatrix FontMatrix 3 -1 roll 6 array CCM def }
    { pop } ifelse                              % name enc

    % Deal with the encoding.

    /Encoding exch def                          % name

    currentdict
    end                                         % name newfontdict
    definefont pop
  } BD
