November 2011 - fset-cvs@common-lisp.net - mailman3.common-lisp.net

[fset-cvs] r30 - in tags/fset_1.3.0: . Code
by sburson＠common-lisp.net 20 Nov '11

20 Nov '11

Author: sburson Date: Sun Nov 20 14:13:53 2011 New Revision: 30 Log: Tagging release 1.3.0. Added: tags/fset_1.3.0/ tags/fset_1.3.0/Code/ - copied from r29, trunk/Code/ tags/fset_1.3.0/fset.asd - copied unchanged from r29, trunk/fset.asd Copied: tags/fset_1.3.0/fset.asd (from r29, trunk/fset.asd) ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ tags/fset_1.3.0/fset.asd Sun Nov 20 14:13:53 2011 (r30, copy of r29, trunk/fset.asd) @@ -0,0 +1,36 @@ +;;; -*- Mode: Lisp; Package: CL-User; Syntax: ANSI-Common-Lisp -*- + +;;; File: fset.asd +;;; Contents: ASDF definitions for FSet +;;; +;;; This file is part of FSet. Copyright (c) 2007 Sympoiesis, Inc. +;;; FSet is licensed under the Lisp Lesser GNU Public License, or LLGPL. +;;; See: http://opensource.franz.com/preamble.html +;;; This license provides NO WARRANTY. + + +(asdf:defsystem FSet + :description "A functional set-theoretic collections library. +See: http://common-lisp.net/project/fset/ +" + :version "1.3.0" + :licence "LLGPL" + :depends-on (:misc-extensions) + :serial t + :components + ((:system :misc-extensions) + (:module "Code" + :serial t + :components + ((:file "defs") + (:file "port") + (:file "order") + (:file "wb-trees") + (:file "fset") + (:file "tuples") + (:file "reader") + (:file "testing") + (:file "interval") + (:file "relations") + (:file "complement-sets") + (:file "bounded-sets")))))

1 0

[fset-cvs] r29 - trunk
by sburson＠common-lisp.net 17 Nov '11

17 Nov '11

Author: sburson Date: Wed Nov 16 21:20:52 2011 New Revision: 29 Log: Adding description, version, and licence. Modified: trunk/fset.asd Modified: trunk/fset.asd ============================================================================== --- trunk/fset.asd Sun Nov 13 13:30:36 2011 (r28) +++ trunk/fset.asd Wed Nov 16 21:20:52 2011 (r29) @@ -10,6 +10,11 @@ (asdf:defsystem FSet + :description "A functional set-theoretic collections library. +See: http://common-lisp.net/project/fset/ +" + :version "1.3.0" + :licence "LLGPL" :depends-on (:misc-extensions) :serial t :components

1 0

[fset-cvs] r28 - trunk/Code
by sburson＠common-lisp.net 13 Nov '11

13 Nov '11

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)

1 0

[fset-cvs] r27 - trunk/Code
by sburson＠common-lisp.net 13 Nov '11

13 Nov '11

Author: sburson Date: Sat Nov 12 21:21:18 2011 New Revision: 27 Log: Merging lots of stuff in from development branch for 1.3.0 release. Highlights: * Added `:default' feature to `map' constructor macro. * Some new modify macros: `includef' (replaces `adjoinf'), `excludef' (replaces `removef'), `intersectf', `imagef', `composef'. `reduce' now works on maps. * Added operations: () `split' (two-valued `filter') () `splice' (splice a seq into another seq) () `appendf' and `prependf' (seq concat-and-assign) () `tuple-key-name' (new export) Also, changed `concat' from binary to n-ary. * Made the methods for `sort' and `stable-sort' on CL sequences copy the sequence first, so these are now functional operations -- consistent with FSet semantics, but not with their CL definitions. (In practice the sequence usually has to be copied anyway; and you can always call `cl:sort' explicitly if you don't want it to be copied.) * Made (convert 'vector seq) always return a simple-vector, instead of figuring out dynamically whether to return a string (which fails on the empty seq, duh). Added (convert 'string seq) that always returns a string (errors if it can't). * New, experimental type `list-relation'. Various other improvements to relations. Modified: trunk/Code/defs.lisp trunk/Code/fset.lisp trunk/Code/order.lisp trunk/Code/reader.lisp trunk/Code/relations.lisp trunk/Code/testing.lisp trunk/Code/tuples.lisp trunk/Code/wb-trees.lisp Modified: trunk/Code/defs.lisp ============================================================================== --- trunk/Code/defs.lisp Sun Nov 9 21:44:59 2008 (r26) +++ trunk/Code/defs.lisp Sat Nov 12 21:21:18 2011 (r27) @@ -37,6 +37,7 @@ ;; are unlikely to be useful in user code. #:equal? #:compare #:compare-slots #:identity-ordering-mixin #:define-cross-type-compare-methods + #:compare-lexicographically #:empty? nonempty? #:size #:set-size #:arb #:contains? #:domain-contains? #:range-contains? #:member? #:multiplicity #:empty-set #:empty-bag #:empty-map #:empty-seq #:empty-tuple @@ -47,14 +48,15 @@ #:union #:bag-sum #:intersection #:bag-product #:complement #:set-difference #:set-difference-2 #:bag-difference #:subset? #:disjoint? #:subbag? - #:filter #:image #:reduce #:domain #:range #:with-default + #:filter #:filter-pairs #:split + #:image #:reduce #:domain #:range #:with-default #:map-union #:map-intersection #:map-difference-2 #:restrict #:restrict-not #:compose #:map-default #:first #:last #:lastcons #:head #:tail #:with-first #:less-first #:push-first #:pop-first - #:with-last #:less-last #:push-last #:pop-last - #:insert #:subseq #:concat #:reverse #:sort #:stable-sort + #:with-last #:less-last #:push-last #:pop-last #:appendf #:prependf + #:insert #:splice #:subseq #:concat #:reverse #:sort #:stable-sort #:find #:find-if #:find-if-not #:count #:count-if #:count-if-not #:position #:position-if #:position-if-not @@ -62,8 +64,10 @@ #:substitute #:substitute-if #:substitute-if-not #:convert #:iterator #:do-set #:do-bag #:do-bag-pairs #:do-map #:do-seq #:do-tuple - #:adjoinf #:removef #:unionf - #:def-tuple-key #:get-tuple-key #:tuple-merge + #:adjoinf #:removef #:includef #:excludef + #:unionf #:intersectf #:imagef #:composef + #:define-tuple-key #:def-tuple-key #:get-tuple-key #:tuple-key-name + #:tuple-merge #:fset-setup-readtable #:*fset-readtable* #:$ ;; Used by the bag methods that convert to and from lists. @@ -72,7 +76,12 @@ #:bounded-set #:make-bounded-set #:bounded-set-contents ;; Relations #:relation #:bin-rel #:wb-bin-rel #:empty-bin-rel #:empty-wb-bin-rel - #:lookup-inv #:inverse #:join #:conflicts)) + #:lookup-inv #:inverse #:join #:conflicts #:map-to-sets + #:list-relation #:wb-list-relation #:empty-list-relation + #:empty-wb-list-relation #:arity #:query #:query-multi #:do-list-relation + #:query-registry #:empty-query-registry #:with-query #:less-query + #:all-queries #:lookup-multi #:forward-key #:lookup-restricted + #:lookup-multi-restricted)) ;;; A convenient package for experimenting with FSet. Also serves as an example Modified: trunk/Code/fset.lisp ============================================================================== --- trunk/Code/fset.lisp Sun Nov 9 21:44:59 2008 (r26) +++ trunk/Code/fset.lisp Sat Nov 12 21:21:18 2011 (r27) @@ -234,6 +234,20 @@ 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) + (:documentation + "Returns two values, (filter fn collection) and +\(filter (cl:complement fn) collection).")) + +(defgeneric filter-pairs (fn collection) + (:documentation + "Just like `filter' except that if invoked on a bag, `fn' (which must be a +Lisp function) is called with two arguments for each pair, the member and the +multiplicity.")) + +(defmethod filter-pairs (fn (collection t)) + (filter fn collection)) + (defgeneric image (fn collection) (:documentation "Returns a new collection containing the result of applying `fn' to each @@ -243,7 +257,20 @@ map, or a set (which is treated as mapping its members to true and everything else to false). `collection' can also be a map, in which case `fn' must be a Lisp function of two arguments that returns two values (the map-default of the -result is that of `collection').")) +result is that of `collection'); also see `compose'.")) + +;;; Convenience methods. +(defmethod image ((fn function) (l list)) + (mapcar fn l)) + +(defmethod image ((fn symbol) (l list)) + (mapcar (coerce fn 'function) l)) + +(defmethod image ((fn map) (l list)) + (mapcar (lambda (x) (@ fn x)) l)) + +(defmethod image ((fn set) (l list)) + (mapcar (lambda (x) (@ fn x)) l)) (defgeneric reduce (fn collection &key key initial-value) (:documentation @@ -261,6 +288,8 @@ (:documentation "Returns the domain of the map, that is, the set of keys mapped by the map.")) +;;; &&& Actually I think this should return a bag. You can then convert it +;;; to a set if you want. (defgeneric range (map) (:documentation "Returns the range of the map, that is, the set of all values to which keys @@ -303,6 +332,23 @@ but not `map2', with the same default as `map1'; and one containing all the pairs that are in `map2' but not `map1', with the same default as `map2'.")) +;;; Possible operation: `map-update' (better name??), which would be like +;;; `map-union' except the keys would be exactly the keys of `map1'. This +;;; would be useful for removing items from chained maps: +;;; +;;; (map-update chained-map +;;; (map (key1 (map (key2 (set val))))) +;;; (fn (x y) (map-update x y #'set-difference))) +;;; +;;; If key1->key2->val is not already present, this returns `chained-map'. +;;; +;;; But another operation with a legitimate claim on the name would simply +;;; apply a function to the range value for a specified key: +;;; +;;; (map-update chained-map key1 +;;; (fn (m) (map-update m key2 +;;; (fn (s) (less s val))))) + (defgeneric restrict (map set) (:documentation "Returns a map containing only those pairs of `map' whose keys are @@ -318,7 +364,8 @@ (:documentation "Returns a new map with the same domain as `map1', which maps each member of that domain to the result of applying first `map1' to it, then applying -`map2-or-fn' to the result.")) +`map2-or-fn' to the result. `map2-or-fn' can also be a sequence, which is +treated as a map from indices to members.")) (defgeneric first (seq) (:documentation @@ -369,11 +416,17 @@ is extended in either direction if needed prior to the insertion; previously uninitialized indices are filled with the seq's default).")) +(defgeneric splice (seq idx subseq) + (:documentation + "Returns a new sequence like `seq' but with the elements of `subseq' inserted +at `idx' (the seq is extended in either direction if needed prior to the insertion; +previously uninitialized indices are filled with the seq's default).")) + ;;; &&& Maybe we should shadow `concatenate' instead, so you can specify a ;;; result type. -(defgeneric concat (seq1 seq2) +(defgeneric concat (seq1 &rest seqs) (:documentation - "Returns the concatenation of `seq1' and `seq2'.")) + "Returns the concatenation of `seq1' with each of `seqs'.")) ;;; This is the opposite order from `cl:coerce', but I like it better, because I @@ -508,19 +561,21 @@ "Returns `seq' sorted by `pred', a function of two arguments; if `key' is supplied, it is a function of one argument that is applied to the elements of `seq' before they are passed to `pred'. The sort is not guaranteed to be -stable.")) +stable. The method for CL sequences copies the sequence first, unlike +`cl:sort'.")) (defmethod sort ((s sequence) pred &key key) - (cl:sort s pred :key key)) + (cl:sort (cl:copy-seq s) pred :key key)) (defgeneric stable-sort (seq pred &key key) (:documentation "Returns `seq' sorted by `pred', a function of two arguments; if `key' is supplied, it is a function of one argument that is applied to the elements of -`seq' before they are passed to `pred'. The sort is guaranteed to be stable.")) +`seq' before they are passed to `pred'. The sort is guaranteed to be stable. +The method for CL sequences copies the sequence first, unlike `cl:stable-sort'.")) (defmethod stable-sort ((s sequence) pred &key key) - (cl:stable-sort s pred :key key)) + (cl:stable-sort (cl:copy-seq s) pred :key key)) (defgeneric find (item collection &key key test) (:documentation @@ -820,6 +875,8 @@ `(lookup ,access-form ,key-temp)))) +;;; `adjoinf' / `removef', which don't form a good pair, are now deprecated +;;; in favor of `includef' / `excludef'. (define-modify-macro adjoinf (&rest item-or-tuple) with "(adjoinf coll . args) --> (setf coll (with coll . args))") @@ -828,9 +885,29 @@ less "(removef coll . args) --> (setf coll (less coll . args))") +(define-modify-macro includef (&rest item-or-tuple) + with + "(includef coll . args) --> (setf coll (with coll . args))") + +(define-modify-macro excludef (&rest item-or-tuple) + less + "(excludef coll . args) --> (setf coll (less coll . args))") + (define-modify-macro unionf (set) union) +(define-modify-macro intersectf (set) + intersection) + +(define-modify-macro imagef (fn) + ximage) + +(defun ximage (coll fn) + (image fn coll)) + +(define-modify-macro composef (fn) + compose) + (define-modify-macro push-first (val) with-first "(push-first seq val) --> (setf seq (with-first seq val))") @@ -863,6 +940,15 @@ (setq ,(car new) (less-last ,(car new))) ,setter)))) +(define-modify-macro appendf (seq) + concat) + +(define-modify-macro prependf (seq) + xconcat) + +(defun xconcat (seq1 seq2) + (concat seq2 seq1)) + ;;; ================================================================================ ;;; Sets @@ -1120,14 +1206,6 @@ (incf i)) result)) -(defmethod convert ((to-type (eql 'seq)) (s set) &key) - ;; Not sure we can improve on this much. - (convert 'seq (convert 'list s))) - -(defmethod convert ((to-type (eql 'wb-seq)) (s set) &key) - ;; Not sure we can improve on this much. - (convert 'wb-seq (convert 'list s))) - (defmethod convert ((to-type (eql 'set)) (l list) &key) (make-wb-set (WB-Set-Tree-From-List l))) @@ -1223,20 +1301,13 @@ (count-if #'(lambda (x) (not (funcall pred x))) s :key key))) (defun print-wb-set (set stream level) - (if (and *print-level* (>= level *print-level*)) - (format stream "#") - (progn - (format stream "#{") - (let ((i 0)) - (do-set (x set) - (format stream " ") - (when (and *print-length* (>= i *print-length*)) - (format stream "...") - (return)) - (incf i) - (let ((*print-level* (and *print-level* (1- *print-level*)))) - (write x :stream stream)))) - (format stream " }")))) + (declare (ignore level)) + (pprint-logical-block (stream nil :prefix "#{" :suffix " }") + (do-set (x set) + (pprint-pop) + (write-char #\Space stream) + (pprint-newline :linear stream) + (write x :stream stream)))) (def-gmap-arg-type :set (set) "Yields the elements of `set'." @@ -1261,6 +1332,15 @@ `(nil #'WB-Set-Tree-With #'make-wb-set ,filterp)) +(def-gmap-res-type :union (&key filterp) + "Returns the union of the values, optionally filtered by `filterp'." + `((set) #'union nil ,filterp)) + +(def-gmap-res-type :intersection (&key filterp) + "Returns the intersection of the values, optionally filtered by `filterp'." + `((complement (set)) #'intersection nil ,filterp)) + + ;;; ================================================================================ ;;; Bags @@ -1381,11 +1461,11 @@ (make-wb-bag (WB-Bag-Tree-Intersect (wb-bag-contents s1) (wb-bag-contents s2)))) (defmethod intersection ((s wb-set) (b wb-bag) &key) - (make-wb-bag (WB-Set-Tree-Intersect (wb-set-contents s) + (make-wb-set (WB-Set-Tree-Intersect (wb-set-contents s) (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b))))) (defmethod intersection ((b wb-bag) (s wb-set) &key) - (make-wb-bag (WB-Set-Tree-Intersect (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)) + (make-wb-set (WB-Set-Tree-Intersect (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)) (wb-set-contents s)))) (defmethod bag-product ((b1 wb-bag) (b2 wb-bag)) @@ -1487,6 +1567,19 @@ (defmethod filter ((pred bag) (b bag)) (bag-filter pred b)) +(defun bag-filter-pairs (pred b) + (let ((result nil)) + (do-bag-pairs (x n b) + (when (funcall pred x n) + (setq result (WB-Bag-Tree-With result x n)))) + (make-wb-bag result))) + +(defmethod filter-pairs ((pred function) (b bag)) + (bag-filter-pairs pred b)) + +(defmethod filter-pairs ((pred symbol) (b bag)) + (bag-filter-pairs (coerce pred 'function) b)) + (defmethod image ((fn function) (b bag)) (bag-image fn b)) @@ -1690,28 +1783,18 @@ (count-if #'(lambda (x) (not (funcall pred x))) s :key key))) (defun print-wb-bag (bag stream level) - (if (and *print-level* (>= level *print-level*)) - (format stream "#") - (progn - (format stream "#{% ") - (let ((i 0)) - (do-bag-pairs (x n bag) - (when (> i 0) - (format stream " ")) - (when (and *print-length* (>= i *print-length*)) - (format stream "...") - (return)) - (incf i) - (let ((*print-level* (and *print-level* (1- *print-level*)))) - (if (> n 1) - (progn - (format stream "#%") - (write `(,x ,n) :stream stream)) - (write x :stream stream)))) - (when (> i 0) - (format stream " "))) - (format stream "%}")))) - + (declare (ignore level)) + (pprint-logical-block (stream nil :prefix "#{%" :suffix " %}") + (let ((i 0)) + (do-bag-pairs (x n bag) + (pprint-pop) + (write-char #\Space stream) + (pprint-newline :linear stream) + (incf i) + (if (> n 1) + (progn + (write `(,x ,n) :stream stream)) + (write x :stream stream)))))) (def-gmap-arg-type :bag (bag) "Yields each element of `bag', as many times as its multiplicity." @@ -1904,6 +1987,27 @@ (setq result (WB-Map-Tree-With result new-x new-y)))) (make-wb-map result (map-default m)))) +(defmethod reduce ((fn function) (m map) &key key (initial-value nil init?)) + (map-reduce fn m initial-value (and key (coerce key 'function)) init?)) + +(defmethod reduce ((fn symbol) (m map) &key key (initial-value nil init?)) + (map-reduce (coerce fn 'function) m initial-value (and key (coerce key 'function)) + init?)) + +(defun map-reduce (fn m initial-value key init?) + (declare (optimize (speed 3) (safety 0)) + (type function fn) + (type (or function null) key)) + (unless init? + (error 'simple-program-error + :format-control "~A on a map requires an initial value" + :format-arguments '(reduce))) + (let ((result initial-value)) + (do-map (x y m) + (let ((x y (if key (funcall key x y) (values x y)))) + (setq result (funcall fn result x y)))) + result)) + (defmethod range ((m map)) (let ((s nil)) (do-map (key val m) @@ -1966,6 +2070,9 @@ (defmethod compose ((m wb-map) (fn symbol)) (map-fn-compose m (coerce fn 'function))) +(defmethod compose ((m wb-map) (s seq)) + (map-fn-compose m (fn (x) (@ s x)))) + (defun map-fn-compose (m fn) (make-wb-map (WB-Map-Tree-Compose (wb-map-contents m) fn) (funcall fn (map-default m)))) @@ -2116,27 +2223,14 @@ (count-if #'(lambda (x) (not (funcall pred x))) m :key key))) (defun print-wb-map (map stream level) - (if (and *print-level* (>= level *print-level*)) - (format stream "#") - (progn - (format stream "#{| ") - (let ((i 0)) - (do-map (x y map) - (when (> i 0) - (format stream " ")) - (when (and *print-length* (>= i *print-length*)) - (format stream "...") - (return)) - (incf i) - (let ((*print-level* (and *print-level* (1- *print-level*)))) - (write (list x y) :stream stream :pretty nil))) - (when (> i 0) - (format stream " "))) - (format stream "|}") - (let ((default (map-default map))) - (when default - (format stream "/~A" default)))))) - + (declare (ignore level)) + (pprint-logical-block (stream nil :prefix "#{|") + (do-map (x y map) + (pprint-pop) + (write-char #\Space stream) + (pprint-newline :linear stream) + (write (list x y) :stream stream)) + (format stream " |}~:[~;/~:*~A~]" (map-default map)))) (def-gmap-arg-type :map (map) "Yields each pair of `map', as two values." @@ -2274,6 +2368,26 @@ (make-wb-seq (WB-Seq-Tree-Insert tree idx val) (seq-default s)))) +(defmethod splice ((s wb-seq) idx subseq) + (let ((tree (wb-seq-contents s)) + ((size (WB-Seq-Tree-Size tree))) + (subseq-tree (wb-seq-contents (convert 'wb-seq subseq)))) + (when (< idx 0) + (setq tree (WB-Seq-Tree-Concat + (WB-Seq-Tree-From-Vector + (make-array (- idx) :initial-element (seq-default s))) + tree)) + (setq idx 0)) + (when (> idx size) + (setq tree (WB-Seq-Tree-Concat + tree (WB-Seq-Tree-From-Vector + (make-array (- idx size) :initial-element (seq-default s))))) + (setq size idx)) + (make-wb-seq (WB-Seq-Tree-Concat (WB-Seq-Tree-Concat (WB-Seq-Tree-Subseq tree 0 idx) + subseq-tree) + (WB-Seq-Tree-Subseq tree idx (WB-Seq-Tree-Size tree))) + (seq-default s)))) + (defmethod less ((s wb-seq) idx &optional (arg2 nil arg2?)) (declare (ignore arg2)) (check-two-arguments arg2? 'less 'wb-seq) @@ -2283,10 +2397,11 @@ (make-wb-seq (WB-Seq-Tree-Remove tree idx) (seq-default s)) s))) -(defmethod concat ((s1 wb-seq) (s2 wb-seq)) - (make-wb-seq (WB-Seq-Tree-Concat (wb-seq-contents s1) (wb-seq-contents s2)) - ;; Don't see what to do but pick one arbitrarily. - (seq-default s1))) +(defmethod concat ((s1 seq) &rest seqs) + (let ((tree (wb-seq-contents s1))) + (dolist (seq seqs) + (setq tree (WB-Seq-Tree-Concat tree (wb-seq-contents (convert 'seq seq))))) + (make-wb-seq tree (seq-default s1)))) (defmethod subseq ((s wb-seq) start &optional end) (let ((tree (wb-seq-contents s)) @@ -2332,6 +2447,10 @@ (defmethod convert ((to-type (eql 'vector)) (s wb-seq) &key) (WB-Seq-Tree-To-Vector (wb-seq-contents s))) +;;; Always returns a string. Signals `type-error' if it encounters a non-character. +(defmethod convert ((to-type (eql 'string)) (s wb-seq) &key) + (WB-Seq-Tree-To-String (wb-seq-contents s))) + (defmethod convert ((to-type (eql 'seq)) (l list) &key) (make-wb-seq (WB-Seq-Tree-From-List l))) @@ -2341,6 +2460,10 @@ (defmethod convert ((to-type (eql 'list)) (s wb-seq) &key) (WB-Seq-Tree-To-List (wb-seq-contents s))) +(defmethod convert ((to-type (eql 'seq)) (s set) &key) + ;; Not sure we can improve on this much. + (convert 'seq (convert 'list s))) + (defmethod convert ((to-type (eql 'wb-seq)) (s set) &key) ;; Not sure we can improve on this much. (convert 'wb-seq (convert 'list s))) @@ -2448,6 +2571,35 @@ (make-wb-seq (WB-Seq-Tree-From-List (nreverse result)) (seq-default s)))) +(defmethod split ((fn function) (s seq)) + (seq-split fn s)) + +(defmethod split ((fn symbol) (s seq)) + (seq-split (coerce fn 'function) s)) + +(defmethod split ((fn map) (s seq)) + (seq-split #'(lambda (x) (lookup fn x)) s)) + +(defmethod split ((fn set) (s seq)) + (seq-split #'(lambda (x) (lookup fn x)) s)) + +(defmethod split ((fn bag) (s seq)) + (seq-split #'(lambda (x) (lookup fn x)) s)) + +(defun seq-split (fn s) + (declare (optimize (speed 3) (safety 0)) + (type function fn)) + (let ((result-1 nil) + (result-2 nil)) + (do-seq (x s) + (if (funcall fn x) + (push x result-1) + (push x result-2))) + (values (make-wb-seq (WB-Seq-Tree-From-List (nreverse result-1)) + (seq-default s)) + (make-wb-seq (WB-Seq-Tree-From-List (nreverse result-2)) + (seq-default s))))) + (defmethod image ((fn function) (s seq)) (seq-image fn s)) @@ -2750,26 +2902,14 @@ :key key :start start :end end :from-end from-end :count count))) (defun print-wb-seq (seq stream level) - (if (and *print-level* (>= level *print-level*)) - (format stream "#") - (progn - (format stream "#[ ") - (let ((i 0)) - (do-seq (x seq) - (when (> i 0) - (format stream " ")) - (when (and *print-length* (>= i *print-length*)) - (format stream "...") - (return)) - (incf i) - (let ((*print-level* (and *print-level* (1- *print-level*)))) - (write x :stream stream))) - (when (> i 0) - (format stream " "))) - (format stream "]") - (let ((default (seq-default seq))) - (when default - (format stream "/~A" default)))))) + (declare (ignore level)) + (pprint-logical-block (stream nil :prefix "#[") + (do-seq (x seq) + (pprint-pop) + (write-char #\Space stream) + (pprint-newline :linear stream) + (write x :stream stream)) + (format stream " ]~:[~;/~:*~A~]" (seq-default seq)))) (def-gmap-arg-type :seq (seq) "Yields the elements of `seq'." @@ -2797,6 +2937,10 @@ #'(lambda (s) (convert 'seq (nreverse s))) ,filterp)) +(def-gmap-res-type :concat (&key filterp) + "Returns the concatenation of the seq values, optionally filtered by `filterp'." + `((seq) #'concat nil ,filterp)) + ;;; ================================================================================ ;;; CL Sequences @@ -2812,6 +2956,14 @@ (defmethod size ((s sequence)) (length s)) -(defmethod lookup ((s sequence) idx) +(defmethod lookup ((s sequence) (idx integer)) (elt s idx)) + +;;; ================================================================================ +;;; Miscellany + +;;; Oooops -- I somehow thought CL already had this. +(define-condition simple-program-error (simple-condition program-error) + ()) + Modified: trunk/Code/order.lisp ============================================================================== --- trunk/Code/order.lisp Sun Nov 9 21:44:59 2008 (r26) +++ trunk/Code/order.lisp Sat Nov 12 21:21:18 2011 (r27) @@ -33,7 +33,17 @@ ;;; Makes it easy to define `compare' methods on new classes. Just say: ;;; ;;; (defmethod compare ((f1 frob) (f2 frob)) -;;; (compare-slots f1 f2 #'frob-foo #'frob-bar)) +;;; (compare-slots f1 f2 'foo #'frob-bar)) +;;; +;;; where `foo' is a slot and `frob-bar' is an accessor (or any other +;;; function on your class). +;;; +;;; If you want distinct instances to never compare `:equal', put `:eql' +;;; at the end of the accessor list to specify that `eql' is the final +;;; determiner of equality for your type: +;;; +;;; (defmethod compare ((f1 frob) (f2 frob)) +;;; (compare-slots f1 f2 'foo #'frob-bar :eql)) ;;; (defmacro compare-slots (obj1 obj2 &rest accessors) "A handy macro for writing the bodies of `compare' methods for user classes. @@ -44,13 +54,23 @@ example, if class `frob' has accessor `frob-foo' and slot `bar': (defmethod compare ((f1 frob) (f2 frob)) - (compare-slots f1 f2 #'frob-foo 'bar))" + (compare-slots f1 f2 #'frob-foo 'bar)) + +If the symbol `:eql' is supplied as the last accessor, then if the comparisons +by the other supplied accessors all return `:equal' but `obj1' and `obj2' are +not eql, this returns `:unequal'." (let ((default-var (gensym "DEFAULT-")) (comp-var (gensym "COMP-")) (obj1-var (gensym "OBJ1-")) (obj2-var (gensym "OBJ2-"))) (labels ((rec (accs) - (if (null accs) default-var + (if (or (null accs) + (and (eq (car accs) ':eql) + (or (null (cdr accs)) + (error "If ~S is supplied to ~S, it must be ~ + the last argument" + ':eql 'compare-slots)))) + default-var `(let ((,comp-var (compare ,(call (car accs) obj1-var) ,(call (car accs) obj2-var)))) (if (or (eq ,comp-var ':less) (eq ,comp-var ':greater)) @@ -73,8 +93,9 @@ (t `(funcall ,fn ,arg))))) `(let ((,obj1-var ,obj1) (,obj2-var ,obj2) - (,default-var ':equal)) - ,(rec accessors))))) + (,default-var ,(if (member ':eql accessors) '':unequal '':equal))) + (if (eql ,obj1-var ,obj2-var) ':equal + ,(rec accessors)))))) ;;; Abstract classes @@ -324,7 +345,8 @@ (let ((len-a (length a)) (len-b (length b)) (default ':equal)) - (cond ((< len-a len-b) ':less) + (cond ((eq a b) ':equal) + ((< len-a len-b) ':less) ((> len-a len-b) ':greater) ((and (simple-vector-p a) (simple-vector-p b)) (dotimes (i len-a default) @@ -359,6 +381,8 @@ (if (or (eq comp ':less) (eq comp ':greater)) comp default))) + (when (eq a b) ; we could get lucky + (return default)) (let ((comp (compare (car a) (car b)))) (when (or (eq comp ':less) (eq comp ':greater)) (return comp)) @@ -412,49 +436,53 @@ can be strings, vectors, lists, or seqs.")) (defmethod compare-lexicographically ((a string) (b string)) - (let ((len-a (length a)) - (len-b (length b))) - (if (and (simple-string-p a) (simple-string-p b)) + (if (eq a b) + ':equal + (let ((len-a (length a)) + (len-b (length b))) + (if (and (simple-string-p a) (simple-string-p b)) + (dotimes (i (min len-a len-b) + (cond ((< len-a len-b) ':less) + ((> len-a len-b) ':greater) + (t ':equal))) + (let ((ca (schar a i)) + (cb (schar b i))) + (cond ((char< ca cb) (return ':less)) + ((char> ca cb) (return ':greater))))) (dotimes (i (min len-a len-b) (cond ((< len-a len-b) ':less) ((> len-a len-b) ':greater) (t ':equal))) - (let ((ca (schar a i)) - (cb (schar b i))) + (let ((ca (char a i)) + (cb (char b i))) (cond ((char< ca cb) (return ':less)) - ((char> ca cb) (return ':greater))))) - (dotimes (i (min len-a len-b) - (cond ((< len-a len-b) ':less) - ((> len-a len-b) ':greater) - (t ':equal))) - (let ((ca (char a i)) - (cb (char b i))) - (cond ((char< ca cb) (return ':less)) - ((char> ca cb) (return ':greater)))))))) + ((char> ca cb) (return ':greater))))))))) (defmethod compare-lexicographically ((a list) (b list)) (compare-lists-lexicographically a b)) (defmethod compare-lexicographically ((a vector) (b vector)) - (let ((len-a (length a)) - (len-b (length b)) - (default ':equal)) - (if (and (simple-vector-p a) (simple-vector-p b)) + (if (eq a b) + ':equal + (let ((len-a (length a)) + (len-b (length b)) + (default ':equal)) + (if (and (simple-vector-p a) (simple-vector-p b)) + (dotimes (i (min len-a len-b) + (cond ((< len-a len-b) ':less) + ((> len-a len-b) ':greater) + (t default))) + (let ((res (compare (svref a i) (svref b i)))) + (when (or (eq res ':less) (eq res ':greater)) + (return res)) + (when (eq res ':unequal) + (setq default ':unequal)))) (dotimes (i (min len-a len-b) (cond ((< len-a len-b) ':less) ((> len-a len-b) ':greater) (t default))) - (let ((res (compare (svref a i) (svref b i)))) + (let ((res (compare (aref a i) (aref b i)))) (when (or (eq res ':less) (eq res ':greater)) (return res)) (when (eq res ':unequal) - (setq default ':unequal)))) - (dotimes (i (min len-a len-b) - (cond ((< len-a len-b) ':less) - ((> len-a len-b) ':greater) - (t default))) - (let ((res (compare (aref a i) (aref b i)))) - (when (or (eq res ':less) (eq res ':greater)) - (return res)) - (when (eq res ':unequal) - (setq default ':unequal))))))) + (setq default ':unequal)))))))) Modified: trunk/Code/reader.lisp ============================================================================== --- trunk/Code/reader.lisp Sun Nov 9 21:44:59 2008 (r26) +++ trunk/Code/reader.lisp Sat Nov 12 21:21:18 2011 (r27) @@ -258,10 +258,11 @@ argument subforms. Each argument subform can be a list of the form (`key-expr' `value-expr'), denoting a mapping from the value of `key-expr' to the value of `value-expr'; or a list of the form ($ `expression'), in which case the -expression must evaluate to a map, denoting all its mappings. The result is -constructed from the denoted mappings in left-to-right order; so if a given key -is supplied by more than one argument subform, its associated value will be -given by the rightmost such subform." +expression must evaluate to a map, denoting all its mappings; or the symbol +`:default', in which case the next argument subform is a form whose value will +become the map's default. The result is constructed from the denoted mappings +in left-to-right order; so if a given key is supplied by more than one argument +subform, its associated value will be given by the rightmost such subform." (expand-map-constructor-form 'map args)) (defmacro wb-map (&rest args) @@ -269,18 +270,23 @@ argument subform can be a list of the form (`key-expr' `value-expr'), denoting a mapping from the value of `key-expr' to the value of `value-expr'; or a list of the form ($ `expression'), in which case the expression must evaluate to a -map, denoting all its mappings. The result is constructed from the denoted -mappings in left-to-right order; so if a given key is supplied by more than -one argument subform, its associated value will be given by the rightmost such -subform." +map, denoting all its mappings; or the symbol `:default', in which case the +next argument subform is a form whose value will become the map's default. The +result is constructed from the denoted mappings in left-to-right order; so if a +given key is supplied by more than one argument subform, its associated value +will be given by the rightmost such subform." (expand-map-constructor-form 'wb-map args)) (defun expand-map-constructor-form (type-name args) (let ((empty-form (ecase type-name (map `(empty-map)) - (wb-map `(empty-wb-map))))) + (wb-map `(empty-wb-map)))) + (default nil)) (labels ((recur (args result) (cond ((null args) result) + ((eq (car args) ':default) + (setq default (cadr args)) + (recur (cddr args) result)) ((not (and (listp (car args)) (= (length (car args)) 2))) (error "Arguments to ~S must all be pairs expressed as 2-element~@ @@ -292,7 +298,7 @@ (recur (cdr args) `(map-union ,result ,(cadar args))))) (t (recur (cdr args) `(with ,result ,(caar args) ,(cadar args))))))) - (recur args empty-form)))) + `(with-default ,(recur args empty-form) ,default)))) (defmacro seq (&rest args) "Constructs a seq of the default implementation according to the supplied Modified: trunk/Code/relations.lisp ============================================================================== --- trunk/Code/relations.lisp Sun Nov 9 21:44:59 2008 (r26) +++ trunk/Code/relations.lisp Sat Nov 12 21:21:18 2011 (r27) @@ -75,6 +75,11 @@ (and found? (WB-Set-Tree-Member? set-tree (cdr pr))))) ;;; Returns the range set. +;;; &&& Aaagh -- not sure this makes sense -- (setf (lookup rel x) ...) doesn't do +;;; the right thing at all, relative to this. Maybe the setf expander for `lookup'/`@' +;;; should call an internal form of `with' that does something different on a +;;; relation... Yes, I think this operation should be renamed, and `setf-lookup' +;;; should not exist on a relation, as `lookup' should not. (defmethod lookup ((br wb-2-relation) x) (let ((found? set-tree (WB-Map-Tree-Lookup (wb-2-relation-map0 br) x))) (if found? (make-wb-set set-tree) @@ -189,17 +194,17 @@ (defmethod union ((br1 wb-2-relation) (br2 wb-2-relation) &key) (let ((new-size 0) ((new-map0 (WB-Map-Tree-Union (wb-2-relation-map0 br1) (wb-2-relation-map0 br2) - (lambda (ignore s1 s2) - (declare (ignore ignore)) + (lambda (s1 s2) (let ((s (WB-Set-Tree-Union s1 s2))) (incf new-size (WB-Set-Tree-Size s)) s)))) (new-map1 (and (or (wb-2-relation-map1 br1) (wb-2-relation-map1 br2)) - (WB-Map-Tree-Union (wb-2-relation-map1 br1) - (wb-2-relation-map1 br2) - (lambda (ignore s1 s2) - (declare (ignore ignore)) - (WB-Set-Tree-Union s1 s2))))))) + (progn + (get-inverse br1) + (get-inverse br2) + (WB-Map-Tree-Union (wb-2-relation-map1 br1) + (wb-2-relation-map1 br2) + #'WB-Set-Tree-Union)))))) (make-wb-2-relation new-size new-map0 new-map1))) (defmethod intersection ((br1 wb-2-relation) (br2 wb-2-relation) &key) @@ -210,14 +215,14 @@ (declare (ignore ignore)) (let ((s (WB-Set-Tree-Intersect s1 s2))) (incf new-size (WB-Set-Tree-Size s)) - (values s s))))) + s)))) (new-map1 (and (or (wb-2-relation-map1 br1) (wb-2-relation-map1 br2)) - (WB-Map-Tree-Intersect (wb-2-relation-map1 br1) - (wb-2-relation-map1 br2) - (lambda (ignore s1 s2) - (declare (ignore ignore)) - (let ((s (WB-Set-Tree-Intersect s1 s2))) - (values s s)))))))) + (progn + (get-inverse br1) + (get-inverse br2) + (WB-Map-Tree-Intersect (wb-2-relation-map1 br1) + (wb-2-relation-map1 br2) + #'WB-Set-Tree-Intersect)))))) (make-wb-2-relation new-size new-map0 new-map1))) (defgeneric join (relation-a column-a relation-b column-b) @@ -268,6 +273,35 @@ (make-wb-2-relation new-size new-map0 new-map1))) +(defmethod compose ((rel wb-2-relation) (fn function)) + (2-relation-fn-compose rel fn)) + +(defmethod compose ((rel wb-2-relation) (fn symbol)) + (2-relation-fn-compose rel (coerce fn 'function))) + +(defmethod compose ((rel wb-2-relation) (fn map)) + (2-relation-fn-compose rel fn)) + +(defmethod compose ((rel wb-2-relation) (fn seq)) + (2-relation-fn-compose rel fn)) + +(defmethod compose ((rel1 wb-2-relation) (rel2 wb-2-relation)) + (join rel1 1 rel2 0)) + +(defun 2-relation-fn-compose (rel fn) + (let ((new-size 0) + ((new-map0 (gmap :wb-map (lambda (x ys) + (let ((result nil)) + (Do-WB-Set-Tree-Members (y ys) + (setq result (WB-Set-Tree-With result (@ fn y)))) + (incf new-size (WB-Set-Tree-Size result)) + (values x result))) + (:wb-map (make-wb-map (wb-2-relation-map0 rel))))))) + (make-wb-2-relation new-size + (wb-map-contents new-map0) + nil))) + + (defgeneric internal-do-2-relation (br elt-fn value-fn)) (defmacro do-2-relation ((key val br &optional value) &body body) @@ -293,6 +327,13 @@ (setq result (WB-Set-Tree-With result (funcall pair-fn x y)))) (make-wb-set result))) +;;; I've made the default conversions between maps and 2-relations use the +;;; same pairs; that is, the conversion from a map to a 2-relation yields a +;;; functional relation with the same mappings, and the inverse conversion +;;; requires a functional relation and yields a map with the same mappings. +;;; This is mathematically elegant, but I wonder if the other kind of conversion +;;; -- where the map's range is set-valued -- is not more useful in practice, +;;; and maybe more deserving of being the default. (defmethod convert ((to-type (eql '2-relation)) (m map) &key from-type) "If `from-type' is the symbol `map-to-sets', the range elements must all be sets, and the result pairs each domain element with each member of the @@ -351,9 +392,17 @@ (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 +domain value to a single range value, and the returned map maps that +domain value to that range value." (2-relation-to-wb-map br)) (defmethod convert ((to-type (eql 'wb-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 +domain value to a single range value, and the returned map maps that +domain value to that range value." (2-relation-to-wb-map br)) (defun 2-relation-to-wb-map (br) @@ -365,6 +414,11 @@ (setq m (WB-Map-Tree-With m x (WB-Set-Tree-Arb s))))) (make-wb-map m))) +(defmethod convert ((to-type (eql 'map-to-sets)) (br wb-2-relation) &key) + "This conversion returns a map mapping each domain value to the set of +corresponding range values." + (make-wb-map (WB-Map-Tree-Compose (wb-2-relation-map0 br) #'make-wb-set))) + (defgeneric conflicts (2-relation) (:documentation "Returns a 2-relation containing only those pairs of `2-relation' whose domain value @@ -398,6 +452,36 @@ (format stream " "))) (format stream "+}")))) +(defmethod iterator ((rel wb-2-relation) &key) + (let ((outer (Make-WB-Map-Tree-Iterator-Internal (wb-2-relation-map0 rel))) + (cur-dom-elt nil) + (inner nil)) + (lambda (op) + (ecase op + (:get (if (WB-Map-Tree-Iterator-Done? outer) + (values nil nil nil) + (progn + (when (or (null inner) (WB-Set-Tree-Iterator-Done? inner)) + (let ((dom-elt inner-tree (WB-Map-Tree-Iterator-Get outer))) + (setq cur-dom-elt dom-elt) + (assert inner-tree) ; must be nonempty + (setq inner (Make-WB-Set-Tree-Iterator-Internal inner-tree)))) + (values cur-dom-elt (WB-Set-Tree-Iterator-Get inner) t)))) + (:done? (WB-Map-Tree-Iterator-Done? outer)) + (:more? (not (WB-Map-Tree-Iterator-Done? outer))))))) + +(def-gmap-arg-type :2-relation (rel) + "Yields each pair of `rel', as two values." + `((iterator ,rel) + #'(lambda (it) (declare (type function it)) (funcall it ':done?)) + (:values 2 #'(lambda (it) (declare (type function it)) (funcall it ':get))))) + +(def-gmap-arg-type :wb-2-relation (rel) + "Yields each pair of `rel', as two values." + `((iterator ,rel) + #'(lambda (it) (declare (type function it)) (funcall it ':done?)) + (:values 2 #'(lambda (it) (declare (type function it)) (funcall it ':get))))) + (def-gmap-res-type :2-relation (&key filterp) "Consumes two values from the mapped function; returns a 2-relation of the pairs. Note that `filterp', if supplied, must take two arguments." @@ -460,7 +544,7 @@ (set-transitive-closure r s)) (defun set-transitive-closure (r s) - ;; This could probably use a little moer work. + ;; This could probably use a little more work. (let ((workset (set-difference (reduce #'union (image r (convert 'seq s)) :initial-value (set)) s)) @@ -471,3 +555,589 @@ (adjoinf result x) (unionf workset (set-difference (@ r x) result)))) result)) + + +(defmacro 2-relation (&rest args) + "Constructs a 2-relation of the default implementation according to the supplied +argument subforms. Each argument subform can be a list of the form (`key-expr' +`value-expr'), denoting a mapping from the value of `key-expr' to the value of +`value-expr'; or a list of the form ($ `expression'), in which case the +expression must evaluate to a 2-relation, all of whose mappings will be +included in the result." + (expand-2-relation-constructor-form '2-relation args)) + +(defmacro wb-2-relation (&rest args) + "Constructs a wb-2-relation according to the supplied argument subforms. +Each argument subform can be a list of the form (`key-expr' `value-expr'), +denoting a mapping from the value of `key-expr' to the value of `value-expr'; +or a list of the form ($ `expression'), in which case the expression must +evaluate to a 2-relation, all of whose mappings will be included in the +result." + (expand-2-relation-constructor-form '2-relation args)) + +(defun expand-2-relation-constructor-form (type-name args) + (let ((empty-form (ecase type-name + (2-relation '(empty-2-relation)) + (wb-2-relation '(empty-wb-2-relation))))) + (labels ((recur (args result) + (cond ((null args) result) + ((not (and (listp (car args)) + (= (length (car args)) 2))) + (error "Arguments to ~S must all be pairs expressed as 2-element~@ + lists, or ($ x) subforms -- not ~S" + type-name (car args))) + ((eq (caar args) '$) + (if (eq result empty-form) + (recur (cdr args) (cadar args)) + (recur (cdr args) `(union ,result ,(cadar args))))) + (t + (recur (cdr args) `(with ,result ,(caar args) ,(cadar args))))))) + (recur args empty-form)))) + + +;;; ================================================================================ +;;; List relations + +;;; A list relation is a general relation (i.e. of arbitrary arity >= 2) whose +;;; tuples are in list form. List relations support a `query' operation that +;;; takes, along with the relation, two lists, each of length equal to the +;;; arity, called the "pattern" and "metapattern". For each position, if the +;;; metapattern contains `nil', the query is not constrained by that position +;;; (the corresponding position in the pattern is ignored); if the metapattern +;;; contains `t' or `:single', then the result set contains only those tuples +;;; with the same value in that position as the pattern has. The difference +;;; between `t' and `:single' has to do with indexing. For each metapattern +;;; that is actually used, an index is constructed if not previously present, +;;; and then is maintained incrementally. If the metapattern has `t' in a +;;; location, the resulting index will contain all values for that location; +;;; if it has `:single', the resulting index will contain only those values +;;; that have actually appeared in a query pattern with this metapattern. + + + +(defstruct (list-relation + (:include relation) + (:constructor nil) + (:predicate list-relation?) + (:copier nil)) + "The abstract class for FSet list relations. It is a structure class. +A list relation is a general relation (i.e. of arbitrary arity >= 2) whose +tuples are in list form.") + +(defstruct (wb-list-relation + (:include list-relation) + (:constructor make-wb-list-relation (arity tuples indices)) + (:predicate wb-list-relation?) + (:print-function print-wb-list-relation) + (:copier nil)) + "A class of functional relations of arbitrary arity >= 2, whose tuples +are in list form." + arity + tuples + ;; a map from augmented metapattern to map from reduced tuple to set of tuples + indices) + + +(defun empty-list-relation (&optional arity) + "We allow the arity to be temporarily unspecified; it will be taken from +the first tuple added, or the first query." + (unless (or (null arity) (and (integerp arity) (>= arity 1))) + (error "Invalid arity")) + (empty-wb-list-relation arity)) + +(defun empty-wb-list-relation (arity) + "We allow the arity to be temporarily unspecified; it will be taken from +the first tuple added, or the first query." + ;; If arity = 1 it's just a set... but what the heck... + (unless (or (null arity) (and (integerp arity) (>= arity 1))) + (error "Invalid arity")) + (make-wb-list-relation arity (set) (map))) + +(defmethod arity ((rel wb-list-relation)) + "Will return `nil' if the arity is not yet specified; see `empty-list-relation'." + (wb-list-relation-arity rel)) + +(defmethod empty? ((rel wb-list-relation)) + (empty? (wb-list-relation-tuples rel))) + +(defmethod size ((rel wb-list-relation)) + (size (wb-list-relation-tuples rel))) + +(defmethod arb ((rel wb-list-relation)) + (arb (wb-list-relation-tuples rel))) + +(defmethod contains? ((rel wb-list-relation) tuple) + (contains? (wb-list-relation-tuples rel) tuple)) + +(defgeneric query (relation pattern metapattern) + (:documentation + "Along with the relation, takes two lists, each of length equal to the +arity, called the `pattern' and `metapattern'; returns a set of tuples +satisfying the query. For each position, if the metapattern contains `nil', +the query is not constrained by that position (the corresponding position in +the pattern is ignored); if the metapattern contains `t' or `:single', then +the result set contains only those tuples with the same value in that +position as the pattern has. The difference between `t' and `:single' has +to do with indexing. For each metapattern that is actually used, an index +is constructed if not previously present, and then is maintained +incrementally. If the metapattern has `t' in a location, the resulting +index will contain all values for that location; if it has `:single', the +resulting index will contain only those values that have actually appeared +in a query pattern with this metapattern.")) + +;;; `:single' is implemented, but not necessarily well enough that you'd want to +;;; use it. +(defmethod query ((rel wb-list-relation) (pattern list) (metapattern list)) + (let ((arity (wb-list-relation-arity rel))) + (if (null arity) + ;; We don't know the arity yet, which means there are no tuples. + (set) + (progn + (unless (and (= (length pattern) arity) + (= (length metapattern) arity)) + (error "Pattern or metapattern is of the wrong length")) + (if (every #'identity metapattern) + (if (contains? rel pattern) (set pattern) (set)) + (let ((augmented-mp (augmented-mp pattern metapattern)) + ((reduced-tuple (reduced-tuple pattern augmented-mp)) + (index (@ (wb-list-relation-indices rel) augmented-mp)))) + (if index + (@ index reduced-tuple) + (progn + + (let ((index-results + (remove nil (mapcar (lambda (index mp-elt pat-elt) + (and index + (@ index (and (eq mp-elt t) + (list pat-elt))))) + (get-indices rel augmented-mp) + augmented-mp pattern)))) + ;; &&& We also want to build composite indices under some + ;; circumstances -- e.g. if the result set is much smaller + ;; than the smallest of `index-results'. + (if index-results + (reduce #'intersection + (sort index-results #'> :key #'size)) + (wb-list-relation-tuples rel))))))))))) + +;;; &&& Another nail in the coffin of `:single'... should just rip it out... +(defgeneric query-multi (rel pattern metapattern) + (:documentation + "Like `query' (q.v.), except that `pattern' is a list of sets of values +rather than a list of values. Returns all tuples in the relation for which +each value is a member of the corresponding set in the pattern. `:single' +in the metapattern is not accepted.")) + +(defmethod query-multi ((rel wb-list-relation) (pattern list) (metapattern list)) + (let ((arity (wb-list-relation-arity rel))) + (if (null arity) + ;; We don't know the arity yet, which means there are no tuples. + (set) + (progn + (unless (and (= (length pattern) arity) + (= (length metapattern) arity)) + (error "Pattern or metapattern is of the wrong length")) + ;; Without :single, the augmented-mp is just the metapattern. + (when (member ':single metapattern) + (error "~S doesn't take ~S" 'query-multi ':single)) + (if (every (fn (s) (= (size s) 1)) pattern) + (query rel (mapcar #'arb pattern) metapattern) + (let ((index-results + (remove nil + (mapcar (lambda (index pat-elt) + (and index + (gmap :union + (fn (pat-elt-elt) + (@ index (list pat-elt-elt))) + (:set pat-elt)))) + (get-indices rel metapattern) + pattern)))) + (if index-results + (reduce #'intersection + (sort index-results #'> :key #'size)) + (wb-list-relation-tuples rel)))))))) + +(defun get-indices (rel augmented-mp) + "Returns a list giving the index to use for each element of `augmented-mp'." + (flet ((make-mp (i elt) + (let ((mp nil) + (arity (wb-list-relation-arity rel))) + (dotimes (j arity) + (push (and (= i (- arity j 1)) elt) mp)) + mp))) + ;; First we see what indices exist on each position. + (let ((ex-inds (gmap :list + (lambda (mp-elt i) + (and mp-elt (or (@ (wb-list-relation-indices rel) + (make-mp i mp-elt)) + (and (not (eq mp-elt t)) + (@ (wb-list-relation-indices rel) + (make-mp i t)))))) + (:list augmented-mp) + (:index 0))) + ((unindexed (mapcar (lambda (index mp-elt) + (and (null index) mp-elt)) + ex-inds augmented-mp)))) + ;; Now, if there were any instantiated positions for which an index did + ;; not exist, construct indices for them. + (unless (every #'null unindexed) + (let ((saved-mps (gmap :list (lambda (unind i) + (and unind (make-mp i unind))) + (:list unindexed) + (:index 0))) + (new-indices (make-array (length augmented-mp) + :initial-element (empty-map (set))))) + (do-set (tuple (wb-list-relation-tuples rel)) + (gmap nil (lambda (tuple-elt unind saved-mp i) + (when (and unind + (or (eq unind t) + (equal? tuple-elt (cdr unind)))) + (adjoinf (@ (svref new-indices i) + (reduced-tuple tuple saved-mp)) + tuple))) + (:list tuple) + (:list unindexed) + (:list saved-mps) + (:index 0))) + (gmap nil (lambda (saved-mp new-index) + (when saved-mp + (setf (@ (wb-list-relation-indices rel) saved-mp) new-index))) + (:list saved-mps) + (:vector new-indices)) + (setq ex-inds (gmap :list (lambda (ex-ind saved-mp new-index) + (or ex-ind (and saved-mp new-index))) + (:list ex-inds) + (:list saved-mps) + (:vector new-indices))))) + ;; &&& If we just built a complete index that subsumes any single-value indices, + ;; need to discard the latter. + ;; &&& Also, if the total size of the single-value indices we build for any + ;; position gets large enough, we should replace them all with a complete index. + ex-inds))) + +(defmethod with ((rel wb-list-relation) tuple &optional (arg2 nil arg2?)) + (declare (ignore arg2)) + (check-two-arguments arg2? 'with 'wb-list-relation) + (let ((arity (or (wb-list-relation-arity rel) + (length tuple)))) + (unless (and (listp tuple) (= (length tuple) arity)) + (error "Length of tuple, ~D, does not equal arity, ~D" + (length tuple) arity)) + (if (contains? (wb-list-relation-tuples rel) tuple) + rel + (make-wb-list-relation arity (with (wb-list-relation-tuples rel) tuple) + ;; Hmm, methinks we need to index the index map... + (image (lambda (aug-mp rt-map) + (if (augmented-mp-matches? aug-mp tuple) + (let ((rt (reduced-tuple tuple aug-mp))) + (values aug-mp + (with rt-map rt + (with (@ rt-map rt) tuple)))) + (values aug-mp rt-map))) + (wb-list-relation-indices rel)))))) + +(defmethod less ((rel wb-list-relation) tuple &optional (arg2 nil arg2?)) + (declare (ignore arg2)) + (check-two-arguments arg2? 'with 'wb-list-relation) + (let ((arity (or (wb-list-relation-arity rel) + (length tuple)))) + (unless (and (listp tuple) (= (length tuple) arity)) + (error "Length of tuple, ~D, does not equal arity, ~D" + (length tuple) arity)) + (if (not (contains? (wb-list-relation-tuples rel) tuple)) + rel + (make-wb-list-relation arity (less (wb-list-relation-tuples rel) tuple) + (image (lambda (aug-mp rt-map) + (if (augmented-mp-matches? aug-mp tuple) + (let ((rt (reduced-tuple tuple aug-mp))) + (values aug-mp + (with rt-map rt + (less (@ rt-map rt) tuple)))) + (values aug-mp rt-map))) + (wb-list-relation-indices rel)))))) + +;;; &&& I suppose that instead of consing these things up all the time we could +;;; have a special pattern object with special compare methods against lists that +;;; would compare only the desired positions. L8r... +(defun reduced-tuple (tuple augmented-mp) + "Returns a list of those members of `tuple' corresponding to instantiated +positions in the original pattern." + (if (every (lambda (x) (eq x t)) augmented-mp) tuple + (gmap (:list :filterp #'identity) ; omits nil + (lambda (pat-elt mp-elt) + (and (eq mp-elt t) pat-elt)) + (:list tuple) + (:list augmented-mp)))) + +(defun augmented-mp (pattern metapattern) + "Returns a list, of the same length as the pattern, which is like the +metapattern except that each `:single' has been replaced by a cons of +`:single' and the corresponding pattern element." + (if (not (member ':single metapattern)) metapattern + (mapcar (lambda (pat-elt mp-elt) + (if (eq mp-elt ':single) (cons ':single pat-elt) + mp-elt)) + pattern metapattern))) + +(defun augmented-mp-matches? (augmented-mp tuple) + (every (lambda (mp-elt tuple-elt) + (or (eq mp-elt nil) (eq mp-elt t) + (and (consp mp-elt) (eq (car mp-elt) ':single) + (equal? tuple-elt (cdr mp-elt))))) + augmented-mp tuple)) + + + +(defgeneric internal-do-list-relation (rel elt-fn value-fn)) + +(defmacro do-list-relation ((tuple rel &optional value) &body body) + `(block nil + (internal-do-list-relation ,rel (lambda (,tuple) . ,body) + (lambda () ,value)))) + +(defmethod internal-do-list-relation ((rel wb-list-relation) elt-fn value-fn) + (Do-WB-Set-Tree-Members (tuple (wb-set-contents (wb-list-relation-tuples rel)) + (funcall value-fn)) + (funcall elt-fn tuple))) + +(defun print-wb-list-relation (rel stream level) + (if (and *print-level* (>= level *print-level*)) + (format stream "#") + (progn + (format stream "#{* ") + (let ((i 0)) + (do-list-relation (tuple rel) + (when (> i 0) + (format stream " ")) + (when (and *print-length* (>= i *print-length*)) + (format stream "...") + (return)) + (incf i) + (let ((*print-level* (and *print-level* (1- *print-level*)))) + (write tuple :stream stream))) + (when (> i 0) + (format stream " "))) + (format stream "*}~@[^~D~]" (arity rel))))) + +#|| + +Okay, this is a start, but: + +() Don't we want to do better meta-indexing, so adding a tuple doesn't require +iterating through all the indices? + +() I'm not creating composite indices yet. The plan is straightforward -- create +one when the size of the final result set is <= the square root of the size of +the smallest index set. This is easy, but how do subsequent queries find the +composite index? + +[Later] I think that for now, the single-value index feature is an unnecessary +complication. Without it, there either exists an index on a column, or not. + +As for composite indices, I think the right way to find them will be with a +discrimination tree (or DAG), but I'm not going to bother with them yet either. + +||# + + +;;; A query registry to be used with `list-relation'. Register queries with +;;; `with-query', supplying a pattern and metapattern. The queries themselves +;;; are uninterpreted except that they are kept in sets (so CL closures are not +;;; a good choice). `lookup' returns the set of queries that match the supplied +;;; tuple. +(defstruct (query-registry + (:constructor make-query-registry (arity indices key-index))) + arity + ;; A map from augmented metapattern to map from reduced tuple to set of queries. + ;; &&& Not worrying for now whether this does anything reasonable with `:single'. + indices + ;; A map from every "key", i.e., value used in an instantiated position in a + ;; pattern, to map from augmented metapattern to set of reduced tuples in which + ;; they were used. + key-index) + +(defun empty-query-registry (&optional arity) + (unless (or (null arity) (and (integerp arity) (>= arity 1))) + (error "Invalid arity")) + (make-query-registry arity (empty-map (empty-map (set))) + (empty-map (empty-map (set))))) + +(defmethod arity ((reg query-registry)) + (query-registry-arity reg)) + +(defmethod with-query ((reg query-registry) (pattern list) (metapattern list) query) + (let ((arity (or (query-registry-arity reg) + (length pattern)))) + (unless (and (= (length pattern) arity) + (= (length metapattern) arity)) + (error "Pattern or metapattern is of the wrong length")) + (let ((augmented-mp (augmented-mp pattern metapattern)) + ((reduced-tuple (reduced-tuple pattern augmented-mp)) + ((prev-1 (@ (query-registry-indices reg) augmented-mp)) + ((prev-2 (@ prev-1 reduced-tuple))) + (aug->red (map (augmented-mp (set reduced-tuple)) :default (set)))))) + (make-query-registry arity + (with (query-registry-indices reg) augmented-mp + (with prev-1 reduced-tuple + (with prev-2 query))) + (map-union (query-registry-key-index reg) + (gmap (:map :default (empty-map (set))) + (fn (key) (values key aug->red)) + (:list reduced-tuple)) + (lambda (x y) (map-union x y #'union))))))) + +(defmethod less-query ((reg query-registry) (pattern list) (metapattern list) query) + (let ((arity (or (query-registry-arity reg) + (length pattern)))) + (unless (and (= (length pattern) arity) + (= (length metapattern) arity)) + (error "Pattern or metapattern is of the wrong length")) + (let ((augmented-mp (augmented-mp pattern metapattern)) + ((reduced-tuple (reduced-tuple pattern augmented-mp)) + ((prev-1 (@ (query-registry-indices reg) augmented-mp)) + ((prev-2 (@ prev-1 reduced-tuple)))))) + (make-query-registry arity + (with (query-registry-indices reg) augmented-mp + (with prev-1 reduced-tuple + (less prev-2 query))) + ;; &&& For now. + (query-registry-key-index reg))))) + +(defmethod all-queries ((reg query-registry)) + (gmap :union (fn (_aug-mp submap) + (gmap :union (fn (_red-tup queries) + queries) + (:map submap))) + (:map (query-registry-indices reg)))) + +(defmethod lookup ((reg query-registry) tuple) + "Returns all queries in `reg' whose patterns match `tuple'." + (let ((arity (or (query-registry-arity reg) + (length tuple)))) + (unless (and (listp tuple) (= (length tuple) arity)) + (error "Length of tuple, ~D, does not match arity, ~D" + (length tuple) arity)) + (gmap :union (lambda (aug-mp rt-map) + (@ rt-map (reduced-tuple tuple aug-mp))) + (:map (query-registry-indices reg))))) + +(defmethod lookup-multi ((reg query-registry) set-tuple) + "Here `set-tuple' contains a set of values in each position. Returns +all queries in `reg' whose patterns match any member of the cartesian +product of the sets." + (let ((arity (or (query-registry-arity reg) + (length set-tuple)))) + (unless (and (listp set-tuple) (= (length set-tuple) arity)) + (error "Length of tuple, ~D, does not match arity, ~D" + (length set-tuple) arity)) + ;; Ugh. At least, computing the cartesian product of the reduced set-tuple + ;; will frequently be faster than computing that of the original. Still, + ;; maybe we &&& need to redesign the indexing scheme here... + (gmap :union (lambda (aug-mp rt-map) + (gmap :union (fn (tuple) + (@ rt-map tuple)) + (:seq (cartesian-product (reduced-tuple set-tuple aug-mp))))) + (:map (query-registry-indices reg))))) + +;;; Since all the members are known to be distinct, we return a seq rather +;;; than pay the setification cost... a little inelegant, though. +(defmethod cartesian-product ((sets list)) + (if (null sets) + (seq nil) + (gmap :concat (fn (tail) + (gmap :seq (fn (x) (cons x tail)) + (:set (car sets)))) + (:seq (cartesian-product (cdr sets)))))) + +(defmethod forward-key ((reg query-registry) from-key to-key) + "Returns a new query-registry in which all queries whose patterns used +`from-key' (in an instantiated position) now use `to-key' in that position +instead." + (let ((key-idx-submap (@ (query-registry-key-index reg) from-key)) + ;; We'll generate garbage maintaining the map, but then the tuple instances + ;; will be shared. + (subst-cache (map))) + (flet ((get-subst (tuple) + (or (@ subst-cache tuple) + (setf (@ subst-cache tuple) + (substitute to-key from-key tuple))))) + (make-query-registry + (query-registry-arity reg) + (image (fn (aug-mp submap) + (let ((red-tups (@ key-idx-submap aug-mp))) + (values aug-mp + (map-union (restrict-not submap red-tups) + (gmap (:map :default (set)) + (fn (tup) + (let ((new-tup (get-subst tup))) + (values new-tup + (union (@ submap tup) + (@ submap new-tup))))) + (:set red-tups)) + #'union)))) + (query-registry-indices reg)) + ;; Hehe, this is fun :-) We need to update the indices for the other + ;; keys that occur along with `from-key' in tuples, and we don't want to + ;; walk the whole index to find them; but we already know what tuples are + ;; affected (the ones in `key-idx-submap'), so we work off of that. Doing + ;; this functionally was interesting. + (map-union (reduce (fn (kidx aug-mp tups) + (let ((to-update + (reduce (fn (x y) (map-union x y #'union)) + (image (fn (tup) + (gmap :map + (fn (x) (values x (set tup))) + (:set (less (convert 'set tup) + from-key)))) + tups)))) + (reduce (fn (kidx key tups) + (let ((prev-1 (@ kidx key)) + ((prev-2 (@ prev-1 aug-mp)))) + (with kidx key + (with prev-1 aug-mp + (union (set-difference prev-2 tups) + (image #'get-subst + tups)))))) + to-update :initial-value kidx))) + key-idx-submap + :initial-value (less (query-registry-key-index reg) from-key)) + (map (to-key (compose key-idx-submap + (fn (tups) + (image #'get-subst tups)))) + :default (empty-map (set))) + (fn (x y) (map-union x y #'union))))))) + +(defmethod lookup-restricted ((reg query-registry) tuple key) + "Returns all queries in `reg' whose patterns match `tuple' and which use +`key' (in an instantiated position) in their patterns." + (let ((arity (or (query-registry-arity reg) + (length tuple)))) + (unless (and (listp tuple) (= (length tuple) arity)) + (error "Length of tuple, ~D, does not match arity, ~D" + (length tuple) arity)) + (gmap :union (lambda (aug-mp rt-map) + (@ rt-map (reduced-tuple tuple aug-mp))) + (:map (let ((key-idx-submap (@ (query-registry-key-index reg) key))) + (image (fn (aug-mp rt-map) + (values aug-mp (restrict rt-map (@ key-idx-submap aug-mp)))) + (query-registry-indices reg))))))) + +(defmethod lookup-multi-restricted ((reg query-registry) set-tuple keys) + "Here `set-tuple' contains a set of values in each position. Returns +all queries in `reg' whose patterns match any member of the cartesian +product of the sets and which use a member of `keys' in their patterns." + (let ((arity (or (query-registry-arity reg) + (length set-tuple)))) + (unless (and (listp set-tuple) (= (length set-tuple) arity)) + (error "Length of tuple, ~D, does not match arity, ~D" + (length set-tuple) arity)) + (gmap :union (lambda (aug-mp rt-map) + (gmap :union (fn (tuple) + (@ rt-map tuple)) + (:seq (cartesian-product (reduced-tuple set-tuple aug-mp))))) + (:map (let ((key-idx-submap + (reduce (fn (x y) (map-union x y #'union)) + (image (query-registry-key-index reg) keys)))) + (image (fn (aug-mp rt-map) + (values aug-mp (restrict rt-map (@ key-idx-submap aug-mp)))) + (query-registry-indices reg))))))) Modified: trunk/Code/testing.lisp ============================================================================== --- trunk/Code/testing.lisp Sun Nov 9 21:44:59 2008 (r26) +++ trunk/Code/testing.lisp Sat Nov 12 21:21:18 2011 (r27) @@ -122,8 +122,11 @@ (test (unequal? (seq 'a 3 'c) (seq 'a 3.0 'c))) (test (less-than? (seq 'a 3 'c) (seq 'a 3.0 'd))) (test (less-than? (seq) (tuple))) - (test (equal (convert 'list (eval '(tuple (+K0+ 1) ($ (tuple (+K1+ 2) (+K2+ 3))) - (+K0+ 2) ($ (tuple (+K4+ 7) (+K2+ 8)))))) + (test (equal (sort (convert 'list (eval '(tuple (+K0+ 1) + ($ (tuple (+K1+ 2) (+K2+ 3))) + (+K0+ 2) + ($ (tuple (+K4+ 7) (+K2+ 8)))))) + #'< :key (fn (x) (tuple-key-number (car x)))) `((,+K0+ . 2) (,+K1+ . 2) (,+K2+ . 8) (,+K4+ . 7)))) (test (less-than? (tuple (+K0+ 1)) (tuple (+K0+ 2)))) (test (unequal? (tuple (+K0+ 1.0) (+K1+ 'c)) (tuple (+K0+ 1) (+K1+ 'c)))) Modified: trunk/Code/tuples.lisp ============================================================================== --- trunk/Code/tuples.lisp Sun Nov 9 21:44:59 2008 (r26) +++ trunk/Code/tuples.lisp Sat Nov 12 21:21:18 2011 (r27) @@ -52,7 +52,7 @@ ;;; with sparse slots (at which most of the tuples created have no assigned ;;; value), you may find the additional functionality of these tuples useful. -;;; Keys can be defined with `def-tuple-key', or obtained at runtime with +;;; Keys can be defined with `define-tuple-key', or obtained at runtime with ;;; `get-tuple-key'. ;;; The implementation gets its speed by arranging for lookup to be done by @@ -148,6 +148,11 @@ (error "Tuple key space exhausted")))))) (defmacro def-tuple-key (name &optional default-fn) + "Deprecated; use `define-tuple-key'." + ;; What this should have been called to begin with. + `(define-tuple-key ,name ,default-fn)) + +(defmacro define-tuple-key (name &optional default-fn) "Defines a tuple key named `name' as a global lexical variable (see `deflex'). If `default-fn' is supplied, it is used to compute a value for lookups where the tuple has no explicit pair with this key; it is called with one argument, Modified: trunk/Code/wb-trees.lisp ============================================================================== --- trunk/Code/wb-trees.lisp Sun Nov 9 21:44:59 2008 (r26) +++ trunk/Code/wb-trees.lisp Sat Nov 12 21:21:18 2011 (r27) @@ -4953,21 +4953,22 @@ (defun WB-Map-Tree-Compose (tree fn) - (if (consp tree) - (cons (car tree) - (gmap (:vector :length (length (cdr tree))) - fn (:simple-vector (cdr tree)))) - (let ((key (WB-Map-Tree-Node-Key tree)) - (val (WB-Map-Tree-Node-Value tree)) - (new-left (WB-Map-Tree-Compose (WB-Map-Tree-Node-Left tree) fn)) - (new-right (WB-Map-Tree-Compose (WB-Map-Tree-Node-Right tree) fn))) - (if (Equivalent-Map? key) - (Make-WB-Map-Tree-Node - (Make-Equivalent-Map (mapcar (lambda (pr) - (cons (car pr) (funcall fn (cdr pr)))) - (Equivalent-Map-Alist key))) - val new-left new-right) - (Make-WB-Map-Tree-Node key (funcall fn val) new-left new-right))))) + (and tree + (if (consp tree) + (cons (car tree) + (gmap (:vector :length (length (cdr tree))) + fn (:simple-vector (cdr tree)))) + (let ((key (WB-Map-Tree-Node-Key tree)) + (val (WB-Map-Tree-Node-Value tree)) + (new-left (WB-Map-Tree-Compose (WB-Map-Tree-Node-Left tree) fn)) + (new-right (WB-Map-Tree-Compose (WB-Map-Tree-Node-Right tree) fn))) + (if (Equivalent-Map? key) + (Make-WB-Map-Tree-Node + (Make-Equivalent-Map (mapcar (lambda (pr) + (cons (car pr) (funcall fn (cdr pr)))) + (Equivalent-Map-Alist key))) + val new-left new-right) + (Make-WB-Map-Tree-Node key (funcall fn val) new-left new-right)))))) ;;; ---------------- @@ -5677,61 +5678,59 @@ (push (Make-WB-Seq-Tree-Node left right) stack)))))))) (defun WB-Seq-Tree-To-Vector (tree) + (let ((result (make-array (WB-Seq-Tree-Size tree)))) + (labels ((fillr (tree result idx) + (declare (optimize (speed 3) (safety 0)) + (fixnum idx)) + (cond ((stringp tree) + (dotimes (i (length (the simple-string tree))) + (setf (svref result (+ idx i)) (schar tree i)))) + ((simple-vector-p tree) + (dotimes (i (length tree)) + (setf (svref result (+ idx i)) (svref tree i)))) + (t + (let ((left (WB-Seq-Tree-Node-Left tree))) + (fillr left result idx) + (fillr (WB-Seq-Tree-Node-Right tree) + result (+ idx (WB-Seq-Tree-Size left)))))))) + (fillr tree result 0) + result))) + +(defun WB-Seq-Tree-To-String (tree) (declare (optimize (speed 3) (safety 0))) - (if (or (null tree) (simple-vector-p tree)) - (coerce tree 'vector) + (if (null tree) "" (labels ((element-type (tree) (cond ((null tree) 'base-char) ((vectorp tree) (cond ((typep tree 'base-string) 'base-char) #+FSet-Ext-Strings ((stringp tree) 'character) - (t t))) + (t + (error 'type-error + :datum (find-if-not #'characterp tree) + :expected-type 'character)))) (t (let ((left (element-type (WB-Seq-Tree-Node-Left tree))) (right (element-type (WB-Seq-Tree-Node-Right tree)))) - (cond ((or (eq left t) (eq right t)) - t) - #+FSet-Ext-Strings + (cond #+FSet-Ext-Strings ((or (eq left 'character) (eq right 'character)) 'character) (t 'base-char))))))) (let ((elt-type (element-type tree))) - (if (member elt-type '(base-char character)) - (let ((result (make-string (WB-Seq-Tree-Size tree) :element-type elt-type))) - (labels ((fillr (tree result idx) - (declare (optimize (speed 3) (safety 0)) - (fixnum idx)) - (cond ((stringp tree) - (dotimes (i (length (the simple-string tree))) - ;; All this code duplication is just so we can use - ;; `(schar result ...)' here and `(svref result ...)' - ;; below. - (setf (schar result (+ idx i)) (schar tree i)))) - (t - (let ((left (WB-Seq-Tree-Node-Left tree))) - (fillr left result idx) - (fillr (WB-Seq-Tree-Node-Right tree) - result (+ idx (WB-Seq-Tree-Size left)))))))) - (fillr tree result 0) - result)) - (let ((result (make-array (WB-Seq-Tree-Size tree)))) - (labels ((fillr (tree result idx) - (declare (optimize (speed 3) (safety 0)) - (fixnum idx)) - (cond ((stringp tree) - (dotimes (i (length (the simple-string tree))) - (setf (svref result (+ idx i)) (schar tree i)))) - ((simple-vector-p tree) - (dotimes (i (length tree)) - (setf (svref result (+ idx i)) (svref tree i)))) - (t - (let ((left (WB-Seq-Tree-Node-Left tree))) - (fillr left result idx) - (fillr (WB-Seq-Tree-Node-Right tree) - result (+ idx (WB-Seq-Tree-Size left)))))))) - (fillr tree result 0) - result))))))) + (let ((result (make-string (WB-Seq-Tree-Size tree) :element-type elt-type))) + (labels ((fillr (tree result idx) + (declare (optimize (speed 3) (safety 0)) + (fixnum idx)) + (cond ((stringp tree) + (dotimes (i (length (the simple-string tree))) + (setf (schar result (+ idx i)) (schar tree i)))) + (t + (let ((left (WB-Seq-Tree-Node-Left tree))) + (fillr left result idx) + (fillr (WB-Seq-Tree-Node-Right tree) + result (+ idx (WB-Seq-Tree-Size left)))))))) + (fillr tree result 0) + result)))))) ;;; ================================================================================

1 0