From 04e68443040c7abad84d66477e98f93bed701760 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 4 Feb 2019 13:09:03 +0100 Subject: Initial import --- app/conversion/1.0/src/FONTANAL.PAC | 261 ++++++++++++++++++++++++++++++++++++ 1 file changed, 261 insertions(+) create mode 100644 app/conversion/1.0/src/FONTANAL.PAC (limited to 'app/conversion/1.0/src/FONTANAL.PAC') diff --git a/app/conversion/1.0/src/FONTANAL.PAC b/app/conversion/1.0/src/FONTANAL.PAC new file mode 100644 index 0000000..c1dc502 --- /dev/null +++ b/app/conversion/1.0/src/FONTANAL.PAC @@ -0,0 +1,261 @@ +PACKET font analysis DEFINES find fonttable, + analyze fonts, + analyze indent levels : +INT VAR th index, cmd index, no of params; +TEXT VAR buffer line; +TEXT PROC next type command (FILE VAR f, INT VAR line number, cont pos) : + INT VAR start pos; + TEXT VAR type cmd := ""; + search loop; + line number := line no (f); + type cmd +. + search loop : + REP + downety (f, "#type"); + IF pattern found + THEN start pos := col (f); + read record (f, buffer line); + IF even number of command delimiters (buffer line, start pos - 1) + THEN extract command (buffer line, start pos, cont pos, type cmd); + col (f, cont pos); + LEAVE search loop + ELSE col (f, start pos + 1) + FI + FI + UNTIL NOT pattern found PER; + cont pos := col (f) +END PROC next type command; +PROC find fonttable (THESAURUS CONST used fonts th, TEXT VAR table name) : + LET old table type = 3009, + new table type = 3100; + TEXT VAR font name; + TEXT CONST users fonttable := fonttable; + INT VAR ds type, fonttable th index; + disable stop; + command dialogue (FALSE); + THESAURUS CONST fonttable th := ALL /"configurator"; + try all fonttables; + fonttable (users fonttable); + command dialogue (TRUE); + enable stop; + IF table name = "" + THEN errorstop ("Keine zur Datei passende Fonttabelle gefunden") + FI +. +try all fonttables : + fonttable th index := 0; + get (fonttable th, table name, fonttable th index); + WHILE fonttable th index > 0 REP + fetch (table name, /"configurator"); + ds type := type (old (table name)); + forget (table name); + IF ds type = old table type COR ds type = new table type + THEN fonttable (table name); + IF is error + THEN put error; + putline ("Fonttabelle `" + table name + "' kann nicht eingestellt werden."); + IF yes ("Abbrechen") + THEN enable stop + ELSE clear error + FI + ELSE IF all used fonts present + THEN LEAVE try all fonttables + FI + FI + FI; + get (fonttable th, table name, fonttable th index) + PER; + table name := "" +. +all used fonts present : + th index := 0; + get (used fonts th, font name, th index); + WHILE th index > 0 REP + IF NOT font exists (font name) + THEN LEAVE all used fonts present WITH FALSE + FI; + get (used fonts th, font name, th index) + PER; + TRUE +END PROC find fonttable; +PROC analyze fonts (FILE VAR f, TEXT VAR fonttable name, + font numbers, INT VAR base font index) : + THESAURUS VAR font th; + TEXT VAR usage, base font; + fonttable name := ""; + font numbers := ""; + base font index := 0; + collect fonts (f, font th, usage); + IF highest entry (font th) <> 0 + THEN analyze users fonts + FI; +. +analyze users fonts : + find fonttable (font th, fonttable name); + TEXT CONST users fonttable := fonttable; + fonttable (fonttable name); + provide font numbers (font th, font numbers, usage, base font); + sort fonts (font numbers); + base font index := pos (font numbers, base font); + IF users fonttable <> "" + THEN fonttable (users fonttable) + FI +END PROC analyze fonts; +PROC analyze fonts (TEXT CONST file name, TEXT VAR fonttable name, + font numbers, INT VAR base font index) : + FILE VAR f := sequential file (modify, file name); + analyze fonts (f, fonttable name, font numbers, base font index) +END PROC analyze fonts; +PROC collect fonts (FILE VAR f, THESAURUS VAR th, TEXT VAR line numbers) : + TEXT VAR cmd, font name, param2; + INT VAR current ln, last ln := 0, + act distance, current font lines, + next pos; + th := empty thesaurus; + line numbers := ""; + toline (f, 1); + col (f, 1); + WHILE NOT eof (f) REP + cmd := next type command (f, current ln, next pos); + cout (current ln); + note text lines for last font; + process font cmd + PER +. + note text lines for last font : + IF last ln <> 0 + THEN act distance := current ln - last ln; + current font lines := line numbers ISUB th index; + current font lines INCR act distance; + replace (line numbers, th index, current font lines) + FI +. +process font cmd : + analyze command ("type:1.1", cmd, 0, cmd index, no of params, + font name, param2); + IF cmd index = 1 + THEN th index := link (th, font name); + IF th index = 0 + THEN add new font + FI; + last ln := current ln + FI +. + add new font : + insert (th, font name, th index); + line numbers CAT ""0""0"" +END PROC collect fonts; +PROC provide font numbers (THESAURUS CONST fonts th, TEXT VAR font numbers, + line numbers, base font name) : + TEXT VAR font name, font no, old line numbers := line numbers; + font numbers := ""; + line numbers := ""; + INT VAR font index, line number, last greatest; + th index := 0; + get (fonts th, font name, th index); + WHILE th index > 0 REP + font no := code (font (font name)); + font index := pos (font numbers, font no); + IF font index = 0 + THEN transfer font + ELSE sum text line number + FI; + get (fonts th, font name, th index) + PER; + determine font with most text +. + transfer font : + font numbers CAT font no; + line numbers CAT (old line numbers ISUB th index) +. + sum text line number : + line number := line numbers ISUB font index; + line number INCR (old line numbers ISUB th index); + replace (line numbers, font index, line number) +. + determine font with most text : + last greatest := 0; + FOR font index FROM 1 UPTO (LENGTH line numbers) DIV 2 REP + line number := line numbers ISUB font index; + IF line number > last greatest + THEN last greatest := line number; + base font name := font numbers SUB font index + FI + PER; +END PROC provide font numbers; +PROC sort fonts (TEXT VAR fonts) : + TEXT VAR font name, spec font; + INT VAR font no, size; + th index := 0; + disable stop; + FILE VAR f := sequential file (output, "fonts"); + get font sizes; + sort ("fonts"); + restore fonts text; + forget ("fonts", quiet); + enable stop +. + get font sizes : + FOR th index FROM 1 UPTO LENGTH fonts REP + font name := fonts SUB th index; + font no := code (font name); + specify size + PER +. + specify size : + size := (indentation pitch (font no) DIV 2) + * (font height (font no) DIV 2); + rotate (size, 8); + spec font := ""223""223""; + replace (spec font, 1, size); + spec font CAT font name; + putline (f, spec font) +. + restore fonts text : + fonts := ""; + input (f); + WHILE NOT eof (f) REP + getline (f, spec font); + font name := spec font SUB 3; + fonts CAT font name + PER +END PROC sort fonts; +PROC analyze indent levels (TEXT CONST file name, TEXT VAR levels string) : + FILE VAR f := sequential file (input, file name); + analyze indent levels (f, levels string); + modify (f) +END PROC analyze indent levels; +PROC analyze indent levels (FILE VAR f, TEXT VAR levels string) : + INT VAR i; + TEXT VAR l, act blanks, current item; + levels string := ""; + WHILE NOT eof (f) REP + getline (f, l); + i := pos (l, ""33"", ""255"", 1) - 1; + IF i > 0 + THEN act blanks := code (i); + i := 1; + IF not yet remembered + THEN insert act blanks + FI + FI + PER; + modify (f) +. +not yet remembered : + WHILE i <= LENGTH levels string REP + current item := levels string SUB i; + IF current item < act blanks + THEN i INCR 1 + ELIF current item = act blanks + THEN LEAVE not yet remembered WITH FALSE + ELSE LEAVE not yet remembered WITH TRUE + FI + PER; + TRUE +. +insert act blanks : + insert char (levels string, act blanks, i) +END PROC analyze indent levels; +END PACKET font analysis; -- cgit v1.2.3