From 98cab31fc3659e33aef260efca55bf9f1753164c Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 11 Feb 2019 11:49:19 +0100 Subject: Add source files from Michael --- system/std.zusatz/1.7.3/src/FONTR16.ELA | 360 ++++++++++++++++++++++++++++++++ 1 file changed, 360 insertions(+) create mode 100644 system/std.zusatz/1.7.3/src/FONTR16.ELA (limited to 'system/std.zusatz/1.7.3/src/FONTR16.ELA') 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; -- cgit v1.2.3