Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 149 lines (127 sloc) 4.655 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
(require 'ra-lists)
(require 'recur)

(defstruct ptbl buckets test)

(defalias 'ptbl? #'ptbl-p)

(defun* fresh-ptbl (&optional (n 107) (test #'equal))
  "Create a fresh persistent hash table with N (107) bins and
TEST for equality."
  (make-ptbl :buckets (ra:make-list n '())
:test test))

(defvar the-empty-ptbl (fresh-ptbl) "An empty EQUAL testing persistent hash table.")
(defvar the-empty-ptbl-eq (fresh-ptbl 107 #'eq) "An empty EQ testing persistent hash table.")

(defun ptbl-set-buckets (p b)
  "Set the BUCKETS part of a persistent table P to B."
  (make-ptbl :buckets b
:test (ptbl-test p)))

(defun ptbl-dip-buckets (p f)
  "Set the BUCKETS part of a persistent table P to (FUNCALL F B),
where B is the old buckets."
  (make-ptbl :buckets (funcall f (ptbl-buckets p))
:test (ptbl-test p)))

(defun ptbl-n-buckets (p)
  "Return the number of buckets in the table P."
  (ra:length (ptbl-buckets p)))

(recur-defun* ptbl-add-to-bucket (bucket key val test &optional acc)
  "Add an association to BUCKET with KEY, VAL and KEY equality
tested under TEST."
  (cond ((empty? bucket) (cons (cons key val) acc))
(t
(let* ((slot (car bucket))
(ckey (car slot))
(bucket-rest (cdr bucket)))
(if (funcall test key ckey) (cons (cons key val) (append bucket-rest acc))
(recur bucket-rest key val test (cons slot acc)))))))

(recur-defun* ptbl-get-from-bucket (bucket key test)
  "Find an association to BUCKET with KEY. TEST defines key equality."
  (cond ((empty? bucket) nil)
(t
(let* ((slot (car bucket))
(ckey (car slot))
(val (cdr slot))
(bucket-rest (cdr bucket)))
(if (funcall test key ckey) val
(recur bucket-rest key test))))))

(defun bucket-keys (bucket)
  "Return all the keys in a BUCKET."
  (mapcar #'car bucket))

(defun bucket-values (bucket)
  "Return all the values in a BUCKET."
  (mapcar #'cdr bucket))


(defun ptbl-set (tbl key val)
  "Return a new persistent hash table which is like TBL except
that KEY is associated with VAL."
  (let* ((h (sxhash key))
(ix (mod h (ptbl-n-buckets tbl)))
(buckets (ptbl-buckets tbl))
(bucket (ra:list-ref buckets ix)))
(ptbl-set-buckets tbl
(ra:list-set buckets ix (ptbl-add-to-bucket bucket key val (ptbl-test tbl))))))

(defun {} (maybe-ptbl &rest args)
  "Construct or augment a PTBL with the KEY/VAL pairs in ARGS.
If MAYBE-PTBL is not a PTBL, treat it as the first key and use an
empty persistent table."
  (if (not (ptbl? maybe-ptbl)) (apply #'{} the-empty-ptbl (cons maybe-ptbl args))
(recur-let ((key/vals args)
(ptbl maybe-ptbl))
(if (empty? key/vals) ptbl
(let ((key (car key/vals))
(val (cadr key/vals))
(rest (cddr key/vals)))
(recur rest
(ptbl-set ptbl key val)))))))

(defun ptbl-get (tbl key &optional or-value)
  "Retreive the association for KEY from the persistent hashtable
TBL. Return OR-VALUE if no association exists, which defaults to
NIL."
  (let* ((h (sxhash key))
(ix (mod h (ptbl-n-buckets tbl)))
(buckets (ptbl-buckets tbl))
(bucket (ra:list-ref buckets ix))
(r (ptbl-get-from-bucket bucket key (ptbl-test tbl))))
(if r r or-value)))

(defun ptbl-keys (tbl)
  "Return a list of all keys in the persistent hash table TBL.
Order is unspecified."
  (recur-let ((buckets (ptbl-buckets tbl))
(keys '()))
(cond
((ra:null? buckets) keys)
(t (recur
(ra:cdr buckets)
(append (bucket-keys (ra:car buckets)) keys))))))

(defun ptbl-values (tbl)
  "Return a list of all values in the persistent hash table TBL.
Order is unspecified."
  (recur-let ((buckets (ptbl-buckets tbl))
(vals '()))
(cond
((ra:null? buckets) vals)
(t (recur
(ra:cdr buckets)
(append (bucket-values (ra:car buckets)) vals))))))

(defun ptbl->alist (tbl)
  "Return an association list with the same assocations as TBL."
  (recur-let ((keys (ptbl-keys tbl))
(pairs '()))
(if (empty? keys)
pairs
(recur (cdr keys)
(cons (cons (car keys)
(ptbl-get tbl (car keys))) pairs)))))

(defun ptbl->ppstring (tbl)
  "Produce a nice string representation of the persistent hash table TBL."
  (recur-let ((keys (ptbl-keys tbl))
(str "({} "))
(if (empty? keys)
str
(recur (cdr keys)
(concat str
(format "%s%s %s%s%s"
(if (or (symbolp (car keys))
(listp (car keys))) "'" "")
(car keys)
(if (or (symbolp (ptbl-get tbl (car keys)))
(symbolp (ptbl-get tbl (car keys)))) "'" "")
(ptbl-get tbl (car keys))
(if (empty? (cdr keys)) ")" " ")))))))

(provide 'persistent-hash-tables)

Something went wrong with that request. Please try again.