Author: sburson Date: Sun Nov 13 13:30:36 2011 New Revision: 28
Log: A few more goodies for 1.3.0:
* Functional deep update; see `update'.
* New `split-from', `split-above', `split-below', and `split-through' operations on sets. These take a value and return all elements of the set
= (from), > (above), < (below), or <= (through) the value.
* `split' renamed to `partition' to forestall confusion with `split-from' etc.
* ABCL port, thanks to Alessio Stalla.
* Works on SBCL 1.0.53.
Modified: trunk/Code/defs.lisp trunk/Code/fset.lisp trunk/Code/port.lisp trunk/Code/relations.lisp trunk/Code/tuples.lisp trunk/Code/wb-trees.lisp
Modified: trunk/Code/defs.lisp ============================================================================== --- trunk/Code/defs.lisp Sat Nov 12 21:21:18 2011 (r27) +++ trunk/Code/defs.lisp Sun Nov 13 13:30:36 2011 (r28) @@ -44,11 +44,11 @@ #:empty-wb-set #:empty-wb-bag #:empty-wb-map #:empty-wb-seq #:empty-dyn-tuple #:least #:greatest #:lookup #:@ - #:with #:less + #:with #:less #:split-from #:split-above #:split-through #:split-below #:union #:bag-sum #:intersection #:bag-product #:complement #:set-difference #:set-difference-2 #:bag-difference #:subset? #:disjoint? #:subbag? - #:filter #:filter-pairs #:split + #:filter #:filter-pairs #:partition #:image #:reduce #:domain #:range #:with-default #:map-union #:map-intersection #:map-difference-2 #:restrict #:restrict-not #:compose #:map-default
Modified: trunk/Code/fset.lisp ============================================================================== --- trunk/Code/fset.lisp Sat Nov 12 21:21:18 2011 (r27) +++ trunk/Code/fset.lisp Sun Nov 13 13:30:36 2011 (r28) @@ -234,11 +234,15 @@ as a Lisp function, `fn' can be a map, or a set (which is treated as mapping its members to true and everything else to false)."))
-(defgeneric split (fn collection) +(defgeneric partition (pred collection) (:documentation "Returns two values, (filter fn collection) and (filter (cl:complement fn) collection)."))
+(defun split (pred collection) + "Deprecated; use `partition'." + (partition pred collection)) + (defgeneric filter-pairs (fn collection) (:documentation "Just like `filter' except that if invoked on a bag, `fn' (which must be a @@ -920,7 +924,7 @@ "Removes the first element from `seq' and returns it." (let ((vars vals new setter getter (get-setf-expansion seq env))) (unless (= 1 (length new)) - (error "Nonsensical `pop-first' form: ~S." `(pop-first ,seq))) + (error "Nonsensical `~A' form: ~S" 'pop-first `(pop-first ,seq))) `(let* (,@(mapcar #'list vars vals) (,(car new) ,getter)) (prog1 @@ -932,7 +936,7 @@ "Removes the last element from `seq' and returns it." (let ((vars vals new setter getter (get-setf-expansion seq env))) (unless (= 1 (length new)) - (error "Nonsensical `pop-last' form: ~S." `(pop-last ,seq))) + (error "Nonsensical `~A' form: ~S" 'pop-last `(pop-last ,seq))) `(let* (,@(mapcar #'list vars vals) (,(car new) ,getter)) (prog1 @@ -951,6 +955,42 @@
;;; ================================================================================ +;;; Functional deep update + +(defun update (fn coll &rest keys) + "Returns a new version of `coll' in which the element reached by doing chained +`lookup's on `keys' is updated by `fn'. An example will help a lot here: +instead of writing + + (incf (@ (@ (@ foo 'a) 3) 7)) + +you can write, equivalently + + (setq foo (update #'1+ foo 'a 3 7)) + +This is perhaps most useful in contexts where you don't want to do the `setq' +anyway." + (labels ((rec (fn coll keys) + (if (null keys) (@ fn coll) + (with coll (car keys) (rec fn (lookup coll (car keys)) (cdr keys)))))) + (rec fn coll keys))) + +;;; If the `fn' is nontrivial, binds a variable to it with a `dynamic-extent' declaration. +;;; (Really, should do this for `image', `filter', etc. etc.) +(define-compiler-macro update (&whole form fn coll &rest keys) + (if (not (or (symbolp fn) + (and (listp fn) + (eq (car fn) 'function) + (symbolp (cadr fn))))) + (let ((fn-var (gensym "FN-"))) + `(let ((,fn-var ,fn)) + (declare (dynamic-extent ,fn-var)) + ; (expansion terminates because `fn-var' is a symbol) + (update ,fn-var ,coll . ,keys))) + form)) + + +;;; ================================================================================ ;;; Sets
;;; Note that while many of these methods are defined on `wb-set', some of them are @@ -1054,6 +1094,24 @@ s (make-wb-set new-contents))))
+(defmethod split-from ((s wb-set) value) + (let ((new-contents (WB-Set-Tree-Split-Above (wb-set-contents s) value))) + (make-wb-set (if (WB-Set-Tree-Member? (wb-set-contents s) value) + (WB-Set-Tree-With new-contents value) + new-contents)))) + +(defmethod split-above ((s wb-set) value) + (make-wb-set (WB-Set-Tree-Split-Above (wb-set-contents s) value))) + +(defmethod split-through ((s wb-set) value) + (let ((new-contents (WB-Set-Tree-Split-Below (wb-set-contents s) value))) + (make-wb-set (if (WB-Set-Tree-Member? (wb-set-contents s) value) + (WB-Set-Tree-With new-contents value) + new-contents)))) + +(defmethod split-below ((s wb-set) value) + (make-wb-set (WB-Set-Tree-Split-Below (wb-set-contents s) value))) + (defmethod union ((s1 wb-set) (s2 wb-set) &key) (make-wb-set (WB-Set-Tree-Union (wb-set-contents s1) (wb-set-contents s2))))
@@ -1109,15 +1167,38 @@ (set-filter (coerce pred 'function) s))
(defmethod filter ((pred map) (s set)) - (set-filter pred s)) + (set-filter #'(lambda (x) (lookup pred x)) s))
(defun set-filter (pred s) + (declare (optimize (speed 3) (safety 0)) + (type function pred)) (let ((result nil)) (do-set (x s) - (when (@ pred x) + (when (funcall pred x) (setq result (WB-Set-Tree-With result x)))) (make-wb-set result)))
+(defmethod partition ((pred function) (s set)) + (set-partition pred s)) + +(defmethod partition ((pred symbol) (s set)) + (set-partition (coerce pred 'function) s)) + +(defmethod partition ((pred map) (s set)) + (set-partition #'(lambda (x) (lookup pred x)) s)) + +(defun set-partition (pred s) + (declare (optimize (speed 3) (safety 0)) + (type function pred)) + (let ((result-1 nil) + (result-2 nil)) + (do-set (x s) + (if (funcall pred x) + (setq result-1 (WB-Set-Tree-With result-1 x)) + (setq result-2 (WB-Set-Tree-With result-2 x)))) + (values (make-wb-set result-1) + (make-wb-set result-2)))) + ;;; A set is another kind of boolean-valued map. (defmethod filter ((pred set) (s set)) (intersection pred s)) @@ -2103,6 +2184,7 @@ (setq result (WB-Set-Tree-With result (funcall pair-fn key val)))) (make-wb-set result)))
+;;; &&& Plist support? The `key-fn' / `value-fn' thing is not very useful. (defmethod convert ((to-type (eql 'map)) (list list) &key (key-fn #'car) (value-fn #'cdr)) (wb-map-from-list list key-fn value-fn)) @@ -2134,6 +2216,32 @@ (setq m (WB-Map-Tree-With m (funcall key-fn pr) (funcall value-fn pr))))) (make-wb-map m)))
+(defmethod convert ((to-type (eql 'map)) (b bag) &key) + (convert 'wb-map b)) + +(defmethod convert ((to-type (eql 'wb-map)) (b bag) &key) + ;; &&& If desired, we can easily make a very fast version of this -- all it has + ;; to do is build new interior nodes, reusing the leaf vectors. + (let ((m nil)) + (do-bag-pairs (x n b) + (setq m (WB-Map-Tree-With m x n))) + (make-wb-map m))) + +(defmethod convert ((to-type (eql 'map)) (ht hash-table) &key) + (convert 'wb-map ht)) + +(defmethod convert ((to-type (eql 'wb-map)) (ht hash-table) &key) + (let ((m nil)) + (maphash (lambda (k v) (setq m (WB-Map-Tree-With m k v))) ht) + (make-wb-map m))) + +(defmethod convert ((to-type (eql 'hash-table)) (m map) + &rest make-hash-table-args &key &allow-other-keys) + (let ((ht (apply #'make-hash-table make-hash-table-args))) + (do-map (x y m) + (setf (gethash x ht) y)) + ht)) + (defmethod find (item (m map) &key key test) (declare (optimize (speed 3) (safety 0))) (if key @@ -2230,7 +2338,7 @@ (write-char #\Space stream) (pprint-newline :linear stream) (write (list x y) :stream stream)) - (format stream " |}~:[~;/~:*~A~]" (map-default map)))) + (format stream " |}~:[~;/~:*~S~]" (map-default map))))
(def-gmap-arg-type :map (map) "Yields each pair of `map', as two values." @@ -2571,22 +2679,22 @@ (make-wb-seq (WB-Seq-Tree-From-List (nreverse result)) (seq-default s))))
-(defmethod split ((fn function) (s seq)) - (seq-split fn s)) +(defmethod partition ((fn function) (s seq)) + (seq-partition fn s))
-(defmethod split ((fn symbol) (s seq)) - (seq-split (coerce fn 'function) s)) +(defmethod partition ((fn symbol) (s seq)) + (seq-partition (coerce fn 'function) s))
-(defmethod split ((fn map) (s seq)) - (seq-split #'(lambda (x) (lookup fn x)) s)) +(defmethod partition ((fn map) (s seq)) + (seq-partition #'(lambda (x) (lookup fn x)) s))
-(defmethod split ((fn set) (s seq)) - (seq-split #'(lambda (x) (lookup fn x)) s)) +(defmethod partition ((fn set) (s seq)) + (seq-partition #'(lambda (x) (lookup fn x)) s))
-(defmethod split ((fn bag) (s seq)) - (seq-split #'(lambda (x) (lookup fn x)) s)) +(defmethod partition ((fn bag) (s seq)) + (seq-partition #'(lambda (x) (lookup fn x)) s))
-(defun seq-split (fn s) +(defun seq-partition (fn s) (declare (optimize (speed 3) (safety 0)) (type function fn)) (let ((result-1 nil) @@ -2909,7 +3017,7 @@ (write-char #\Space stream) (pprint-newline :linear stream) (write x :stream stream)) - (format stream " ]~:[~;/~:*~A~]" (seq-default seq)))) + (format stream " ]~:[~;/~:*~S~]" (seq-default seq))))
(def-gmap-arg-type :seq (seq) "Yields the elements of `seq'."
Modified: trunk/Code/port.lisp ============================================================================== --- trunk/Code/port.lisp Sat Nov 12 21:21:18 2011 (r27) +++ trunk/Code/port.lisp Sun Nov 13 13:30:36 2011 (r28) @@ -236,37 +236,56 @@ nil)))
+#+abcl +(progn + (defun make-lock (&optional name) + (declare (ignore name)) + (threads:make-mutex)) + (defmacro with-lock ((lock &key (wait? t)) &body body) + (declare (ignore wait?)) + `(threads:with-mutex (,lock) + . ,body)) + ;; For those implementations that support SMP but don't give us direct ways + ;; to generate memory barriers, we assume that grabbing a lock suffices. + (deflex *Memory-Barrier-Lock* + (threads:make-mutex)) + (defmacro read-memory-barrier () + '(threads:with-mutex (*Memory-Barrier-Lock*) + nil)) + (defmacro write-memory-barrier () + '(threads:with-mutex (*Memory-Barrier-Lock*) + nil))) +
;;; ----------------
;;; Constants used by the tuple implementation. We choose the widths of ;;; two bitfields to fit in a fixnum less the sign bit. +;;; These numbers are noncritical except possibly for small fixnums. + +;;; Fixnum widths of known implementations: +;;; SBCL >= 1.0.53, 64-bit: 62 +;;; ECL, 64-bit: 61 +;;; SBCL < 1.0.53, OpenMCL/Clozure CL, +;;; Scieneer CL, 64-bit 60 +;;; CLISP, 64-bit 48 +;;; Symbolics L-, I-machine; ABCL 31 +;;; Allegro, CMUCL, SBCL, ECL +;;; LispWorks (most), 32-bit 29 +;;; CLISP, 32-bit; CADR, LMI Lambda 24 +;;; LispWorks 4 on Linux 23 + +(defconstant Tuple-Value-Index-Size + (floor (+ 5 (integer-length most-positive-fixnum)) 3) + "This limits the number of key/value pairs in any tuple.")
(defconstant Tuple-Key-Number-Size - (ecase (integer-length most-positive-fixnum) - (61 40) ; ECL, 64-bit - (60 40) ; SBCL, OpenMCL, Scieneer CL, 64-bit - (48 32) ; CLISP, 64-bit - (31 18) ; Symbolics L-machine, I-machine - (29 17) ; Allegro, CMUCL, SBCL, LispWorks (most), ECL, 32-bit - (24 15) ; CLISP, 32-bit - (23 14)) ; LispWorks 4 on Linux + (- (integer-length most-positive-fixnum) Tuple-Value-Index-Size) "This limits the number of tuple-keys that can exist in a session.")
(defconstant Tuple-Key-Number-Mask (1- (ash 1 Tuple-Key-Number-Size)))
-(defconstant Tuple-Value-Index-Size - (ecase (integer-length most-positive-fixnum) - (61 21) - (60 20) - (48 16) - (31 13) - (29 12) - (24 9) - (23 9)) - "This limits the number of key/value pairs in any tuple.") -
;;; ----------------
Modified: trunk/Code/relations.lisp ============================================================================== --- trunk/Code/relations.lisp Sat Nov 12 21:21:18 2011 (r27) +++ trunk/Code/relations.lisp Sun Nov 13 13:30:36 2011 (r28) @@ -391,6 +391,29 @@ (setq m0 (WB-Map-Tree-With m0 k new))))) (make-wb-2-relation size m0 nil)))
+(defmethod convert ((to-type (eql '2-relation)) + (s seq) + &key key-fn (value-fn #'identity)) + (convert 'wb-2-relation s :key-fn key-fn :value-fn value-fn)) + +(defmethod convert ((to-type (eql 'wb-2-relation)) + (s seq) + &key key-fn (value-fn #'identity)) + (let ((m0 nil) + (size 0) + (key-fn (coerce key-fn 'function)) + (value-fn (coerce value-fn 'function))) + (do-seq (row s) + (let ((k (funcall key-fn row)) + (v (funcall value-fn row)) + ((found? prev (WB-Map-Tree-Lookup m0 k)) + ((new (WB-Set-Tree-With prev v))))) + (declare (ignore found?)) + (when (> (WB-Set-Tree-Size new) (WB-Set-Tree-Size prev)) + (incf size) + (setq m0 (WB-Map-Tree-With m0 k new))))) + (make-wb-2-relation size m0 nil))) + (defmethod convert ((to-type (eql 'map)) (br wb-2-relation) &key) "This conversion requires the relation to be functional, and returns a map representing the function; that is, the relation must map each
Modified: trunk/Code/tuples.lisp ============================================================================== --- trunk/Code/tuples.lisp Sat Nov 12 21:21:18 2011 (r27) +++ trunk/Code/tuples.lisp Sun Nov 13 13:30:36 2011 (r28) @@ -229,6 +229,9 @@ ((< ,nkeys*2-var 48) 5) (t 6)))))
+(defmethod domain ((tup dyn-tuple)) + (Tuple-Desc-Key-Set (dyn-tuple-descriptor tup))) + (defparameter Tuple-Reorder-Score-Threshold 15 ; SWAG "The reorder score that triggers a major reordering.")
@@ -501,18 +504,14 @@ (funcall elt-fn x y)))
(defun print-dyn-tuple (tuple stream level) - (format stream "#~~<") - (let ((i 0)) + (declare (ignore level)) + (pprint-logical-block (stream nil :prefix "#~<") (do-tuple (key val tuple) - (unless (= i 0) - (format stream " ")) - (when (and *print-length* (>= i *print-length*)) - (format stream "...") - (return)) - (incf i) - (write (list (tuple-key-name key) val) - :stream stream :level (and *print-level* (- *print-level* level))))) - (format stream ">")) + (pprint-pop) + (write-char #\Space stream) + (pprint-newline :linear stream) + (write (list (tuple-key-name key) val) :stream stream)) + (format stream ">")))
(defmethod compare ((tup1 tuple) (tup2 tuple)) (let ((key-set-1 (Tuple-Desc-Key-Set (dyn-tuple-descriptor tup1))) @@ -575,3 +574,11 @@ (push (funcall pair-fn k v) result)) (nreverse result)))
+ +;;; ================================================================================ + +(defmethod image ((key tuple-key) (s set)) + (set-image #'(lambda (x) (lookup x key)) s)) + +(defmethod image ((key tuple-key) (s seq)) + (seq-image #'(lambda (x) (lookup x key)) s))
Modified: trunk/Code/wb-trees.lisp ============================================================================== --- trunk/Code/wb-trees.lisp Sat Nov 12 21:21:18 2011 (r27) +++ trunk/Code/wb-trees.lisp Sun Nov 13 13:30:36 2011 (r28) @@ -473,6 +473,22 @@
;;; ================================================================================ +;;; Split-Above/Below + +(defconstant Hedge-Negative-Infinity + '|&*$ Hedge negative infinity $*&|) + +(defconstant Hedge-Positive-Infinity + '|&*$ Hedge positive infinity $*&|) + +(defun WB-Set-Tree-Split-Above (tree value) + (WB-Set-Tree-Split tree value Hedge-Positive-Infinity)) + +(defun WB-Set-Tree-Split-Below (tree value) + (WB-Set-Tree-Split tree Hedge-Negative-Infinity value)) + + +;;; ================================================================================ ;;; Union, intersection, and set difference
;;; Adams recommends using four versions of each of these routines, one for each @@ -481,12 +497,6 @@ ;;; up distinguished "negative infinity" and "positive infinity" values which, for ;;; all practical purposes, will never show up in sets.
-(defconstant Hedge-Negative-Infinity - '|&*$ Hedge negative infinity $*&|) - -(defconstant Hedge-Positive-Infinity - '|&*$ Hedge positive infinity $*&|) - (defun WB-Set-Tree-Union (tree1 tree2) "Returns the union of `tree1' and `tree2'. Runs in time linear in the total sizes of the two trees." @@ -918,10 +928,22 @@ ;;; ================================================================================ ;;; Miscellany
+;;; &&& Even with the pair special case, this is actually still 70% slower than +;;; repeated `with', though it conses slightly less. +;;; The right way is to sort the list, then do something like WB-Seq-Tree-From-List. (defun WB-Set-Tree-From-List (lst) (labels ((recur (lst n) (cond ((= n 0) nil) ((= n 1) (vector (car lst))) + ;; Reduces consing about 12%, improves speed. + ((= n 2) + (let ((v (make-array 2))) + (if (Less-Than? (car lst) (cadr lst)) + (setf (svref v 0) (car lst) + (svref v 1) (cadr lst)) + (setf (svref v 0) (cadr lst) + (svref v 1) (car lst))) + v)) (t (let ((n2 (floor n 2))) (WB-Set-Tree-Union (recur lst n2) @@ -5702,9 +5724,12 @@ (labels ((element-type (tree) (cond ((null tree) 'base-char) ((vectorp tree) - (cond ((typep tree 'base-string) 'base-char) + (cond #+FSet-Ext-Strings + ((typep tree 'base-string) 'base-char) #+FSet-Ext-Strings ((stringp tree) 'character) + #-FSet-Ext-Strings + ((stringp tree) 'base-char) (t (error 'type-error :datum (find-if-not #'characterp tree) @@ -5712,6 +5737,7 @@ (t (let ((left (element-type (WB-Seq-Tree-Node-Left tree))) (right (element-type (WB-Seq-Tree-Node-Right tree)))) + (declare (ignorable left right)) (cond #+FSet-Ext-Strings ((or (eq left 'character) (eq right 'character)) 'character)