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.5/src/font convertor 9 | 1065 ++++++++++++++++++++++++++ 1 file changed, 1065 insertions(+) create mode 100644 system/std.zusatz/1.7.5/src/font convertor 9 (limited to 'system/std.zusatz/1.7.5/src/font convertor 9') diff --git a/system/std.zusatz/1.7.5/src/font convertor 9 b/system/std.zusatz/1.7.5/src/font convertor 9 new file mode 100644 index 0000000..22ce9af --- /dev/null +++ b/system/std.zusatz/1.7.5/src/font convertor 9 @@ -0,0 +1,1065 @@ +PACKET font convertor (* Autor : Rudolf Ruland *) + (* Stand : 11.07.86 *) + DEFINES create font table , (* Version 9 *) + add fonts, + create font file : + + +LET t tag = 1, + t bold = 2, + t number = 3, + t text = 4, + t operator = 5, + t delimiter = 6, + t end of file = 7, + + nil modus = 0, + font table modus = 1, + font modus = 2, + extension modus = 3, + + x unit = 1, + y unit = 2, + on string = 3, + off string = 4, + indentation pitch = 5, + font lead = 6, + font height = 7, + font depth = 8, + larger font = 9, + smaller font = 10, + font string = 11, + y off sets = 12, + bold off set = 13; + +THESAURUS VAR names, english identification := empty thesaurus, + german identification := empty thesaurus; + +insert (english identification, "xunit"); +insert (english identification, "yunit"); +insert (english identification, "onstring"); +insert (english identification, "offstring"); +insert (english identification, "indentationpitch"); +insert (english identification, "fontlead"); +insert (english identification, "fontheight"); +insert (english identification, "fontdepth"); +insert (english identification, "nextlargerfont"); +insert (english identification, "nextsmallerfont"); +insert (english identification, "fontstring"); +insert (english identification, "yoffsets"); +insert (english identification, "boldoffset"); + +insert (german identification, "xeinheit"); +insert (german identification, "yeinheit"); +insert (german identification, "onsequenz"); +insert (german identification, "offsequenz"); +insert (german identification, "einrueckbreite"); +insert (german identification, "durchschuss"); +insert (german identification, "fonthoehe"); +insert (german identification, "fonttiefe"); +insert (german identification, "groessererfont"); +insert (german identification, "kleinererfont"); +insert (german identification, "fontsequenz"); +insert (german identification, "yverschiebungen"); +insert (german identification, "boldverschiebung"); + +INT VAR modus, last modus, symbol type, int symbol, pitch, + identification nr, link nr, extension code 1, + char code 1, char code, char pos, vorzeichen, + replacements length, index; +TEXT VAR symbol, font table name, replacement, char, buffer, z; +BOOL VAR english; +FILE VAR file, font file; + +(*****************************************************************) + +LET max fonts = 50, + max extensions = 120, + font table type = 3009, + + FONTTABLE = STRUCT ( + + THESAURUS font names, + + TEXT replacements, font name links, + extension chars, extension indexes, + + ROW 4 TEXT on strings, off strings, + + REAL x unit, y unit, + + ROW 256 INT replacements table, + + INT last font, last extension + + ROW max fonts STRUCT ( + TEXT font string, font name indexes, replacements, + extension chars, extension indexes, y offsets, + ROW 256 INT pitch table, replacements table, + INT indentation pitch, font lead, font height, font depth, + next larger font, next smaller font, bold offset ) fonts , + + ROW max extensions STRUCT ( + TEXT replacements, + ROW 256 INT pitch table, replacements table, + INT std pitch ) extensions , + + ); + +BOUND FONTTABLE VAR font table; + +DATASPACE VAR ds; + +INT VAR font nr, extension nr; + +. font : font table. fonts (font nr) +. extension : font table. extensions (extension nr) +. line nr : line no (file) - 1 +.; + +(*****************************************************************) + + +PROC create font table : + + create font table (last param) + +END PROC create font table; + + +PROC create font table (TEXT CONST font file) : + +file := sequential file (input, font file); +disable stop; +ds := nilspace; +modus := nil modus; +load; +IF is error THEN error (errormessage) FI; +forget (ds); + +END PROC create font table; + + +PROC add fonts (TEXT CONST font tab name, font file) : + +file := sequential file (input, font file); +font table name := font tab name; +change all (font table name, " ", ""); +IF NOT exists (font table name) COR type (old (font table name)) <> font table type + THEN errorstop ("Fonttabelle """ + font table name + """ gibt es nicht") +FI; +disable stop; +ds := old (font table name); +fonttable := ds; +modus := font modus; +font nr := fonttable. last font; +extension nr := fonttable. last extension; +load; +IF is error THEN error (errormessage) FI; +forget (ds); + +END PROC add fonts; + + +PROC load : + +enable stop; +initialize loading; +REP get kennung; + get identification; + get char specifications; +UNTIL eof (file) OR symbol type = t end of file PER; +font table found; + +. initialize loading : + scan (file); + get next symbol; + +. font table found : + IF font nr = 0 + THEN errorstop ("Fonts zur Fonttabelle """ + + font table name + """ fehlen"); + ELSE font table. last font := font nr; + font table. last extension := extension nr; + forget (font table name, quiet); + copy (ds, font table name); + type (old (font table name), font table type); + forget (ds); ds := nilspace; + FI; + +. get next symbol : + next symbol (file, symbol, symbol type); + +. get semicolon : + get next symbol; + IF symbol <> ";" OR symbol type <> t delimiter + THEN errorstop ("';' erwartet") FI; + +. + get kennung : + cout (line nr); + IF symbol type <> t bold + THEN errorstop ("Kennung erwartet") FI; + IF symbol = "FONTTABLE" OR symbol = "FONTTABELLE" + THEN initialize font table; + get font table name; + ELIF symbol = "FONT" + THEN initialize font; + get font names; + ELIF symbol = "EXTENSION" OR symbol = "ERWEITERUNG" + THEN get extension char; + initialize extension; + ELIF modus = nil modus + THEN errorstop ("Kennung 'FONTTABLE' oder 'FONTTABELLE' zu Beginn der Datei erwartet") + ELSE errorstop ("unzulaessige Kennung") + FI; + + . initialize font table : + IF modus <> nil modus THEN font table found FI; + modus := font table modus; + font nr := 0; + extension nr := 0; + font table := ds; + font table. font names := empty thesaurus; + font table. replacements := ""; + font table. font name links := ""; + font table. extension chars := ""; + font table. extension indexes := ""; + font table. x unit := 10.0/2.54; + font table. y unit := 6.0/2.54; + font table. replacements table := 0; + FOR index FROM 1 UPTO 4 + REP font table. on strings (index) := ""; + font table. off strings (index) := ""; + PER; + + . get font table name : + get name list; + symbol type := t text; + symbol := name (names, 1); + IF exists (symbol) + THEN forget (symbol); + IF exists (symbol) + THEN errorstop ("Fonttabelle existiert schon") FI; + FI; + font table name := symbol; + + . initialize font : + IF font nr = max fonts + THEN errorstop ("zu viele Fonts") FI; + font nr INCR 1; + modus := font modus; + replacements length := LENGTH font table. replacements; + font. font string := ""; + font. font name indexes := ""; + font. replacements := ""; + font. extension chars := ""; + font. extension indexes := ""; + font. y offsets := ""0""0""; + font. indentation pitch := int (font table. x unit * 2.54 / 10.0); + font. font lead := 0; + font. font height := int (font table. y unit * 2.54 / 6.0); + font. font depth := 0; + font. next larger font := 0; + font. next smaller font := 0; + font. bold offset := 0; + font. pitch table := font. indentation pitch; + font. replacements table := font table. replacements table; + FOR index FROM 1 UPTO LENGTH font table. extension chars + REP font. replacements table + ( code (font table. extension chars SUB index) + 1 ) := maxint; + PER; + + . get font names : + get name list; + index := 0; + symbol type := t text; + WHILE next font name + REP link nr := link (font table. font names, symbol); + IF link nr = 0 + THEN insert (font table. font names, symbol, link nr); + font table. font name links CAT font nr; + ELIF (font table. font name links ISUB link nr) = 0 + THEN replace (font table. font name links, link nr, font nr); + ELSE errorstop ("Font existiert in Fonttabelle """ + + font table name + """ schon") + FI; + font. font name indexes CAT link nr; + PER; + + . next font name : + get (names, symbol, index); + symbol <> "" + + . get extension char : + get name list; + symbol type := t text; + symbol := name (names, 1); + IF LENGTH symbol <> 1 + THEN errorstop ("nur ein Zeichen bei Erweiterung erlaubt") FI; + extension code 1 := code (symbol) + 1; + IF NOT is kanji esc (symbol) + THEN errorstop ("ESC-Zeichen erwartet") FI; + + . initialize extension : + IF NOT two bytes + THEN errorstop ("Erweiterungen nur im zwei-Byte-Modus erlaubt") FI; + IF extension nr = max extensions + THEN errorstop ("zu viele Erweiterungen") FI; + extension nr INCR 1; + IF modus <> extension modus THEN last modus := modus FI; + modus := extension modus; + IF last modus = font table modus + THEN initalize font table extension + ELSE initalize font extension + FI; + + . initalize font table extension : + IF pos (font table. extension chars, symbol) <> 0 + THEN errorstop ("Erweiterung wurde schon definiert") FI; + extension. replacements := ""; + extension. std pitch := 0; + extension. pitch table := 0; + extension. replacements table := 0; + font table. extension chars CAT symbol; + font table. extension indexes CAT extension nr; + font table. replacements table (extension code 1) := max int; + replacements length := 0; + + . initalize font extension : + IF pos (font. extension chars, symbol) <> 0 + THEN errorstop ("Erweiterung wurde schon definiert") FI; + extension. replacements := ""; + extension. std pitch := font. pitch table (extension code 1) XOR (-maxint-1); + extension. pitch table := extension. std pitch; + font. extension chars CAT symbol; + font. extension indexes CAT extension nr; + char pos := pos (font table. extension chars, symbol); + IF char pos <> 0 + THEN index := font table. extension indexes ISUB char pos; + extension. replacements table := + font table. extensions (index). replacements table; + replacements length := + LENGTH font table. extensions (index). replacements; + font. replacements table (extension code 1) := max int; + ELSE extension. replacements table := 0; + replacements length := 0; + FI; + +. + get identification : + WHILE identification found + REP cout (line nr); + determine identification link nr; + select identification; + PER; + + . identification found : + get next symbol; + symbol type = t tag + + . determine identification link nr : + identification nr := link (english identification, symbol); + english := TRUE; + IF identification nr = 0 + THEN identification nr := link (german identification, symbol); + english := FALSE; + IF identification nr = 0 + THEN errorstop ("unzulaesige Identifikation") FI; + FI; + + . select identification : + get next symbol; + IF symbol <> "=" OR symbol type <> t operator + THEN errorstop ("'=' nach Identifikation fehlt") FI; + get next symbol; + SELECT identification nr OF + CASE x unit : x unit found + CASE y unit : y unit found + CASE on string : on string found + CASE off string : off string found + CASE indentation pitch : indentation pitch found + CASE font lead : font lead found + CASE font height : font height found + CASE font depth : font depth found + CASE larger font : larger font found + CASE smaller font : smaller font found + CASE font string : font string found + CASE y offsets : y offsets found + CASE bold offset : bold offset found + END SELECT; + + . x unit found : + check modus (font table modus); + font table. x unit := real (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("REAL-Denoter nach 'x unit' erwartet") + ELSE errorstop ("REAL-Denoter nach 'x einheit' erwartet") + FI; + FI; + get semicolon; + + . y unit found : + check modus (font table modus); + font table. y unit := real (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("REAL-Denoter nach 'y unit' erwartet") + ELSE errorstop ("REAL-Denoter nach 'y einheit' erwartet") + FI; + FI; + get semicolon; + + . on string found : + check modus (font table modus); + FOR index FROM 1 UPTO 4 + REP IF symbol type <> t text + THEN IF english + THEN errorstop ("TEXT-Denoter nach 'on string' erwartet") + ELSE errorstop ("TEXT-Denoter nach 'on sequenz' erwartet") + FI; + FI; + font table. on strings (index) := symbol; + get next symbol; + IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter + THEN errorstop ("',' oder ';' in Liste erwartet") FI; + IF symbol = ";" THEN LEAVE on string found FI; + IF index = 4 THEN errorstop ("';' erwartet") FI; + get next symbol; + PER; + + . off string found : + check modus (font table modus); + FOR index FROM 1 UPTO 4 + REP IF symbol type <> t text + THEN IF english + THEN errorstop ("TEXT-Denoter nach 'off string' erwartet") + ELSE errorstop ("TEXT-Denoter nach 'off sequenz' erwartet") + FI; + FI; + font table. off strings (index) := symbol; + get next symbol; + IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter + THEN errorstop ("',' oder ';' in Liste erwartet") FI; + IF symbol = ";" THEN LEAVE off string found FI; + IF index = 4 THEN errorstop ("';' erwartet") FI; + get next symbol; + PER; + + . indentation pitch found : + check modus (font modus); + font. indentation pitch := int (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("INT-Denoter nach 'indentation pitch' erwartet") + ELSE errorstop ("INT-Denoter nach 'einrueckbreite' erwartet") + FI; + FI; + font. pitch table := font. indentation pitch; + get semicolon; + + . font lead found : + check modus (font modus); + font. font lead := int (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("INT-Denoter nach 'font lead' erwartet") + ELSE errorstop ("INT-Denoter nach 'durchschuss' erwartet") + FI; + FI; + get semicolon; + + . font height found : + check modus (font modus); + font. font height := int (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("INT-Denoter nach 'font height' erwartet") + ELSE errorstop ("INT-Denoter nach 'fonthoehe' erwartet") + FI; + FI; + get semicolon; + + . font depth found : + check modus (font modus); + font. font depth := int (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("INT-Denoter nach 'font depth' erwartet") + ELSE errorstop ("INT-Denoter nach 'fonttiefe' erwartet") + FI; + FI; + get semicolon; + + . larger font found : + check modus (font modus); + IF symbol type <> t text + THEN IF english + THEN errorstop ("TEXT-Denoter nach 'next larger font' erwartet") + ELSE errorstop ("TEXT-Denoter nach 'groesserer font' erwartet") + FI; + FI; + determine link nr; + font. next larger font := link nr; + get semicolon; + + . smaller font found : + check modus (font modus); + IF symbol type <> t text + THEN IF english + THEN errorstop ("TEXT-Denoter nach 'next smaller font' erwartet") + ELSE errorstop ("TEXT-Denoter nach 'kleinerer font' erwartet") + FI; + FI; + determine link nr; + font. next smaller font := link nr; + get semicolon; + + . determine link nr : + change all (symbol, " ", ""); + IF symbol = "" + THEN link nr := 0 + ELSE link nr := link (font table. font names, symbol); + IF link nr = 0 + THEN insert (font table. font names, symbol, link nr); + font table. font name links CAT 0; + FI; + FI; + + . font string found : + check modus (font modus); + IF symbol type <> t text + THEN IF english + THEN errorstop ("TEXT-Denoter nach 'font string' erwartet") + ELSE errorstop ("TEXT-Denoter nach 'fontsequenz' erwartet") + FI; + FI; + font. font string := symbol; + get semicolon; + + . y offsets found : + check modus (font modus); + font. y offsets := ""; + REP IF symbol = "-" AND symbol type = t operator + THEN vorzeichen := -1; + get next symbol; + ELSE vorzeichen := 1; + FI; + int symbol := vorzeichen * int (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("INT-Denoter nach 'y offsets' erwartet") + ELSE errorstop ("INT-Denoter nach 'y verschiebungen' erwartet") + FI; + FI; + font. y offsets CAT int symbol; + get next symbol; + IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter + THEN errorstop ("',' oder ';' in Liste erwartet") FI; + IF symbol = ";" THEN LEAVE y offsets found FI; + get next symbol; + PER; + + . bold offset found : + check modus (font modus); + IF symbol = "-" AND symbol type = t operator + THEN vorzeichen := -1; + get next symbol; + ELSE vorzeichen := 1; + FI; + font. bold offset := vorzeichen * int (symbol); + IF NOT last conversion ok + THEN IF english + THEN errorstop ("INT-Denoter nach 'bold offset' erwartet") + ELSE errorstop ("INT-Denoter nach 'bold verschiebungen' erwartet") + FI; + FI; + get semicolon; + +. + get char specifications : + WHILE char found + REP cout (line nr); + char specification; + get next symbol; + PER; + + . char found : + symbol type = t text + + . char specification : + IF LENGTH symbol <> 1 + THEN errorstop ("nur ein Zeichen bei Zeichenangabe erlaubt") FI; + char := symbol; + char code 1 := code (char) + 1; + look for specification; + look for specification; + get semicolon; + + . look for specification : + get next symbol; + IF symbol = ";" AND symbol type = t delimiter + THEN LEAVE char specification + ELIF symbol = "," AND symbol type = t delimiter + THEN get specification + ELSE errorstop ("',' oder ';' bei Zeichenspezifikation erwartet") + FI; + + . get specification : + get next symbol; + IF symbol type = t number + THEN pitch specification; + ELIF symbol type = t text + THEN replacement specification + ELSE errorstop ("unzulaessiger Wert bei Zeichenspezifikation") + FI; + + . pitch specification : + int symbol := int (symbol); + IF NOT last conversion ok + THEN errorstop ("INT-Denoter bei Breitenangabe erwartet") FI; + IF modus = font modus + THEN font. pitch table (char code 1) := int symbol; + IF is kanji esc (char) + THEN set bit (font. pitch table (char code 1), 15) FI; + ELIF modus = extension modus + THEN IF last modus = font modus AND + font. pitch table (extension code 1) <> max int + THEN font. pitch table (extension code 1) := max int FI; + extension. pitch table (char code 1) := int symbol; + FI; + + . replacement specification : + IF LENGTH symbol > 255 + THEN errorstop ("Ersatzdarstellungen duerfen nur 255 Zeichen haben") FI; + IF modus = font table modus + THEN font table. replacements table (char code 1) := + (LENGTH font table. replacements + 1); + font table. replacements CAT code (LENGTH symbol); + font table. replacements CAT symbol; + IF is kanji esc (char) + THEN set bit (font table. replacements table (char code 1), 15) FI; + ELIF modus = font modus + THEN font. replacements table (char code 1) := + (replacements length + LENGTH font. replacements + 1); + font. replacements CAT code (LENGTH symbol); + font. replacements CAT symbol; + IF is kanji esc (char) + THEN set bit (font. replacements table (char code 1), 15) FI; + ELIF modus = extension modus + THEN IF last modus = font modus AND + font. replacements table (extension code 1) <> max int + THEN font. replacements table (extension code 1) := max int FI; + extension. replacements table (char code 1) := + (replacements length + LENGTH extension. replacements + 1); + extension. replacements CAT code (LENGTH symbol); + extension. replacements CAT symbol; + FI; + +END PROC load; + + +PROC get name list : + + names := empty thesaurus; + get next symbol; + IF symbol <> ":" OR symbol type <> t delimiter + THEN errorstop ("':' nach Kennung erwartet") FI; + REP get next symbol; + change all (symbol, " ", ""); + IF symbol type <> t text + THEN errorstop ("TEXT-Denoter in Namesliste erwartet") FI; + IF symbol = "" + THEN errorstop ("'niltext' als Name nicht erlaubt") FI; + insert (names, symbol); + get next symbol; + IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter + THEN errorstop ("',' oder ';' in Liste erwartet") FI; + UNTIL symbol = ";" PER; + + . get next symbol : + next symbol (file, symbol, symbol type); + +END PROC get name list; + + +OP := (ROW 256 INT VAR l, INT CONST r) : + +INT VAR i; +IF modus = extension modus OR NOT two bytes + THEN FOR i FROM 1 UPTO 256 REP l (i) := r PER; + ELSE FOR i FROM 1 UPTO 129 REP l (i) := r PER; + FOR i FROM 130 UPTO 160 REP l (i) := r - maxint - 1 PER; + FOR i FROM 161 UPTO 224 REP l (i) := r PER; + FOR i FROM 225 UPTO 240 REP l (i) := r - maxint - 1 PER; + FOR i FROM 241 UPTO 256 REP l (i) := r PER; +FI; + +END OP :=; + + +PROC check modus (INT CONST mod) : + + IF mod <> modus THEN errorstop ("unzulaessige Identifikation") FI; + +END PROC check modus; + + +PROC error (TEXT CONST message) : + +(*INT CONST l := error line;*) + clear error; + errorstop ("Zeile " + text (line nr) + " bei " + letztes symbol + + " : " + message (* + errorline if neccessary *) ); + + . letztes symbol : + IF symbol type <> t text + THEN symbol + ELSE decode (symbol); + """" + symbol + """" + FI +(* + . errorline if neccessary : + IF l = 0 + THEN "" + ELSE " -> " + text (l) + FI +*) +END PROC error; + + +(*******************************************************************) + + +PROC create font file (TEXT CONST font table name, font file name) : + +enable stop; +connect font table; +put font table in font file; + +. + connect font table : + buffer := font table name; + change all (buffer, " ", ""); + IF NOT exists (buffer) COR type (old (buffer)) <> font table type + THEN errorstop ("Fonttabelle """ + buffer + """ gibt es nicht") + FI; + font table := old (buffer); + +. + put font table in font file : + enable stop; + font file := sequential file (output, font file name); + z := " "; + max line length (font file, 1000); + put font table; + FOR font nr FROM 1 UPTO font table. last font REP put font PER; + +. put font table : + z CAT "FONTTABLE : """; z CAT buffer; z CAT """;"; put z; + z CAT " x unit = "; z CAT text (font table. x unit); z CAT ";"; put z; + z CAT " y unit = "; z CAT text (font table. y unit); z CAT ";"; put z; + z CAT " on string = """; z cat on strings; z CAT """;"; put z; + z CAT " off string = """; z cat off strings; z CAT """;"; put z; + put font table replacements; + put font table extensions; + put z; + + . z cat on strings : + FOR index FROM 1 UPTO 4 + REP buffer := font table. on strings (index); + decode (buffer); + z CAT buffer; + IF index <> 4 THEN z CAT """, """ FI; + PER; + + . z cat off strings : + FOR index FROM 1 UPTO 4 + REP buffer := font table. off strings (index); + decode (buffer); + z CAT buffer; + IF index <> 4 THEN z CAT """, """ FI; + PER; + + . put font table replacements : + put z; + FOR char code FROM 0 UPTO 255 + REP char code 1 := char code + 1; + link nr := font table. replacements table (char code 1); + reset bit (link nr, 15); + IF link nr > 0 AND link nr <> maxint + THEN z CAT " "; + put char code; + put font table replacement; + put z; + FI; + PER; + + . put font table replacement : + replacement := subtext (font table. replacements, link nr + 1, + link nr + code (font table. replacements SUB link nr) ); + put replacement; + + . put font table extensions : + IF font table. extension chars <> "" + THEN FOR index FROM 1 UPTO LENGTH font table. extension chars + REP put font table extension PER; + FI; + + . put font table extension : + put z; + z CAT " EXTENSION : """""; + z CAT text 3 (code (font table. extension chars SUB index)); + z CAT """"";"; + put z; put z; + replacements length := 0; + extension nr := font table. extension indexes ISUB index; + FOR char code FROM 0 UPTO 255 + REP char code 1 := char code + 1; + link nr := extension. replacements table (char code 1); + IF link nr > 0 + THEN z CAT " "; + put char code; + put extension replacement; + put z; + FI; + PER; + +. put font : + put z; + z CAT " FONT : "; z cat font names; z CAT ";"; put z; + z CAT " indentation pitch = "; + z CAT text(font. indentation pitch); + z CAT ";"; put z; + IF font. font lead <> 0 + THEN z CAT " font lead = "; + z CAT text(font. font lead); + z CAT ";"; put z; + FI; + z CAT " font height = "; + z CAT text(font. font height); + z CAT ";"; put z; + IF font. font depth <> 0 + THEN z CAT " font depth = "; + z CAT text(font. font depth); + z CAT ";"; put z; + FI; + IF next larger <> "" + THEN z CAT " next larger font = """; + z CAT next larger; + z CAT """;"; put z; + FI; + IF next smaller <> "" + THEN z CAT " next smaller font = """; + z CAT next smaller; + z CAT """;"; put z; + FI; + IF font. font string <> "" + THEN z CAT " font string = """; + z CAT font string; + z CAT """;"; put z; + FI; + IF (font. y offsets ISUB 1) <> 0 OR LENGTH font. y offsets > 2 + THEN z CAT " y offsets = "; + z cat y offsets; + z CAT ";"; put z; + FI; + IF font. bold offset <> 0 + THEN z CAT " bold offset = "; + z CAT text(font. bold offset); + z CAT ";"; put z; + FI; + put font pitches and replacements; + put font extensions; + + . next larger : name (font table. font names, font. next larger font) + . next smaller : name (font table. font names, font. next smaller font) + . font string : buffer := font. font string; decode (buffer); buffer + + . z cat font names : + z CAT """"; + z CAT name (font table. font names, font. font name indexes ISUB 1); + z CAT """"; + FOR index FROM 2 UPTO LENGTH font. font name indexes DIV 2 + REP z CAT ", """; + z CAT name (font table. font names, font. font name indexes ISUB index); + z CAT """"; + PER; + + . z cat y offsets : + z CAT text (font. y offsets ISUB 1); + FOR index FROM 2 UPTO LENGTH font. y offsets DIV 2 + REP z CAT ", "; + z CAT text (font. y offsets ISUB index); + PER; + + . put font pitches and replacements : + BOOL VAR ausgabe := FALSE; + replacements length := LENGTH font table. replacements; + put z; + z CAT " "; + FOR char code FROM 0 UPTO 255 + REP char code 1 := char code + 1; + pitch := font. pitch table (char code 1); + reset bit (pitch, 15); + link nr := font. replacements table (char code 1); + reset bit (link nr, 15); + IF (pitch <> font. indentation pitch) OR + (link nr > replacements length AND link nr <> maxint) + THEN put font char pitch and replacement; + IF ausgabe + THEN put z; + ausgabe := FALSE; + ELSE ausgabe := TRUE; + FI; + z CAT " "; + FI; + PER; + IF ausgabe THEN put z ELSE z := " " FI; + + . put font char pitch and replacement : + put char code; + put font char pitch; + IF link nr > replacements length AND link nr <> maxint + THEN put font replacement; + IF NOT ausgabe THEN z CAT (6 - LENGTH replacement) * " " FI; + ELIF ausgabe + THEN z CAT ";" + ELSE z CAT "; "; + FI; + + . put font char pitch : + IF pitch = max int + THEN char pos := pos (font. extension chars, code (char code)); + IF char pos <> 0 + THEN pitch := font table. extensions + (font. extension indexes ISUB char pos). std pitch + FI; + FI; + put char pitch; + + . put font replacement : + link nr DECR replacements length; + replacement := subtext (font. replacements, link nr + 1, + link nr + code (font. replacements SUB link nr) ); + put replacement; + + . put font extensions : + IF font. extension chars <> "" + THEN FOR index FROM 1 UPTO LENGTH font. extension chars + REP put font extension PER; + FI; + + . put font extension : + put z; + z CAT " ERWEITERUNG : """""; + z CAT text 3 (code (font. extension chars SUB index)); + z CAT """"";"; + put z; put z; z CAT " "; + detemine replacements length; + extension nr := font. extension indexes ISUB index; + ausgabe := FALSE; + FOR char code FROM 0 UPTO 255 + REP char code 1 := char code + 1; + pitch := extension. pitch table (char code 1); + link nr := extension. replacements table (char code 1); + IF pitch <> extension. std pitch OR link nr > replacements length + THEN put extension char pitch and replacement; + IF ausgabe + THEN put z; + ausgabe := FALSE; + ELSE ausgabe := TRUE; + FI; + z CAT " "; + FI; + PER; + IF ausgabe THEN put z ELSE z := " " FI; + + . detemine replacements length : + char pos := pos (font table. extension chars, + font. extension chars SUB index); + IF char pos <> 0 + THEN replacements length := LENGTH font table. extensions + (font table. extension indexes ISUB char pos). replacements; + ELSE replacements length := 0; + FI; + + . put extension char pitch and replacement : + put char code; + put char pitch; + IF link nr > replacements length + THEN put extension replacement; + IF NOT ausgabe THEN z CAT (6 - LENGTH replacement) * " " FI; + ELIF ausgabe + THEN z CAT ";" + ELSE z CAT "; "; + FI; + +. put extension replacement : + link nr DECR replacements length; + replacement := subtext (extension. replacements, link nr + 1, + link nr + code (extension. replacements SUB link nr) ); + put replacement; + +. put char code : + IF (char code >= 32 AND char code <= 122) OR + (char code >= 214 AND char code <= 223) OR + char code = 124 OR char code = 126 OR char code = 251 + THEN z CAT "(* "; + z CAT code (char code); + z CAT " *) """""; + ELSE z CAT " """""; + FI; + z CAT text 3 (char code); + z CAT """"""; + +. put char pitch : + z CAT ","; + z CAT text (pitch, 5); + +. put replacement : + decode (replacement); + z CAT ", """; + z CAT replacement; + z CAT """;" + +END PROC create font file; + + +PROC put z : + + putline (font file, z); + cout (lines (font file)); + z := " "; + +END PROC put z; + + +PROC decode (TEXT VAR string) : + + INT VAR p; + change all (string, """", """"""); + p := pos (string, ""0"", ""31"", 1); + WHILE p <> 0 + REP change (string, p, p, """" + text (code(string SUB p)) + """"); + p := pos (string, ""0"", ""31"", p); + PER; + p := pos (string, ""127"", ""255"", 1); + WHILE p <> 0 + REP change (string, p, p, """" + text (code(string SUB p)) + """"); + p := pos (string, ""127"", ""255"", p); + PER; + +END PROC decode; + + +TEXT PROC text 3 (INT CONST value) : + + buffer := text (value, 3); + change all (buffer, " ", "0"); + buffer + +END PROC text 3; + +END PACKET font convertor; -- cgit v1.2.3