Dicktentabelle


%!PS-Adobe-1.0
%%Creator: Holger Gehringer
%%Title: Beispiel fuer Dickten
%%CreationDate: Mo, 23.11.1998
%%DocumentMedia: A4 595 842 0 () ()
%%Orientation: Portrait
%%Pages: (atend)
%%DocumentFonts: Times-Roman Helvetica
%%EndComments

% Das Programm zeigt, wie die Dicktentabelle eines Fonts geaendert werden kann.
% In diesem Beispiel werden die Dickten eines existierenden Fonts so gerundet,
% dass sie jeweils ganzahlige Vielfache der Pixelgroesse betragen.

/ModWidthsDict 8 dict def        % Lokaler Speicher fuer Modifywidths

/ModifyWidths                    % Modifywidths benoetigt 4 Parameter:
{ ModWidthsDict begin
    /UniqueID exch def           % Eine UniguelD-Nimgner fuer den neuen Font
    /NewWidths exch def          % Ein Dictionary mit den neuen Dickten
    /NewFontname exch def        % Den Namen des neuen Fonts
    /BaseFontname exch def       % Den Namen des Basis-Fonts

    /BaseFontDict                % Basis-Font
    BaseFontname findfont def

    /NumEntries BaseFontDict     % Laenge des neuen Dictionaries ergibt sich aus
    maxlength 1 add def          % alter Laenge plus einem Metrics-Eintrag.

    BaseFontDict                 % Hat altes Dictionary noch keine UniqueID-Num-
    /UniqueID known not          % mer, dann schaffe Raum dafuer. (Eingebaute
    { /NumEntries NumEntries     % Fonts in der Laserwriter-Version 23.0 haben
      1 add def                  % noch keine Nummer)
    } if

    /NewFont                     % Dictionary fuer neuen Font
    NumEntries dict def

    BaseFontDict                 % Alle Eintraege des alten Font-Dictionaries
    { exch dup dup /FID ne       % werden kopiert. Ausgenommen bleiben FID-Ein-
      exch /FontBBox ne and      % trag und FontBBox (s.u.)
      { exch NewFont
        3 1 roll put
      }
      { pop pop
      } ifelse
    } forall

    /NewFontBBox BaseFontDict    % wegen eines Fehlers in Vers. 23.0 der Laser-
    /FontBBox get aload          % Writer-Software kann Font-Bounding-Box nicht
    length array astore def      % kopiert, sondern muss neu erzeugt werden.
    
    NewFont /FontName            % Der neue Name wird eingetragen.
    NewFontname put
    NewFont /FontBBox            % Neue FontBBox wird eingetragen
    NewFontBBox put
    NewFont /Metrics             % Die neue Dickten-Tabelle wird eingetragen.
    NewWidths put
    NewFont /UniqueID            % die UniqueID-Nummer wird eingetragen.
    UniqueID put
    
    NewFontname NewFont          % Der neue Font wird definiert
    definefont pop               % Dictionary auf Stack kann geloescht werden
  end
} def

/RoundWidthsDict 13 dict def     % Lokaler Speicher fuer RoundWidths

/RoundWidths                     % RoundWidths nimmt drei Argumente:
{ RoundWidthsDict begin
    /PtSize exch def             % Schriftgroesse in Punkt
    /Resolution exch def         % Aufloesung des Ausgabegeraetes
    /Fontname exch def           % Font
    
    /TheFont                     % Font suchen
    Fontname findfont def
    
    /NewWidths TheFont           % Die neue Dicktentabelle hat genau so viele
    /CharStrings get length      % Eintraege, wie der Font Zeichen umfasst
    dict def
    
    /PixelsPerEm PtSize 72 div   % Zahl der Pixel fuer gegebene Punktgroesse
    Resolution mul def
    
    /UnitsPerPixel 1000          % Zahl der Einheiten (im Zeichen-Koord.s.) je
    PixelsPerEm div def          % Pixel
    
    gsave
    nulldevice                   % Verwendung des nulldevice eliminiert Rund-
                                 % ungsfehler, die sonst entstehen koennten.
    TheFont 1 scalefont setfont  % Verwendung einer Schriftgroesse von 1 pt be-
                                 % schleunigt die Berechnungen.
    /CharCount 0 def
    TheFont /Encoding get        % Fuer jedes Zeichen des Fonts ...
    { /Charname exch def
      Charname /.notdef ne
      { /CharWidth 1 string dup  % Alte Dickte ermitteln
        0 CharCount put
   stringwidth pop
   1000 mul def
   /Multiples CharWidth          % Neue Dickte in Pixeln
   UnitsPerPixel div
   round cvi def
   /NewCharWidth
   UnitsPerPixel
   Multiples mul def
   NewWidths Charname            % Neue Dickte in NewWidths-Dictionary eintragen
   NewCharWidth put
      } if
      /CharCount CharCount
      1 add def
    } forall
    grestore
    NewWidths                    % Dictionary mit neuen Dickten bleibt auf Stack
  end
} def

/FindResDict 4 dict def
FindResDict begin
  /TempMatrix matrix def
  /Epsilon 0.001 def             % Toleranzwert, wird in FindResolution benoet.
end

/FindResolution                  % ermittelt die Aufloesung des Ausgabegeraetes
{ FindResDict begin              % (in Punkte je Zoll)
    72 0 TempMatrix              % Koordinaten eines 1 Zoll langen Vektors in
    defaultmatrix dtransform     % Geraetekoordinaten umrechnen
    /Y exch def
    /X exch def
    X abs Epsilon gt             % Sind beide Koord. <> 0 (Rundungsfehler be-
    Y abs Epsilon gt and         % ruecksichtigt), so benutzt das Ausgabegeraet
                                 % ein Koord.s., das nicht parallel oder senk-
                                 % recht zum Standard-Benutzer-K.s. verlaeuft -
                                 % in diesem Fall sind die Berechnungen sinnlos.
    { stop
    }
    { X dup mul Y dup mul
      add sqrt
    } ifelse
  end
} def

/StringShow                      % zeigt einen String im aktuellen Font
{ (HOHOHOHO oaobocodoeofogohoiojok) show
  (olomonopoqorosotouovowoxoyoz) show
} def

/Res FindResolution def          % Aufloesung des Ausgabegeraets ermitteln

/UID /Times-Roman findfont       % UniqueID des Basis-Fonts ermitteln
dup /UniqueID known              % Falls nicht vorhanden, 0 benutzen
{ /UniqueID get
}
{ pop 0
} ifelse def

%%EndProlog

/RWid /Times-Roman Res 6         % Gerundete Dickten fuer 6 pt Times berechnen
RoundWidths def

%%Page: 1 1
/Times-Roman /TR6 RWid           % und neuen Font mit diesen Dickten definieren
UID 1 add ModifyWidths

/Times-Roman findfont            % Test-String in normaler Times ausgeben
6 scalefont setfont
130 560 moveto StringShow

/TR6 findfont                    % Test-String mit geaenderten Dickten ausgeben
6 scalefont setfont
130 550 moveto StringShow

/RWid /Times-Roman Res 7         % Das Ganze nochmal mit 7 Punkt Times
RoundWidths def
/Times-Roman /TR7 RWid
UID 2 add ModifyWidths

/Times-Roman findfont
7 scalefont setfont
130 500 moveto StringShow

/TR7 findfont
7 scalefont setfont
130 490 moveto StringShow

/RWid /Times-Roman Res 8         % Und schliesslich mit 8 pt Schriftgroesse
RoundWidths def
/Times-Roman /TR8 RWid
UID 3 add ModifyWidths

/Times-Roman findfont
8 scalefont setfont
130 440 moveto StringShow

/TR8 findfont
8 scalefont setfont
130 430 moveto StringShow

showpage

%%Trailer
%%Pages: 1


Vorschau:

Download PostScript-File

© Holger Gehringer, Dezember 1998