[fset-cvs] r28 - trunk/Code
sburson at common-lisp.net
sburson at common-lisp.net
Sun Nov 13 21:30:37 UTC 2011
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)
More information about the Fset-cvs
mailing list