%!
% Add composite (i.e. accented) characters to any font
% By J. Chroboczek <jec@dcs.ed.ac.uk>
%
% -- code follows this line --
%%BeginResource: procset compose 0.8 0
% Copyright (c) 1996-1999 by J. Chroboczek
% This code may be distributed under the terms of the 
% GNU Public License, either version 3 of the license, or (at your
% option) any later version.
/makeCompositeDict 20 dict def
makeCompositeDict begin
/nameUnique {                           % name nameUnique namexxxxxx
  dup length exch 1 index string cvs    % length (name)
  1 index 12 add string dup             % length (name) (...) (...)
  3 2 roll 0 exch putinterval           % length (name...)
  dup 3 2 roll
  rand 12 string cvs
  putinterval
} bind def

/doMakeComposite
{
  /compositeChars exch def
  /targetEncoding exch def
  /baseEncoding exch def
  /newfontname exch def
  /oldfontname exch def
  /oldfont oldfontname findfont def
  /newfont 20 dict def
  /oldFontMatrix oldfont /FontMatrix get def
  /oldFontBBox oldfont /FontBBox get cvlit def
  /oldfontcopy oldfont length dict def

  newfont begin
    /FontType 3 def
    /PaintType 0 def      % not used
    /FontMatrix [0.001 0 0 0.001 0 0] def
    /FontBBox
    [
      oldFontBBox 0 get oldFontBBox 1 get
      oldFontMatrix transform
      [1000 0 0 1000 0 0] transform
      oldFontBBox 2 get oldFontBBox 3 get
      oldFontMatrix transform
      [1000 0 0 1000 0 0] transform
    ] cvx def

    /StrokeWidth 0 def                  % not used

    /Encoding targetEncoding def

    /Decoding 256 dict def              % invert base encoding vector
    Decoding begin
      0 1 255
      { dup baseEncoding exch get exch def } bind for
    end

    newfont /compositeChars compositeChars put

    /FontName newfontname def

% make a copy of the original font, reencoding it
    oldfont
    oldfontcopy begin
      {1 index /FID ne
        {def}
        {pop pop} ifelse
      } bind forall
    end
    oldfontcopy /Encoding baseEncoding put
    oldfontname nameUnique oldfontcopy definefont
    1000 scalefont /OriginalFont exch def

    /BuildChar                          % newfont n BuildChar -
    {
      exch begin                        % n
        /OriginalFont load setfont
        /Encoding load exch get         % glyphName
        /compositeChars load dup
        2 index known                   % glyphName compositeChars known-p
        { 1 index get                   % glyphName [ 65 x y 129 ]
          dup 0 get ( ) dup             % glyphName [...] 65 ( ) ( )
          0 3 index put                 % glyphName [...] 65 (A)
          dup stringwidth setcharwidth
          0 0 moveto
          show pop                      % glyphName [...]
          dup 1 get 1 index 2 get       % glyphName [...] x y
          moveto                        % glyphName [...]
          3 get ( ) dup 3 2 roll        % glyphName ( ) ( ) 129
          0 exch put                    % glyphName (')
          show                          % glyphName
        }
        { pop
          /Decoding load                % glyphName Decoding
          dup 2 index known             % glyphName Decoding known-p
          { exch get }
          { pop pop 0 } ifelse          % n'
          ( ) dup 0 3 index put dup     % n' (A) (A)
          stringwidth setcharwidth
          0 0 moveto
          show                          % n'
        } ifelse
        pop
      end
    } bind def
  end                                   % newfont
  newfontname newfont definefont pop
} def                                   % doMakeComposite

/fillEuro {                             % w h --
  gsave exch 1000 div exch 1000 div scale
  955.852 232.172 moveto
  904.495 180.815 lineto
  829.454 117.848 734.626 83.333 636.667 83.333 curveto
  406.667 83.333 220 270 220 500 curveto
  220 730 406.667 916.667 636.667 916.667 curveto
  759.831 916.667 876.684 862.177 955.852 767.828 curveto
  988.474 855.291 lineto
  894.851 947.996 768.422 1000 636.667 1000 curveto
  360.667 1000 136.667 776 136.667 500 curveto
  136.667 224 360.667 0 636.667 0 curveto
  753.23 0 866.13 40.725 955.852 115.135 curveto
  closepath fill
  
  869.037 541.667 moveto
  901.025 625 lineto
  31.989 625 lineto
  0 541.667 lineto
  closepath fill
  
  805.059 375 moveto
  837.048 458.333 lineto
  31.989 458.333 lineto
  0 375 lineto
  closepath fill
  grestore
} bind def

/makeEuroCharstring {                   % w h -- charstring
  [ /pop cvx                            % w h mark pop
    3 index 0 0 0                       % w h mark pop w 0 0 0
    7 index 7 index /setcachedevice cvx 
                                % w h mark pop w 0 0 0 w h setcachedevice
    10 index 10 index /fillEuro load /exec cvx ] 
  cvx bind 3 1 roll pop pop
} def

/doEurifyFont {                         % oldname newname --
  exch
  findfont dup dup                      % newname dict dict dict
  /FontMatrix get matrix invertmatrix   % newname dict dict m
  {} forall pop pop [ 5 1 roll 0 0] makefont setfont   % newnamedict
  0 0 moveto
  (5) stringwidth pop                     % newname dict w
  (M) false charpath pathbbox 4 1 roll pop pop pop % newnamedict w h
  3 2 roll                                % newname w h dict
  
  dup length dict dup 3 1 roll begin      % newname w h newdict
    {1 index /FID ne {def} {pop pop} ifelse} forall
    CharStrings dup length 1 add dict dup 3 1 roll begin % newnamew h newdict newdict'
      {def} forall
      /Euro                               % newname w h newdict newdict' /Euro
      4 index 4 index makeEuroCharstring def
    end                                   % newname w h newdict newdict'
    /CharStrings exch def
  end
  3 1 roll pop pop                      % newname dict
  definefont pop
} bind def

end                                     % makeCompositeDict

% oldfontname newfontname baseEncoding targetEncoding compositeChars --
/makeComposite
{
  makeCompositeDict begin doMakeComposite end
} bind def

% oldfontname newfontname
/eurifyFont
{
  makeCompositeDict begin doEurifyFont end
} bind def
%%EndResource