diff options
Diffstat (limited to 'app/conversion/1.0/src/FONTANAL.PAC')
| -rw-r--r-- | app/conversion/1.0/src/FONTANAL.PAC | 261 |
1 files changed, 261 insertions, 0 deletions
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;
|