harvey/sys/src/cmd/gs/lib/addxchar.ps

%    Copyright (C) 1999 Aladdin Enterprises.  All rights reserved.
% 
% This file is part of AFPL Ghostscript.
% 
% AFPL Ghostscript is distributed with NO WARRANTY OF ANY KIND.  No author or
% distributor accepts any responsibility for the consequences of using it, or
% for whether it serves any particular purpose or works at all, unless he or
% she says so in writing.  Refer to the Aladdin Free Public License (the
% "License") for full details.
% 
% Every copy of AFPL Ghostscript must include a copy of the License, normally
% in a plain ASCII text file named PUBLIC.  The License grants you the right
% to copy, modify and redistribute AFPL Ghostscript, but only under certain
% conditions described in the License.  Among other things, the License
% requires that the copyright notice and this notice be preserved on all
% copies.

% $Id: addxchar.ps,v 1.2 2000/09/19 18:29:11 lpd Exp $
% Add the Central European and other Adobe extended Latin characters to a
% Type 1 font.
% Requires -dWRITESYSTEMDICT to disable access protection.

(type1ops.ps) runlibfile

% ---------------- Utilities ---------------- %

/addce_dict 50 dict def
addce_dict begin

% Define the added copyright notice.
/addednotice (. Portions Copyright (C) 1999 Aladdin Enterprises.) def 

% Open a font for modification by removing the FID and changing the
% FontName.  Removing UniqueID and XUID is not necessary, since we
% will only be adding characters.
/openfont {		% <name> <font> openfont <name> <font'>
  dup length dict copy
  dup /FID undef
  dup /FontName 3 index put
} def

% Do the equivalent of false charpath for a glyph.
% This should really be an operator!
/glyphpath {		% <glyph> glyphpath -
  currentfont /Encoding get 0 3 -1 roll put
  <00> false charpath
} def

% Do the equivalent of charpath + pathbbox for a glyph.
/glyphbbox {		% <glyph> glyphbbox <llx> <lly> <urx> <ury>
	% We cache this value, because it's expensive to compute.
  BBoxes 1 index .knownget {
    exch pop
  } {
    gsave newpath 0 0 moveto dup glyphpath [pathbbox] grestore
    BBoxes 3 -1 roll 2 index put
  } ifelse aload pop
} def

% Get the side bearing and width for a glyph.
/glyphsbw {		% <glyph> glyphsbw <lsbx> <wx>
	% We cache this value, because it's expensive to compute.
  SBW 1 index .knownget {
    exch pop
  } {
    dup glyphcs { dup /hsbw eq { pop exit } if } forall
    2 array astore
    SBW 3 -1 roll 2 index put
  } ifelse aload pop
} def

% Get the CharString for a glyph, as an array.
/glyphcs {		% <glyph> glyphcs <array>
  CharStrings exch get
  4330 exch dup length string .type1decrypt exch pop
  dup length lenIV sub lenIV exch getinterval
  0 () /SubFileDecode filter [ exch charstack_read ]
} def

% Find an occurrence of a value in an array.
/asearch {		% <array> <value> asearch <index> true
			% <array> <value> asearch false
  false 0 4 2 roll exch {
		% Stack: false index value element
    2 copy eq { pop pop exch not exch dup exit } if
    exch 1 add exch
  } forall pop pop
} def

% Convert an array back to a CharString.
/csdef {		% <glyph> <array> csdef -
  charproc_string
  4330 exch dup .type1encrypt exch pop readonly
  CharStrings 3 1 roll put
} def

% Split an accented character name.
/splitaccented {	% <Baccent> splitaccented <Baccent> <B> <accent>
    dup =string cvs
    dup 0 1 getinterval cvn
    exch dup length 1 sub 1 exch getinterval cvn
} def

% Begin the definition of a 'seac' character.
% Defines accent, base, abox, bbox.
% The initial dx lines up the origins of the base and the accent.
/beginseac {		% <bchar> <achar> beginseac
			%   -mark- <lsbx> <wx> /hsbw <asb> <dx>
  /accent exch def /base exch def
  /abox [accent glyphbbox] def
  /bbox [base glyphbbox] def
  [ base glyphsbw /hsbw accent glyphsbw pop
  dup 4 index sub
} def

% Center the accent over the base of a 'seac' character.
/centeraccent {		% <dx> centeraccent <adx>
  bbox 2 get bbox 0 get add 2 div
  abox 2 get abox 0 get add 2 div
  sub add
} def

% Finish the definition of a 'seac' character.
/finishseac {		% <charname> -mark- ... <adx> <ady> finishseac -
  exch cvi exch cvi
  charindex base get charindex accent get /seac ] csdef
} def

% ---------------- Main program ---------------- %

% Define accented characters that can be made with seac,
% with the accent centered over the character.
/seacchars [
  /Abreve /Amacron
  /Cacute /Ccaron /Dcaron
  /Ecaron /Edotaccent /Emacron
  /Gbreve
  /Idotaccent /Imacron
  /Lacute
  /Nacute /Ncaron
  /Ohungarumlaut /Omacron
  /Racute /Rcaron
  /Sacute /Scedilla
  /Tcaron
  /Uhungarumlaut /Umacron /Uogonek /Uring
  /Zacute /Zdotaccent
  /abreve /amacron
  /cacute /ccaron
  /ecaron /edotaccent /emacron
  /gbreve
  /lacute
  /nacute /ncaron
  /ohungarumlaut /omacron
  /racute /rcaron
  /sacute /scedilla
  /uhungarumlaut /umacron /uring
  /zacute /zdotaccent
] def

% Define seac characters where the accent lines up with the right
% edge of the character.
/seacrightchars [
  /Aogonek /Eogonek /Iogonek /aogonek /eogonek /iogonek /uogonek
] def

% Define seac characters where the caron becomes an appended quoteright.
/seaccaronchars [
  /dcaron /lcaron /tcaron
] def

% Define seac characters using commaaccent.
/seaccommachars [
  /Gcommaaccent /Kcommaaccent /Lcommaaccent /Ncommaaccent /Rcommaaccent
  /Scommaaccent /Tcommaaccent
  /gcommaaccent /kcommaaccent /lcommaaccent /ncommaaccent /rcommaaccent
  /scommaaccent /tcommaaccent
] def

% Define the characters copied from the Symbol font.
/symbolchars [
  /Delta /greaterequal /lessequal /lozenge /notequal /partialdiff
  /summation
] def

% Define the procedures for editing the commaaccent character.
% Delete all the hints, since it's too hard to adjust them.
/caedit mark
  /rmoveto { exch commatop sub cvi exch }
  /hstem { pop pop pop }
  /vstem 1 index
  /callothersubr {
    dup 3 eq { 4 { pop } repeat /skip true def } if
  }
  /pop { skip { pop /skip false def } if }
.dicttomark def

/addce {		% <name> <font> addce <font'>
  20 dict begin
  /origfont 1 index def
  openfont
  dup /CharStrings 2 copy get dup length dict copy put
  dup /Encoding 2 copy get dup length array copy put
  dup /FontInfo 2 copy get dup length dict copy put
  definefont /font exch def
  currentdict font end begin begin
  font 1000 scalefont setfont
  /symbolfont /Symbol findfont def
  /BBoxes CharStrings length dict def
  /SBW CharStrings length dict def

  /italfactor FontInfo /ItalicAngle .knownget {
    neg dup sin exch cos div
  } {
    0
  } ifelse def

	% Invert the Encoding (needed for seac).

  /charindex 256 dict def
  0 1 255 {
    charindex exch Encoding 1 index get exch put
  } for

	% Add the commaaccent character, by moving the comma downward.

  /comma glyphbbox /commatop exch def pop pop pop
  /comma glyphcs
    /skip false def
    [ exch { caedit 1 index .knownget { exec } if } forall ]
  /commaaccent exch csdef

	% Add the accented characters that can be made with seac.

  seacchars {
    splitaccented beginseac
      centeraccent
		% If the accent would collide with the base character,
		% raise it a little.
      abox 1 get bbox 3 get sub dup 0 le {
		% ... but not if the accent is in the low position.
	abox 1 get 0 gt {
	  neg 60 add
		% Adjust the X position if italic.
	  dup italfactor mul 3 -1 roll add exch
	} {
	  pop 0
	} ifelse
      } {
	pop 0
      } ifelse
    finishseac
  } forall

  seacrightchars {
    splitaccented beginseac
    bbox 2 get abox 2 get sub add	% line up right edges
    0 finishseac
  } forall

  /dcroat /d /hyphen beginseac
    bbox 2 get abox 2 get sub add	% line up right edges
  0 finishseac

  /imacron /dotlessi /macron beginseac
    centeraccent
  0 finishseac

  /Lcaron /L /quoteright beginseac
    bbox 2 get abox 2 get sub add	% line up right edges
  0 finishseac

  seaccaronchars {
    dup =string cvs 0 1 getinterval cvn /quoteright beginseac
		% Move the quote to the right of the character.
    bbox 2 get abox 0 get sub 50 add add
		% Adjust the character width as well.
    4 -1 roll abox 2 get abox 0 get sub 50 add add cvi 4 1 roll
    0 finishseac
  } forall

  seaccommachars {
    dup =string cvs 0 1 getinterval cvn /comma beginseac
      centeraccent
      commatop neg
		% Lower the accent if the character extends below
		% the baseline
      bbox 1 get 0 .min add
    finishseac
  } forall

	% Add the characters from the Symbol font.
	% We should scale them to match the FontBBox, but we don't.

  symbolchars {
    symbolfont /CharStrings get 1 index get
    CharStrings 3 1 roll put
  } forall

	% Add the one remaining character.

  CharStrings /Dcroat CharStrings /Eth get put

	% Recompute the FontBBox, since some of the accented characters
	% may have enlarged it.

  /llx 1000 def /lly 1000 def /urx 0 def /ury 0 def
  CharStrings {
    pop glyphbbox
    ury .max /ury exch def urx .max /urx exch def
    lly .min /lly exch def llx .min /llx exch def
  } forall
  /FontBBox llx cvi lly cvi urx ceiling cvi ury ceiling cvi 4 packedarray def

	% Restore the Encoding and wrap up.

  [/Copyright /Notice] {
    FontInfo 1 index .knownget {
      addednotice concatstrings FontInfo 3 1 roll put
    } {
      pop
    } ifelse
  } forall
  FontName font openfont
  dup /Encoding origfont /Encoding get put
  definefont

  end end
} def

currentdict end readonly pop	% addce_dict

/addce { addce_dict begin addce end } def

% ---------------- Integration ---------------- %

% We would like to patch the font loader so that it adds the extended
% Latin characters automatically.  We haven't done this yet.

% ---------------- Test program ---------------- %

/TEST where { pop TEST } { false } ifelse {
  /FONT where { pop } { /FONT /Palatino-Italic def } ifelse
  (unprot.ps) runlibfile
  unprot
  (wrfont.ps) runlibfile
  wrfont_dict begin
    /eexec_encrypt true def
    /binary_CharStrings true def
  end
  save
    FONT findfont
    /Latin-CE exch addce setfont
    (t.ce.pfb) (w) file dup writefont closefile
  restore
  (prfont.ps) runlibfile
  (t.ce.pfb) (r) file .loadfont
  /Latin-CE DoFont
  quit
} if