PACKET fonts routines
(************************************************************************** 
***** Verwaltung der Schriftfontstabelle  **  Author : R. Nolting     *****
***** Benoetigt von allen Druckertreibern **  Version: 0.1 / 3.5.82   *****
*****                                     **  Version: 1.0 / 8.6.82   ***** 
*****                                     **  Version: 2.0 / 1. 8. 82 *****
***** Schrittweite in x und y in Tabelle  **  Version: 3.0 / 1. 9. 83 ***** 
***** Zeilenhoehe in cm                   **  Version: 3.1 / 2. 4. 84 *****
**************************************************************************)
 
    DEFINES 
             load font table,
             get font,
             list fonts,
             inch,
             current font number,
             lf height of current font,
             x factor per inch, 
             y factor per inch:

LET max fonts = 8;
LET max nr points = 4;
LET PRINTTYPE = STRUCT (INT x steps per inch, y steps per inch,
                        ROW max nr points INT point size,
                        TEXT name, pitch table, codetable);
ROW max fonts PRINTTYPE VAR font;
FILE VAR font file;
INT VAR font number := 1, point number := 1;
TEXT VAR record :=  " ",
         symb;
INT VAR i;
REAL CONST inch := 2.54;
 
INT PROC x factor per inch: 
  x step
END PROC x factor per inch;
 
INT PROC y factor per inch: 
  lf 
END PROC y factor per inch;
 
REAL PROC lf height of current font:
  real(point (point number)) * inch / real (lf)  (* 9.1.84 Nolting *)
END PROC lf height of current font;
 
INT PROC current font number: 
  font number 
END PROC current font number;
(*******************************************************************
*********  Setzen und Liefern von Schriftsaetzen              ******
*******************************************************************)
PROC init font:
FOR font number FROM 1 UPTO max fonts REP;
  lf := 1; 
  x step := 1; 
  FOR point number FROM 1 UPTO max nr points REP 
    point(point number) := 1; 
    PER;
  kode := "";
  name := "";
  pitch:= "";
  PER;
END PROC init font;
(******************************************************************)
 
PROC list fonts:
  line;
  FOR font number FROM 1 UPTO max fonts REP
   IF name <> "" AND name <> " "
       THEN put typ name 
       FI;
    line;
    PER;
  font number := 1; point number := 1;
. 
put typ name:
  put (font number); put (".");
  put ("'"); put (name); put ("'");
  IF length (pitch) > 1 
     THEN put ("proportional mit Blankbreite"); put (code (pitch SUB 32))
     ELSE put ("fest mit Blankbreite"); put (code (pitch));
     FI;
  put ("und Zeilenhoehe"); put (point (1));
END PROC list fonts;
 
BOOL PROC font is in table (TEXT CONST name of font):
  record := name of font;
  changeall (record, " ","");
  IF record = ""
     THEN font number := 1; TRUE
     ELSE search through the table
     FI
.
search through the table:
(* der Name des gewuenschten Types darf noch ein angehaengtes Attribut haben *)
  FOR font number FROM 1 UPTO max fonts REPEAT
    IF pos (record, name) = 1
       THEN LEAVE search through the table WITH TRUE
       FI;
    PER;
    font number := 1;
    FALSE
ENDPROC font is in table;
 
PROC get font (TEXT VAR name of font,
               TEXT VAR font pitch table, font code table,
               BOOL VAR success):
INT VAR lf size := 0;
  get font (name of font, lf size, 
            font pitch table, font code table, success); 
  replace (font pitch table, 10, code(lfsize)); 
END PROC get font; 
 
PROC get font (TEXT VAR name of font, INT VAR size,
               TEXT VAR font pitch table, font code table,
               BOOL VAR success):
  success := font is in table (name of font);
  name of font := name;
  (* hiermit wird eine Ueberpruefung 'alter Typ = neuer Typ'
     im aufrufenden Programm ermoeglicht *)
  font code table := kode;
  font pitch table := pitch;
  point number := max nr points;
  WHILE point (point number) <> size REP
    point number DECR 1; 
    UNTIL point number = 1 PER; 
  size := point (point number); 
  IF size = point (1) 
     THEN font pitch table := pitch;
          LEAVE get font 
     ELSE font pitch table := ""
     FI; 
  INT VAR j := point (1); 
  FOR i FROM 1 UPTO length (pitch) REP
    font pitch table CAT code(code (pitch SUB i) * size DIV j)
    PER;

END PROC get font;
 
LET tag            = 1 ,
    bold           = 2 , 
    number         = 3 ,
    string         = 4 ,  (* = text; aber PROC text wird benoetigt *)
    operator       = 5 ,
    delimiter      = 6 , 
    end of file    = 7 , 
    within comment = 8 ,
    within text    = 9 ;
 
PROC load font table (TEXT CONST font file name):
BOOL VAR prop font;
INT VAR type of symbol := 0;
REAL VAR blank in cm ,
         lf in cm;
REAL VAR width, inch factor;
INT VAR factor width;
 
enable stop;
IF NOT exists (font file name)
   THEN errorstop ("Fontdatei nicht vorhanden")
   FI;
font file := sequential file (input, font file name);
  init font;
  font number := 0;
  getline (font file, record);
  protline (record);
  WHILE NOT eof (font file) REP
    font number INCR 1;
    get font name and parameters;
    get char width and output function;
  UNTIL eof (font file) COR font number >= max fonts PER;
  font number := 1; point number := 1;
.
get font name and parameters:
  get font name; 
  get fixed or prop; 
  get blank width; 
  get linefeed height; 
  get pointsizes;
  get optional x steps per inch;
  fill pitch and code table with default;
. 
get font name:
  next entry;  prot (symb);
  IF (symb SUB 1) = "#" 
     THEN symb := subtext (symb, 2);
          WHILE (symb SUB length(symb)) <> "#" REP
            name CAT symb;
            next entry; prot (symb);
            IF symb = ""
               THEN errorstop ("# fehlt beim Fontnamen");
               FI;
            PER;
            name CAT subtext (symb, 1, length (symb)-1)
     ELSE error stop ("1. Symbol kein Fontname")
     FI;
. 
get fixed or prop:
  next entry;
  prop font := (symb SUB 1) = "p" OR (symb SUB 1) = "P";
  prot (symb);
. 
get blank width:
  next entry;
  blank in cm := real (symb); 
  IF NOT last conversion ok COR blank in cm < 0.01 
     THEN errorstop ("Blankbreite falsch") 
     FI;
  prot ("Blank=");prot (symb);
. 
get linefeed height: 
  next entry; 
  lf in cm := real (symb);
  IF NOT last conversion ok COR lf in cm < 0.01 
     THEN errorstop ("Linefeedhoehe falsch") 
     FI;
  prot ("lf="); prot(symb);
.
get pointsizes:
  next entry; 
  IF symb <> "(" 
     THEN protline ("alle Pointgroessen = 1 per Voreinstellung") ; 
          LEAVE get pointsizes
     FI; 
  protline(" "); prot ("lf in punkten=");
  get one lf size;
  lf := int (inch * real (point (1))/ lf in cm + 0.5);
. 
get one lf size:
  FOR i FROM 1 UPTO max nr points REP
    next entry; 
    IF symb = ")" 
       THEN LEAVE get one lf size
       ELIF symb = "" 
            THEN errorstop ("Pointangaben unvollstaendig") 
       FI; 
    point(i) := int (symb); 
    IF NOT last conversion ok COR point (i) < 1
       THEN errorstop ("Pointgroesse falsch")
       FI;
    prot (symb); prot (",");
    PER;
. 
get optional x steps per inch:
  IF symb = ")"
     THEN next entry FI;
  IF symb = "" 
     THEN width := 1.0
     ELSE width := real (symb)
     FI;
  x step := int (inch * width / blank in cm + 0.5);
  factor width := int (width + 0.5);
  IF NOT last conversion ok COR x step < 1
     THEN errorstop ("minimale Schritte falsch")
     FI;
  protline(" "); prot ("Schritte pro Inch="); prot (text(x step)); prot(","); prot (text(lf)); protline(" ");
.
fill pitch and code table with default:
  IF prop font
     THEN pitch  := 255 * code (factor width)
     ELSE pitch  := code (factor width)
     FI;
  kode  := 31 * ""0"";
  kode  CAT 224 * ""1""; (* print all *)
  inch factor := real (x step)
.
get char width and output function:
  WHILE NOT eof (font file) REP
    getline (font file, record);
    protline (record);
    IF (record SUB 1) = "#" AND pos (record, "#", 2, length (record)) > 2
       THEN LEAVE get char width and output function
       FI;
    get internal code for char;
    IF char code > 0 AND char code <= 255
       THEN IF prop font 
               THEN get char width;
                    prot (text(factor width));
                    replace (pitch, char code, code (factor width))
               FI;
               get output function
       FI;
    PER;
.
get internal code for char:
INT VAR char code;
  next entry; prot (symb);
  IF length(symb) = 1 
     THEN char code := code (symb SUB 1)
     ELIF symb >= "000" AND symb <= "255" 
          THEN char code := int (symb); 
               IF NOT last conversion ok 
                  THEN errorstop ("Zeichen falsch") 
                  FI 
     ELSE errorstop ("Zeichen falsch") 
     FI; 

.
get char width:
  next entry; 
  IF pos (symb, ".") > 0
     THEN width := real (symb);
          factor width := int (round(((width * inch factor) / inch), 0))
     ELSE factor width := int (symb) 
     FI;
  IF NOT last conversion ok 
     THEN errorstop ("Breitenangabe falsch") 
     FI 
.
get output function:
  next entry; prot (symb);  protline(" ");
  IF symb = "" 
     THEN symb := "1"
     FI;
  replace (kode, char code, code (int (symb)));
  IF NOT last conversion ok 
     THEN errorstop ("Ausgabefunktion falsch") 
     FI;
END PROC load font table;
 
PROC next entry:
INT VAR next blank pos;
WHILE (record SUB 1) = " " REP
  record := subtext (record, 2, length (record)) PER;
next blank pos := pos (record, " ");
IF next blank pos >= 1
   THEN symb := subtext (record, 1, next blank pos - 1);
        record := subtext (record, next blank pos + 1)
   ELSE symb := record;
        record := ""
   FI;
END PROC next entry;

PROC prot (TEXT CONST t):
  IF online
     THEN put (t)
     FI;
END PROC prot;

PROC protline (TEXT CONST t):
  IF online
     THEN putline (t)
     FI;
END PROC protline;

init font; (* PACKET Initialisierung ******************************)
.
name:   font[font number].name 
. 
pitch:  font[font number].pitch table 
. 
kode:   font [font number].code table 
.
lf:     font [fontnumber].y steps per inch
. 
x step: font [font number].x steps per inch
. 
point:  font [font number].point size
.
END PACKET fonts routines;