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;