;;; -*- Mode: Scheme -*-

;;;; Hash Tries: Persistent Trie-Structured Hash Tables

;;; Copyright (c) 2009, Taylor R. Campbell
;see "hash-trie.incl.scm"

(module hash-trie

(;export
  make-hash-trie-type
  hash-trie-type?
  hash-trie-type/key-equality-predicate
  hash-trie-type/key-hash-function
  make-hash-trie
  hash-trie?
  hash-trie/type
  hash-trie/count
  hash-trie/empty?
  hash-trie/search
  hash-trie/lookup
  hash-trie/member?
  hash-trie/update
  hash-trie/insert
  hash-trie/modify
  hash-trie/intern
  hash-trie/delete
  hash-trie/fold
  hash-trie->alist
  hash-trie/key-list
  hash-trie/datum-list
  alist->hash-trie
  string-hash
  symbol-hash
  exact-integer-hash
  real-number-hash
  complex-number-hash
  hash-trie-type:complex-number
  hash-trie-type:real-number
  hash-trie-type:exact-integer
  hash-trie-type:symbol
  hash-trie-type:string
  ;
  hash-trie-root
  hash-trie-branch?
  hash-trie-branch-vector
  hash-trie-bucket?
  hash-trie-bucket-list)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken foreign))
(import (chicken bitwise))

;;

;w/ cplxnum since type cannot check value!
(define-type real (or integer float ratnum cplxnum))

(define-type alist (list-of pair))

(define-type <hash-trie-type> (struct <hash-trie-type>))
(define-type <hash-trie> (struct <hash-trie>))

(: make-hash-trie-type (procedure procedure -> <hash-trie-type>))
(: hash-trie-type? (* -> boolean : <hash-trie-type>))
(: hash-trie-type/key-equality-predicate (<hash-trie-type> -> procedure))
(: hash-trie-type/key-hash-function (<hash-trie-type> -> procedure))

(: make-hash-trie (<hash-trie-type> -> <hash-trie>))
(: hash-trie? (* -> boolean : <hash-trie>))
(: hash-trie/type (<hash-trie> -> <hash-trie-type>))
(: hash-trie/count (<hash-trie> -> fixnum))
(: hash-trie/empty? (<hash-trie> -> boolean))

(: hash-trie/search (<hash-trie> * procedure procedure -> void))
(: hash-trie/lookup (<hash-trie> * * -> *))
(: hash-trie/member? (<hash-trie> * -> boolean))

(: hash-trie/update (<hash-trie> * procedure procedure  -> void))
(: hash-trie/insert (<hash-trie> * * -> <hash-trie>))
(: hash-trie/modify (<hash-trie> * * procedure -> <hash-trie>))
(: hash-trie/intern (<hash-trie> * procedure -> * <hash-trie>))
(: hash-trie/delete (<hash-trie> * -> <hash-trie>))

#; ;i feel violated
(: hash-trie/fold (forall (e) (<hash-trie> e (* * e -> e) -> e)))
(: hash-trie/fold (<hash-trie> * (* * * -> *) -> *))

(: hash-trie->alist (<hash-trie> -> alist))
(: hash-trie/key-list (<hash-trie> -> alist))
(: hash-trie/datum-list (<hash-trie> -> alist))
(: alist->hash-trie (alist <hash-trie-type> -> <hash-trie>))

(: string-hash (string -> fixnum))
(: symbol-hash (symbol -> fixnum))
(: exact-integer-hash (integer -> fixnum))
(: real-number-hash (real -> fixnum))
(: complex-number-hash (real -> fixnum))

;;

;from srfi-60 example implementation - slib logical.scm

(define lognot bitwise-not)

;@
(define bitwise-bit-count
  (letrec ((logcnt (lambda (n tot)
                     (if (zero? n)
                          tot
                          (logcnt (quotient n 16)
                                  (+ (vector-ref
                                      '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
                                      (modulo n 16))
                                     tot))))))
    (lambda (n)
      (cond ((negative? n) (lognot (logcnt (lognot n) 0)))
	          ((positive? n) (logcnt n 0))
	          (else 0)))))
;@
(define (logcount n)
  (cond ((negative? n) (bitwise-bit-count (lognot n)))
	      (else (bitwise-bit-count n))))

(define bit-count logcount)

(include "hash-trie.incl")

;hash-trie->stream uses branch? bucket? bucket/list
;what would make a "protected" API?
(define hash-trie-root hash-trie.root)
(define hash-trie-branch? branch?)
(define (hash-trie-branch-vector branch) branch)
(define hash-trie-bucket? bucket?)
(define hash-trie-bucket-list bucket/list)

); hash-trie