UNSAFE MODULE ID;

IMPORT Wx, Word, Cstring, Ctypes, ASCII, Text, Text8CString;

CONST
  MaxLength   = 8192 - BYTESIZE(ADDRESS) (* allocator goo *);
  NullChar    = '\000';

TYPE
  StrPtr     = UNTRACED REF CHAR;
  CharBuffer = UNTRACED REF ARRAY [0 .. MaxLength - 1] OF CHAR;
  DescBuffer = REF ARRAY OF Desc;

TYPE
  Desc = RECORD
    start  : StrPtr  := NIL;
    hash   : INTEGER := 0;
    text   : TEXT    := NIL;
  END;

VAR
  next_char : CARDINAL := 0;
  chars     := NEW (CharBuffer);

  next_t    : T := 1;
  ids       := NEW (DescBuffer, 2000);

  hashMask  : INTEGER := 2047; (* == 2^11-1 == 11 bits on *)
  hashTable := NEW (REF ARRAY OF T, 2048);

  empty_id  := Add ("");

PROCEDURE Add (x: TEXT): T =
  VAR
    t: T;
    a: REF ARRAY OF CHAR;
    l: INTEGER;
  BEGIN
    l := Text.Length(x);
    a := NEW(REF ARRAY OF CHAR, l + 1);
    FOR i := 0 TO l - 1 DO
      a^[i] := Text.GetChar(x, i);
    END;
    a^[l] := '\000';
    t := FromStr (a^, LAST (a^));
    IF (ids[t].text = NIL) THEN ids[t].text := x; END;
    RETURN t;
  END Add;

PROCEDURE FromStr (READONLY buf: ARRAY OF CHAR;  length: INTEGER): T =
  VAR hash, n: INTEGER;  bucket: CARDINAL;  t: T;  p0, p1: StrPtr;
  BEGIN
    length := MIN (length, NUMBER (buf));
    IF (length <= 0) THEN RETURN empty_id END;
    p0 := ADR (buf[0]);
    hash := 0;
    FOR i := 0 TO length - 1 DO
      hash := Word.Plus (Word.Times (17, hash), ORD (buf[i]));
    END;

    bucket := Word.And (hash, hashMask);
    LOOP
      t := hashTable[bucket];
      IF (t = NoID) THEN (* empty! *) EXIT; END;
      IF (ids[t].hash = hash) THEN
        p0 := ADR (buf[0]);
        p1 := ids[t].start;
        n  := length;
        WHILE (n > 0) AND (p0^ = p1^) DO
          DEC (n);
          INC (p0, ADRSIZE (p0^));
          INC (p1, ADRSIZE (p1^));
        END;
        IF (n = 0) AND (p1^ = NullChar) THEN RETURN t; END;
      END;
      INC (bucket);
      IF (bucket >= NUMBER (hashTable^)) THEN bucket := 0; END;
    END;

    (* we didn't find a match => build a new one *)
    t := next_t;  INC (next_t);
    IF (t >= NUMBER (ids^)) THEN ExpandIDs (); END;
    hashTable[bucket] := t;

    (* make sure we've got room to stuff the characters *)
    IF (next_char + length >= LAST (chars^)) THEN ExpandChars (); END;

    (* initialize the descriptor and stuff the characters *)
    WITH z = ids[t] DO
      z.start := ADR (chars[next_char]);
      z.hash  := hash;
      z.text  := NIL;
      SUBARRAY (chars^, next_char, length) := SUBARRAY (buf, 0, length);
      chars [next_char + length] := NullChar;
      INC (next_char, length + 1);
    END;

    (* make sure we're not overloading the hash table *)
    IF (2 * next_t > NUMBER (hashTable^)) THEN ExpandHashTable (); END;

    RETURN t;
  END FromStr;

PROCEDURE ToText (t: T): TEXT =
  VAR ptr: StrPtr; x: TEXT;
  BEGIN
    <*ASSERT t < next_t*>
    IF (t = NoID) THEN RETURN NIL END;
    x := ids[t].text;
    IF (x = NIL) THEN
      ptr := ids[t].start;
      x   := Text8CString.New (LOOPHOLE (ptr, Ctypes.char_star));
      ids[t].text := x;
    END;
    RETURN x;
  END ToText;

PROCEDURE Put (wr: Wx.T;  t: T) =
  VAR ptr := LOOPHOLE (ids[t].start, CharBuffer);  len: INTEGER;
  BEGIN
    <*ASSERT t < next_t*>
    IF (t = NoID) THEN RETURN END;
    len := Cstring.strlen (LOOPHOLE (ptr, Ctypes.char_star));
    Wx.PutStr (wr, SUBARRAY (ptr^, 0, len));
  END Put;

PROCEDURE Hash (t: T): INTEGER =
  BEGIN
    <*ASSERT t < next_t*>
    RETURN ids[t].hash;
  END Hash;

PROCEDURE Compare (a, b: T): [-1 .. +1] =
  CONST NUL = '\000';
  VAR pa, pb: StrPtr;  ca, cb: CHAR;
  BEGIN
    <*ASSERT a < next_t AND b < next_t *>
    IF (a = b) THEN RETURN 0; END;
    pa := ids[a].start;
    pb := ids[b].start;
    LOOP
      ca := ASCII.Upper [pa^];
      cb := ASCII.Upper [pb^];
      IF (ca # cb) THEN
        IF (ca < cb) THEN RETURN -1 ELSE RETURN +1 END;
      END;
      IF (ca = NUL) THEN RETURN 0; END;
      INC (pa, ADRSIZE (pa^));
      INC (pb, ADRSIZE (pb^));
    END;
    (*******
    RETURN Cstring.strcmp (pa, pb) < 0;
    *******)
  END Compare;

PROCEDURE ExpandChars () =
  BEGIN
    chars := NEW (CharBuffer);
    next_char := 0;
  END ExpandChars;

PROCEDURE ExpandIDs () =
  VAR n := NUMBER (ids^);  new := NEW (DescBuffer, n+n);
  BEGIN
    SUBARRAY (new^, 0, n) := ids^;
    ids := new;
  END ExpandIDs;

PROCEDURE ExpandHashTable () =
  VAR
    n_old   := NUMBER (hashTable^);
    n_new   := n_old + n_old;
    new     := NEW (REF ARRAY OF T, n_new);
    newMask := hashMask + hashMask + 1;
    t       : T;
    bucket  : INTEGER;
  BEGIN
    FOR i := 0 TO n_new - 1 DO new[i] := NoID END;

    FOR i := 0 TO n_old - 1 DO
      t := hashTable [i];
      IF (t # NoID) THEN
        bucket := Word.And (ids[t].hash, newMask);
        WHILE (new[bucket] # NoID) DO
          INC (bucket);
          IF (bucket >= n_new) THEN bucket := 0; END;
        END;
        new[bucket] := t;
      END;
    END;

    hashMask := newMask;
    hashTable := new;
  END ExpandHashTable;

BEGIN
END ID.