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;