diff options
Diffstat (limited to 'system/std.zusatz/1.7.3/src/FONTR16.ELA')
| -rw-r--r-- | system/std.zusatz/1.7.3/src/FONTR16.ELA | 360 |
1 files changed, 360 insertions, 0 deletions
diff --git a/system/std.zusatz/1.7.3/src/FONTR16.ELA b/system/std.zusatz/1.7.3/src/FONTR16.ELA new file mode 100644 index 0000000..91acfe0 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/FONTR16.ELA @@ -0,0 +1,360 @@ +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;
|