summaryrefslogtreecommitdiff
path: root/system/base/1.7.5/src/thesaurus
diff options
context:
space:
mode:
Diffstat (limited to 'system/base/1.7.5/src/thesaurus')
-rw-r--r--system/base/1.7.5/src/thesaurus332
1 files changed, 332 insertions, 0 deletions
diff --git a/system/base/1.7.5/src/thesaurus b/system/base/1.7.5/src/thesaurus
new file mode 100644
index 0000000..5ef7251
--- /dev/null
+++ b/system/base/1.7.5/src/thesaurus
@@ -0,0 +1,332 @@
+(* ------------------- VERSION 2 06.03.86 ------------------- *)
+PACKET thesaurus handling (* Autor: J.Liedtke *)
+
+ DEFINES THESAURUS ,
+ := ,
+ empty thesaurus ,
+ insert, (* fuegt ein Element ein *)
+ delete, (* loescht ein Element falls vorhanden*)
+ rename, (* aendert ein Element falls vorhanden*)
+ CONTAINS , (* stellt fest, ob enthalten *)
+ link , (* index in thesaurus *)
+ name , (* name of entry *)
+ get , (* get next entry ("" is eof)*)
+ highest entry : (* highest valid index of thes*)
+
+
+TYPE THESAURUS = TEXT ;
+
+LET thesaurus size = 200 ,
+ nil = 0 ,
+ niltext = "" ,
+ max name length = 80 ,
+
+ begin entry char = ""0"" ,
+ end entry char = ""1"" ,
+
+ nil entry = ""0""1"" ,
+ nil name = "" ,
+
+ quote = """" ;
+
+TEXT VAR entry ;
+INT VAR cache index := 0 ,
+ cache pos ;
+
+
+PROC access (THESAURUS CONST thesaurus, TEXT CONST name) :
+
+ construct entry ;
+ IF NOT cache identifies entry
+ THEN search through thesaurus list
+ FI ;
+ IF entry found
+ THEN cache index := code (list SUB (cache pos - 1))
+ ELSE cache index := 0
+ FI .
+
+construct entry :
+ entry := begin entry char ;
+ entry CAT name ;
+ decode invalid chars (entry, 2) ;
+ entry CAT end entry char .
+
+search through thesaurus list :
+ cache pos := pos (list, entry) .
+
+cache identifies entry :
+ cache pos <> 0 AND
+ pos (list, entry, cache pos, cache pos + LENGTH entry) = cache pos .
+
+entry found : cache pos > 0 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC access ;
+
+PROC access (THESAURUS CONST thesaurus, INT CONST index) :
+
+ IF cache identifies index
+ THEN cache index := index ;
+ construct entry
+ ELSE cache pos := pos (list, code (index) + begin entry char) ;
+ IF entry found
+ THEN cache pos INCR 1 ;
+ cache index := index ;
+ construct entry
+ ELSE cache index := 0 ;
+ entry := niltext
+ FI
+ FI .
+
+construct entry :
+ entry := subtext (list, cache pos, pos (list, end entry char, cache pos)) .
+
+cache identifies index :
+ subtext (list, cache pos-1, cache pos) = code (index) + begin entry char .
+
+entry found : cache pos > 0 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC access ;
+
+
+
+THESAURUS PROC empty thesaurus :
+
+ THESAURUS : (""1"")
+
+ENDPROC empty thesaurus ;
+
+
+OP := (THESAURUS VAR dest, THESAURUS CONST source ) :
+
+ CONCR (dest) := CONCR (source) .
+
+ENDOP := ;
+
+TEXT VAR insert name ;
+
+PROC insert (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) :
+
+ insert name := name ;
+ decode invalid chars (insert name, 1) ;
+ IF insert name = "" OR LENGTH insert name > max name length
+ THEN index := nil ; errorstop ("Name unzulaessig")
+ ELSE insert element
+ FI .
+
+insert element :
+ search free entry ;
+ IF entry found
+ THEN insert into directory
+ ELSE add entry to directory if possible
+ FI .
+
+search free entry :
+ access (thesaurus, nil name) .
+
+insert into directory :
+ change (list, cache pos + 1, cache pos, insert name) ;
+ index := cache index .
+
+add entry to directory if possible :
+ INT CONST next free index := code (list SUB LENGTH list) ;
+ IF next free index <= thesaurus size
+ THEN add entry to directory
+ ELSE directory overflow
+ FI .
+
+add entry to directory :
+ list CAT begin entry char ;
+ cache pos := LENGTH list ;
+ cache index := next free index ;
+ list CAT insert name ;
+ list CAT end entry char + code (next free index + 1) ;
+ index := cache index .
+
+directory overflow :
+ index := nil .
+
+entry found : cache index > 0 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC insert ;
+
+PROC decode invalid chars (TEXT VAR name, INT CONST start pos) :
+
+ INT VAR invalid char pos := pos (name, ""0"", ""31"", start pos) ;
+ WHILE invalid char pos > 0 REP
+ change (name, invalid char pos, invalid char pos, decoded char) ;
+ invalid char pos := pos (name, ""0"", ""31"", invalid char pos)
+ PER .
+
+decoded char : quote + text(code(name SUB invalid char pos)) + quote.
+
+ENDPROC decode invalid chars ;
+
+PROC insert (THESAURUS VAR thesaurus, TEXT CONST name) :
+
+ INT VAR index ;
+ insert (thesaurus, name, index) ;
+ IF index = nil AND NOT is error
+ THEN errorstop ("THESAURUS-Ueberlauf")
+ FI .
+
+ENDPROC insert ;
+
+PROC delete (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) :
+
+ access (thesaurus, name) ;
+ index := cache index ;
+ delete (thesaurus, index) .
+
+ENDPROC delete ;
+
+PROC delete (THESAURUS VAR thesaurus, INT CONST index) :
+
+ access (thesaurus, index) ;
+ IF entry found
+ THEN delete entry
+ FI .
+
+delete entry :
+ IF is last entry of thesaurus
+ THEN cut off as much as possible
+ ELSE set to nil entry
+ FI .
+
+set to nil entry :
+ change (list, cache pos, cache pos + LENGTH entry - 1, nil entry) .
+
+cut off as much as possible :
+ WHILE predecessor is also nil entry REP
+ set cache to this entry
+ PER ;
+ list := subtext (list, 1, cache pos - 1) ;
+ erase cache .
+
+predecessor is also nil entry :
+ subtext (list, cache pos - 3, cache pos - 2) = nil entry .
+
+set cache to this entry :
+ cache pos DECR 3 .
+
+erase cache :
+ cache pos := 0 ;
+ cache index := 0 .
+
+is last entry of thesaurus :
+ pos (list, end entry char, cache pos) = LENGTH list - 1 .
+
+list : CONCR (thesaurus) .
+
+entry found : cache index > nil .
+
+ENDPROC delete ;
+
+
+BOOL OP CONTAINS (THESAURUS CONST thesaurus, TEXT CONST name ) :
+
+ IF name = niltext OR LENGTH name > max name length
+ THEN FALSE
+ ELSE access (thesaurus, name) ; entry found
+ FI .
+
+entry found : cache index > nil .
+
+ENDOP CONTAINS ;
+
+PROC rename (THESAURUS VAR thesaurus, TEXT CONST old, new) :
+
+ rename (thesaurus, link (thesaurus, old), new)
+
+ENDPROC rename ;
+
+PROC rename (THESAURUS VAR thesaurus, INT CONST index, TEXT CONST new) :
+
+ insert name := new ;
+ decode invalid chars (insert name, 1) ;
+ IF insert name = "" OR LENGTH insert name > max name length
+ THEN errorstop ("Name unzulaessig")
+ ELSE change to new name
+ FI .
+
+change to new name :
+ access (thesaurus, index) ;
+ IF cache index <> 0 AND entry <> ""
+ THEN change (list, cache pos + 1, cache pos + LENGTH entry - 2, insert name)
+ FI .
+
+list : CONCR (thesaurus) .
+
+ENDPROC rename ;
+
+INT PROC link (THESAURUS CONST thesaurus, TEXT CONST name) :
+
+ access (thesaurus, name) ;
+ cache index .
+
+ENDPROC link ;
+
+TEXT PROC name (THESAURUS CONST thesaurus, INT CONST index) :
+
+ access (thesaurus, index) ;
+ subtext (entry, 2, LENGTH entry - 1) .
+
+ENDPROC name ;
+
+PROC get (THESAURUS CONST thesaurus, TEXT VAR name, INT VAR index) :
+
+ identify index ;
+ REP
+ to next entry
+ UNTIL end of list COR valid entry found PER .
+
+identify index :
+ IF index = 0
+ THEN cache index := 0 ;
+ cache pos := 1
+ ELSE access (thesaurus, index)
+ FI .
+
+to next entry :
+ cache pos := pos (list, begin entry char, cache pos + 1) ;
+ IF cache pos > 0
+ THEN get entry
+ ELSE get nil entry
+ FI .
+
+get entry :
+ cache index INCR 1 ;
+ index := cache index ;
+ name := subtext (list, cache pos + 1, end entry pos - 1) .
+
+get nil entry :
+ cache index := 0 ;
+ cache pos := 0 ;
+ index := 0 ;
+ name := "" .
+
+end entry pos : pos (list, end entry char, cache pos) .
+
+end of list : index = 0 .
+
+valid entry found : name <> "" .
+
+list : CONCR (thesaurus) .
+
+ENDPROC get ;
+
+INT PROC highest entry (THESAURUS CONST thesaurus) : (*840813*)
+
+ code (list SUB LENGTH list) - 1 .
+
+list : CONCR (thesaurus) .
+
+ENDPROC highest entry ;
+
+ENDPACKET thesaurus handling ;
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-25 18:02:31 +0000