(*******************************************************************)
(** Release history:                                              **)
(**    17th January 1985   version 1.0.0 First port to new world  **)
(*******************************************************************)
IMPLEMENTATION MODULE Dict;

 (*
    Title   :  Dictionary Management System
    LastEdit:  Fri Dec 28 12:38:18 1984
    Author  :  LDS & GT
    Acorn Computers VLSI Design Aids Group
*)

FROM   SYSTEM     IMPORT WORD, TSIZE, MAXINT, ADDRESS, ADR;
FROM   Strings    IMPORT String;
IMPORT Strings;
FROM   SysStreams IMPORT sysOut, sysErr;
FROM   Storage    IMPORT ALLOCATE, DEALLOCATE;
FROM   XStorage   IMPORT tSP, tNew, tMark, tPop;
FROM   MinAndMax  IMPORT Max;
FROM   lcASCII    IMPORT lcascii;
FROM   TextIO     IMPORT WriteChars, WriteString;
IMPORT WriteF; 
FROM WriteF IMPORT S, H;
CONST  VeryBig = MAXINT DIV 16;
       FAILED  = FALSE;
       SUCCESS = TRUE;
       EndStringCh = 0C;       
TYPE    HIDDEN = POINTER TO Dictionary;

        pEntry = POINTER TO Entry;
         Entry = RECORD
	           next: pEntry;
                   name: String;    (* Key to be looked at           *)
		   Attr: KeyAttr;   (* ExactLength? ExactCase?       *)
               MatchLen: INTEGER;   (* Min len for unambiguous match *)
                  order: INTEGER;
                   item: WORD;
                 END;

    Dictionary = RECORD
                Entries: pEntry;
	    nextEntryNo: INTEGER;
                   size: INTEGER;
               modified: BOOLEAN;   (* whether to re-compute min-matches *)
                 END;
		 
   pEntryArray = POINTER TO ARRAY [0..VeryBig] OF pEntry;
   
         MATCH = (YES, NO, AMBIGUOUS);

      WORDPROC = PROCEDURE(VAR WORD); (* Dispose procs must look like this. *)
(*------------------------------------------------------------------------*)
PROCEDURE MinMatch (e1, e2: pEntry);
VAR  c1, c2: CHAR;  MinLen: INTEGER;
BEGIN
  (* compute the minimum prefix of e1 and e2. This is used to *)
  (* accumulate Max (MinPrefix (ej, ek)) for each ej.            *)
  (* Character-case is ignored for this purpose.              *)
  MinLen := 0;
  LOOP
    c1 := e1^.name^[MinLen];  c2 := e2^.name^[MinLen];  INC (MinLen);
    IF  (c1 = 0C) OR (c2 = 0C)  THEN EXIT END;
    c1 := lcascii[c1]; c2 := lcascii[c2]; (* Compute all minmatches regardless
                                             of case differences *)
    IF c1 <> c2 THEN EXIT END;
  END;
  e1^.MatchLen := Max (e1^.MatchLen, MinLen);
  e2^.MatchLen := Max (e2^.MatchLen, MinLen);
END MinMatch;
(*------------------------------------------------------------------------*)
PROCEDURE Matches(entry:pEntry; SoughtKey:String; Attr:KeyAttr): MATCH;
                    
VAR  minmatch,j: INTEGER; 
     c1,c2     : CHAR;
     mapcase   : BOOLEAN;
BEGIN
  minmatch := entry^.MatchLen;
  IF ((ExactLength IN entry^.Attr) OR (ExactLength IN Attr))
     AND (NOT (NoExactLength IN Attr)) THEN minmatch:=9876543 END;
  IF (ExactCase IN Attr) THEN      mapcase := FALSE
  ELSIF (NoExactCase IN Attr) THEN mapcase := TRUE
  ELSE  mapcase := (NOT (ExactCase IN entry^.Attr))
  END;
  j := 0;
  LOOP
    c1:=entry^.name^[j]; c2:=SoughtKey^[j]; INC(j);
    IF mapcase THEN c1:=lcascii[c1]; c2:=lcascii[c2] END;
    IF (c1 # c2) THEN 
       IF (c2 # 0C)         THEN RETURN NO 
       ELSIF (j > minmatch) THEN RETURN YES
       ELSE                      RETURN AMBIGUOUS
       END
    ELSIF (c1 = 0C) THEN RETURN YES
    END
  END;
END Matches;
(*------------------------------------------------------------------------*)
PROCEDURE OrderEntriesIn (dict: DICT): pEntryArray;
VAR  dictentries: pEntryArray;  j, entryNo: INTEGER;  entry: pEntry;
BEGIN
  WITH dict^ DO WITH Implementation^ DO
    (* build temp array of ptrs to entries... *)
    dictentries := tNew (tSP, nextEntryNo*TSIZE (ADDRESS));
    FOR j := 0 TO nextEntryNo-1 DO dictentries^[j] := NIL END;
    (* do the address sort... *)
    entry := Entries;
    WHILE entry <> NIL DO
      dictentries^[entry^.order] := entry;
      entry := entry^.next;
    END (* while *);
    modified    := FALSE;
    IF nextEntryNo = size THEN RETURN dictentries END;
    (* N.B. 'holes' in the order numbering appear as NIL in entries^... *)
    (* Now re-number the dict entries and compress the array...   *)
    entryNo := 0;
    FOR j := 0 TO nextEntryNo-1 DO
      entry := dictentries^[j];
      IF entry <> NIL THEN
	entry^.order := entryNo; dictentries^[entryNo] := entry;
        INC (entryNo);
      END;
    END;
    nextEntryNo := entryNo;
    size        := entryNo;  (* this should be correct anyway *)
  END END;
  RETURN dictentries;
END OrderEntriesIn;
(*------------------------------------------------------------------------*)
PROCEDURE ReComputeMinMatches (dict: DICT);
VAR  I, J: INTEGER;  entryI: pEntry;  dictentries: pEntryArray;
BEGIN
  tMark (tSP);
  dictentries := OrderEntriesIn (dict);
  (* and re-compute the maxima of the min-match prefixes... *)
  WITH dict^.Implementation^ DO
    FOR I := 0 TO size-2 DO
      entryI := dictentries^[I];
      FOR J := I+1 TO size-1 DO MinMatch (entryI, dictentries^[J]) END;
    END;
  END;
  tPop (tSP);
END ReComputeMinMatches;
(*------------------------------------------------------------------------*)
PROCEDURE Locate (dict :DICT; Key :String; Attr :KeyAttr;
                  ReMatchIfNeeded: BOOLEAN): pEntry;
VAR  prev, this: pEntry;  match: MATCH;
BEGIN
  WITH dict^.Implementation^ DO
    (* evaluate min-match lengths ONLY if required... *)
    IF ReMatchIfNeeded AND modified THEN ReComputeMinMatches (dict) END;
    dict^.ErrorCode := NoError;
    prev := NIL;  this := Entries;
    LOOP
      IF this = NIL THEN EXIT END;
      match := Matches (this, Key, Attr);
      IF match = YES THEN
        IF prev <> NIL THEN (* move found entry to front of queue *)
          prev^.next := this^.next;  this^.next := Entries;  Entries := this;
        END;
        dict^.ErrorCode := NoError;
        RETURN this;
      ELSIF match = AMBIGUOUS THEN dict^.ErrorCode := Ambiguous END;
      prev := this;  this := prev^.next;
    END (* while *);
    (* Assert: Key Not in dict or Ambiguous match... *)
    IF dict^.ErrorCode = Ambiguous THEN
      IF NOT dict^.Silent THEN
        this := Entries;
        WHILE this <> NIL DO
          IF Matches (this, Key, Attr) = AMBIGUOUS THEN
            WriteChars (sysOut, "Dict: '");    WriteString (sysOut, Key);
            WriteChars (sysOut, "' ambiguously matches '");
            WriteString (sysOut, this^.name);
            WriteChars (sysOut, "' in dictionary '");
            WriteString (sysOut, dict^.Name);
            WriteChars (sysOut, "'\N");
          END;
	  this := this^.next;
        END (* while *);
      END;
    ELSE (* not found *)  
      dict^.ErrorCode := NotFound;
      IF NOT dict^.Silent THEN
        WriteChars (sysOut, "Dict: '");    WriteString (sysOut, Key);
        WriteChars (sysOut, "' not found in dictionary '");
        WriteString (sysOut, dict^.Name);  WriteChars (sysOut, "'\N");
      END;
    END;
  END;
  RETURN NIL;
END Locate;
(*------------------------------------------------------------------------*)
PROCEDURE NullWORDPROC(VAR w: WORD);
BEGIN
END NullWORDPROC;

PROCEDURE NewDictS (Name: String): DICT;
VAR name: ARRAY [0..255] OF CHAR;
BEGIN
   Strings.CopySC(Name, name);
   RETURN (NewDict(name))
END NewDictS;

PROCEDURE NewDict (name: ARRAY OF CHAR): DICT;
VAR  dict: DICT;
BEGIN
IF Trace THEN
  WriteF.WriteF1(sysErr,"NewDict ('%S');\N", H(name));
END;
  NEW (dict);
  WITH dict^ DO
    ErrorCode := NoError;  Silent := FALSE;
    Name := Strings.CopyCS (name);
    Dispose := WORD(NullWORDPROC);
    NEW (Implementation);
    WITH Implementation^ DO
      Entries := NIL;
      size := 0;  modified := FALSE;  nextEntryNo := 0;
    END;
  END;
  RETURN dict;
END NewDict;
(*------------------------------------------------------------------------*)
PROCEDURE EnterS (dict: DICT;  Key: String;  KeyAttributes: KeyAttr;
                                                      thing: WORD);
VAR key :ARRAY [0..255] OF CHAR;
BEGIN
   Strings.CopySC(Key, key);
   Enter(dict, key, KeyAttributes, thing)
END EnterS;
(*------------------------------------------------------------------------*)
PROCEDURE Enter (dict: DICT;  Key: ARRAY OF CHAR;  KeyAttributes: KeyAttr;
                                                            thing: WORD);
VAR
  entry: pEntry; wasSilent: BOOLEAN; CopyOfKey :String;
  DisposeProc: WORDPROC;
  PROCEDURE EqualWW(A, B: WORD): BOOLEAN;
  BEGIN
    RETURN (INTEGER(A)=INTEGER(B))
  END EqualWW;
BEGIN
IF Trace THEN
  WriteF.WriteF2(sysErr,"Enter (%S, '%S', ???, ???);\N",
   S(dict^.Name), H(Key));
END;
  WITH dict^ DO
    wasSilent := Silent;  Silent := TRUE;
    CopyOfKey := Strings.CopyCS(Key);
    entry := Locate (dict, CopyOfKey, KeyAttr{ExactLength
                                           (*,ExactCase*)}, FALSE);
    Silent := wasSilent;  ErrorCode := NoError;
    IF entry <> NIL THEN
      DisposeProc := WORDPROC(dict^.Dispose);
IF Debug THEN
IF EqualWW(DisposeProc, Strings.Dispose) THEN
  WriteF.WriteF2(sysErr,"Replacing '%S' by '%S' ",
   WriteF.S(String(entry^.item)),
   WriteF.S(String(thing)));
  WriteF.WriteF2(sysErr,"under key %S in %S\N",
   WriteF.S(entry^.name),
   WriteF.S(dict^.Name));
ELSE
  WriteF.WriteF1(sysErr,"Replacing under key %S\N",
   WriteF.S(entry^.name));
END;END;
      DisposeProc(entry^.item);
      Strings.Dispose (entry^.name)
    ELSE
      WITH Implementation^ DO
         NEW (entry);  entry^.next := Entries;  Entries := entry;  INC (size);
      END
    END;
    WITH entry^ DO
      name  := CopyOfKey;
      Attr  := KeyAttributes;
      IF ExactLength IN KeyAttributes THEN MatchLen:=-2 ELSE MatchLen:=-1 END;
      item  := thing;
      order := Implementation^.nextEntryNo;
    END;
    WITH Implementation^ DO modified := TRUE;  INC (nextEntryNo) END;
  END;
END Enter;
(*------------------------------------------------------------------------*)
PROCEDURE Found (dict :DICT; Key :String; VAR Val: WORD) :BOOLEAN;
VAR  entry: pEntry;
BEGIN
IF Trace THEN
  WriteF.WriteF2(sysErr,"Found? (%S, '%S', ???);\N",
   S(dict^.Name), S(Key));
END;
  WITH dict^ DO
    ErrorCode := NoError;
    entry := Locate (dict, Key, KeyAttr {}, TRUE);
    IF ErrorCode <> NoError THEN
       Val := WORD(NIL); RETURN (FAILED)
    ELSE
       Val := entry^.item; RETURN (SUCCESS)
    END;
  END;
END Found;
PROCEDURE FoundExp (dict: DICT;      Key      :String;
                VAR Val : WORD;  VAR ExactKey :String) :BOOLEAN;
VAR  entry: pEntry;
BEGIN
IF Trace THEN
  WriteF.WriteF2(sysErr,"FoundExp? (%S, '%S', ???, ???);\N",
   S(dict^.Name), S(Key));
END;
  WITH dict^ DO
    ErrorCode := NoError;
    entry := Locate (dict, Key, KeyAttr {}, TRUE);
    IF ErrorCode <> NoError THEN
       ExactKey := String(NIL);
       Val := WORD(NIL); RETURN (FAILED)
    ELSE
       ExactKey := Strings.CopySS(entry^.name);
       Val := entry^.item; RETURN (SUCCESS)
    END;
  END;
END FoundExp;
(*------------------------------------------------------------------------*)
PROCEDURE FoundWith (Attribute: KeyAttr;
                     dict: DICT; Key :String;  VAR Val: WORD)
                                                                :BOOLEAN;
VAR  entry: pEntry;
BEGIN
IF Trace THEN
  WriteF.WriteF2(sysErr,"FoundWith? (???, %S, '%S', ???);\N",
   S(dict^.Name), S(Key));
END;
  WITH dict^ DO
    ErrorCode := NoError;
    entry := Locate (dict, Key, Attribute, TRUE);
    IF ErrorCode<>NoError THEN
       Val := WORD(NIL); RETURN (FAILED)
    ELSE
       Val := entry^.item; RETURN (SUCCESS)
    END
  END
END FoundWith;
PROCEDURE FoundWithExp (Attribute :KeyAttr;  dict     :DICT; Key :String;
                    VAR Val       :WORD; VAR ExactKey :String)
                                                               :BOOLEAN;
VAR  entry: pEntry;
BEGIN
IF Trace THEN
  WriteF.WriteF2(sysErr,"FoundWithExp? (???, %S, '%S', ???, ???);\N",
   S(dict^.Name), S(Key));
END;
  WITH dict^ DO
    ErrorCode := NoError;
    entry := Locate (dict, Key, Attribute, TRUE);
    IF ErrorCode<>NoError THEN
       ExactKey := String(NIL);
       Val := WORD(NIL); RETURN (FAILED)
    ELSE
       ExactKey := Strings.CopySS (entry^.name);
       Val := entry^.item; RETURN (SUCCESS)
    END
  END
END FoundWithExp;
(*------------------------------------------------------------------------*)
PROCEDURE RemoveS(dict: DICT; VAR Key: String);
VAR key :ARRAY [0..255] OF CHAR;
BEGIN
   Strings.CopySC(Key, key);
   Remove(dict, key)
END RemoveS;
(*------------------------------------------------------------------------*)
PROCEDURE Remove (dict: DICT; Key: ARRAY OF CHAR);
VAR  entry: pEntry; CopyOfKey: String; DisposeProc: WORDPROC;
  PROCEDURE EqualWW(A, B: WORD): BOOLEAN;
  BEGIN
    RETURN (INTEGER(A)=INTEGER(B))
  END EqualWW;
BEGIN
IF Trace THEN
  WriteF.WriteF2(sysErr,"Remove (%S, '%S');\N",
   S(dict^.Name), H(Key));
END;
  WITH dict^ DO
    ErrorCode := NoError;
    CopyOfKey := Strings.CopyCS(Key);
    entry := Locate (dict, CopyOfKey, KeyAttr {ExactLength
                                            (*,ExactCase*)}, FALSE);
    (************ DISPOSE CONTENTS HERE TOO *GT* ************)
    Strings.Dispose(CopyOfKey);
    IF ErrorCode<>NoError THEN RETURN END;
    WITH Implementation^ DO
      Entries := Entries^.next;  modified := TRUE;  DEC (size);
    END;
    DisposeProc := WORDPROC(dict^.Dispose);
IF Debug THEN
IF EqualWW(DisposeProc, Strings.Dispose) THEN
  WriteF.WriteF1(sysErr,"Removing '%S' ",
   WriteF.S(String(entry^.item)));
  WriteF.WriteF2(sysErr,"under key %S in %S\N",
   WriteF.S(entry^.name),
   WriteF.S(dict^.Name));
ELSE
  WriteF.WriteF2(sysErr,"Removing contents of key %S in %S\N",
   WriteF.S(entry^.name),
   WriteF.S(dict^.Name));
END;END;
    DisposeProc(entry^.item);
    Strings.Dispose (entry^.name);  DISPOSE (entry);
  END;
END Remove;
(*------------------------------------------------------------------------*)
PROCEDURE DeleteDict(VAR dict: DICT);
VAR j: INTEGER; dictentries: pEntryArray; DisposeProc :WORDPROC;
  PROCEDURE EqualWW(A, B: WORD): BOOLEAN;
  BEGIN
    RETURN (INTEGER(A)=INTEGER(B))
  END EqualWW;
BEGIN
IF Trace THEN
  WriteF.WriteF1(sysErr,"DeleteDict (%S);\N",
   S(dict^.Name));
END;
  WITH dict^ DO
    ErrorCode := NoError;
    tMark(tSP);
    dictentries := OrderEntriesIn (dict);
    FOR j := 0 TO Implementation^.size-1 DO
      WITH dictentries^[j]^ DO
        DisposeProc := WORDPROC(dict^.Dispose);
IF Debug THEN
IF EqualWW(DisposeProc, Strings.Dispose) THEN
  WriteF.WriteF1(sysErr,"Deleting '%S' ",
   WriteF.S(String(item)));
  WriteF.WriteF2(sysErr,"under key %S in %S\N",
   WriteF.S(name),
   WriteF.S(dict^.Name));
ELSE
  WriteF.WriteF2(sysErr,"Deleting contents of key %S in %S\N",
   WriteF.S(name),
   WriteF.S(dict^.Name));
END;END;
        Strings.Dispose(name);
        DisposeProc(item)
      END;
      DISPOSE(dictentries^[j]);
    END (* for *);
    tPop(tSP);
  END;
  DISPOSE(dict^.Implementation);
  DISPOSE(dict);
  dict := DICT(NIL);
END DeleteDict;
(*------------------------------------------------------------------------*)
PROCEDURE ForAllIn (dict :DICT;  Done: CSCANPROC; VAR parm: WORD): BOOLEAN;
VAR  j: INTEGER;  EarlyStop: BOOLEAN;  entry: pEntry;
     dictentries :pEntryArray;
BEGIN
IF Trace THEN
  WriteF.WriteF1(sysErr,"ForAllIn? (%S, ???, ???);\N",
   S(dict^.Name));
END;
  (* N.B. this renumbers thing^.order if required *)
  WITH dict^ DO
    ErrorCode := NoError;
    tMark (tSP);
    dictentries := OrderEntriesIn (dict);
(* Following code replaces:
    j := 0;  done := FALSE;
    WHILE (j < Implementation^.size) AND NOT done DO
      entry := dictentries^[j];
      WITH entry^ DO done := Done (name^, item, parm) END;
    END;
*)
    j := 0;  EarlyStop := FALSE;
    LOOP
      IF (j >= Implementation^.size) THEN EXIT END;
      entry := dictentries^[j];
      WITH entry^ DO EarlyStop := Done (name^, item, parm) END;
      IF EarlyStop THEN EXIT END;
      INC (j)
    END;
    tPop (tSP);
  END;
  RETURN EarlyStop;
END ForAllIn;
(*------------------------------------------------------------------------*)
BEGIN
  Debug := FALSE; Trace := FALSE;
END Dict.