diff --git a/faim.lisp b/faim.lisp index d224ea45c0d2030982c295d6b49fb0362a043491..757f7998bbc50cfd5998ccf2830723261f4fcd21 100644 --- a/faim.lisp +++ b/faim.lisp @@ -51,8 +51,9 @@ (defmethod check-invariant ((i fmap:<faim>) role map) (declare (optimize (debug 3))) (declare (ignore role)) - (check-type map trie-head) - (trie-check-invariant (datum map) (node-height map) 0) + (when map + (check-type map trie-head) + (trie-check-invariant (datum map) (node-height map) 0)) map) (defun trie-check-invariant (trie position key) diff --git a/functional-map.lisp b/functional-map.lisp index a087156dca85ca84e10f522e68160320d3a2bb4a..c0fbe513c71f0b26c0f8ad057fefd55d4869f500 100644 --- a/functional-map.lisp +++ b/functional-map.lisp @@ -12,7 +12,7 @@ #:<map> #:<alist> #:<binary-tree> #:<avl-tree> #:<number-keyed-functional-map> #:<nkfm> - #:<pure-hash-table> #:<pure-equal-hash-table> + #:<pure-hash-table> #:<pure-equal-hash-table> #:<pht> #:<equal-pht> #:<faim> #:empty #:empty-p @@ -23,6 +23,7 @@ #:decons #:fold-left #:fold-right + #:for-each #:append #:divide #:count @@ -74,7 +75,8 @@ yielding association k_1 v_1 .. k_n v_n, and computing by repeatedly deconstructing it as by decons, yielding association k_1 v_1 .. k_n v_n, and computing (f k_1 v_1 (f k2 v_2 (f ... (f k_n-1 v_n-1 (f k_n v_n seed))...)))")) - +(defgeneric fmap:for-each (interface map f) + (:documentation "For every key value pair in map, (funcall f k v)")) (defgeneric fmap:append (interface map1 map2) (:documentation "Merge two maps, returning a merged map. Mappings from MAP1 override those from MAP2.")) diff --git a/pure-alist.lisp b/pure-alist.lisp index 450cd8270ce3d92d262ba4b5e09de4df233a1602..55e3be4deec271fd83b6a1ab11ee968f8a865dc3 100644 --- a/pure-alist.lisp +++ b/pure-alist.lisp @@ -52,6 +52,9 @@ (defmethod fmap:fold-right ((i fmap:<alist>) map f seed) (reduce (lambda (pair acc) (funcall f (car pair) (cdr pair) acc)) map :initial-value seed :from-end t)) +(defmethod fmap:for-each ((i fmap:<alist>) map f) + (loop :for (key . val) :in map :do (funcall f key val)) + (values)) (defmethod fmap:divide ((i fmap:<alist>) map) (let* ((l (length map)) (l1 (floor l 2))) diff --git a/pure-hash-tables.lisp b/pure-hash-tables.lisp index fcb7ec657bdc9209f569ee6b868896ec4a17af23..f8a65d594f650b99f61470141165c7eec3195021 100644 --- a/pure-hash-tables.lisp +++ b/pure-hash-tables.lisp @@ -7,7 +7,7 @@ (defclass fmap:<pure-hash-table> (fmap:<map> eq:<hashable> - fmap-simple-empty) + fmap-simple-empty fmap-simple-append) ((alist-interface :accessor alist-interface)) (:documentation "pure hash table")) @@ -18,12 +18,21 @@ (defparameter fmap:<pure-hash-table> (memo:memoized 'make-instance 'fmap:<pure-hash-table>)) -(defparameter <pht> fmap:<pure-hash-table>) +(defparameter fmap:<pht> fmap:<pure-hash-table>) (defclass fmap:<pure-equal-hash-table> (fmap:<pure-hash-table> eq:<equal>) ()) (defparameter fmap:<pure-equal-hash-table> (memo:memoized 'make-instance 'fmap:<pure-equal-hash-table>)) -(defparameter <equal-pht> fmap:<pure-equal-hash-table>) +(defparameter fmap:<equal-pht> fmap:<pure-equal-hash-table>) + +(defmethod check-invariant ((i fmap:<pure-hash-table>) role map) + (check-invariant fmap:<nkfm> role map) + (fmap:for-each + fmap:<nkfm> map + (lambda (hash bucket) + (declare (ignore hash)) + (check-invariant (alist-interface i) role bucket))) + map) (defmethod fmap:lookup ((i fmap:<pure-hash-table>) node key) (if (null node) (values nil nil) @@ -68,6 +77,12 @@ (declare (ignore h)) (fmap:fold-right (alist-interface i) bucket f a)) seed)) +(defmethod fmap:for-each ((i fmap:<pure-hash-table>) map f) + (fmap:for-each + fmap:<nkfm> map + (lambda (hash bucket) + (declare (ignore hash)) + (fmap:for-each (alist-interface i) bucket f)))) (defmethod fmap:divide ((i fmap:<pure-hash-table>) node) (cond ((null node) @@ -88,10 +103,3 @@ (multiple-value-list (fmap:divide i node))) (t (fmap:divide/list fmap:<nkfm> node)))) - -#| -(defparameter <pht> fmap:<pure-hash-table>) - -(sort (fmap:fold-left <pht> (reduce (lambda (x i) (fmap:insert <pht> x i i)) (loop :for i :below 1000 :collect i) :initial-value nil) (lambda (m k v) k (cons v m)) nil) '<) - -|# diff --git a/pure-trees.lisp b/pure-trees.lisp index d614e4e1b5fb709a31fdbb178496fdd199edf625..f7959e28db4187e4a53e7c3f8b3fad0aab8959c7 100644 --- a/pure-trees.lisp +++ b/pure-trees.lisp @@ -139,6 +139,12 @@ between them, re-balancing as needed.")) (funcall f (node-key node) (node-value node) (fmap:fold-right i (right node) f seed))))) +(defmethod fmap:for-each ((i fmap:<binary-tree>) node f) + (when node + (fmap:for-each i (left node) f) + (funcall f (node-key node) (node-value node)) + (fmap:for-each i (right node) f)) + (values)) (defmethod fmap:divide ((i fmap:<binary-tree>) node) (cond ((null node) @@ -215,6 +221,20 @@ between them, re-balancing as needed.")) (node-height (right node)))))) (assert (member (node-balance node) '(-1 0 1))))) +#| Minimum number of nodes in a tree of height n (maximum is 2^n-1) +(memo:define-memo-function f (n) + (cond ((zerop n) 0) + ((= n 1) 1) + (t (+ 1 (f (1- n)) (f (- n 2)))))) +It's a variant of the fibonacci function, +and it grows exponentially like phi^n when n is big. +This ensures that even in the worst-case scenario, +a balanced tree is logarithmically shallow. + +Exercise: prove that the in the above algorithms, +tree:node is always called with branches that are of comparable height... +|# + (defmethod tree:node ((i fmap:<avl-tree>) &key left right key value) (flet ((mk (&key left right key value) (let ((lh (node-height left)) diff --git a/test/functional-map.lisp b/test/functional-map.lisp index ee7a6b490380c78839217c128932b63864e4bd14..b874d44a9228d0419748faf1dc75215d0d1d9e0c 100644 --- a/test/functional-map.lisp +++ b/test/functional-map.lisp @@ -36,12 +36,18 @@ (defmethod test-map ((i fmap:<map>)) ;;; TODO: test each and every function in the API + (assert (null (alist-from i (fmap:empty i)))) + (assert (fmap:empty-p i (from-alist i ()))) (assert (equal "12" (fmap:lookup i (from-alist i '((57 . "57") (10 . "10") (12 . "12"))) 12))) + (loop :for (k . v) :in *al-1* :with m = (from-alist i *al-1*) :do + (assert (eq v (fmap:lookup i m k)))) + (assert (equal-alist *alist-10-latin* + (alist-from i (from-alist i *alist-10-latin*)))) (assert (equal-alist *alist-10-latin* (alist-from i (from-alist i *alist-10-latin*)))) (assert (equal-alist *alist-100-decimal* @@ -55,13 +61,18 @@ t) (defmethod test-map :after ((i fmap:<number-keyed-functional-map>)) - (let ((m (fmap:convert - i <alist> - (make-alist 1000 "~@R")))) - (check-invariant i :node m) - (assert (equal 10 (fare-utils::node-height m))) - (assert (equal 1000 (fmap:count i m))))) + (let* ((a1 (make-alist 1000 "~@R")) + (a2 (shuffle-list a1)) + (m1 (fmap:convert i <alist> a1)) + (m2 (fmap:convert i <alist> a2))) + (check-invariant i :map m1) + (check-invariant i :map m2) + (assert (= 10 (fare-utils::node-height m1))) + (assert (<= 10 (fare-utils::node-height m2) 15)) + (assert (= 1000 (fmap:count i m1))) + (assert (= 1000 (fmap:count i m2))))) (test-map fmap:<alist>) (test-map fmap:<nkfm>) +(test-map fmap:<pht>) (test-map fmap:<faim>)