;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

(use goo/boot)
(use goo/fun)
(use goo/class)
(use goo/macros)
(use goo/types)
(use goo/any)
(use goo/log)
(use goo/chr)
(use goo/mag)
(use goo/math)
(use goo/packer)
(use goo/cols/col)
(use goo/cols/colx)
(use goo/cols/map)
(use goo/cols/seq)
(use goo/cols/seqx)
(use goo/cols/flat)
(use goo/cols/rep)
(use goo/cols/tup)
(use goo/cols/lst)
(use goo/cols/str)

;;; TABLES

;; Is 1 million big enough?
;; (dv *max-prime-for-table* 1000000)
;; 
;; List of the first number in each prime pair
;; (dv *twin-primes* (compute-twin-primes *max-prime-for-table*))

(exported
 (dc <tab> (<map> <col!>))
 (dc <set> (<tab>))
 ;; Factor to grow by
 (dp tab-growth-factor (<tab> => <flo>) 2.0)
 ;; When to grow or shrink (percentage of table size)
 (dp tab-growth-threshold (<tab> => <flo>) 0.8)
 (dp tab-shrink-threshold (<tab> => <flo>) 0.5)
)
(dc <tab-vec> (<seq!>))
  ;; Number of filled and vacant elements
  (dp! %vacated (<tab-vec> => <int>) 0)
  ;; Modulus values for primary and secondary hash
  (dp %primary-modulus (<tab-vec> => <int>))
  (dp %secondary-modulus (<tab-vec> => <int>))
  ;; Number of buckets and number of elements in each bucket
  (dp %n-buckets (<tab-vec> => <int>))
  (dp %bucket-depth (<tab-vec> => <int>))
  ;; The actual table data representation
  (dp! %data (<tab-vec> => <rep>))
  ;; GC state
  ;; (dp %gc-state (<tab-vec> => <any>))

(dp! %count (<tab> => <int>) 0)
(dp! %vector (<tab> => <tab-vec>))

(exported
 (dg tab-hash (x|<tab> => <fun>))
 
 ;; (dv $permanent-hash-state #f)
 ;; (df tab-gc-state ())
 
 (dg id-hash (x))

 (dc <str-tab> (<tab>))
 
 (df case-insensitive-string-hash (x|<str> => <int>))
 (df case-insensitive-string-equal (x|<str> y|<str> => <log>))
 )



(dv *twin-primes*
  (as <tup>
    '(3 5 11 17 29 41 47 59 71 101 107 137 149 167 179 191 197 227 239
      269 281 311 347 419 431 461 521 569 599 617 641 659 809 839 881 1019
      1049 1091 1151 1229 1277 1319 1367 1427 1481 1607 1667 1721 1787 1871
      1931 1997 2081 2141 2207 2267 2339 2549 2657 2729 2801 2969 3119 3251
      3359 3461 3557 3671 3767 3917 4019 4127 4241 4421 4547 4721 4931 5099
      5231 5417 5639 5849 6089 6269 6449 6659 6827 7127 7307 7547 7757 8009
      8219 8429 8819 9041 9281 9629 9929 10271 10529 10859 11159 11447
      11777 12107 12539 12917 13337 13679 14081 14447 14867 15269 15731
      16139 16631 17189 17657 18119 18911 19421 19961 20477 21011 21557
      22109 22697 23291 23909 24917 25577 26249 26951 27689 28409 29129
      29879 30839 31721 32531 33347 34211 35081 36011 36929 37991 39041
      40037 41141 42179 43319 44531 45821 47057 48311 49529 50891 52181
      53549 54917 56477 57899 59357 60887 62927 64577 66359 68111 69827
      71711 73607 75539 77477 79559 81551 83639 85817 88001 90371 92639
      95087 97499 99989 102497 105227 108011 110729 113537 116531 119549
      122597 125789 128939 132329 135647 139121 142607 146297 149969 153887
      157769 161729 166301 170537 174929 179381 183917 188831 193601 198461
      203429 208589 213947 219311 224909 230561 236477 242447 248639 254927
      261431 268517 275321 282239 289841 297467 304979 312617 320561 328589
      336827 345461 354251 363149 372269 381629 391217 401309 411527 422087
      432659 443561 454709 466181 478067 490031 502499 515087 527981 541361
      555041 569081 583337 598049 613007 628679 644489 660617 677231 694259
      711707 729557 747827 766541 785777 805499 825827 846749 868121 889871
      912449 935591 959207 983327)))

 
;; TODO: SIZE FILL N-BUCKETS BUCKET-DEPTH PRIMARY-MODULUS SECONDARY-MODULUS
(df fab-tab-vec
    (size|<int> fill-value
     n-buckets|<int> bucket-depth|<int>
     primary-modulus|<int> secondary-modulus|<int>
     => <tab-vec>)
  (def v (new <tab-vec>
           %n-buckets n-buckets
           %bucket-depth bucket-depth
           %primary-modulus primary-modulus
           %secondary-modulus secondary-modulus))
  (set (%data v) (rep-fab size fill-value))
  v)

(df @fill! (x|<tab-vec> fill)
  (rep-fill! (%data x) fill))

;; (dl (@velt inline) (vector|<tab-vec> index|<int> => <any>) ;; TODO: DM
(dl @velt (vector|<tab-vec> index|<int> => <any>) ;; TODO: DM
  ;; (elt (%data vector) index)
  (%relt (%data vector) (%iu index)))

;; (dl (@velt-setter inline) (new-value vector|<tab-vec> index|<int> => <any>) 
(dl @velt-setter (new-value vector|<tab-vec> index|<int> => <any>) 
  ;; (set (elt (%data vector) index) new-value)
  (set (%relt (%data vector) (%iu index)) new-value))

(dm clr! (vector|<tab-vec> fill-value)
  (@fill! vector fill-value)
  (set (%vacated vector) 0))

(dv *debug-tables?* #f)

;; (df trace (port msg (args ...))
;;  (and *debug-tables?* (app msg port msg args))))
      

(dm key-test (_|<tab> => <fun>) ==)
(dm tab-hash (_|<tab> => <fun>) id-hash)

(dv $nul-cell-marker '("nul cell"))
(dv $vacated-cell-marker '("vacated cell"))

(dm fab ((type (t< <tab>)) size|<int> => <tab>)
  ;; (trace out "FAB %= SIZE %=\n" type size)
  (def (tup n-buckets bucket-depth) (choose-table-geometry size))
  (def table (new type))
  (set (%vector table)
       (fab-tab-vec
        (* n-buckets (* bucket-depth 2)) $nul-cell-marker
        n-buckets bucket-depth
        n-buckets (- n-buckets 2)))
  table)

;; (ds with-hash (((tup ,bucket-index ,bucket-offset) (,table ,key)) ,@body)
;;   `(let ((test-function (key-test ,table))
;;           (hash-function (tab-hash ,table))
;;           ((hash <int>) (hash-function ,key))
;;           (vector (%vector table))
;;           (,bucket-index (mod hash (%primary-modulus vector)))
;;           (,bucket-offset (+ (mod hash (%secondary-modulus vector)) 1)))
;;          ,@body))

(dm elt-or (table|<tab> key default => <any>)
  (def test-function (key-test table))
  (def vector        (%vector table))
  (def n-buckets     (%n-buckets vector))
  (def bucket-depth  (%bucket-depth vector))
  (def hash|<int>    ((tab-hash table) key))
  (def bucket-index  (mod hash (%primary-modulus vector)))
  (def bucket-offset (+ (mod hash (%secondary-modulus vector)) 1))
  ;; Search each bucket
  (rep outer ((bucket-index bucket-index) (probes 0))
    (if (< probes n-buckets)
        (let ((index (* bucket-index (* bucket-depth 2))))
          (rep inner ((i 0) (raw-index index))
            (if (< i bucket-depth)
                (let ((this-key (@velt vector raw-index)))
                  (cond ((== this-key $nul-cell-marker)
                         default)
                        ((test-function key this-key)
                         (@velt vector (+ raw-index bucket-depth)))
                        (#t
                         (inner (+ i 1) (+ raw-index 1)))))
                ;; Not in this bucket try the next one
                (outer (mod- bucket-index bucket-offset n-buckets)
                       (+ probes 1)))))
        ;; Table totally full???  That's not right
        (internal-error "The table is totally full this shouldn't happen"))))



(dm elt-setter (value table|<tab> key => <any>)
  ;; (trace out "PUT COUNT %= val %=\n" (%count table) value)
  (def vector (%vector table))
  (if (>= (%count table)
          (* (* (%n-buckets vector) (%bucket-depth vector))
             (tab-growth-threshold table)))
      ;; Grow the table if it's too full
      (set vector (%vector (grow-table table)))
      (if (> (+ (%count table) (%vacated vector)) 
             (* (* (%n-buckets vector) (%bucket-depth vector))
                (tab-growth-threshold table))) 
          ;; Rehash when there are too many vacated elements
          (set vector (%vector (rehash-table table)))))
  (def test-function (key-test table))
  (def bucket-depth  (%bucket-depth vector))
  (def n-buckets     (%n-buckets vector))
  (def hash|<int>    ((tab-hash table) key))
  (def bucket-index  (mod hash (%primary-modulus vector)))
  (def bucket-offset (+ (mod hash (%secondary-modulus vector)) 1))
  ;; Search each bucket
  (rep outer ((bucket-index bucket-index) (probes|<int> 0))
    (if (< probes n-buckets)
        (let ((index (* bucket-index (* bucket-depth 2))))
          ;; (trace out "LOOKING AT %=\n" index)
          (rep inner ((vacancy-index #f) (i|<int> 0) (raw-index|<int> index))
            (if (< i bucket-depth)
                (let ((this-key (@velt vector raw-index)))
                  (cond
                    ;; end of chain and not found
                    ((== this-key $nul-cell-marker)
                     (def index 
                       (if vacancy-index
                           ;; use a vacant cell if you found one
                           (seq (decf (%vacated vector)) vacancy-index)
                           ;; use this cell
                           raw-index))
                     ;; (trace out "FOUND NUL CELL @ %d\n"
                     ;;        raw-index)
                     (set (@velt vector index) key)
                     (set (@velt vector (+ index bucket-depth)) value)
                     (incf (%count table))
                     value)
                    ((== this-key $vacated-cell-marker) ;; remember vacancy
                     ;; N.B. Only record the _first_ vacant cell
                     (inner 
                      (or vacancy-index raw-index) (+ i 1) (+ raw-index 1)))
                    ;; key already in table update value
                    ((test-function key this-key)
                     (set (@velt vector (+ raw-index bucket-depth)) value)
                     ;; (trace out "FOUND KEY @ %d\n" raw-index)
                     value)
                    (#t
                     (inner vacancy-index (+ i 1) (+ raw-index 1)))))
                ;; Not in this bucket try the next one
                (outer (mod- bucket-index bucket-offset n-buckets)
                       (+ probes 1)))))
        ;; Table totally full???  That's not right
        (internal-error "The table is totally full this shouldn't happen"))))

(dm del (x|<tab> key => <tab>)
  (del! (dup x) key))

(dm del! (table|<tab> key => <tab>)
  (def test-function (key-test table))
  (def vector        (%vector table))
  (def n-buckets     (%n-buckets vector))
  (def bucket-depth  (%bucket-depth vector))
  (def hash|<int>    ((tab-hash table) key))
  (def bucket-index  (mod hash (%primary-modulus vector)))
  (def bucket-offset (+ (mod hash (%secondary-modulus vector)) 1))
  ;; Search each bucket
  (rep outer ((bucket-index bucket-index) (probes|<int> 0))
    (if (< probes n-buckets)
        (let ((index|<int> (* bucket-index (* bucket-depth 2))))
          ;; (trace out "LOOKING AT %=\n" index)
          (rep inner ((i|<int> 0) (raw-index|<int> index))
            (if (< i bucket-depth)
                (let ((this-key (@velt vector raw-index)))
                  (cond ((== this-key $nul-cell-marker) 
                         #f)
                        ;; N.B. Don't look at already vacated cells along
                        ;;      the collision chain 
                        ((and (~== this-key $vacated-cell-marker)
                              (test-function key this-key))
                         (set (@velt vector raw-index) $vacated-cell-marker)
                         ;; In a GC-ed environment clear the value cell too!
                         (decf (%count table))
                         (incf (%vacated vector))
                         #t)
                        (#t
                         (inner (+ i 1) (+ raw-index 1)))))
                ;; Not in this bucket try the next one
                (outer (mod- bucket-index bucket-offset n-buckets)
                       (+ probes 1)))))
        ;; Table totally full???  That's not right
        (internal-error "The table is totally full this shouldn't happen")))
  table)

(dm do-keyed (function|<fun> table|<tab>)
  (def vector    (%vector table))
  (def n-buckets (%n-buckets vector))
  (def depth     (%bucket-depth vector))
  (rep outer ((b|<int> 0))
    (when (< b n-buckets)
      (rep inner ((i|<int> 0))
        (when (< i depth)
          (def key (@velt vector (+ i (* b (* depth 2)))))
          (unless (or (== key $nul-cell-marker) 
                      (== key $vacated-cell-marker))
            ;; (trace out "B %= I %=\n" b i)
            (def index (+ i (+ (* b (* depth 2)) depth)))
            (function key (@velt vector index)))
          (inner (+ i 1))))
      (outer (+ b 1)))))

(dm do (function|<fun> table|<tab>)
  (def vector    (%vector table))
  (def n-buckets (%n-buckets vector))
  (def depth     (%bucket-depth vector))
  (rep outer ((b|<int> 0))
    (when (< b n-buckets)
      (rep inner ((i|<int> 0))
        (when (< i depth)
          (def key (@velt vector (+ i (* b (* depth 2)))))
          (unless (or (== key $nul-cell-marker) 
                      (== key $vacated-cell-marker))
            (def index (+ i (+ (* b (* depth 2)) depth)))
            (function (@velt vector index)))
          (inner (+ i 1))))
      (outer (+ b 1)))))

(dm zap! (table|<tab> => <tab>)
  (clr! (%vector table) $nul-cell-marker)
  (set (%count table) 0)
  table)

(dm len (table|<tab> => <int>)
  (%count table))

(dc <tab-enum> (<enum>))
(dp! @vec  (<tab-enum> => <tab-vec>))
(dp! @buc  (<tab-enum> => <int>))
(dp! @idx  (<tab-enum> => <int>))
(dp @fin? (<tab-enum> => <log>) #f)
(dv $fin-enum (new <tab-enum> @fin? #t))

(dm enum (table|<tab> => <tab-enum>)
  (if (= (len table) 0)
      $fin-enum
      (let ((vector    (%vector table))
            (n-buckets (%n-buckets vector))
            (depth     (%bucket-depth vector)))
        (rep outer ((b|<int> 0))
          (if (< b n-buckets)
              (rep inner ((i|<int> 0))
                (if (< i depth)
                    (let ((key (@velt vector (+ i (* b (* depth 2))))))
                      (if (or (== key $nul-cell-marker)
                              (== key $vacated-cell-marker))
                          (inner (+ i 1))
                          (new <tab-enum> @vec vector @buc b @idx i)))
                    (outer (+ b 1))))
              $fin-enum)))))

(dm nxt (e|<tab-enum> => <tab-enum>)
  (def vector    (@vec e))
  (def n-buckets (%n-buckets vector))
  (def depth     (%bucket-depth vector))
  (def bucket    (@buc e))
  (def index     (@idx e))
  (rep outer ((b|<int> bucket) (first? #t))
    (if (< b n-buckets)
      (rep inner ((i|<int> (if first? (+ index 1) 0)))
        (if (< i depth)
            (let ((key (@velt vector (+ i (* b (* depth 2))))))
              (if (or (== key $nul-cell-marker)
                      (== key $vacated-cell-marker))
                  (inner (+ i 1))
                  (renew e @vec vector @buc b @idx i)))
            (outer (+ b 1) #f)))
      $fin-enum)))

(dm fin? (e|<tab-enum> => <log>)
  (@fin? e))

(dm now-key (e|<tab-enum> => <any>)
  (def vector (@vec e))
  (def depth  (%bucket-depth vector))
  (@velt vector (+ (@idx e) (* (@buc e) (* depth 2)))))

(dm now (e|<tab-enum> => <any>)
  (def vector (@vec e))
  (def depth  (%bucket-depth vector))
  (@velt vector (+ (@idx e) (+ depth (* (@buc e) (* depth 2))))))

(dm now-setter (value e|<tab-enum>)
  (def vector (@vec e))
  (def index  (@idx e))
  (def depth  (%bucket-depth vector))
  (set (@velt vector (+ index (+ depth (* (@buc e) (* depth 2))))) value))

;;; Internal functions

(dm tab-keys (table|<tab> => <lst>)
  (packing () (do-keyed (fun (k v) (pack k)) table)))

(dm grow-table (table|<tab> => <tab>)
  ;; (let ((vec (%vector table)))
  ;;   (trace out "GROWING TABLE %= %= OF %=\n" (object-name table)
  ;;        (%count table) (* (%n-buckets vec) (%bucket-depth vec))))
  (def vector (%vector table))
  (def (tup new-n-buckets new-bucket-depth)
    (choose-table-geometry
     (floor (* (* (%n-buckets vector) (%bucket-depth vector))
               (tab-growth-factor table)))))
  (def new-vector
    (fab-tab-vec
     (* new-n-buckets (* new-bucket-depth 2))
     $nul-cell-marker
     new-n-buckets new-bucket-depth new-n-buckets (- new-n-buckets 2)))
  ;; (trace out "OLD DATA %=\n" (%data (%vector table)))
  (copy-to-new-vector table new-vector)
  (set (%vector table) new-vector)
  ;; (trace out "NEW DATA %=\n" (%data (%vector table)))
  ;;--- It would be nice to be able to deallocate the old vector
  table)

(dm rehash-table (table|<tab> => <tab>)
  (def vector (%vector table))
  (def new-vector
    (fab-tab-vec
     (* (%n-buckets vector) (* (%bucket-depth vector) 2))
     $nul-cell-marker 
     (%n-buckets vector) (%bucket-depth vector)
     (%primary-modulus vector) 
     (%secondary-modulus vector)))
  (copy-to-new-vector table new-vector)
  (set (%vector table) new-vector)
  table)

(df choose-table-geometry
    (capacity|<int> => (tup n-buckets|<int> bucket-depth|<int>))
  ;;--- These numbers are completely arbitrary and need to be tuned up
  (esc return
    (def depth
      (cond
        ((< capacity 2000)    1)
        ((< capacity 5000)    2)
        ((< capacity 15000)   4)
        ((< capacity 50000)   8)
        ((< capacity 250000) 16)
        (#t                  32)))
    (do (fun ((p <int>))
          (when (> p (1st (ceil/ capacity depth)))
            (return (tup (+ p 2) depth))))
        *twin-primes*)
    (internal-error "Not enough primes to compute new table size")))

(dm copy-to-new-vector (table|<tab> new-vector)
  (do-keyed
   (fun (k v)
     (def test-function          (key-test table))
     (def new-n-buckets          (%n-buckets new-vector))
     (def new-bucket-depth       (%bucket-depth new-vector))
     (def new-primary-modulus    (%primary-modulus new-vector))
     (def new-secondary-modulus  (%secondary-modulus new-vector))
     (def hash|<int>             ((tab-hash table) k))
     (def new-bucket-index       (mod hash new-primary-modulus))
     (def new-bucket-offset      (+ (mod hash new-secondary-modulus) 1))
     ;; (trace out "VISITING (%= %=)\n" k v)
     ;; Search each bucket
     (rep outer ((new-bucket-index new-bucket-index) (probes|<int> 0))
       (if (< probes new-n-buckets)
           (let ((bucket-start 
                  (* new-bucket-index (* new-bucket-depth 2))))
             (rep inner ((i|<int> 0) (index|<int> bucket-start))
               (if (< i new-bucket-depth)
                   (let ((this-key (@velt new-vector index)))
                     (if (== this-key $nul-cell-marker)
                         ;; (trace out "COPYING TO (%= %=) %=\n" k v index)
                         (seq
                           (set (@velt new-vector index) k)
                           (set (@velt new-vector (+ index new-bucket-depth)) v))
                         (inner (+ i 1) (+ index 1))))
                   ;; No room in this bucket try the next one
                   (outer
                    (mod- new-bucket-index new-bucket-offset new-n-buckets)
                    (+ probes 1)))))
           ;; Table totally full???  That's not right
           (internal-error "The table is totally full this shouldn't happen"))))
   table))

;;; HASHING FUNCTIONS

;; TODO: SOME STORY FOR REHASHING ON GC MOVEMENT
;; (df tab-gc-state () $permanent-hash-state)

(dm id-hash (x) (address-of x))

(dm id-hash (x|<log>) (if x 131 149))

;; TODO: CHECK FOR CORRECTNESS
(df rot (x|<int> a|<int> => <int>)
  (| (>> x a) (<< x a)))

(dm id-hash (x|<int>)
  ;; Offset it so that 0 doesn't hash to 0
  (abs (+ (- (rot x 15) x) 31)))
  
(dm id-hash (x|<chr>)
  (id-hash (as <int> x)))

(dm id-hash (x|<flo>)
  (+ (flo-bits x) 89))

(dm id-hash (x|<tup>)
  (rep loop ((t-enum (enum x)) (cur-hash 0))
    (when (not (fin? t-enum))
      (def cur-elem (now t-enum))
      (loop (nxt t-enum) (+ (* cur-hash 31) (id-hash cur-elem)))
      )
    cur-hash
    )
  )

(dm key-type (x|<str-tab> => <type>) <str>)
(dm elt-type (x|<str-tab> => <type>) <sym>)

(df case-insensitive-string-hash (x|<str> => <int>)
  (def e (len x))
  (rep loop ((i|<int> 0) (hash|<int> 0))
    (if (< i e)
        (loop (+ i 1)
              (mod (+ (<< hash 6) (& (as <int> (low-elt x i)) #x9f)) 970747))
        hash)))

(df case-insensitive-string-equal (x|<str> y|<str> => <log>)
  (def sy 0) (def ey (len y))
  (when (== (len x) (- ey sy))
    (rep loop ((i|<int> sy))
      (or (== i ey)
          (let ((cx|<chr> (low-elt x (- i sy)))
                (cy|<chr> (low-elt y i)))
            (and (or (== cx cy) (== (to-lower cx) (to-lower cy)))
                 (loop (+ i 1))))))))

(dm key-test (_|<str-tab> => <fun>) case-insensitive-string-equal)
(dm tab-hash (_|<str-tab> => <fun>) case-insensitive-string-hash)

;;;;
;;;; SETS
;;;;

(dm add! (c|<set> x => <set>)
  (set (elt c x) #t) 
  c)

(dm mem? (c|<set> x => <log>)
  (elt-or c x #f))

(dm elts (x|<col> keys|<seq> => <col>)
  (def res (fab <tab> (len keys)))
  (do (fun (k) (set (elt res k) (elt x k))) keys)
  (col-res x res))

