(* ------------------- 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 ;