Initial import

1 files changed, 360 insertions, 0 deletions

diff --git a/lang/prolog/1.8.7/src/thesaurus b/lang/prolog/1.8.7/src/thesaurus
new file mode 100644
index 0000000..4694981
--- /dev/null
+++ b/lang/prolog/1.8.7/src/thesaurus
@@ -0,0 +1,360 @@
+(* ------------------- VERSION 2     19.01.87 ------------------- *)
+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                       *)
+                   decode invalid chars ,(* Steuerzeichen dekodieren            *)
+                   get ,                 (* get next entry ("" is eof)          *)
+                   highest entry :       (* highest valid index of thes         *)
+
+
+TYPE THESAURUS = TEXT ;
+ 
+LET nil = 0 ,
+    niltext = "" ,
+    max name length = 80 ,
+    begin entry char = ""0"" ,
+    end entry char   = ""255"" ,
+    nil entry        = ""0""255"" ,
+    nil name         = "" ,
+    quote            = """" ;
+
+TEXT VAR entry ,
+         dummy ;
+INT VAR  cache index := 0 ,
+         cache pos ;
+
+
+TEXT PROC decode (INT CONST number) :
+
+  dummy := "  " ;
+  replace (dummy, 1, number) ;
+  dummy .
+
+ENDPROC decode ;
+
+INT PROC decode (TEXT CONST string, INT CONST position) :
+
+  subtext (string, position, position + 1) ISUB 1 .
+
+ENDPROC decode ;
+
+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 := decode (list, cache pos - 2)
+    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, decode (index) + begin entry char) ;
+         IF entry found
+           THEN cache pos INCR 2 ;
+                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-2, cache pos) = decode (index) + begin entry char .
+
+entry found :  cache pos > 0 .
+
+list :    CONCR (thesaurus) .
+
+ENDPROC access ;
+
+
+
+THESAURUS PROC empty thesaurus :
+
+  THESAURUS : (""1""0"")
+
+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) ;
+  insert name if possible .
+
+insert name if possible :
+  IF insert name = "" OR LENGTH insert name > max name length
+    THEN index := nil ; errorstop ("Name unzulaessig")
+  ELIF overflow
+      THEN index := nil
+      ELSE insert element
+  FI .
+ 
+overflow :
+  LENGTH CONCR (thesaurus) + LENGTH insert name + 4 > max text length .
+
+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 := decode (list, LENGTH list - 1) ;
+  add entry to directory .
+
+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 + decode (next free index + 1) ;
+  index := cache index .
+
+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 ;
+  change all (name, ""255"", quote + "255" + quote) .
+
+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 - 4, cache pos - 3) = nil entry .
+
+set cache to this entry :
+  cache pos DECR 4 .
+
+erase cache :
+  cache pos := 0 ;
+  cache index := 0 .
+
+is last entry of thesaurus :
+  pos (list, end entry char, cache pos) = LENGTH list - 2 .
+
+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 overflow
+    THEN errorstop ("THESAURUS-Ueberlauf")
+  ELIF insert name = "" OR LENGTH insert name > max name length 
+    THEN errorstop ("Name unzulaessig")
+    ELSE change to new name
+  FI .
+ 
+overflow :
+  LENGTH CONCR (thesaurus) + LENGTH insert name + 4 > max text length .
+
+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 correct cache pos ;
+         get entry
+    ELSE get nil entry
+  FI .
+
+correct cache pos :
+  IF (list SUB cache pos + 2) = begin entry char
+    THEN cache pos INCR 2
+  ELIF (list SUB cache pos + 1) = begin entry char
+    THEN cache pos INCR 1
+  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*)
+
+  decode (list, LENGTH list - 1) - 1 .
+
+list :   CONCR (thesaurus) .
+
+ENDPROC highest entry ;
+
+ENDPACKET thesaurus handling ;
+