(* ------------------- VERSION 3 06.03.86 ------------------- *)
PACKET text DEFINES
max text length ,
SUB ,
subtext ,
text ,
length , LENGTH ,
CAT ,
+ ,
* ,
replace ,
change ,
change all ,
compress ,
pos ,
code ,
ISUB ,
RSUB ,
delete char ,
insert char ,
delete int ,
insert int ,
heap size ,
collect heap garbage ,
stranalyze ,
LEXEQUAL ,
LEXGREATER ,
LEXGREATEREQUAL :
TEXT VAR text buffer , tail buffer ;
INT CONST max text length := 32000 ;
TEXT OP SUB (TEXT CONST text, INT CONST pos ) :
EXTERNAL 48
END OP SUB ;
TEXT PROC subtext (TEXT CONST source, INT CONST from, to ):
EXTERNAL 49
ENDPROC subtext ;
TEXT PROC subtext (TEXT CONST source, INT CONST from ) :
EXTERNAL 50
ENDPROC subtext ;
INT PROC code (TEXT CONST text) :
EXTERNAL 46
END PROC code ;
TEXT PROC code (INT CONST code) :
EXTERNAL 47
ENDPROC code ;
INT OP ISUB (TEXT CONST text, INT CONST index) :
EXTERNAL 44
ENDOP ISUB ;
PROC replace (TEXT VAR text, INT CONST index, value) :
EXTERNAL 45
ENDPROC replace ;
REAL OP RSUB (TEXT CONST text, INT CONST index) :
EXTERNAL 100
ENDOP RSUB ;
PROC replace (TEXT VAR text, INT CONST index, REAL CONST code) :
EXTERNAL 101
ENDPROC replace ;
PROC replace (TEXT VAR dest, INT CONST pos, TEXT CONST source) :
EXTERNAL 51
ENDPROC replace ;
TEXT PROC text (TEXT CONST source, INT CONST length ) :
IF length < LENGTH source
THEN text buffer := subtext (source,1,length)
ELSE text buffer := source ;
mit blanks auffuellen
FI ;
text buffer .
mit blanks auffuellen :
INT VAR i ;
FOR i FROM 1 UPTO length - LENGTH source REP
text buffer CAT " "
PER .
ENDPROC text ;
TEXT PROC text (TEXT CONST source, INT CONST length, from) :
text ( subtext (source, from) , length )
ENDPROC text ;
OP CAT (TEXT VAR right, TEXT CONST left ) :
EXTERNAL 52
ENDOP CAT ;
TEXT OP + (TEXT CONST left, right) :
text buffer := left ;
text buffer CAT right ;
text buffer
ENDOP + ;
TEXT OP * (INT CONST times, TEXT CONST source ) :
text buffer := "" ;
INT VAR i ;
FOR i FROM 1 UPTO times REP
text buffer CAT source
PER ;
text buffer
ENDOP * ;
INT PROC length (TEXT CONST text ) :
EXTERNAL 53
ENDPROC length ;
INT OP LENGTH (TEXT CONST text ) :
EXTERNAL 53
ENDOP LENGTH ;
INT PROC pos (TEXT CONST source, pattern) :
EXTERNAL 54
ENDPROC pos ;
INT PROC pos (TEXT CONST source, pattern, INT CONST from) :
EXTERNAL 55
ENDPROC pos ;
INT PROC pos (TEXT CONST source, pattern, INT CONST from, to) :
EXTERNAL 56
ENDPROC pos ;
INT PROC pos (TEXT CONST source, low, high, INT CONST from) :
EXTERNAL 58
ENDPROC pos ;
TEXT PROC compress (TEXT CONST text) :
INT VAR begin, end ;
search first non blank ;
search last non blank ;
text buffer := subtext (text, begin, end) ;
text buffer .
search first non blank :
begin := 1 ;
WHILE (text SUB begin) = " " REP
begin INCR 1
PER .
search last non blank :
end := LENGTH text ;
WHILE (text SUB end) = " " REP
end DECR 1
PER .
ENDPROC compress ;
PROC change (TEXT VAR destination, INT CONST from, to, TEXT CONST new) :
IF LENGTH new = to - from + 1 AND to <= LENGTH destination
THEN replace (destination, from, new)
ELSE change via buffer
FI .
change via buffer :
text buffer := subtext (destination, 1, from-1) ;
text buffer CAT new ;
tail buffer := subtext (destination, to + 1) ;
text buffer CAT tail buffer ;
destination := text buffer
ENDPROC change ;
PROC change (TEXT VAR destination, TEXT CONST old, new) :
INT CONST position := pos (destination, old) ;
IF position > 0
THEN change (destination, position, position + LENGTH old -1, new)
FI
ENDPROC change ;
PROC change all (TEXT VAR destination, TEXT CONST old, new) :
INT VAR position := pos (destination, old) ;
IF LENGTH old = LENGTH new
THEN change by replace
ELSE change by change
FI .
change by replace :
WHILE position > 0 REP
replace (destination, position, new) ;
position := pos (destination, old, position + LENGTH new)
PER .
change by change :
WHILE position > 0 REP
change (destination, position, position + LENGTH old - 1 , new) ;
position := pos (destination, old, position + LENGTH new)
PER .
ENDPROC change all ;
PROC delete char (TEXT VAR string, INT CONST delete pos) :
IF delete pos > 0
THEN tail buffer := subtext (string, delete pos + 1) ;
string := subtext (string, 1, delete pos - 1) ;
string CAT tail buffer
FI
END PROC delete char ;
PROC insert char (TEXT VAR string, TEXT CONST char,
INT CONST insert pos) :
IF insert pos > 0 AND insert pos <= LENGTH string + 1
THEN tail buffer := subtext (string, insert pos) ;
string := subtext (string, 1, insert pos - 1) ;
string CAT char ;
string CAT tail buffer
FI
END PROC insert char ;
INT PROC heap size :
EXTERNAL 93
ENDPROC heap size ;
PROC collect heap garbage :
EXTERNAL 94
ENDPROC collect heap garbage ;
PROC stranalyze (ROW 256 INT CONST table, INT VAR sum, INT CONST max sum,
TEXT CONST string, INT VAR index, INT CONST to,
INT VAR exit code) :
EXTERNAL 57
ENDPROC stranalyze ;
(*******************************************************************)
(* lexikographische Vergleiche *)
(* Nach DIN 5007, Abschnitt 1 und Abschnitt 3.2 (Bindestrich) *)
(* Autor: Rainer Hahn, Jochen Liedtke *)
(* Stand: 1.7.4 (Jan. 1985) *)
(*******************************************************************)
LET first umlaut = ""214"" ,
umlauts = ""214""215""216""217""218""219""251"" ;
TEXT VAR left letter, right letter;
BOOL OP LEXEQUAL (TEXT CONST left, right) :
compare (left, right) ;
left letter = right letter
ENDOP LEXEQUAL ;
BOOL OP LEXGREATER (TEXT CONST left, right) :
compare (left, right) ;
left letter > right letter
ENDOP LEXGREATER ;
BOOL OP LEXGREATEREQUAL (TEXT CONST left, right) :
compare (left, right) ;
left letter >= right letter
ENDOP LEXGREATEREQUAL ;
PROC compare (TEXT CONST left, right) :
to begin of lex relevant text ;
REP
get left letter ;
get right letter
UNTIL NOT letter match OR both ended PER .
to begin of lex relevant text :
INT VAR
left pos := pos (left, ""65"",""254"", 1) ,
right pos := pos (right,""65"",""254"", 1) ;
IF left pos = 0
THEN left pos := LENGTH left + 1
FI ;
IF right pos = 0
THEN right pos := LENGTH right + 1
FI .
get left letter :
left letter := left SUB left pos ;
left pos INCR 1 .
get right letter :
right letter := right SUB right pos ;
right pos INCR 1 .
letter match :
IF left letter = right letter
THEN TRUE
ELSE dine (left, left letter, left pos) ;
dine (right, right letter, right pos) ;
IF exactly one letter is double letter
THEN expand other letter
FI ;
left letter = right letter
FI .
exactly one letter is double letter :
LENGTH left letter <> LENGTH right letter.
expand other letter :
IF LENGTH left letter = 1
THEN left letter CAT (left SUB left pos) ;
left pos INCR 1
ELSE right letter CAT (right SUB right pos) ;
right pos INCR 1
FI .
both ended : left letter = "" .
ENDPROC compare ;
PROC dine (TEXT CONST string, TEXT VAR char, INT VAR string pos) :
skip non letter chars ;
IF is capital letter
THEN translate to small letter
ELIF char >= first umlaut
THEN translate umlaut
FI .
skip non letter chars :
WHILE NOT (is letter OR end of string) REP
char := string SUB string pos ;
string pos INCR 1
PER .
translate to small letter :
char := code (code (char) + 32) .
translate umlaut :
SELECT pos (umlauts, char) OF
CASE 1,4 : char := "ae"
CASE 2,5 : char := "oe"
CASE 3,6 : char := "ue"
CASE 7 : char := "ss"
ENDSELECT .
is capital letter :
INT VAR char code := code (char) ;
65 <= char code AND char code <= 90 .
is letter :
char code := code (char) OR 32 ;
(97 <= char code AND char code <= 122) OR char code >= 128 .
end of string : char = "" .
ENDPROC dine ;
OP CAT (TEXT VAR result, INT CONST number) :
result CAT " ";
replace (result, LENGTH result DIV 2, number);
END OP CAT;
PROC insert int (TEXT VAR result, INT CONST insert pos, number) :
INT VAR pos := insert pos * 2 - 1;
change (result, pos, pos - 1, " ");
replace (result, insert pos, number);
END PROC insert int;
PROC delete int (TEXT VAR result, INT CONST delete pos) :
INT VAR pos := delete pos * 2;
change (result, pos - 1, pos, "")
END PROC delete int;
ENDPACKET text ;