diff --git a/.gitignore b/.gitignore index af1167f7858ef79b34b8160696a134ace21b6854..fb3c469cdcc60baf6c820bc71b477f19c69e94d5 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ _darcs Java-Code *.64xfasl .DS_Store +Coverage-Reports diff --git a/Code/champ.lisp b/Code/champ.lisp index d20852458d3626819dab8e492470c206b5339fd2..9049973310ef4e3807d036f1d7e9d2fb2042b16d 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -117,30 +117,30 @@ (defstruct (ch-set-node ((consp tree) (the fixnum (car tree))) (t (ch-set-node-hash-value tree)))) -(defun ch-set-tree-with (tree value hash-fn compare-fn &optional (depth 0)) +(defun ch-set-tree-with (tree value hash-fn compare-fn &optional (depth 0) replace?) (declare (optimize (speed 3) (safety 0)) (type function hash-fn compare-fn) (type (integer 0 64) depth)) (let ((value-hash (hash-to-fixnum value hash-fn))) (declare (fixnum value-hash)) (rlabels (rec tree (ash value-hash (- (* champ-hash-bits-per-level depth))) depth) - (rec (node hash-shifted depth &optional node-hash) + (rec (node hash-shifted depth) (declare (fixnum hash-shifted) - (type (integer 0 64) depth) - (type (or null fixnum) node-hash)) + (type (integer 0 64) depth)) (let ((hash-bits (logand hash-shifted champ-hash-level-mask))) (if (null node) (vector (ash 1 hash-bits) 0 1 value-hash value) (if (consp node) ;; We can create collision nodes at any level (see below). -- Well, not at the root. But ;; this is called from elsewhere (e.g. `-union') on subtrees, which might be collision nodes. - (let ((node-hash (or node-hash (hash-to-fixnum (wb-set-tree-arb (cdr node)) hash-fn))) - ((wb-hash-shifted (ash node-hash (- (* champ-hash-bits-per-level depth))))) + (let ((wb-hash-shifted (ash (the fixnum (car node)) (- (* champ-hash-bits-per-level depth)))) (size (1+ (wb-set-tree-size (cdr node))))) - (declare (fixnum wb-hash-shifted hash-shifted size)) + (declare (fixnum wb-hash-shifted size)) (if (= hash-shifted wb-hash-shifted) ;; Update the collision node. - (let ((new-wb-tree (wb-set-tree-with (cdr node) value compare-fn))) + (let ((new-wb-tree (wb-set-tree-with (if replace? (wb-set-tree-less (cdr node) value compare-fn) + (cdr node)) + value compare-fn))) (if (eq new-wb-tree (cdr node)) node ;; New entry in collision node @@ -150,7 +150,7 @@ (defstruct (ch-set-node (content-hash (hash-mix (car node) value-hash))) (if (= hash-bits wb-hash-bits) (vector 0 (ash 1 hash-bits) size content-hash - (rec node (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth) node-hash)) + (rec node (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth))) (vector (ash 1 hash-bits) (ash 1 wb-hash-bits) size content-hash value node))))) ;; Normal case @@ -165,7 +165,9 @@ (defstruct (ch-set-node ;; Entry found (let ((ex-value (svref node entry-idx))) (if (equal?-cmp value ex-value compare-fn) - node + (if (and replace? (not (eq value ex-value))) + (vector-update node entry-idx value) + node) ;; Entry with different value found: make a subnode (let ((hash-shifted (ash hash-shifted (- champ-hash-bits-per-level))) (ex-value-hash (hash-to-fixnum ex-value hash-fn)) @@ -186,7 +188,11 @@ (defstruct (ch-set-node (incf (ch-set-node-size n)) (unless (consp n2) (hash-mixf (ch-set-node-hash-value n) value-hash)) - n))) + (if (and (> depth 0) (consp n2) + (zerop (ch-set-node-entry-mask n)) + (= 1 (logcount (ch-set-node-subnode-mask n)))) + n2 + n)))) ;; No entry found: check for subnode (if (logbitp hash-bits subnode-mask) ;; Subnode found @@ -213,7 +219,7 @@ (defstruct (ch-set-node (declare (optimize (speed 3) (safety 0)) (simple-vector vec) (fixnum rem-idx ins-idx)) - (assert (<= rem-idx (the fixnum (1- ins-idx)))) + (assert (< rem-idx ins-idx)) (let ((len (length vec)) ((v (make-array len)))) (declare (fixnum len)) @@ -328,6 +334,7 @@ (defstruct (ch-set-node (svref tree ch-set-node-header-size)))) (defun ch-set-tree-contains? (tree value hash-fn compare-fn &optional (depth 0)) + "On success, returns the set element as the second value." (declare (optimize (speed 3) (safety 0)) (type function hash-fn compare-fn) (type (integer 0 64) depth)) @@ -664,8 +671,8 @@ (defstruct (ch-set-node (type champ-subnode-index isubnode)) (svref n (- (length n) isubnode 1))) -(declaim (inline ch-set-node-add-entry)) -(defun ch-set-node-add-entry (n idx val hash-fn) +(declaim (inline ch-set-node-add-entry!)) +(defun ch-set-node-add-entry! (n idx val hash-fn) (declare (optimize (speed 3) (safety 0)) (type champ-bit-index idx) (type function hash-fn)) @@ -674,8 +681,8 @@ (defstruct (ch-set-node (incf (ch-set-node-size n)) (hash-mixf (ch-set-node-hash-value n) (hash-to-fixnum val hash-fn))) -(declaim (inline ch-set-node-add-subnode)) -(defun ch-set-node-add-subnode (n idx subnode hash-fn) +(declaim (inline ch-set-node-add-subnode!)) +(defun ch-set-node-add-subnode! (n idx subnode hash-fn) (declare (optimize (speed 3) (safety 0)) (type champ-bit-index idx) (type function hash-fn)) @@ -684,7 +691,7 @@ (defstruct (ch-set-node (= 1 (logcount (ch-set-node-entry-mask subnode))) (= 0 (ch-set-node-subnode-mask subnode))) ;; `subnode' contains only an entry -- pull it up. - (ch-set-node-add-entry n idx (svref subnode ch-set-node-header-size) hash-fn) + (ch-set-node-add-entry! n idx (svref subnode ch-set-node-header-size) hash-fn) (progn (when (and (not (consp subnode)) (= 0 (ch-set-node-entry-mask subnode)) @@ -700,7 +707,7 @@ (defstruct (ch-set-node (hash-mixf (ch-set-node-hash-value n) (ch-set-tree-hash-value subnode)))))) (defun ch-set-tree-union (tree1 tree2 hash-fn compare-fn) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 1) (safety 0)) (type function hash-fn compare-fn)) (rlabels (rec tree1 tree2 0) (rec (tree1 tree2 depth) @@ -723,12 +730,32 @@ (defstruct (ch-set-node (vector 0 (ash 1 bits1) size chash (rec tree1 tree2 (1+ depth))) (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size chash subnode1 subnode0))))))) - ((consp tree1) - (do-wb-set-tree-members (x (cdr tree1)) - (setq tree2 (ch-set-tree-with tree2 x hash-fn compare-fn depth))) - tree2) - ((consp tree2) - (rec tree2 tree1 depth)) + ((or (consp tree1) (consp tree2)) + ;; Left preference: we prefer values from `tree1' when they're equal. + ;; This took even more code, and was even more of a PITA, than I expected. + (let ((tree1-collision? (consp tree1)) + ((norm-node coll-node (swap-if tree1-collision? tree1 tree2)) + ((hash-bits (champ-hash-bits (the fixnum (car coll-node)) depth)) + (entry-mask (ch-set-node-entry-mask norm-node)) + (subnode-mask (ch-set-node-subnode-mask norm-node))))) + (declare (type simple-vector norm-node)) + (cond ((logbitp hash-bits entry-mask) + (let ((ientry (1-bits-below hash-bits entry-mask)) + (isubnode (1-bits-below hash-bits subnode-mask)) + ((value (ch-set-node-entry norm-node ientry)) + ((new-subnode + (ch-set-tree-with coll-node value hash-fn compare-fn (1+ depth) + (not tree1-collision?)))))) + (ch-set-node-change-entry-to-subnode norm-node ientry isubnode hash-bits new-subnode hash-fn))) + ((logbitp hash-bits subnode-mask) + (let ((isubnode (1-bits-below hash-bits subnode-mask)) + ((old-subnode (ch-set-node-subnode norm-node isubnode)))) + (ch-set-node-replace-subnode norm-node isubnode + (if tree1-collision? (rec coll-node old-subnode (1+ depth)) + (rec old-subnode coll-node (1+ depth)))))) + (t + (ch-set-node-insert-subnode norm-node (1-bits-below hash-bits subnode-mask) hash-bits + coll-node))))) (t (let ((entries1 (ch-set-node-entry-mask tree1)) (entries2 (ch-set-node-entry-mask tree2)) @@ -747,11 +774,11 @@ (defstruct (ch-set-node (isubnode2 0)) (declare (fixnum ientry1 isubnode1 ientry2 isubnode2)) (flet ((add-entry (idx val) - (ch-set-node-add-entry res-n idx val hash-fn)) + (ch-set-node-add-entry! res-n idx val hash-fn)) (add-subnode (idx subnode) - (ch-set-node-add-subnode res-n idx subnode hash-fn)) - (subtree-with (tree value) - (ch-set-tree-with tree value hash-fn compare-fn (1+ depth)))) + (ch-set-node-add-subnode! res-n idx subnode hash-fn)) + (subtree-with (tree value &optional replace?) + (ch-set-tree-with tree value hash-fn compare-fn (1+ depth) replace?))) (do-bit-indices (idx (logior all-entries all-subnodes)) (cond ((and (logbitp idx entries1) (logbitp idx entries2)) (let ((val1 (ch-set-node-entry tree1 (postincf ientry1))) @@ -763,7 +790,8 @@ (defstruct (ch-set-node (let ((val (ch-set-node-entry tree1 (postincf ientry1)))) (if (logbitp idx subnodes2) (let ((subnode (ch-set-node-subnode tree2 (postincf isubnode2)))) - (add-subnode idx (subtree-with subnode val))) + ;; Must replace for left preference. + (add-subnode idx (subtree-with subnode val t))) (add-entry idx val)))) ((logbitp idx entries2) (let ((val (ch-set-node-entry tree2 (postincf ientry2)))) @@ -801,7 +829,24 @@ (defstruct (ch-set-node (setq result (ch-set-tree-with result x hash-fn compare-fn depth)))) result))) ((consp tree2) - (rec tree2 tree1 depth)) + (let ((hash-bits (champ-hash-bits (the fixnum (car tree2)) depth)) + (entry-mask (ch-set-node-entry-mask tree1)) + (subnode-mask (ch-set-node-subnode-mask tree1))) + (cond ((logbitp hash-bits entry-mask) + (let ((ientry (1-bits-below hash-bits entry-mask)) + ((value (ch-set-node-entry tree1 ientry)))) + (and (wb-set-tree-contains? (cdr tree2) value compare-fn) + (ch-set-tree-with nil value hash-fn compare-fn depth)))) + ((logbitp hash-bits subnode-mask) + (let ((isubnode (1-bits-below hash-bits subnode-mask)) + ((old-subnode (ch-set-node-subnode tree1 isubnode))) + (result nil)) + (do-wb-set-tree-members (x (cdr tree2)) + (let ((v1? v1 (ch-set-tree-contains? old-subnode x hash-fn compare-fn (1+ depth)))) + (when v1? + (setq result (ch-set-tree-with result v1 hash-fn compare-fn depth))))) + result)) + (t nil)))) (t (let ((entries1 (ch-set-node-entry-mask tree1)) (entries2 (ch-set-node-entry-mask tree2)) @@ -812,9 +857,9 @@ (defstruct (ch-set-node ((res-len (min (length tree1) (length tree2))) ((res-n (make-array res-len :initial-element 0))))) (flet ((add-entry (idx val) - (ch-set-node-add-entry res-n idx val hash-fn)) + (ch-set-node-add-entry! res-n idx val hash-fn)) (add-subnode (idx subnode) - (ch-set-node-add-subnode res-n idx subnode hash-fn)) + (ch-set-node-add-subnode! res-n idx subnode hash-fn)) (subtree-contains? (tree val) (ch-set-tree-contains? tree val hash-fn compare-fn (1+ depth)))) (do-bit-indices (idx (logior (logand entries1 entries2) (logand subnodes1 subnodes2) @@ -827,13 +872,15 @@ (defstruct (ch-set-node (when (equal?-cmp val1 val2 compare-fn) (add-entry idx val1)))) ((and (logbitp idx entries1) (logbitp idx subnodes2)) - (let ((val (ch-set-node-entry tree1 (1-bits-below idx entries1)))) - (when (subtree-contains? (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)) val) - (add-entry idx val)))) + (let ((val1 (ch-set-node-entry tree1 (1-bits-below idx entries1)))) + (when (subtree-contains? (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)) val1) + (add-entry idx val1)))) ((and (logbitp idx subnodes1) (logbitp idx entries2)) - (let ((val (ch-set-node-entry tree2 (1-bits-below idx entries2)))) - (when (subtree-contains? (ch-set-node-subnode tree1 (1-bits-below idx subnodes1)) val) - (add-entry idx val)))) + (let ((val2 (ch-set-node-entry tree2 (1-bits-below idx entries2))) + ((val1? val1 (subtree-contains? (ch-set-node-subnode tree1 (1-bits-below idx subnodes1)) + val2)))) + (when val1? + (add-entry idx val1)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) (add-subnode idx (rec (ch-set-node-subnode tree1 (1-bits-below idx subnodes1)) (ch-set-node-subnode tree2 (1-bits-below idx subnodes2)) @@ -873,9 +920,9 @@ (defstruct (ch-set-node ((res-len (length (the simple-vector tree1))) ; upper bound ((res-n (make-array res-len :initial-element 0))))) (flet ((add-entry (idx val) - (ch-set-node-add-entry res-n idx val hash-fn)) + (ch-set-node-add-entry! res-n idx val hash-fn)) (add-subnode (idx subnode) - (ch-set-node-add-subnode res-n idx subnode hash-fn)) + (ch-set-node-add-subnode! res-n idx subnode hash-fn)) (subtree-less (subtree val) (ch-set-tree-less subtree val hash-fn compare-fn (1+ depth))) (subtree-contains? (subtree val) @@ -944,9 +991,9 @@ (defstruct (ch-set-node (isubnode2 0)) (declare (fixnum ientry1 isubnode1 ientry2 isubnode2)) (flet ((add-entry (n idx val) - (ch-set-node-add-entry n idx val hash-fn)) + (ch-set-node-add-entry! n idx val hash-fn)) (add-subnode (n idx subnode) - (ch-set-node-add-subnode n idx subnode hash-fn)) + (ch-set-node-add-subnode! n idx subnode hash-fn)) (subtree-less (subtree val) (ch-set-tree-less subtree val hash-fn compare-fn (1+ depth))) (subtree-contains? (subtree val) @@ -994,6 +1041,53 @@ (defstruct (ch-set-node (1 (vector (ash 1 (champ-hash-bits hash depth)) 0 1 hash (wb-set-tree-arb wb-set-tree))) (t (cons hash wb-set-tree)))) +(defun ch-set-node-replace-subnode (node isubnode new-subnode) + "Returns a new node with `new-subnode' replacing the subnode at `isubnode'." + (declare (optimize (speed 3) (safety 0)) + (type simple-vector node) + (type champ-subnode-index isubnode)) + (let ((old-subnode (ch-set-node-subnode node isubnode)) + (n (vector-update node (- (length node) isubnode 1) new-subnode))) + (declare (type simple-vector n)) + (setf (svref n (- (length n) isubnode 1)) new-subnode) + (incf (ch-set-node-size n) (- (ch-set-tree-size new-subnode) (ch-set-tree-size old-subnode))) + (hash-mixf (ch-set-node-hash-value n) + (hash-unmix (ch-set-tree-hash-value new-subnode) + (ch-set-tree-hash-value old-subnode))) + n)) + +(defun ch-set-node-insert-subnode (node isubnode hash-bits new-subnode) + "Returns a new node with `new-subnode' inserted just before `isubnode'." + (declare (optimize (speed 3) (safety 0)) + (type simple-vector node) + (type champ-bit-index hash-bits) + (type champ-subnode-index isubnode)) + (let ((n (vector-insert node (- (length node) isubnode) new-subnode))) + (logiorf (ch-set-node-subnode-mask n) (ash 1 hash-bits)) + (incf (ch-set-node-size n) (ch-set-tree-size new-subnode)) + (hash-mixf (ch-set-node-hash-value n) (ch-set-tree-hash-value new-subnode)) + n)) + +(defun ch-set-node-change-entry-to-subnode (node ientry isubnode hash-bits new-subnode hash-fn) + "Returns a new node with entry `ientry' removed, and `new-subnode' inserted just +before `isubnode'." + (declare (optimize (speed 3) (safety 0)) + (type simple-vector node) + (type champ-bit-index hash-bits) + (type champ-entry-index ientry) + (type champ-subnode-index isubnode) + (type function hash-fn)) + (let ((value (ch-set-node-entry node ientry)) + (n (vector-rem-1-ins-1 node (+ ch-set-node-header-size ientry) + (- (length node) isubnode) new-subnode))) + (logandc2f (ch-set-node-entry-mask n) (ash 1 hash-bits)) + (logiorf (ch-set-node-subnode-mask n) (ash 1 hash-bits)) + (incf (ch-set-node-size n) (1- (ch-set-tree-size new-subnode))) + (hash-mixf (ch-set-node-hash-value n) + (hash-unmix (ch-set-tree-hash-value new-subnode) + (hash-to-fixnum value hash-fn))) + n)) + (defun ch-set-compact-node (n) (declare (optimize (speed 3) (safety 0))) (let ((entries (ch-set-node-entry-mask n)) @@ -1102,6 +1196,7 @@ (defstruct (ch-set-node ;;; Verifier (defun ch-set-tree-verify (tree hash-fn) + (declare (optimize (debug 3))) (or (null tree) (rlabels (rec tree 0 0) (rec (node depth partial-hash) @@ -1216,29 +1311,29 @@ (defstruct (ch-map-node (type champ-subnode-index isubnode)) (svref node (- (length node) isubnode 1))) -(defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn &optional (depth 0)) +(defun ch-map-tree-with (tree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn &optional (depth 0) replace?) (declare (optimize (speed 3) (safety 0)) (type function key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (type (integer 0 64) depth)) (let ((key-hash (hash-to-fixnum key key-hash-fn))) (declare (fixnum key-hash)) (rlabels (rec tree (ash key-hash (- (* champ-hash-bits-per-level depth))) depth) - (rec (node hash-shifted depth &optional node-hash) + (rec (node hash-shifted depth) (declare (fixnum hash-shifted) - (type (integer 0 64) depth) - (type (or null fixnum) node-hash)) + (type (integer 0 64) depth)) (let ((hash-bits (logand hash-shifted champ-hash-level-mask))) (if (null node) (vector (ash 1 hash-bits) 0 1 key-hash nil key value) (if (consp node) ;; Collision node. - (let ((node-hash (or node-hash (hash-to-fixnum (wb-map-tree-arb-pair (cdr node)) key-hash-fn))) - ((wb-hash-shifted (ash node-hash (* (- champ-hash-bits-per-level) depth)))) + (let ((wb-hash-shifted (ash (the fixnum (caar node)) (* (- champ-hash-bits-per-level) depth))) (size (1+ (wb-map-tree-size (cdr node))))) - (declare (fixnum wb-hash-shifted hash-shifted size)) + (declare (fixnum wb-hash-shifted size)) (if (= hash-shifted wb-hash-shifted) ;; Update the collision node. - (let ((new-wb-tree (wb-map-tree-with (cdr node) key value key-cmp-fn val-cmp-fn))) + (let ((new-wb-tree (wb-map-tree-with (if replace? (wb-map-tree-less (cdr node) key key-cmp-fn) + (cdr node)) + key value key-cmp-fn val-cmp-fn))) (if (eq new-wb-tree (cdr node)) node (let ((value-hash (and (cdar node) @@ -1259,7 +1354,7 @@ (defstruct (ch-map-node (value-hash (and (cdar node) (hash-mix (cdar node) (hash-to-fixnum value val-hash-fn))))) (if (= hash-bits wb-hash-bits) (vector 0 (ash 1 hash-bits) size key-hash value-hash - (rec node (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth) node-hash)) + (rec node (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth))) (vector (ash 1 hash-bits) (ash 1 wb-hash-bits) size key-hash value-hash key value node))))) ;; Normal case. @@ -1273,9 +1368,12 @@ (defstruct (ch-map-node (ex-val (svref node (1+ entry-idx)))) (if (equal?-cmp key ex-key key-cmp-fn) (if (equal?-cmp value ex-val val-cmp-fn) - node ; Key found, value equal: nothing to do + ;; Key found, value equal: nothing to do (unless `replace?' requested) + (if (and replace? (not (and (eq key ex-key) (eq value ex-val)))) + (vector-update-2 node entry-idx key value) + node) ;; Key found, value differs: just update value - (let ((n (vector-update node (+ entry-idx 1) value))) + (let ((n (vector-update-2 node entry-idx key value))) (when (ch-map-node-value-hash n) (hash-mixf (ch-map-node-value-hash n) (hash-unmix (hash-to-fixnum value val-hash-fn) (hash-to-fixnum ex-val val-hash-fn)))) @@ -1319,8 +1417,8 @@ (defstruct (ch-map-node (let ((n (vector-update node subnode-idx new-subnode))) ;; If only a value was updated, the subnode won't have changed size. (setf (ch-map-node-size n) - (the fixnum (+ (ch-map-node-size n) (- (the fixnum (ch-map-tree-size new-subnode)) - (the fixnum (ch-map-tree-size subnode)))))) + (the fixnum (+ (ch-map-node-size n) (- (ch-map-tree-size new-subnode) + (ch-map-tree-size subnode))))) (hash-mixf (ch-map-node-key-hash n) (hash-unmix (ch-map-tree-key-hash new-subnode) (ch-map-tree-key-hash subnode))) (when (ch-map-node-value-hash n) @@ -1371,6 +1469,14 @@ (defstruct (ch-map-node (setf (svref v (+ idx i 2)) (svref vec (+ idx i)))) v)) +(defun vector-update-2 (vec idx val-0 val-1) + (declare (optimize (speed 3) (safety 0)) + (simple-vector vec) + (fixnum idx)) + (let ((v (vector-update vec idx val-0))) + (setf (svref v (1+ idx)) val-1) + v)) + (defun ch-map-tree-hash-value (tree val-hash-fn) (hash-mix (ch-map-tree-key-hash tree) (ch-map-tree-value-hash tree val-hash-fn))) @@ -1458,7 +1564,7 @@ (defstruct (ch-map-node (assert (= depth 0)) (values nil (svref node (1+ entry-idx)))) (t - (let ((n (vector-remove-2-at node entry-idx))) + (let ((n (vector-remove-2 node entry-idx))) (logandc2f (ch-map-node-entry-mask n) (ash 1 hash-bits)) (decf (ch-map-node-size n)) (hash-unmixf (ch-map-node-key-hash n) key-hash) @@ -1470,12 +1576,12 @@ (defstruct (ch-map-node ((subnode-idx (- (the fixnum (length node)) 1 subnode-raw-idx)))) (declare (fixnum subnode-raw-idx subnode-idx)) (if (not (logbitp hash-bits subnode-mask)) - (values node 0) + (values node nil) (let ((subnode (svref node subnode-idx))) (let ((new-subnode lookup-val (rec subnode (ash hash-shifted (- champ-hash-bits-per-level)) (1+ depth)))) (if (eq new-subnode subnode) - (values node 0) + (values node nil) (let ((n (cond ((consp new-subnode) (vector-update node subnode-idx new-subnode)) ((and (= 1 (logcount (ch-map-node-entry-mask new-subnode))) @@ -1484,16 +1590,14 @@ (defstruct (ch-map-node (let ((new-entry-idx (+ ch-map-node-header-size (* 2 (1-bits-below hash-bits entry-mask)))) - ((n (vector-ins-2-rem-1 - node new-entry-idx (svref new-subnode ch-map-node-header-size) - (svref new-subnode (1+ ch-map-node-header-size)) - subnode-idx)))) + (k v (ch-map-node-entry new-subnode 0)) + ((n (vector-ins-2-rem-1 node new-entry-idx k v subnode-idx)))) (logiorf (ch-map-node-entry-mask n) (ash 1 hash-bits)) (logandc2f (ch-map-node-subnode-mask n) (ash 1 hash-bits)) n)) ((and (= 0 (ch-map-node-entry-mask new-subnode)) (= 1 (logcount (ch-map-node-subnode-mask new-subnode))) - (consp (svref new-subnode ch-map-node-header-size))) + (consp (ch-map-node-subnode new-subnode 0))) ;; New subnode contains only a collision node: pull it up into this node (vector-update node subnode-idx (svref new-subnode ch-map-node-header-size))) @@ -1507,7 +1611,7 @@ (defstruct (ch-map-node (ch-map-tree-value-hash subnode val-hash-fn)))) (values n lookup-val))))))))))))))) -(defun vector-remove-2-at (vec idx) +(defun vector-remove-2 (vec idx) (declare (optimize (speed 3) (safety 0)) (simple-vector vec) (fixnum idx)) @@ -1559,7 +1663,7 @@ (defstruct (ch-map-node (* 2 (1-bits-below hash-bits entry-mask)))) ((ex-key (svref node entry-idx)))) (and (equal?-cmp ex-key key key-cmp-fn) - (values t (svref node (1+ entry-idx))))) + (values t (svref node (1+ entry-idx)) (svref node entry-idx)))) (let ((subnode-mask (ch-map-node-subnode-mask node))) (and (logbitp hash-bits subnode-mask) (let ((subnode-idx (- (the fixnum (length node)) @@ -1893,8 +1997,8 @@ (defstruct (ch-map-node ;;; -------------------------------- ;;; Union, intersection, set-difference, subset?, disjoint? -(declaim (inline ch-map-node-add-entry)) -(defun ch-map-node-add-entry (n idx key val key-hash-fn) +(declaim (inline ch-map-node-add-entry!)) +(defun ch-map-node-add-entry! (n idx key val key-hash-fn) (declare (optimize (speed 3) (safety 0)) (type champ-bit-index idx) (type function key-hash-fn)) @@ -1905,8 +2009,8 @@ (defstruct (ch-map-node (incf (ch-map-node-size n)) (hash-mixf (ch-map-node-key-hash n) (hash-to-fixnum key key-hash-fn))) -(declaim (inline ch-map-node-add-subnode)) -(defun ch-map-node-add-subnode (n idx subnode key-hash-fn) +(declaim (inline ch-map-node-add-subnode!)) +(defun ch-map-node-add-subnode! (n idx subnode key-hash-fn) (declare (optimize (speed 3) (safety 0)) (type champ-bit-index idx) (type function key-hash-fn)) @@ -1915,7 +2019,7 @@ (defstruct (ch-map-node (= 1 (logcount (ch-map-node-entry-mask subnode))) (= 0 (ch-map-node-subnode-mask subnode))) ;; `subnode' contains only an entry -- pull it up. - (ch-map-node-add-entry n idx (svref subnode ch-map-node-header-size) + (ch-map-node-add-entry! n idx (svref subnode ch-map-node-header-size) (svref subnode (1+ ch-map-node-header-size)) key-hash-fn) (progn (when (and (not (consp subnode)) @@ -1932,10 +2036,10 @@ (defstruct (ch-map-node (hash-mixf (ch-map-node-key-hash n) (ch-map-tree-key-hash subnode)))))) (defun ch-map-tree-union (tree1 tree2 val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 1) (safety 0)) (type function val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) - (rlabels (rec tree1 tree2 val-fn 0) - (rec (tree1 tree2 val-fn depth) + (rlabels (rec tree1 tree2 0) + (rec (tree1 tree2 depth) (declare (type (integer 0 64) depth) (type function val-fn)) (cond ((null tree1) tree2) @@ -1943,7 +2047,7 @@ (defstruct (ch-map-node ((eq tree1 tree2) tree1) ((and (consp tree1) (consp tree2)) (if (= (the fixnum (caar tree1)) (the fixnum (caar tree2))) - (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) + (let ((result (wb-map-tree-union (cdr tree1) (cdr tree2) val-fn key-cmp-fn val-cmp-fn))) (ch-map-node-from-wb result (caar tree1) depth)) (let ((bits1 (champ-hash-bits (the fixnum (caar tree1)) depth)) (bits2 (champ-hash-bits (the fixnum (caar tree2)) depth)) @@ -1951,22 +2055,46 @@ (defstruct (ch-map-node (key-hash (hash-mix (caar tree1) (caar tree2)))) (declare (fixnum size)) (if (= bits1 bits2) - (vector 0 (ash 1 bits1) size key-hash nil (rec tree1 tree2 val-fn (1+ depth))) + (vector 0 (ash 1 bits1) size key-hash nil (rec tree1 tree2 (1+ depth))) (let ((subnode0 subnode1 (swap-if (> bits1 bits2) tree1 tree2))) (vector 0 (logior (ash 1 bits1) (ash 1 bits2)) size key-hash nil subnode1 subnode0)))))) - ((consp tree1) - (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) - (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) - (if v2? - (let ((new-v second-val (funcall val-fn v1 v2))) - (if (eq second-val ':no-value) - (setq tree2 (ch-map-tree-less tree2 k1 key-hash-fn key-cmp-fn val-hash-fn depth)) - (setq tree2 (ch-map-tree-with tree2 k1 new-v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn - depth)))) - (setq tree2 (ch-map-tree-with tree2 k1 v1 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn depth))))) - tree2) - ((consp tree2) - (rec tree2 tree1 (fn (x y) (funcall val-fn y x)) depth)) + ((or (consp tree1) (consp tree2)) + ;; I foolishly undertook to implement left preference and make this case more efficient at + ;; the same time. Turned out to take a crapload of code (and my time), for a not-very-common + ;; case. Sometimes maximum performance is not worth the complication. + (let ((tree1-collision? (consp tree1)) + ((norm-node coll-node (swap-if tree1-collision? tree1 tree2)) + ((hash-bits (champ-hash-bits (the fixnum (caar coll-node)) depth)) + (entry-mask (ch-map-node-entry-mask norm-node)) + (subnode-mask (ch-map-node-subnode-mask norm-node))))) + (declare (type simple-vector norm-node)) + (cond ((logbitp hash-bits entry-mask) + (let ((ientry (1-bits-below hash-bits entry-mask)) + ((norm-key norm-val (ch-map-node-entry norm-node ientry)) + ((coll-val? coll-val coll-key (wb-map-tree-lookup (cdr coll-node) norm-key key-cmp-fn)) + ((new-subnode + (if coll-val? + (let ((new-val second-val + (if tree1-collision? (compute-new-val coll-val norm-val) + (compute-new-val norm-val coll-val)))) + (if (eq second-val ':no-value) + (ch-map-tree-less coll-node norm-key key-hash-fn key-cmp-fn val-hash-fn + (1+ depth)) + (ch-map-tree-with coll-node (if tree1-collision? coll-key norm-key) + new-val key-hash-fn key-cmp-fn val-hash-fn + val-cmp-fn (1+ depth) (not tree1-collision?)))) + (ch-map-tree-with coll-node norm-key norm-val key-hash-fn key-cmp-fn val-hash-fn + val-cmp-fn (1+ depth) (not tree1-collision?)))))))) + (ch-map-node-change-entry-to-subnode norm-node hash-bits new-subnode key-hash-fn val-hash-fn))) + ((logbitp hash-bits subnode-mask) + (let ((isubnode (1-bits-below hash-bits subnode-mask)) + ((old-subnode (ch-map-node-subnode norm-node isubnode)))) + (ch-map-node-replace-subnode norm-node hash-bits + (if tree1-collision? (rec coll-node old-subnode (1+ depth)) + (rec old-subnode coll-node (1+ depth))) + key-hash-fn val-hash-fn))) + (t + (ch-map-node-insert-subnode norm-node hash-bits coll-node val-hash-fn))))) (t (let ((entries1 (ch-map-node-entry-mask tree1)) (entries2 (ch-map-node-entry-mask tree2)) @@ -1986,15 +2114,15 @@ (defstruct (ch-map-node (declare (fixnum ientry1 isubnode1 ientry2 isubnode2)) (setf (ch-map-node-value-hash res-n) nil) (flet ((add-entry (idx key val) - (ch-map-node-add-entry res-n idx key val key-hash-fn)) + (ch-map-node-add-entry! res-n idx key val key-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn) + (ch-map-node-add-subnode! res-n idx subnode key-hash-fn) nil) ; hush, SBCL (subtree-lookup (tree key) (ch-map-tree-lookup tree key key-hash-fn key-cmp-fn (1+ depth))) - (subtree-with (subtree key value) + (subtree-with (subtree key value &optional replace?) (ch-map-tree-with subtree key value key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn - (1+ depth))) + (1+ depth) replace?)) (subtree-less (subtree key) (ch-map-tree-less subtree key key-hash-fn key-cmp-fn val-hash-fn (1+ depth)))) (do-bit-indices (idx everything) @@ -2002,7 +2130,7 @@ (defstruct (ch-map-node (let ((key1 val1 (ch-map-node-entry tree1 (postincf ientry1))) (key2 val2 (ch-map-node-entry tree2 (postincf ientry2)))) (if (equal?-cmp key1 key2 key-cmp-fn) - (let ((new-val second-val (funcall val-fn val1 val2))) + (let ((new-val second-val (compute-new-val val1 val2))) (unless (eq second-val ':no-value) (add-entry idx key1 new-val))) (add-subnode idx (subtree-with (subtree-with nil key1 val1) key2 val2))))) @@ -2012,61 +2140,89 @@ (defstruct (ch-map-node (let ((subnode2 (ch-map-node-subnode tree2 (postincf isubnode2))) ((val2? val2 (subtree-lookup subnode2 key1)))) (if val2? - (let ((new-val second-val (funcall val-fn val1 val2))) + (let ((new-val second-val (compute-new-val val1 val2))) (if (eq second-val ':no-value) (add-subnode idx (subtree-less subnode2 key1)) - (add-subnode idx (subtree-with subnode2 key1 new-val)))) - (add-subnode idx (subtree-with subnode2 key1 val1)))) + (add-subnode idx (subtree-with subnode2 key1 new-val t)))) + (add-subnode idx (subtree-with subnode2 key1 val1 t)))) (add-entry idx key1 val1)))) ((logbitp idx entries2) (let ((key2 val2 (ch-map-node-entry tree2 (postincf ientry2)))) (if (logbitp idx subnodes1) (let ((subnode1 (ch-map-node-subnode tree1 (postincf isubnode1))) - ((val1? val1 (subtree-lookup subnode1 key2)))) + ((val1? val1 key1 (subtree-lookup subnode1 key2)))) (if val1? - (let ((new-val second-val (funcall val-fn val1 val2))) + (let ((new-val second-val (compute-new-val val1 val2))) (if (eq second-val ':no-value) (add-subnode idx (subtree-less subnode1 key2)) - (add-subnode idx (subtree-with subnode1 key2 new-val)))) + (add-subnode idx (subtree-with subnode1 key1 new-val t)))) (add-subnode idx (subtree-with subnode1 key2 val2)))) (add-entry idx key2 val2)))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) (add-subnode idx (rec (ch-map-node-subnode tree1 (postincf isubnode1)) (ch-map-node-subnode tree2 (postincf isubnode2)) - val-fn (1+ depth)))) + (1+ depth)))) ((logbitp idx subnodes1) (add-subnode idx (ch-map-node-subnode tree1 (postincf isubnode1)))) ((logbitp idx subnodes2) (add-subnode idx (ch-map-node-subnode tree2 (postincf isubnode2)))) (t (error "Bug in 'ch-map-tree-union'"))))) ;; When two entries meet and become a subnode, we no longer need the value slot. - (ch-map-compact-node res-n))))))) + (ch-map-compact-node res-n))))) + (compute-new-val (val1 val2) + (if (equal?-cmp val1 val2 val-cmp-fn) + val1 + (funcall val-fn val1 val2))))) (defun ch-map-tree-intersection (tree1 tree2 val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (declare (optimize (speed 3) (safety 0)) (type function val-fn key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn)) - (rlabels (rec tree1 tree2 val-fn 0) - (rec (tree1 tree2 val-fn depth) + (rlabels (rec tree1 tree2 0) + (rec (tree1 tree2 depth) (declare (type (integer 0 64) depth) (type function val-fn)) (cond ((or (null tree1) (null tree2)) nil) ((eq tree1 tree2) tree1) - ((and (consp tree1) (consp tree2)) - (and (= (the fixnum (caar tree1)) (the fixnum (caar tree2))) - (let ((result (wb-map-tree-intersect (cdr tree1) (cdr tree2) val-fn key-cmp-fn))) - (ch-map-node-from-wb result (caar tree1) depth)))) ((consp tree1) - (let ((result nil)) - (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) - (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) - (when v2? - (let ((new-v second-val (funcall val-fn v1 v2))) - (unless (eq second-val ':no-value) - (setq result (ch-map-tree-with result k1 new-v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn - depth))))))) - result)) + (if (consp tree2) + (and (= (the fixnum (caar tree1)) (the fixnum (caar tree2))) + (let ((result (wb-map-tree-intersect (cdr tree1) (cdr tree2) val-fn key-cmp-fn val-cmp-fn))) + (ch-map-node-from-wb result (caar tree1) depth))) + (let ((result nil)) + (do-wb-map-tree-pairs (k1 v1 (cdr tree1)) + (let ((v2? v2 (ch-map-tree-lookup tree2 k1 key-hash-fn key-cmp-fn depth))) + (when v2? + (let ((new-v second-val (compute-new-val v1 v2))) + (unless (eq second-val ':no-value) + (setq result (ch-map-tree-with result k1 new-v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn + depth))))))) + result))) ((consp tree2) - (rec tree2 tree1 (fn (x y) (funcall val-fn y x)) depth)) + (let ((hash-bits (champ-hash-bits (the fixnum (caar tree2)) depth)) + (entry-mask (ch-map-node-entry-mask tree1)) + (subnode-mask (ch-map-node-subnode-mask tree1))) + (cond ((logbitp hash-bits entry-mask) + (let ((ientry (1-bits-below hash-bits entry-mask)) + ((k1 v1 (ch-map-node-entry tree1 ientry)) + ((v2? v2 (wb-map-tree-lookup (cdr tree2) k1 key-cmp-fn))))) + (and v2? + (let ((new-v second-val (compute-new-val v1 v2))) + (and (not (eq second-val ':no-value)) + (ch-map-tree-with nil k1 new-v key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn + depth)))))) + ((logbitp hash-bits subnode-mask) + (let ((isubnode (1-bits-below hash-bits subnode-mask)) + ((old-subnode (ch-map-node-subnode tree1 isubnode))) + (result nil)) + (do-wb-map-tree-pairs (k2 v2 (cdr tree2)) + (let ((v1? v1 k1 (ch-map-tree-lookup old-subnode k2 key-hash-fn key-cmp-fn (1+ depth)))) + (when v1? + (let ((new-v second-val (compute-new-val v1 v2))) + (unless (eq second-val ':no-value) + (setq result (ch-map-tree-with result k1 new-v key-hash-fn key-cmp-fn + val-hash-fn val-cmp-fn depth))))))) + result)) + (t nil)))) (t (let ((entries1 (ch-map-node-entry-mask tree1)) (entries2 (ch-map-node-entry-mask tree2)) @@ -2079,9 +2235,9 @@ (defstruct (ch-map-node ((res-n (make-array res-len :initial-element 0)))))) (setf (ch-map-node-value-hash res-n) nil) (flet ((add-entry (idx key val) - (ch-map-node-add-entry res-n idx key val key-hash-fn)) + (ch-map-node-add-entry! res-n idx key val key-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn)) + (ch-map-node-add-subnode! res-n idx subnode key-hash-fn)) (subtree-lookup (tree key) (ch-map-tree-lookup tree key key-hash-fn key-cmp-fn (1+ depth)))) (do-bit-indices (idx combined-mask) @@ -2089,7 +2245,7 @@ (defstruct (ch-map-node (let ((key1 val1 (ch-map-node-entry tree1 (1-bits-below idx entries1))) (key2 val2 (ch-map-node-entry tree2 (1-bits-below idx entries2)))) (when (equal?-cmp key1 key2 key-cmp-fn) - (let ((new-val second-val (funcall val-fn val1 val2))) + (let ((new-val second-val (compute-new-val val1 val2))) (unless (eq second-val ':no-value) (add-entry idx key1 new-val)))))) ((and (logbitp idx entries1) (logbitp idx subnodes2)) @@ -2097,22 +2253,26 @@ (defstruct (ch-map-node (subnode2 (ch-map-node-subnode tree2 (1-bits-below idx subnodes2))) ((val2? val2 (subtree-lookup subnode2 key1)))) (when val2? - (let ((new-val second-val (funcall val-fn val1 val2))) + (let ((new-val second-val (compute-new-val val1 val2))) (unless (eq second-val ':no-value) (add-entry idx key1 new-val)))))) ((and (logbitp idx subnodes1) (logbitp idx entries2)) (let ((key2 val2 (ch-map-node-entry tree2 (1-bits-below idx entries2))) (subnode1 (ch-map-node-subnode tree1 (1-bits-below idx subnodes1))) - ((val1? val1 (subtree-lookup subnode1 key2)))) + ((val1? val1 key1 (subtree-lookup subnode1 key2)))) (when val1? - (let ((new-val second-val (funcall val-fn val1 val2))) + (let ((new-val second-val (compute-new-val val1 val2))) (unless (eq second-val ':no-value) - (add-entry idx key2 new-val)))))) + (add-entry idx key1 new-val)))))) ((and (logbitp idx subnodes1) (logbitp idx subnodes2)) (add-subnode idx (rec (ch-map-node-subnode tree1 (1-bits-below idx subnodes1)) (ch-map-node-subnode tree2 (1-bits-below idx subnodes2)) - val-fn (1+ depth)))))) - (ch-map-compact-node res-n)))))))) + (1+ depth)))))) + (ch-map-compact-node res-n)))))) + (compute-new-val (val1 val2) + (if (equal?-cmp val1 val2 val-cmp-fn) + (values val1 nil) + (n-values 2 (funcall val-fn val1 val2)))))) (defun ch-map-tree-diff-2 (tree1 tree2 key-hash-fn key-cmp-fn val-hash-fn val-cmp-fn) (declare (optimize (speed 3) (safety 0)) @@ -2163,9 +2323,9 @@ (defstruct (ch-map-node (setf (ch-map-node-value-hash res-n1) nil) (setf (ch-map-node-value-hash res-n2) nil) (flet ((add-entry (n idx key val) - (ch-map-node-add-entry n idx key val key-hash-fn)) + (ch-map-node-add-entry! n idx key val key-hash-fn)) (add-subnode (n idx subnode) - (ch-map-node-add-subnode n idx subnode key-hash-fn)) + (ch-map-node-add-subnode! n idx subnode key-hash-fn)) (subtree-less (subtree key) (ch-map-tree-less subtree key key-hash-fn key-cmp-fn val-hash-fn (1+ depth))) (subtree-lookup (subtree key) @@ -2249,9 +2409,9 @@ (defstruct (ch-map-node ((res-n (make-array res-len :initial-element 0)))))) (setf (ch-map-node-value-hash res-n) nil) (flet ((add-entry (idx key val) - (ch-map-node-add-entry res-n idx key val key-hash-fn)) + (ch-map-node-add-entry! res-n idx key val key-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn)) + (ch-map-node-add-subnode! res-n idx subnode key-hash-fn)) (map-lookup (map-subtree key) (ch-map-tree-lookup map-subtree key key-hash-fn key-cmp-fn (1+ depth))) (set-contains? (set-subtree key) @@ -2313,9 +2473,9 @@ (defstruct (ch-map-node ((res-n (make-array res-len :initial-element 0))))) (setf (ch-map-node-value-hash res-n) nil) (flet ((add-entry (idx key val) - (ch-map-node-add-entry res-n idx key val key-hash-fn)) + (ch-map-node-add-entry! res-n idx key val key-hash-fn)) (add-subnode (idx subnode) - (ch-map-node-add-subnode res-n idx subnode key-hash-fn)) + (ch-map-node-add-subnode! res-n idx subnode key-hash-fn)) (map-subtree-less (subtree key) (ch-map-tree-less subtree key key-hash-fn key-cmp-fn val-hash-fn (1+ depth))) (set-contains? (set-subtree key) @@ -2352,6 +2512,109 @@ (defstruct (ch-map-node 0 1 key-hash nil k v))) (t (cons (cons key-hash nil) wb-map-tree)))) +(defun ch-map-node-replace-subnode (node hash-bits new-subnode key-hash-fn val-hash-fn) + "Returns a new node with `new-subnode' replacing the subnode at `isubnode'." + (declare (optimize (speed 3) (safety 0)) + (type simple-vector node) + (type champ-bit-index hash-bits) + (type function key-hash-fn val-hash-fn)) + (let ((isubnode (1-bits-below hash-bits (ch-map-node-subnode-mask node))) + ((old-subnode (ch-map-node-subnode node isubnode)))) + ;; Even when unioning, the `:no-value' feature can generate empty subnodes... + (cond ((null new-subnode) + (let ((n (vector-remove-n-at node (- (length node) isubnode 1) 1))) + (logandc2f (ch-map-node-subnode-mask n) (ash 1 hash-bits)) + (decf (ch-map-node-size n) (ch-map-tree-size old-subnode)) + (hash-unmixf (ch-map-node-key-hash n) (ch-map-tree-key-hash old-subnode)) + (when (ch-map-node-value-hash n) + (hash-unmixf (ch-map-node-value-hash n) (ch-map-tree-value-hash old-subnode val-hash-fn))) + n)) + ;; ... or single-entry ones. + ((and (not (consp new-subnode)) + (= 1 (logcount (ch-map-node-entry-mask new-subnode))) + (= 0 (ch-map-node-subnode-mask new-subnode))) + (let ((ientry (1-bits-below hash-bits (ch-map-node-entry-mask node))) + (key val (ch-map-node-entry new-subnode 0)) + ((n (vector-ins-2-rem-1 node (+ ch-map-node-header-size (* 2 ientry)) key val + (- (length node) isubnode 1))))) + (logiorf (ch-map-node-entry-mask n) (ash 1 hash-bits)) + (logandc2f (ch-map-node-subnode-mask n) (ash 1 hash-bits)) + (incf (ch-map-node-size n) (- 1 (ch-map-tree-size old-subnode))) + (hash-mixf (ch-map-node-key-hash n) + (hash-unmix (hash-to-fixnum key key-hash-fn) + (ch-map-tree-key-hash old-subnode))) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) + (hash-unmix (hash-to-fixnum val val-hash-fn) + (ch-map-tree-value-hash old-subnode val-hash-fn)))) + n)) + (t + (let ((n (vector-update node (- (length node) isubnode 1) new-subnode))) + (declare (type simple-vector n)) + (setf (svref n (- (length n) isubnode 1)) new-subnode) + (incf (ch-map-node-size n) (- (ch-map-tree-size new-subnode) (ch-map-tree-size old-subnode))) + (hash-mixf (ch-map-node-key-hash n) + (hash-unmix (ch-map-tree-key-hash new-subnode) + (ch-map-tree-key-hash old-subnode))) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) + (hash-unmix (ch-map-tree-value-hash new-subnode val-hash-fn) + (ch-map-tree-value-hash old-subnode val-hash-fn)))) + n))))) + +(defun ch-map-node-insert-subnode (node hash-bits new-subnode val-hash-fn) + "Returns a new node with `new-subnode' inserted just before `isubnode'." + (declare (optimize (speed 3) (safety 0)) + (type simple-vector node) + (type champ-bit-index hash-bits)) + (let ((isubnode (1-bits-below hash-bits (ch-map-node-subnode-mask node))) + ((n (vector-insert node (- (length node) isubnode) new-subnode)))) + (logiorf (ch-map-node-subnode-mask n) (ash 1 hash-bits)) + (incf (ch-map-node-size n) (ch-map-tree-size new-subnode)) + (hash-mixf (ch-map-node-key-hash n) (ch-map-tree-key-hash new-subnode)) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) + (ch-map-tree-value-hash new-subnode val-hash-fn))) + n)) + +(defun ch-map-node-change-entry-to-subnode (node hash-bits new-subnode key-hash-fn val-hash-fn) + "Returns a new node with entry `ientry' removed, and `new-subnode' inserted just +before `isubnode'." + (declare (optimize (speed 3) (safety 0)) + (type simple-vector node) + (type champ-bit-index hash-bits) + (type function key-hash-fn val-hash-fn)) + (let ((ientry (1-bits-below hash-bits (ch-map-node-entry-mask node))) + (isubnode (1-bits-below hash-bits (ch-map-node-subnode-mask node))) + ((old-key old-val (ch-map-node-entry node ientry)))) + ;; Even when unioning, the `:no-value' feature can generate single-entry subnodes. + (if (and (not (consp new-subnode)) + (= 1 (logcount (ch-map-node-entry-mask new-subnode))) + (= 0 (ch-map-node-subnode-mask new-subnode))) + (let ((key val (ch-map-node-entry new-subnode 0)) + ((n (vector-update-2 node (+ ch-map-node-header-size (* 2 ientry)) key val)))) + (hash-mixf (ch-map-node-key-hash n) + (hash-unmix (hash-to-fixnum key key-hash-fn) + (hash-to-fixnum old-key key-hash-fn))) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) + (hash-unmix (hash-to-fixnum val val-hash-fn) + (hash-to-fixnum old-val val-hash-fn)))) + n) + (let ((n (vector-rem-2-ins-1 node (+ ch-map-node-header-size (* 2 ientry)) + (- (length node) isubnode) new-subnode))) + (logandc2f (ch-map-node-entry-mask n) (ash 1 hash-bits)) + (logiorf (ch-map-node-subnode-mask n) (ash 1 hash-bits)) + (incf (ch-map-node-size n) (1- (ch-map-tree-size new-subnode))) + (hash-mixf (ch-map-node-key-hash n) + (hash-unmix (ch-map-tree-key-hash new-subnode) + (hash-to-fixnum old-key key-hash-fn))) + (when (ch-map-node-value-hash n) + (hash-mixf (ch-map-node-value-hash n) + (hash-unmix (ch-map-tree-value-hash new-subnode val-hash-fn) + (hash-to-fixnum old-val val-hash-fn)))) + n)))) + (defun ch-map-compact-node (n) (declare (optimize (speed 3) (safety 0))) (let ((entries (ch-map-node-entry-mask n)) @@ -2389,6 +2652,7 @@ (defstruct (ch-map-node n)))) (defun ch-map-tree-verify (tree key-hash-fn val-hash-fn) + (declare (optimize (debug 3))) (or (null tree) (rlabels (rec tree 0 0) (rec (node depth partial-hash) @@ -2397,11 +2661,9 @@ (defstruct (ch-map-node (progn (cerror "Ignore and proceed." "Verification check failed at ~:A: ~S" (path depth partial-hash) ',form) - nil)))) + t)))) (let ((entry-mask (ch-map-node-entry-mask node)) - (subnode-mask (ch-map-node-subnode-mask node)) - ((entry-bits (bit-indices entry-mask)) - (subnode-bits (bit-indices subnode-mask)))) + (subnode-mask (ch-map-node-subnode-mask node))) (and (test (= 0 (logand entry-mask subnode-mask))) (test (= 0 (ash entry-mask (- champ-node-radix)))) (test (= 0 (ash subnode-mask (- champ-node-radix)))) @@ -2428,7 +2690,7 @@ (defstruct (ch-map-node key-hash) (new-partial-hash hash-bits depth partial-hash))))) (:arg index 0) - (:arg list entry-bits)) + (:arg list (bit-indices entry-mask))) ;; Verify subnodes (gmap :and (fn (subnode-idx hash-bits) (let ((subnode (svref node (- (length node) 1 subnode-idx)))) @@ -2457,7 +2719,7 @@ (defstruct (ch-map-node (hash-mixf node-value-hash (ch-map-node-value-hash subnode))) t))))) (:arg index 0) - (:arg list subnode-bits)) + (:arg list (bit-indices subnode-mask))) ;; Finally, check size and hashes (test (= (ch-map-node-size node) size)) (test (= (ch-map-node-key-hash node) node-key-hash)) diff --git a/Code/defs.lisp b/Code/defs.lisp index e3f079623f63be65db80bb9c26811085229aaf50..ec0326a3bf0e59b274a67d6e939ad72ffe206d5c 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -16,6 +16,7 @@ (:import-from :gmap #:gmap #:alist #:constant #:index #:index-inc #:sum) (:shadowing-import-from :new-let #:let #:cond) (:shadowing-import-from :mt19937 #:make-random-state #:random #:*random-state*) + #+allegro (:implementation-packages "FSET" "FSET2") ;; For each of these shadowed symbols, using packages must either shadowing- ;; import it or shadowing-import the original Lisp symbol. (:shadow ;; Shadowed type/constructor names @@ -40,20 +41,18 @@ #:wb-custom-set #:wb-custom-bag #:wb-custom-map #:ch-custom-set #:ch-custom-map #:wb-custom-replay-set #:wb-custom-replay-map #:ch-custom-replay-set #:ch-custom-replay-map - ;; `Equal?' is exported because users may want to call it; `Compare' - ;; because they may want to extend it; and `Compare-Slots' because it's - ;; useful in extending `Compare'. But `Less-Than?' and `Greater-Than?' - ;; are unlikely to be useful in user code. - #:equal? #:compare #:compare-slots #:compare-slots-no-unequal #:eql-compare + #:equal? #:compare #:compare-slots #:compare-slots-no-unequal #:hash-slots #:eql-compare #:define-equality-slots #:define-comparison-slots #:define-hash-function #:unwrap-equivalent-node ; custom comparison functions may have to call this #:hash-value #:hash-value-fixnum #:zero #:hash-mix #:hash-mixf #:hash-multiply #:identity-equality-mixin #:identity-ordering-mixin #:define-cross-type-compare-methods - #:compare-lexicographically + #:compare-lexicographically #:compare-lists-lexicographically #:compare-strings-lexicographically + #:compare-vectors-lexicographically #:compare-seqs-lexicographically #:empty? #:nonempty? #:size #:set-size #:arb #:contains? #:domain-contains? #:range-contains? #:member? #:multiplicity - #:empty-set #:empty-bag #:empty-map #:empty-seq #:empty-tuple + #:empty-set #:empty-set-like #:empty-bag #:empty-bag-like #:empty-map #:empty-map-like + #:empty-seq #:empty-tuple #:empty-wb-set #:empty-wb-bag #:empty-wb-map #:empty-wb-seq #:empty-dyn-tuple #:empty-ch-set #:empty-ch-map #:empty-replay-set #:empty-wb-replay-set #:empty-replay-map #:empty-wb-replay-map @@ -61,16 +60,17 @@ #:least #:greatest #:lookup #:rank #:at-rank #:index #:at-index #:@ #:with #:less #:split-from #:split-above #:split-through #:split-below #:union #:bag-sum #:intersection #:bag-product #:complement - #:set-difference #:set-difference-2 #:bag-difference #:bag-pairs + #:set-difference #:set-difference-2 #:bag-difference #:bag-pairs #:wb-bag-pairs #:subset? #:proper-subset? #:disjoint? #:subbag? #:proper-subbag? #:filter #:filter-pairs #:partition - #:image #:reduce #:domain #:range #:with-default #:update + #:image #:reduce #:domain #:range #:update + #:with-default #:default #:map-union #:map-intersection #:map-difference-2 - #:restrict #:restrict-not #:compose #:map-default + #:restrict #:restrict-not #:compose #:first #:last #:lastcons #:head #:tail #:with-first #:less-first #:push-first #:pop-first - #:with-last #:less-last #:push-last #:pop-last #:appendf #:prependf #:insertf + #:with-last #:less-last #:push-last #:pop-last #:appendf #:prependf #:insertf #:splicef #:insert #:splice #:subseq #:concat #:reverse #:sort #:stable-sort #:sort-and-group #:find #:find-if #:find-if-not #:count #:count-if #:count-if-not @@ -100,6 +100,7 @@ #:full-set ;; Relations #:relation #:relation? #:2-relation #:2-relation? #:wb-2-relation #:wb-2-relation? + #:wb-custom-2-relation #:ch-2-relation #:ch-2-relation? #:ch-custom-2-relation #:empty-2-relation #:empty-wb-2-relation #:empty-ch-2-relation #:do-2-relation #:lookup-inv #:inverse #:join #:conflicts #:map-to-sets #:list-relation #:list-relation? #:wb-list-relation #:wb-list-relation? @@ -116,41 +117,52 @@ ;;; Since we've shadowed `cl:count', we need to do this. (gmap:def-result-type-synonym fset:count cl:count) +;;; We want to import this below, so make sure it exists. +(defvar fset::erapmoc) -;;; The need has arisen to define a second FSet package. There are two motivations: -;;; () the planned introduction of the CHAMP data structure for sets, maps, and bags, -;;; which will become the default, incompatibly altering the behavior of the corresponding -;;; constructor macros, and requiring methods on `hash-value' as well as `compare' for -;;; user types; -;;; () miscellaneous infelicities in the API which cannot be fixed compatibly. -;;; -;;; The plan is for both packages to continue to exist indefinitely. New client code is -;;; encouraged to use package `fset2' instead of `fset'; existing clients may update -;;; their code at their leisure. -;;; NOTE: This package is not ready for use yet. I will announce when it is. + +;;; For a discussion of how the `fset2' package differs from `fset', see: +;;; https://gitlab.common-lisp.net/fset/fset/-/merge_requests/2 (defpackage :fset2 (:nicknames :com.ergy.fset2 :com.sympoiesis.fset2) (:use :cl :fset :new-let :lexical-contexts :rev-fun-bind :misc-extensions.define-class) (:import-from :gmap #:gmap #:alist #:constant #:index #:sum) (:shadowing-import-from :new-let #:let #:cond) (:shadowing-import-from :mt19937 #:make-random-state #:random #:*random-state*) - ;; For each of these shadowed symbols, using packages must either shadowing- + #+allegro (:implementation-packages "FSET" "FSET2") + ;; For each of these shadowed CL symbols, using packages must either shadowing- ;; import it or shadowing-import the original Lisp symbol. - (:shadow ;; Shadowed type/constructor names - #:set #:map - ;; Shadowed set operations - #:union #:intersection #:set-difference #:complement - ;; Shadowed sequence operations - #:first #:last #:subseq #:reverse #:sort #:stable-sort - #:reduce - #:find #:find-if #:find-if-not - #:count #:count-if #:count-if-not - #:position #:position-if #:position-if-not - #:remove #:remove-if #:remove-if-not - #:substitute #:substitute-if #:substitute-if-not - #:some #:every #:notany #:notevery - ;; Additional shadowed names from `fset:' - #:map-intersection) + (:shadowing-import-from :fset + ;; Shadowed set operations + #:union #:intersection #:set-difference #:complement + ;; Shadowed sequence operations + #:first #:last #:subseq #:reverse #:sort #:stable-sort + #:reduce + #:find #:find-if #:find-if-not + #:count #:count-if #:count-if-not + #:position #:position-if #:position-if-not + #:remove #:remove-if #:remove-if-not + #:substitute #:substitute-if #:substitute-if-not + #:some #:every #:notany #:notevery + ;; Other exported symbols + #:wb-bag-pairs #:$ #:% #:? + ;; Internal, for testing + #:erapmoc) + ;; These are shadowed `fset:' symbols, with different definitions in `fset2:'. + (:shadow ;; Names shadowed from `fset:' to implement FSet2 semantics + #:set #:map #:wb-map #:wb-custom-map #:ch-map #:ch-custom-map #:seq #:wb-seq + #:replay-map #:wb-replay-map #:wb-custom-replay-map #:ch-replay-map #:ch-custom-replay-map + #:empty-set #:empty-map #:empty-wb-map #:empty-ch-map #:empty-seq #:empty-wb-seq + #:rank #:define-tuple-key #:get-tuple-key #:map-to-sets #:concat + ;; These just changed from `&optional' to `&key' + #:empty-wb-set #:empty-ch-set #:empty-wb-bag #:empty-wb-replay-set #:empty-ch-replay-set + #:empty-replay-map #:empty-wb-replay-map #:empty-ch-replay-map + #:empty-wb-2-relation #:empty-ch-2-relation + #:empty-list-relation #:empty-wb-list-relation #:empty-ch-list-relation + ;; Map and seq operations that handle defaults differently + #:lookup #:map-union #:map-intersection #:map-difference-2 #:compose + ;; Functions that call `lookup', transitively + #:internal-lookup #:@ #:image #:filter #:partition) (:export #:collection #:set #:bag #:map #:seq #:tuple #:collection? #:set? #:bag? #:map? #:seq? #:tuple? #:wb-set #:wb-bag #:wb-map #:wb-seq #:dyn-tuple @@ -160,20 +172,18 @@ #:wb-custom-set #:wb-custom-bag #:wb-custom-map #:ch-custom-set #:ch-custom-map #:wb-custom-replay-set #:wb-custom-replay-map #:ch-custom-replay-set #:ch-custom-replay-map - ;; `Equal?' is exported because users may want to call it; `Compare' - ;; because they may want to extend it; and `Compare-Slots' because it's - ;; useful in extending `Compare'. But `Less-Than?' and `Greater-Than?' - ;; are unlikely to be useful in user code. - #:equal? #:compare #:compare-slots #:compare-slots-no-unequal #:eql-compare + #:equal? #:compare #:compare-slots #:compare-slots-no-unequal #:hash-slots #:eql-compare #:define-equality-slots #:define-comparison-slots #:define-hash-function #:unwrap-equivalent-node ; custom comparison functions may have to call this #:hash-value #:hash-value-fixnum #:zero #:hash-mix #:hash-mixf #:hash-multiply - #:identity-equality-mixin #:identity-ordering-mixin + #:identity-equality-mixin #:define-cross-type-compare-methods - #:compare-lexicographically + #:compare-lexicographically #:compare-lists-lexicographically #:compare-strings-lexicographically + #:compare-vectors-lexicographically #:compare-seqs-lexicographically #:empty? #:nonempty? #:size #:set-size #:arb #:contains? #:domain-contains? #:range-contains? #:member? #:multiplicity - #:empty-set #:empty-bag #:empty-map #:empty-seq #:empty-tuple + #:empty-set #:empty-set-like #:empty-bag #:empty-bag-like #:empty-map #:empty-map-like + #:empty-seq #:empty-tuple #:empty-wb-set #:empty-wb-bag #:empty-wb-map #:empty-wb-seq #:empty-dyn-tuple #:empty-ch-set #:empty-ch-map #:empty-replay-set #:empty-wb-replay-set #:empty-replay-map #:empty-wb-replay-map @@ -181,16 +191,21 @@ #:least #:greatest #:lookup #:rank #:at-rank #:index #:at-index #:@ #:with #:less #:split-from #:split-above #:split-through #:split-below #:union #:bag-sum #:intersection #:bag-product #:complement - #:set-difference #:set-difference-2 #:bag-difference #:bag-pairs + #:set-difference #:set-difference-2 #:bag-difference #:bag-pairs #:wb-bag-pairs #:subset? #:proper-subset #:disjoint? #:subbag? #:proper-subbag? #:filter #:filter-pairs #:partition - #:image #:reduce #:domain #:range #:with-default #:update + #:image #:reduce #:domain #:range #:update + #:with-default #:without-default #:default + #:lookup-error #:map-domain-error #:map-domain-error-map #:map-domain-error-key + #:seq-bounds-error #:seq-bounds-error-seq #:seq-bounds-error-index + #:tuple-key-unbound-error #:tuple-key-unbound-error-tuple #:tuple-key-unbound-error-key + #:empty-seq-error #:empty-seq-error-seq #:map-union #:map-intersection #:map-difference-2 - #:restrict #:restrict-not #:compose #:map-default + #:restrict #:restrict-not #:compose #:first #:last #:lastcons #:head #:tail #:with-first #:less-first #:push-first #:pop-first - #:with-last #:less-last #:push-last #:pop-last #:appendf #:prependf #:insertf + #:with-last #:less-last #:push-last #:pop-last #:appendf #:prependf #:insertf #:splicef #:insert #:splice #:subseq #:concat #:reverse #:sort #:stable-sort #:sort-and-group #:find #:find-if #:find-if-not #:count #:count-if #:count-if-not @@ -202,7 +217,7 @@ #:do-set #:do-bag #:do-bag-pairs #:do-map #:do-map-domain #:do-seq #:do-tuple #:adjoinf #:removef #:includef #:excludef #:unionf #:intersectf #:set-differencef #:map-unionf #:map-intersectf #:imagef #:composef - #:define-tuple-key #:def-tuple-key #:get-tuple-key #:tuple-key-name #:tuple-key? + #:define-tuple-key #:get-tuple-key #:tuple-key-name #:tuple-key? #:tuple-merge #:fset-setup-readtable #:*fset-readtable* #:fset-setup-rereading-readtable #:*fset-rereading-readtable* @@ -220,7 +235,8 @@ #:full-set ;; Relations #:relation #:relation? #:2-relation #:2-relation? #:wb-2-relation #:wb-2-relation? - #:empty-2-relation #:empty-wb-2-relation #:empty-chb-2-relation #:do-2-relation + #:wb-custom-2-relation #:ch-2-relation #:ch-2-relation? #:ch-custom-2-relation + #:empty-2-relation #:empty-wb-2-relation #:empty-ch-2-relation #:do-2-relation #:lookup-inv #:inverse #:join #:conflicts #:map-to-sets #:list-relation #:list-relation? #:wb-list-relation #:wb-list-relation? #:empty-list-relation #:empty-wb-list-relation #:empty-ch-list-relation #:do-list-relation @@ -236,6 +252,11 @@ ;;; Since we've shadowed `cl:count', we need to do this. (gmap:def-result-type-synonym fset2:count cl:count) +#+sbcl +(progn + (sb-ext:add-implementation-package ':fset2 ':fset) + (sb-ext:add-implementation-package ':fset ':fset2)) + ;;; A convenient package for experimenting with FSet. Also serves as an example ;;; of how one might create a package for code to be written using FSet. Note, @@ -262,8 +283,27 @@ #:substitute #:substitute-if #:substitute-if-not #:some #:every #:notany #:notevery)) +(defpackage :fset2-user + (:use :cl :fset2 :gmap :new-let :lexical-contexts) + (:shadowing-import-from :new-let #:let #:cond) + (:shadowing-import-from :fset2 + ;; Shadowed type/constructor names + #:set #:map + ;; Shadowed set operations + #:union #:intersection #:set-difference #:complement + ;; Shadowed sequence operations + #:first #:last #:subseq #:reverse #:sort #:stable-sort + #:reduce + #:find #:find-if #:find-if-not + #:count #:count-if #:count-if-not + #:position #:position-if #:position-if-not + #:remove #:remove-if #:remove-if-not + #:substitute #:substitute-if #:substitute-if-not + #:some #:every #:notany #:notevery)) + (pushnew ':FSet *features*) +(pushnew ':FSet2 *features*) ;;; The seq implementation tries to use strings for leaf vectors when possible. ;;; In some Lisp implementations, there are two kinds of strings; but in some diff --git a/Code/fset.lisp b/Code/fset.lisp index bdf8e4ff0a38369e937b746eb39c217cc13e26ad..28433b45dc7c4704af4c8b625301e1beaf3bd836 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -119,11 +119,35 @@ (defgeneric lookup (collection key) (:documentation - "If `collection' is a map, returns the value to which `key' is mapped. -If `collection' is a seq, takes `key' as an index and returns the -corresponding member (0-origin, of course). If `collection' is a set or -bag that contains a member equal to `key', returns true and the member -as two values, else false and `nil'; this is useful for canonicalization.")) + "If `collection' is a map, returns three values: if it contains a key equal +to `key', the corresponding value, true, and the key found; otherwise, the map's +default, false, and `nil'. + +If `collection' is a seq, takes `key' as an index and returns two values: if +the index is in bounds, the corresponding element and true; otherwise, the +seq's default and false. + +If `collection' is a set or bag that contains a member equal to `key', returns +true and the member as two values, else false and `nil'; this is useful for +canonicalization.")) +(defgeneric fset2:lookup (collection key) + (:documentation + "If `collection' is a map, returns three values: if it contains a key equal +to `key', the corresponding value, true, and the key found; otherwise, the map's +default, false, and `nil'. If there's no mapping for `key' and the map has no +default, signals an error of type `map-domain-error'. + +If `collection' is a seq, takes `key' as an index and returns two values: if +the index is in bounds, the corresponding element and true; otherwise, the +seq's default and false. If the index is out of bounds and the seq has no +default, signals an error of type `seq-bounds-error'. + +If `collection' is a set that contains a member equal to `key', returns true +and the member as two values, else false and `nil'; this is useful for +canonicalization. + +If `collection' is a bag that contains a member equal to `key', returns its +multiplicity and the member as two values, else zero and `nil'.")) (defgeneric rank (collection value) (:documentation @@ -140,6 +164,20 @@ purpose; but another collection that is `equal?' but not `eq' to this one will in general order them differently. Also, on a bag, multiplicities are ignored for this purpose.")) +(defgeneric fset2:rank (collection value) + (:documentation + "Defined on tree \(WB\) collections only. See `index'. + +If `collection' is a set or bag that contains `value', returns the rank +of `value' in the ordering defined by `compare', and a true second value. +If `collection' is a map whose domain contains `value', returns the rank of +`value' in the domain of the map, and a true second value. If `value' is +not in the collection, the second value is false, and the first value is the +rank that `value' would have if it were added. Note that if there are +values/keys that are unequal but equivalent to `value', an arbitrary order +will be imposed on them for this purpose; but another collection that is +`equal?' but not `eq' to this one will in general order them differently. +Also, on a bag, multiplicities are ignored for this purpose.")) (defgeneric at-rank (collection rank) (:documentation @@ -285,7 +323,7 @@ member of `sub', `super' contains the same value with at least the same multiplicity.")) -(defgeneric filter (fn collection) +(define-generics (filter fset2:filter) (fn collection) (:documentation "Returns a new collection containing those members or pairs of `collection' for which `fn' returns true. If `collection' is a set, bag, or seq, `fn' is @@ -294,7 +332,7 @@ 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).")) -(defmethod filter (fn (s sequence)) +(define-methods (filter fset2:filter) (fn (s sequence)) (cl:remove-if-not fn s)) (defgeneric partition (pred collection) @@ -326,6 +364,24 @@ (defmethod filter-pairs (fn (collection t)) bag methods take keyword argument `:compare-fn-name', and the map method takes `:key-compare-fn-name' and `:val-compare-fn-name'. +If `collection' is a map or seq, the default of the result is the same. + +As well 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 fset2:image (fn collection &key) + (:documentation + "Returns a new collection containing the result of applying `fn' to each +member of `collection', which may be a set, bag, map, or seq. In the bag case, +the multiplicity of each member of the result is the sum of the multiplicities +of the values that `fn' maps to it. In the map case, `fn' is expected to return +two values, which become the new domain and range values. Except in the seq +case, you may wish to specify the organization of the result, so the set and +bag methods take keyword argument `:compare-fn-name', and the map method takes +`:key-compare-fn-name' and `:val-compare-fn-name'. + +If `collection' is a map or seq, the result has a default as specified by +the `:default' or `:no-default?' keyword arguments, if given, or else `nil'. + As well 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).")) @@ -354,14 +410,21 @@ (defmethod reduce (fn (s sequence) &rest keyword-args (defgeneric default (collection) (:documentation - "Returns the default for the map or seq, i.e., the value returned by `lookup' -when the supplied key or index is not in the domain.")) + "Returns two values. If the map or seq has a default \(the value returned +by `lookup' when the supplied key or index is not in the domain\), returns the +default and a true second value; otherwise, the second value is false.")) (defgeneric with-default (collection new-default) (:documentation "Returns a new map or seq with the same contents as `collection' but whose default is now `new-default'.")) +(defgeneric fset2:without-default (collection) + (:documentation + "Returns a new map, replay map, or seq with the same contents as `collection' +but with no default. Subsequent `lookup' operations on a key not in the map, +or a index outside the seq's bounds, will signal an error.")) + ;;; Prior to 1.4.0, this unconditionally called `val-fn' on the defaults of the ;;; two maps to produce the defaults of the result. This was a PITA in the ;;; common case in which the defaults were null. Now, it calls `val-fn' only @@ -382,6 +445,24 @@ (defmethod reduce (fn (s sequence) &rest keyword-args New feature: if `val-fn' returns `:no-value' as a second value, the result will contain no pair with the corresponding key.")) +(defgeneric fset2:map-union (map1 map2 &optional val-fn) + (:documentation + "Returns a map containing all the keys of `map1' and `map2', where the +value for each key contained in only one map is the value from that map, and +the value for each key contained in both maps is the result of calling +`val-fn' on the value from `map1' and the value from `map2'. `val-fn' +defaults to simply returning its second argument, so the entries in `map2' +simply shadow those in `map1'. The default for the new map is: if both maps +have defaults, the result of calling `val-fn' on those defaults; if only one +map has a default, that default; otherwise none. + +`map-union' assumes that `val-fn' is idempotent, i.e., if the two values +passed to `val-fn' are equal, `val-fn' must return the same value; it may +elide calls to `val-fn' on that basis. + +If `val-fn' returns `:no-value' as a second value, the result will contain +no pair with the corresponding key.")) + ;;; Prior to 1.4.0, this unconditionally called `val-fn' on the defaults of the ;;; two maps to produce the defaults of the result. This was a PITA in the ;;; common case in which the defaults were null. Now, it calls `val-fn' only @@ -401,11 +482,37 @@ (defmethod reduce (fn (s sequence) &rest keyword-args New feature: if `val-fn' returns `:no-value' as a second value, the result will contain no pair with the corresponding key.")) +(defgeneric fset2:map-intersection (map1 map2 &optional val-fn) + (:documentation + "Returns a map containing all the keys that are in the domains of both +`map1' and `map2', where the value for each key is the result of calling +`val-fn' on the value from `map1' and the value from `map2'. `val-fn' +defaults to simply returning its second argument, so the entries in `map2' +simply shadow those in `map1'. The default for the new map is the result +of calling `val-fn' on the defaults for the two maps, if they both have +defaults; else none. + +`map-intersection' assumes that `val-fn' is idempotent, i.e., if the two +values passed to `val-fn' are equal, `val-fn' must return the same value; +it may elide calls to `val-fn' on that basis. + +If `val-fn' returns `:no-value' as a second value, the result will contain +no pair with the corresponding key.")) + (defgeneric map-difference-2 (map1 map2) (:documentation "Returns, as two values: a map containing all the pairs that are in `map1' 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'.")) +(defgeneric fset2:map-difference-2 (map1 map2) + (:documentation + "Returns, as two values: a map containing all the pairs that are in `map1' +but not `map2', and one containing all the pairs that are in `map2' but not +`map1'. + +The default for each returned map is that of its corresponding argument, if +it has a default, except if the defaults are equal, in which case neither +returned map has a default.")) ;;; Possible operation: `map-update' (better name??), which would be like ;;; `map-union' except the keys would be exactly the keys of `map1'. This @@ -441,6 +548,14 @@ (defmethod reduce (fn (s sequence) &rest keyword-args of that domain to the result of applying first `map1' to it, then applying `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 fset2:compose (map1 map2-or-fn &key) + (: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' can also be a sequence, which is +treated as a map from indices to members. If `map1' has a default, the value +of `map2-or-fn' applied to that default becomes the default of the returned +map.")) (defgeneric first (seq) (:documentation @@ -487,22 +602,24 @@ (defmethod last ((s sequence)) (defgeneric insert (seq idx val) (:documentation - "Returns a new sequence like `seq' but with `val' inserted at `idx' (the seq + "Returns a new sequence like `seq' but with `val' 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).")) +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).")) +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 &rest seqs) (:documentation - "Returns the concatenation of `seq1' with each of `seqs'.")) - + "Returns the concatenation of `seq1' with each of `seqs'. The result has the +same default as `seq1'.")) +(defgeneric fset2:concat (seq1 &rest seqs) + (:documentation + "Returns the concatenation of `seq1' with each of `seqs'. The result has the +same default as `seq1'.")) ;;; This is the opposite order from `cl:coerce', but I like it better, because I ;;; think the calls are easier to read with the type first. It's also consistent @@ -513,7 +630,7 @@ (defmethod last ((s sequence)) have additional keyword parameters to further specify the kind of conversion. \(`sequence' here refers to a CL sequence -- either a list or a vector, unless the implementation has more sequence subtypes. FSet's `seq' is not a subtype of -`sequence'.) +`sequence'.\) When `to-type' is one of the abstract types -- `set', `bag', `map' etc. -- the only guarantee is that `convert' will return an instance of the requested type. @@ -615,7 +732,7 @@ (defmethod last ((s sequence)) 2-relation seq 1, 6 wb-2-relation seq 6 map wb-2-relation 1, 11 - wb-map wb-2-relation 1, 11 + wb-map wb-2-relation 11 map-to-sets wb-2-relation 12 tuple tuple 0 @@ -703,16 +820,10 @@ (defmethod last ((s sequence)) functions, respectively, to be used. The returned map will be converted, if necessary, to use the specified functions, or to use `compare' for those not specified. -17. The default of the result is the same as that of the argument. +17. The default of the result is `nil' (in FSet 1) or the same as that of the + argument (in FSet 2). 18. Constructs the ch (CHAMP tree) implementation of its type (`ch-set' etc.).")) -;;; The `&allow-other-keys' is to persuade SBCL not to issue warnings about keywords -;;; that are accepted by some methods of `convert'. This differs from the behavior -;;; we would get by specifying `&allow-other-keys' in the `defgeneric' parameter list; -;;; this way, we still get runtime errors on unexpected keywords (which I guess is an -;;; SBCL extension, since CLHS 7.6.4 says we shouldn't). -(declaim (ftype (function (t t &key &allow-other-keys) t) convert)) - ;;; ================================================================================ ;;; Iterators @@ -1281,25 +1392,25 @@ (defmethod contains? ((ls list) x &optional (y nil y?)) (check-two-arguments y? 'contains 'list) (member x ls :test #'equal?)) -(defmethod concat ((a list) &rest seqs) +(define-methods (concat fset2:concat) ((a list) &rest seqs) (append a (reduce #'append seqs :key (fn (x) (convert 'list x)) :from-end t))) (defmethod convert ((to-type (eql 'list)) (ls list) &key) ls) -(defmethod filter ((pred symbol) (ls list)) +(define-methods (filter fset2:filter) ((pred symbol) (ls list)) (remove-if-not (coerce pred 'function) ls)) -(defmethod filter ((pred function) (ls list)) +(define-methods (filter fset2:filter) ((pred function) (ls list)) (remove-if-not pred ls)) (defmethod convert ((to-type (eql 'vector)) (v vector) &key) v) -(defmethod partition ((pred symbol) (ls list)) +(define-methods (partition fset2:partition) ((pred symbol) (ls list)) (list-partition (coerce-to-function pred) ls)) -(defmethod partition ((pred function) (ls list)) +(define-methods (partition fset2:partition) ((pred function) (ls list)) (list-partition pred ls)) (defun list-partition (pred ls) @@ -1313,29 +1424,37 @@ (defmethod partition ((pred function) (ls list)) (push x res2))) (values (nreverse res1) (nreverse res2)))) -(defmethod image ((fn function) (l list) &key) +(define-methods (image fset2:image) ((fn function) (l list) &key) (mapcar fn l)) -(defmethod image ((fn symbol) (l list) &key) +(define-methods (image fset2:image) ((fn symbol) (l list) &key) (mapcar (coerce fn 'function) l)) (defmethod image ((fn map) (l list) &key) (mapcar (lambda (x) (lookup fn x)) l)) +(defmethod fset2:image ((fn map) (l list) &key) + (mapcar (lambda (x) (fset2:lookup fn x)) l)) (defmethod image ((fn set) (l list) &key) (mapcar (lambda (x) (lookup fn x)) l)) +(defmethod fset2:image ((fn set) (l list) &key) + (mapcar (lambda (x) (fset2:lookup fn x)) l)) -(defmethod image ((fn function) (l vector) &key) +(define-methods (image fset2:image) ((fn function) (l vector) &key) (cl:map 'vector fn l)) -(defmethod image ((fn symbol) (l vector) &key) +(define-methods (image fset2:image) ((fn symbol) (l vector) &key) (cl:map 'vector (coerce fn 'function) l)) (defmethod image ((fn map) (l vector) &key) (cl:map 'vector (lambda (x) (lookup fn x)) l)) +(defmethod fset2:image ((fn map) (l vector) &key) + (cl:map 'vector (lambda (x) (fset2:lookup fn x)) l)) (defmethod image ((fn set) (l vector) &key) (cl:map 'vector (lambda (x) (lookup fn x)) l)) +(defmethod fset2:image ((fn set) (l vector) &key) + (cl:map 'vector (lambda (x) (fset2:lookup fn x)) l)) ;;; ---------------- @@ -1346,9 +1465,9 @@ (defmethod image ((fn set) (l vector) &key) ;;; your list is longer than three or maybe four, you should probably use a dynamic tuple; ;;; see `tuples.lisp'. -(defmethod lookup ((ls list) (key (eql 'first))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'first))) (cl:first ls)) -(defmethod lookup ((ls list) (key (eql 'cl:first))) ; in case they don't shadowing-import `fset:first' +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'cl:first))) ; in case of no shadowing-import of `fset:first' (cl:first ls)) (defmethod with ((ls list) (key (eql 'first)) &optional (val nil val?)) @@ -1358,56 +1477,56 @@ (defmethod with ((ls list) (key (eql 'cl:first)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (cons val (cdr ls))) -(defmethod lookup ((ls list) (key (eql 'second))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'second))) (second ls)) (defmethod with ((ls list) (key (eql 'second)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) val (cddr ls))) -(defmethod lookup ((ls list) (key (eql 'third))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'third))) (third ls)) (defmethod with ((ls list) (key (eql 'third)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) (second ls) val (cdddr ls))) -(defmethod lookup ((ls list) (key (eql 'fourth))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'fourth))) (fourth ls)) (defmethod with ((ls list) (key (eql 'fourth)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) (second ls) (third ls) val (cddddr ls))) -(defmethod lookup ((ls list) (key (eql 'fifth))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'fifth))) (fifth ls)) (defmethod with ((ls list) (key (eql 'fifth)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) (second ls) (third ls) (fourth ls) val (cdr (cddddr ls)))) -(defmethod lookup ((ls list) (key (eql 'sixth))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'sixth))) (sixth ls)) (defmethod with ((ls list) (key (eql 'sixth)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) (second ls) (third ls) (fourth ls) (fifth ls) val (cddr (cddddr ls)))) -(defmethod lookup ((ls list) (key (eql 'seventh))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'seventh))) (seventh ls)) (defmethod with ((ls list) (key (eql 'seventh)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) (second ls) (third ls) (fourth ls) (fifth ls) (sixth ls) val (cdddr (cddddr ls)))) -(defmethod lookup ((ls list) (key (eql 'eighth))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'eighth))) (eighth ls)) (defmethod with ((ls list) (key (eql 'eighth)) &optional (val nil val?)) (check-three-arguments val? 'with 'list) (list* (cl:first ls) (second ls) (third ls) (fourth ls) (fifth ls) (sixth ls) (seventh ls) val (cddddr (cddddr ls)))) -(defmethod lookup ((ls list) (key (eql 'ninth))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'ninth))) (ninth ls)) (defmethod with ((ls list) (key (eql 'ninth)) &optional (val nil val?)) @@ -1415,7 +1534,7 @@ (defmethod with ((ls list) (key (eql 'ninth)) &optional (val nil val?)) (list* (cl:first ls) (second ls) (third ls) (fourth ls) (fifth ls) (sixth ls) (seventh ls) (eighth ls) val (cdr (cddddr (cddddr ls))))) -(defmethod lookup ((ls list) (key (eql 'tenth))) +(define-methods (lookup fset2:lookup) ((ls list) (key (eql 'tenth))) (tenth ls)) (defmethod with ((ls list) (key (eql 'tenth)) &optional (val nil val?)) @@ -1428,6 +1547,7 @@ (defmethod with ((ls list) (key (eql 'tenth)) &optional (val nil val?)) ;;; Functional deep update (defun update (fn coll &rest keys) + (declare (dynamic-extent fn)) "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 @@ -1441,12 +1561,15 @@ (defmethod with ((ls list) (key (eql 'tenth)) &optional (val nil val?)) This is perhaps most useful in contexts where you don't want to do the `setq' anyway. `fn' can be a function object, an fbound symbol, or a map." (labels ((rec (fn coll keys) - (if (null keys) (@ (if (symbolp fn) (coerce fn 'function) fn) coll) + (if (null keys) (@ fn coll) (with coll (car keys) (rec fn (lookup coll (car keys)) (cdr keys)))))) - (rec fn coll keys))) + (rec (if (symbolp fn) (coerce fn 'function) 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.) +;;; -- Actually, I'm not sure SBCL needs this. It might be enough to add the declaration to +;;; the `defun' (as I've now done). Also, it makes a bigger difference here than for `image' +;;; etc., because `fn' is called only once. (define-compiler-macro update (&whole form fn coll &rest keys) (if (not (or (symbolp fn) (and (listp fn) @@ -1479,7 +1602,9 @@ (defstruct (tree-set-org (compare-fn-name nil :type symbol :read-only t) (compare-fn nil :type function :read-only t)) -(deflex +fset-default-tree-set-org+ (make-tree-set-org 'compare #'compare)) +;;; I wanted to use `defconstant' for these, but the compiler tries to evaluate them at +;;; compile time, and `make-tree-set-org' doesn't yet exist. +(defparameter +fset-default-tree-set-org+ (make-tree-set-org 'compare #'compare)) (declaim (inline make-wb-set make-wb-custom-set)) @@ -1544,24 +1669,28 @@ (defstruct (wb-custom-set (make-wb-default-set contents) (make-wb-custom-set contents org))) -(defparameter *empty-wb-set* (make-wb-set nil)) +(defparameter +empty-wb-set+ (make-wb-set nil)) (declaim (inline empty-set)) (defun empty-set () "Returns an empty set of the default implementation." - *empty-wb-set*) + +empty-wb-set+) +;;; `fset2:empty-set' is below -;; For the constructor macros. -(defmethod empty-instance-function ((class-name (eql 'set))) - 'empty-set) - -(declaim (inline empty-wb-set)) +(declaim (inline empty-wb-set fset2:empty-wb-set)) (defun empty-wb-set (&optional compare-fn-name) "Returns an empty wb-set. By default, it will be ordered by `fset:compare'; to use a custom ordering, supply the comparison function name (a symbol) as `compare-fn-name'." (if (null compare-fn-name) - *empty-wb-set* + +empty-wb-set+ + (empty-wb-custom-set compare-fn-name))) +(defun fset2:empty-wb-set (&key compare-fn-name) + "Returns an empty wb-set. By default, it will be ordered by `fset:compare'; +to use a custom ordering, supply the comparison function name (a symbol) as +`compare-fn-name'." + (if (null compare-fn-name) + +empty-wb-set+ (empty-wb-custom-set compare-fn-name))) ;;; We cache the last empty `wb-custom-set' instance with a given org, so as to reuse them @@ -1577,7 +1706,7 @@ (defmethod empty-instance-function ((class-name (eql 'set))) (assert (and compare-fn-name (symbolp compare-fn-name) (symbol-package compare-fn-name)) () "compare-fn-name must be a nonnull interned symbol") (if (eq compare-fn-name 'compare) - *empty-wb-set* + +empty-wb-set+ (let ((prev-instance (gethash compare-fn-name +empty-wb-custom-set-cache+)) (compare-fn (symbol-function compare-fn-name))) (if (and prev-instance @@ -1586,13 +1715,10 @@ (defmethod empty-instance-function ((class-name (eql 'set))) (setf (gethash compare-fn-name +empty-wb-custom-set-cache+) (make-wb-custom-set nil (make-tree-set-org compare-fn-name compare-fn))))))) -(defmethod empty-instance-function ((class-name (eql 'wb-set))) - `empty-wb-set) - (defgeneric empty-set-like (s) (:documentation "Returns an empty set of the same implementation, and using the same compare -or hash function, as `s'.")) +or hash function, as `s'. `s' can also be a bag.")) (defmethod empty-set-like ((s wb-default-set)) (empty-set)) @@ -1612,6 +1738,21 @@ (defmethod compare-fn-name ((s wb-default-set)) (defmethod compare-fn-name ((s wb-custom-set)) (tree-set-org-compare-fn-name (wb-custom-set-org s))) +(defgeneric compare-sets (a b elt-compare-fn) + (:documentation + "Compares two sets `a' and `b', using `elt-compare-fn' to compare their +elements. Returns one of the standard FSet comparison result symbols, `:equal', +`:less', `:greater', or `:unequal'.")) + +;;; Help users out since the default default is still `nil'. +(defmethod compare-sets ((a null) (b null) elt-compare-fn) + (declare (ignore elt-compare-fn)) + ':equal) + +(defmethod compare-sets ((a wb-set) (b wb-set) elt-compare-fn) + (declare (type function elt-compare-fn)) + (WB-Set-Tree-Compare (wb-set-contents a) (wb-set-contents b) elt-compare-fn)) + (define-wb-set-method empty? ((s wb-set)) (null (contents s))) @@ -1632,12 +1773,15 @@ (define-wb-set-method contains? ((s wb-set) x &optional (y nil y?)) (WB-Set-Tree-Contains? (contents s) x (compare-fn s))) ;;; Note, first value is `t' or `nil'. -(define-wb-set-method lookup ((s wb-set) key) +(define-wb-set-methods (lookup fset2:lookup) ((s wb-set) key) (WB-Set-Tree-Find-Equal (contents s) key (compare-fn s))) (define-wb-set-method rank ((s wb-set) x) (let ((found? rank (WB-Set-Tree-Rank (contents s) x (compare-fn s)))) (values (if found? rank (1- rank)) found?))) +(define-wb-set-method fset2:rank ((s wb-set) x) + (let ((found? rank (WB-Set-Tree-Rank (contents s) x (compare-fn s)))) + (values rank found?))) (define-wb-set-method at-rank ((s wb-set) rank) (let ((contents (contents s)) @@ -1716,8 +1860,8 @@ (define-wb-set-method union ((s1 wb-set) (s2 wb-set) &key) (defmethod intersection ((s1 set) (s2 set) &key) "Fallback method for mixed implementations." (let ((result (empty-set-like s1))) - (do-set (x s2) - (when (contains? s1 x) + (do-set (x s1) + (when (contains? s2 x) (includef result x))) result)) @@ -1800,23 +1944,26 @@ (define-wb-set-method disjoint? ((s1 wb-set) (s2 wb-set)) (WB-Set-Tree-Disjoint? (contents s1) (contents s2) (compare-fn s1)) (call-next-method))) +(defmethod compare ((s1 wb-set) (s2 wb-set)) + ;; Just as comparing sets of different classes just compares the classes, so comparing WB-sets + ;; with different compare-fns just compares the compare-fns. + (let ((name-comp (compare (wb-set-compare-fn-name s1) (wb-set-compare-fn-name s2)))) + (ecase name-comp + ((:less :greater) + name-comp) + (:equal + ;; Hoo boy. The compare-fn has been redefined since one of the sets was created. + ;; Update them and try again. + (compare (convert 'wb-set s1 :compare-fn-name (wb-set-compare-fn-name s1)) + (convert 'wb-set s2 :compare-fn-name (wb-set-compare-fn-name s1)))) + (:unequal + ;; Shouldn't be possible, since we check the symbol-package in `empty-wb-custom-set'. + (error "Can't compare wb-sets with uninterned compare-fn-names with same symbol-name"))))) + (define-wb-set-method compare ((s1 wb-set) (s2 wb-set)) (if-same-compare-fns (s1 s2) (WB-Set-Tree-Compare (contents s1) (contents s2) (compare-fn s1)) - ;; Just as comparing sets of different classes just compares the classes, so comparing WB-sets - ;; with different compare-fns just compares the compare-fns. - (let ((name-comp (compare (wb-set-compare-fn-name s1) (wb-set-compare-fn-name s2)))) - (ecase name-comp - ((:less :greater) - name-comp) - (:equal - ;; Hoo boy. The compare-fn has been redefined since one of the sets was created. - ;; Update them and try again. - (compare (convert 'wb-set s1 :compare-fn-name (wb-set-compare-fn-name s1)) - (convert 'wb-set s2 :compare-fn-name (wb-set-compare-fn-name s1)))) - (:unequal - ;; Shouldn't be possible, since we check the symbol-package in `empty-wb-custom-set'. - (error "Can't compare wb-sets with uninterned compare-fn-names with same symbol-name")))))) + (call-next-method))) (define-wb-set-method hash-value ((s wb-set)) ;; I expect this to be rarely used, so I don't want to make everybody pay the cost of a @@ -1853,14 +2000,16 @@ (define-wb-set-method fun-iterator ((s wb-set) &key from-end?) (WB-Set-Tree-Rev-Fun-Iter (contents s)) (WB-Set-Tree-Fun-Iter (contents s)))) -(define-wb-set-method filter ((pred function) (s wb-set)) +(define-wb-set-methods (filter fset2:filter) ((pred function) (s wb-set)) (make s (wb-set-filter pred (contents s) (compare-fn s)))) -(define-wb-set-method filter ((pred symbol) (s wb-set)) +(define-wb-set-methods (filter fset2:filter) ((pred symbol) (s wb-set)) (make s (wb-set-filter (coerce-to-function pred) (contents s) (compare-fn s)))) (define-wb-set-method filter ((pred map) (s wb-set)) (make s (wb-set-filter #'(lambda (x) (lookup pred x)) (contents s) (compare-fn s)))) +(define-wb-set-method fset2:filter ((pred map) (s wb-set)) + (make s (wb-set-filter #'(lambda (x) (fset2:lookup pred x)) (contents s) (compare-fn s)))) (defun wb-set-filter (pred contents compare-fn) (declare (optimize (speed 3) (safety 0)) @@ -1872,24 +2021,27 @@ (define-wb-set-method filter ((pred map) (s wb-set)) result)) ;;; A set is another kind of boolean-valued map. -(defmethod filter ((pred set) (s set)) +(define-methods (filter fset2:filter) ((pred set) (s set)) (intersection pred s)) ;;; A bag is yet another kind of boolean-valued map. -(defmethod filter ((pred bag) (s set)) +(define-methods (filter fset2:filter) ((pred bag) (s set)) (intersection pred s)) -(define-wb-set-method partition ((pred function) (s wb-set)) +(define-wb-set-methods (partition fset2:partition) ((pred function) (s wb-set)) (let ((res1 res2 (wb-set-partition pred (contents s) (compare-fn s)))) (values (make s res1) (make s res2)))) -(define-wb-set-method partition ((pred symbol) (s wb-set)) +(define-wb-set-methods (partition fset2:partition) ((pred symbol) (s wb-set)) (let ((res1 res2 (wb-set-partition (coerce-to-function pred) (contents s) (compare-fn s)))) (values (make s res1) (make s res2)))) (define-wb-set-method partition ((pred map) (s wb-set)) (let ((res1 res2 (wb-set-partition #'(lambda (x) (lookup pred x)) (contents s) (compare-fn s)))) (values (make s res1) (make s res2)))) +(define-wb-set-method fset2:partition ((pred map) (s wb-set)) + (let ((res1 res2 (wb-set-partition #'(lambda (x) (fset2:lookup pred x)) (contents s) (compare-fn s)))) + (values (make s res1) (make s res2)))) (defun wb-set-partition (pred contents compare-fn) (declare (optimize (speed 3) (safety 0)) @@ -1902,27 +2054,30 @@ (define-wb-set-method partition ((pred map) (s wb-set)) (setq result-2 (WB-Set-Tree-With result-2 x compare-fn)))) (values result-1 result-2))) -(define-wb-set-method image ((fn function) (s wb-set) &key compare-fn-name) +(define-wb-set-methods (image fset2:image) ((fn function) (s wb-set) &key compare-fn-name) (wb-set-image fn (contents s) (or compare-fn-name (compare-fn-name s)))) -(define-wb-set-method image ((fn symbol) (s wb-set) &key compare-fn-name) +(define-wb-set-methods (image fset2:image) ((fn symbol) (s wb-set) &key compare-fn-name) (wb-set-image (coerce-to-function fn) (contents s) (or compare-fn-name (compare-fn-name s)))) (define-wb-set-method image ((fn map) (s wb-set) &key compare-fn-name) - (wb-set-image fn (contents s) (or compare-fn-name (compare-fn-name s)))) + (wb-set-image (fn (x) (lookup fn x)) (contents s) (or compare-fn-name (compare-fn-name s)))) +(define-wb-set-method fset2:image ((fn map) (s wb-set) &key compare-fn-name) + (wb-set-image (fn (x) (fset2:lookup fn x)) (contents s) (or compare-fn-name (compare-fn-name s)))) -(define-wb-set-method image ((fn set) (s wb-set) &key compare-fn-name) - (wb-set-image fn (contents s) (or compare-fn-name (compare-fn-name s)))) +(define-wb-set-methods (image fset2:image) ((fn set) (s wb-set) &key compare-fn-name) + (wb-set-image (fn (x) (lookup fn x)) (contents s) (or compare-fn-name (compare-fn-name s)))) -(define-wb-set-method image ((fn bag) (s wb-set) &key compare-fn-name) - (wb-set-image fn (contents s) (or compare-fn-name (compare-fn-name s)))) +(define-wb-set-methods (image fset2:image) ((fn bag) (s wb-set) &key compare-fn-name) + (wb-set-image (fn (x) (lookup fn x)) (contents s) (or compare-fn-name (compare-fn-name s)))) (defun wb-set-image (fn contents compare-fn-name) + (declare (type function fn)) (let ((org (wb-set-org (empty-wb-set compare-fn-name))) (result nil)) (do-wb-set-tree-members (x contents) - (setq result (WB-Set-Tree-With result (@ fn x) (tree-set-org-compare-fn org)))) + (setq result (WB-Set-Tree-With result (funcall fn x) (tree-set-org-compare-fn org)))) (make-wb-set result org))) (defmethod reduce ((fn function) (s set) &key key (initial-value nil init?)) @@ -1955,7 +2110,7 @@ (defmethod sort ((s set) pred &key key) (defmethod stable-sort ((s set) pred &key key) (convert 'seq (cl:stable-sort (convert 'vector s) pred :key key))) -(defmethod convert ((to-type (eql 'set)) (s set) &key) +(define-convert-methods (set fset2:set) ((s set) &key) s) (defmethod convert ((to-type (eql 'wb-set)) (s set) &key compare-fn-name) @@ -1989,6 +2144,8 @@ (defmethod convert ((to-type (eql 'vector)) (s set) &key) (defmethod convert ((to-type (eql 'set)) (l list) &key input-sorted?) (make-wb-set (wb-set-from-list l input-sorted? #'compare))) +(defmethod convert ((to-type (eql 'fset2:set)) (l list) &key) + (convert 'ch-set l)) (defmethod convert ((to-type (eql 'wb-set)) (l list) &key input-sorted? compare-fn-name) (convert-to-wb-set s nil @@ -2001,6 +2158,8 @@ (defmethod convert ((to-type (eql 'wb-set)) (l list) &key input-sorted? compare- (defmethod convert ((to-type (eql 'set)) (s seq) &key input-sorted?) (make-wb-set (wb-set-from-sequence s input-sorted? #'compare))) +(defmethod convert ((to-type (eql 'fset2:set)) (s seq) &key) + (convert 'ch-set s)) (defmethod convert ((to-type (eql 'wb-set)) (s seq) &key input-sorted? compare-fn-name) (convert-to-wb-set s nil @@ -2008,6 +2167,8 @@ (defmethod convert ((to-type (eql 'wb-set)) (s seq) &key input-sorted? compare-f (defmethod convert ((to-type (eql 'set)) (s sequence) &key input-sorted?) (make-wb-set (wb-set-from-sequence s input-sorted? #'compare))) +(defmethod convert ((to-type (eql 'fset2:set)) (s sequence) &key) + (convert 'ch-set s)) (defmethod convert ((to-type (eql 'wb-set)) (s sequence) &key input-sorted? compare-fn-name) (convert-to-wb-set s nil @@ -2020,17 +2181,17 @@ (defmethod convert ((to-type (eql 'wb-set)) (s sequence) &key input-sorted? comp (defmethod find (item (s set) &key key test) (declare (optimize (speed 3) (safety 0))) - (let ((test (coerce-to-function-or-equal? test))) + (let ((test default? (coerce-to-function-or-equal? test))) (if key (let ((key (coerce-to-function key))) (do-set (x s) (when (funcall test item (funcall key x)) (return x)))) - (if (not (eq test #'equal?)) - (do-set (x s) - (when (funcall test item x) - (return x))) - (nth-value 1 (lookup s item)))))) + (if (and default? (eq (compare-fn s) #'compare)) + (nth-value 1 (lookup s item)) + (do-set (x s) + (when (funcall test item x) + (return x))))))) (defmethod find-if (pred (s set) &key key) (declare (optimize (speed 3) (safety 0))) @@ -2059,8 +2220,8 @@ (defmethod count (item (s set) &key key test) (do-set (x s total) (when (funcall test item (funcall key x)) (incf total)))) - (if default? - (if (lookup s item) 1 0) + (if (and default? (eq (compare-fn s) #'compare)) + (if (contains? s item) 1 0) (let ((total 0)) (declare (fixnum total)) (do-set (x s total) @@ -2128,6 +2289,8 @@ (defstruct (hash-set-org (compare-fn nil :type function :read-only t) (hash-fn nil :type function :read-only t)) +(defparameter +fset-default-hash-set-org+ (make-hash-set-org 'compare #'compare #'hash-value)) + (declaim (inline make-ch-set)) (defstruct (ch-set @@ -2139,16 +2302,29 @@ (defstruct (ch-set (contents nil :read-only t) (org nil :type hash-set-org :read-only t)) -(defparameter *empty-ch-set* (make-ch-set nil (make-hash-set-org 'compare #'compare #'hash-value))) +(defparameter +empty-ch-set+ (make-ch-set nil +fset-default-hash-set-org+)) + +(declaim (inline fset2:empty-set)) +(defun fset2:empty-set () + "Returns an empty set of the default implementation." + +empty-ch-set+) -(declaim (inline empty-ch-set)) +(declaim (inline empty-ch-set fset2:empty-ch-set)) (defun empty-ch-set (&optional compare-fn-name) "Returns an empty ch-set. By default, it will use `fset:compare' to compare values, and `fset:hash-value' to hash them; to use a custom comparison and hash, use `define-hash-function' to associate them, and then supply the name of the comparison function as `compare-fn-name'." (if (null compare-fn-name) - *empty-ch-set* + +empty-ch-set+ + (empty-ch-custom-set compare-fn-name))) +(defun fset2:empty-ch-set (&key compare-fn-name) + "Returns an empty ch-set. By default, it will use `fset:compare' to compare +values, and `fset:hash-value' to hash them; to use a custom comparison and hash, +use `define-hash-function' to associate them, and then supply the name of the +comparison function as `compare-fn-name'." + (if (null compare-fn-name) + +empty-ch-set+ (empty-ch-custom-set compare-fn-name))) (deflex +empty-ch-custom-set-cache+ (make-hash-table :test 'eq)) @@ -2157,7 +2333,7 @@ (defstruct (ch-set (assert (and compare-fn-name (symbolp compare-fn-name) (symbol-package compare-fn-name)) () "compare-fn-name must be a nonnull interned symbol") (if (eq compare-fn-name 'compare) - *empty-ch-set* + +empty-ch-set+ (let ((prev-instance (gethash compare-fn-name +empty-ch-custom-set-cache+)) (compare-fn (symbol-function compare-fn-name)) (hash-fn-name (or (get compare-fn-name 'hash-function) @@ -2172,9 +2348,6 @@ (defstruct (ch-set (setf (gethash compare-fn-name +empty-ch-custom-set-cache+) (make-ch-set nil (make-hash-set-org compare-fn-name compare-fn hash-fn))))))) -(defmethod empty-instance-function ((class-name (eql 'ch-set))) - 'empty-ch-set) - (defmethod empty-set-like ((s ch-set)) (empty-ch-set (hash-set-org-compare-fn-name (ch-set-org s)))) @@ -2205,7 +2378,7 @@ (defmethod contains? ((s ch-set) x &optional (y nil y?)) (ch-set-tree-contains? (ch-set-contents s) x (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)))) -(defmethod lookup ((s ch-set) key) +(define-methods (lookup fset2:lookup) ((s ch-set) key) (let ((hsorg (ch-set-org s))) (ch-set-tree-contains? (ch-set-contents s) key (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)))) @@ -2271,7 +2444,7 @@ (defmethod set-difference ((s1 ch-set) (s2 ch-set) &key) (defmethod set-difference-rev ((s1 ch-set) (s2 ch-set)) (if-same-ch-set-orgs (s1 s2 hsorg) - (make-ch-set (ch-set-tree-diff (ch-set-contents s1) (ch-set-contents s2) + (make-ch-set (ch-set-tree-diff (ch-set-contents s2) (ch-set-contents s1) (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)) hsorg) @@ -2297,12 +2470,12 @@ (defmethod disjoint? ((s1 ch-set) (s2 ch-set)) (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)) (call-next-method))) -(defmethod partition ((pred function) (s ch-set)) +(define-methods (partition fset2:partition) ((pred function) (s ch-set)) (let ((hsorg (ch-set-org s)) ((res1 res2 (ch-set-partition pred (ch-set-contents s) hsorg)))) (values (make-ch-set res1 hsorg) (make-ch-set res2 hsorg)))) -(defmethod partition ((pred symbol) (s ch-set)) +(define-methods (partition fset2:partition) ((pred symbol) (s ch-set)) (let ((hsorg (ch-set-org s)) ((res1 res2 (ch-set-partition (coerce-to-function pred) (ch-set-contents s) hsorg)))) (values (make-ch-set res1 hsorg) (make-ch-set res2 hsorg)))) @@ -2311,6 +2484,10 @@ (defmethod partition ((pred map) (s ch-set)) (let ((hsorg (ch-set-org s)) ((res1 res2 (ch-set-partition #'(lambda (x) (lookup pred x)) (ch-set-contents s) hsorg)))) (values (make-ch-set res1 hsorg) (make-ch-set res2 hsorg)))) +(defmethod fset2:partition ((pred map) (s ch-set)) + (let ((hsorg (ch-set-org s)) + ((res1 res2 (ch-set-partition #'(lambda (x) (fset2:lookup pred x)) (ch-set-contents s) hsorg)))) + (values (make-ch-set res1 hsorg) (make-ch-set res2 hsorg)))) (defun ch-set-partition (pred contents hsorg) (declare (optimize (speed 3) (safety 0)) @@ -2325,14 +2502,16 @@ (defmethod partition ((pred map) (s ch-set)) (setq result-2 (ch-set-tree-with result-2 x hash-fn compare-fn)))) (values result-1 result-2))) -(defmethod filter ((pred function) (s ch-set)) +(define-methods (filter fset2:filter) ((pred function) (s ch-set)) (ch-set-filter pred s)) -(defmethod filter ((pred symbol) (s ch-set)) +(define-methods (filter fset2:filter) ((pred symbol) (s ch-set)) (ch-set-filter (coerce-to-function pred) s)) (defmethod filter ((pred map) (s ch-set)) (ch-set-filter #'(lambda (x) (lookup pred x)) s)) +(defmethod fset2:filter ((pred map) (s ch-set)) + (ch-set-filter #'(lambda (x) (fset2:lookup pred x)) s)) (defun ch-set-filter (pred s) (declare (optimize (speed 3) (safety 0)) @@ -2345,26 +2524,29 @@ (defmethod filter ((pred map) (s ch-set)) (hash-set-org-compare-fn hsorg))))) (make-ch-set result hsorg))) -(defmethod image ((fn function) (s ch-set) &key compare-fn-name) +(define-methods (image fset2:image) ((fn function) (s ch-set) &key compare-fn-name) (ch-set-image fn s compare-fn-name)) -(defmethod image ((fn symbol) (s ch-set) &key compare-fn-name) +(define-methods (image fset2:image) ((fn symbol) (s ch-set) &key compare-fn-name) (ch-set-image (coerce-to-function fn) s compare-fn-name)) (defmethod image ((fn map) (s ch-set) &key compare-fn-name) - (ch-set-image fn s compare-fn-name)) + (ch-set-image (fn (x) (lookup fn x)) s compare-fn-name)) +(defmethod fset2:image ((fn map) (s ch-set) &key compare-fn-name) + (ch-set-image (fn (x) (fset2:lookup fn x)) s compare-fn-name)) -(defmethod image ((fn set) (s ch-set) &key compare-fn-name) - (ch-set-image fn s compare-fn-name)) +(define-methods (image fset2:image) ((fn set) (s ch-set) &key compare-fn-name) + (ch-set-image (fn (x) (lookup fn x)) s compare-fn-name)) -(defmethod image ((fn bag) (s ch-set) &key compare-fn-name) - (ch-set-image fn s compare-fn-name)) +(define-methods (image fset2:image) ((fn bag) (s ch-set) &key compare-fn-name) + (ch-set-image (fn (x) (lookup fn x)) s compare-fn-name)) (defun ch-set-image (fn s compare-fn-name) + (declare (type function fn)) (let ((result nil) (hsorg (ch-set-org (if compare-fn-name (empty-ch-set compare-fn-name) s)))) (do-ch-set-tree-members (x (ch-set-contents s)) - (setq result (ch-set-tree-with result (@ fn x) (hash-set-org-hash-fn hsorg) + (setq result (ch-set-tree-with result (funcall fn x) (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)))) (make-ch-set result hsorg))) @@ -2472,22 +2654,25 @@ (defstruct (wb-bag (contents nil :read-only t) (org nil :type tree-set-org :read-only t)) -(defparameter *empty-wb-bag* (make-wb-bag nil +fset-default-tree-set-org+)) +(defparameter +empty-wb-bag+ (make-wb-bag nil +fset-default-tree-set-org+)) (declaim (inline empty-bag)) (defun empty-bag () "Returns an empty bag of the default implementation and type." - *empty-wb-bag*) - -(defmethod empty-instance-function ((class-name (eql 'bag))) - 'empty-bag) + +empty-wb-bag+) -(declaim (inline empty-wb-bag)) +(declaim (inline empty-wb-bag fset2:empty-wb-bag)) (defun empty-wb-bag (&optional compare-fn-name) "Returns an empty `wb-bag' ordered according to `compare-fn-name', which must be a symbol." (if (null compare-fn-name) - *empty-wb-bag* + +empty-wb-bag+ + (empty-wb-custom-bag compare-fn-name))) +(defun fset2:empty-wb-bag (&key compare-fn-name) + "Returns an empty `wb-bag' ordered according to `compare-fn-name', which +must be a symbol." + (if (null compare-fn-name) + +empty-wb-bag+ (empty-wb-custom-bag compare-fn-name))) (deflex +empty-wb-custom-bag-cache+ (make-hash-table :test 'eq)) @@ -2496,7 +2681,7 @@ (defmethod empty-instance-function ((class-name (eql 'bag))) (assert (and compare-fn-name (symbolp compare-fn-name) (symbol-package compare-fn-name)) () "compare-fn-name must be a nonnull interned symbol") (if (eq compare-fn-name 'compare) - *empty-wb-bag* + +empty-wb-bag+ (let ((prev-instance (gethash compare-fn-name +empty-wb-custom-bag-cache+)) (compare-fn (symbol-function compare-fn-name))) (if (and prev-instance @@ -2505,13 +2690,15 @@ (defmethod empty-instance-function ((class-name (eql 'bag))) (setf (gethash compare-fn-name +empty-wb-custom-bag-cache+) (make-wb-bag nil (make-tree-set-org compare-fn-name compare-fn))))))) -(defmethod empty-instance-function ((class-name (eql 'wb-bag))) - 'empty-wb-bag) - (defmethod empty-set-like ((b wb-bag)) (let ((tsorg (wb-bag-org b))) (empty-wb-custom-set (tree-set-org-compare-fn-name tsorg)))) +(defgeneric empty-bag-like (b) + (:documentation + "Returns an empty bag of the same implementation, and using the same compare +or hash function, as `b'. `b' can also be a set.")) + (defmethod empty-bag-like ((b wb-bag)) (let ((tsorg (wb-bag-org b))) (empty-wb-custom-bag (tree-set-org-compare-fn-name tsorg)))) @@ -2548,11 +2735,18 @@ (defmethod lookup ((b wb-bag) x) (if (plusp mult) (values t value-found) (values nil nil)))) +(defmethod fset2:lookup ((b wb-bag) x) + (WB-Bag-Tree-Multiplicity (wb-bag-contents b) x + (tree-set-org-compare-fn (wb-bag-org b)))) (defmethod rank ((b wb-bag) x) "Returns the rank in the set ordering, i.e. the upper bound is the `set-size'." (let ((found? rank (WB-Bag-Tree-Rank (wb-bag-contents b) x (tree-set-org-compare-fn (wb-bag-org b))))) (values (if found? rank (1- rank)) found?))) +(defmethod fset2:rank ((b wb-bag) x) + "Returns the rank in the set ordering, i.e. the upper bound is the `set-size'." + (let ((found? rank (WB-Bag-Tree-Rank (wb-bag-contents b) x (tree-set-org-compare-fn (wb-bag-org b))))) + (values rank found?))) (defmethod at-rank ((s wb-bag) rank) "Takes the rank in the set ordering, i.e. the upper bound is the `set-size'." @@ -2614,9 +2808,10 @@ (defmethod less ((b wb-bag) value &optional (multiplicity 1)) (defmethod split-from ((b wb-bag) value) (let ((compare-fn (tree-set-org-compare-fn (wb-bag-org b))) - ((new-contents (WB-Bag-Tree-Split-Above (wb-bag-contents b) value compare-fn)))) - (make-wb-bag (if (< 0 (WB-Bag-Tree-Multiplicity (wb-bag-contents b) value compare-fn)) - (WB-Bag-Tree-With new-contents value compare-fn) + ((new-contents (WB-Bag-Tree-Split-Above (wb-bag-contents b) value compare-fn)) + (count (WB-Bag-Tree-Multiplicity (wb-bag-contents b) value compare-fn)))) + (make-wb-bag (if (plusp count) + (WB-Bag-Tree-With new-contents value compare-fn count) new-contents) (wb-bag-org b)))) @@ -2626,9 +2821,10 @@ (defmethod split-above ((b wb-bag) value) (defmethod split-through ((b wb-bag) value) (let ((compare-fn (tree-set-org-compare-fn (wb-bag-org b))) - ((new-contents (WB-Bag-Tree-Split-Below (wb-bag-contents b) value compare-fn)))) - (make-wb-bag (if (< 0 (WB-Bag-Tree-Multiplicity (wb-bag-contents b) value compare-fn)) - (WB-Bag-Tree-With new-contents value compare-fn) + ((new-contents (WB-Bag-Tree-Split-Below (wb-bag-contents b) value compare-fn)) + (count (WB-Bag-Tree-Multiplicity (wb-bag-contents b) value compare-fn)))) + (make-wb-bag (if (plusp count) + (WB-Bag-Tree-With new-contents value compare-fn count) new-contents) (wb-bag-org b)))) @@ -2639,10 +2835,12 @@ (defmethod split-below ((b wb-bag) value) (defmethod union ((b1 bag) (b2 bag) &key) "Fallback method for mixed implementations." (let ((result b1)) - (do-bag-pairs (x n2 b2) - (let ((n1 (multiplicity result x))) - (when (< n1 n2) - (includef result x (- n2 n1))))) + (do-bag-pairs (x2 n2 b2) + (let ((n1 x1 (multiplicity result x2))) + (cond ((zerop n1) + (includef result x2 n2)) + ((< n1 n2) + (includef result x1 (- n2 n1)))))) result)) (defmethod union ((b1 wb-bag) (b2 wb-bag) &key) @@ -2663,16 +2861,20 @@ (defmethod union ((b wb-bag) (s wb-set) &key) (let ((scmp (wb-set-compare-fn s)) (bcmp (tree-set-org-compare-fn (wb-bag-org b)))) (if (eq scmp bcmp) - (make-wb-bag (WB-Bag-Tree-Union (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) - (wb-bag-contents b) bcmp) + (make-wb-bag (WB-Bag-Tree-Union (wb-bag-contents b) (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) + bcmp) (wb-bag-org b)) (call-next-method)))) (defmethod union ((s set) (b bag) &key) "Fallback method for mixed implementations." (let ((result (convert 'bag s))) - (do-bag-pairs (x n b) - (setq result (with result x (- n (if (contains? s x) 1 0))))) + (do-bag-pairs (xb n b) + (let ((xs? xs (lookup s xb))) + (cond ((not xs?) + (includef result xb n)) + ((> n 1) + (includef result xs (1- n)))))) result)) (defmethod union ((s wb-set) (b wb-bag) &key) @@ -2687,8 +2889,11 @@ (defmethod union ((s wb-set) (b wb-bag) &key) (defmethod bag-sum ((b1 bag) (b2 bag)) "Fallback method for mixed implementations." (let ((result b1)) - (do-bag-pairs (x n b2) - (includef result x n)) + (do-bag-pairs (x2 n2 b2) + (let ((n1 x1 (multiplicity b1 x2))) + (if (zerop n1) + (includef result x2 n2) + (includef result x1 n2)))) result)) (defmethod bag-sum ((b1 wb-bag) (b2 wb-bag)) @@ -2701,15 +2906,16 @@ (defmethod bag-sum ((b bag) (s set)) "Fallback method for mixed implementations." (let ((result b)) (do-set (x s) - (setq result (with result x))) + (let ((nb xb (multiplicity b x))) + (includef result (if (zerop nb) x xb)))) result)) (defmethod bag-sum ((b wb-bag) (s wb-set)) (let ((scmp (wb-set-compare-fn s)) (bcmp (tree-set-org-compare-fn (wb-bag-org b)))) (if (eq scmp bcmp) - (make-wb-bag (WB-Bag-Tree-Sum (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) - (wb-bag-contents b) bcmp) + (make-wb-bag (WB-Bag-Tree-Sum (wb-bag-contents b) + (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) bcmp) (wb-bag-org b)) (call-next-method)))) @@ -2717,7 +2923,9 @@ (defmethod bag-sum ((s set) (b bag)) "Fallback method for mixed implementations." (let ((result (convert 'bag s))) (do-bag-pairs (x n b) - (setq result (with result x n))) + (let ((xs? xs (lookup s x))) + (if xs? (includef result xs n) + (includef result x n)))) result)) (defmethod bag-sum ((s wb-set) (b wb-bag)) @@ -2732,8 +2940,8 @@ (defmethod bag-sum ((s wb-set) (b wb-bag)) (defmethod intersection ((b1 bag) (b2 bag) &key) "Fallback method for mixed implementations." (let ((result (empty-bag-like b1))) - (do-bag-pairs (x n2 b2) - (includef result x (min (multiplicity b1 x) n2))) + (do-bag-pairs (x1 n1 b1) + (includef result x1 (min (multiplicity b2 x1) n1))) result)) (defmethod intersection ((b1 wb-bag) (b2 wb-bag) &key) @@ -2764,9 +2972,8 @@ (defmethod intersection ((b wb-bag) (s wb-set) &key) (defmethod intersection ((s set) (b bag) &key) "Fallback method for mixed implementations." (let ((result (empty-set-like s))) - (do-bag-pairs (x n b) - (declare (ignore n)) - (when (contains? s x) + (do-set (x s) + (when (contains? b x) (includef result x))) result)) @@ -2774,16 +2981,18 @@ (defmethod intersection ((s wb-set) (b wb-bag) &key) (let ((scmp (wb-set-compare-fn s)) (bcmp (tree-set-org-compare-fn (wb-bag-org b)))) (if (eq scmp bcmp) - (make-wb-set (WB-Set-Tree-Intersect (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)) - (wb-set-contents s) bcmp) + (make-wb-set (WB-Set-Tree-Intersect (wb-set-contents s) (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)) + bcmp) (wb-set-org s)) (call-next-method)))) (defmethod bag-product ((b1 bag) (b2 bag)) "Fallback method for mixed implementations." (let ((result (empty-bag-like b1))) - (do-bag-pairs (x n2 b2) - (includef result x (* (multiplicity b1 x) n2))) + (do-bag-pairs (x2 n2 b2) + (let ((n1 x1 (multiplicity b1 x2))) + (unless (zerop n1) + (includef result x1 (* n1 n2))))) result)) (defmethod bag-product ((b1 wb-bag) (b2 wb-bag)) @@ -2805,17 +3014,18 @@ (defmethod bag-product ((b wb-bag) (s wb-set)) (let ((scmp (wb-set-compare-fn s)) (bcmp (tree-set-org-compare-fn (wb-bag-org b)))) (if (eq scmp bcmp) - (make-wb-bag (WB-Bag-Tree-Product (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) - (wb-bag-contents b) bcmp) + (make-wb-bag (WB-Bag-Tree-Product (wb-bag-contents b) (WB-Set-Tree-To-Bag-Tree (wb-set-contents s)) + bcmp) (wb-bag-org b)) (call-next-method)))) (defmethod bag-product ((s set) (b bag)) "Fallback method for mixed implementations." - (let ((result (empty-bag-like s))) - (do-bag-pairs (x n b) - (when (contains? s x) - (includef result x n))) + (let ((result (convert 'bag (empty-set-like s)))) + (do-bag-pairs (xb n b) + (let ((xs? xs (lookup s xb))) + (when xs? + (includef result xs n)))) result)) (defmethod bag-product ((s wb-set) (b wb-bag)) @@ -2881,7 +3091,7 @@ (defmethod subbag? ((b1 bag) (b2 bag)) (return nil)))) (defmethod subbag? ((b1 wb-bag) (b2 wb-bag)) - (if-same-wb-bag-orgs (b2 b2 tsorg) + (if-same-wb-bag-orgs (b1 b2 tsorg) (WB-Bag-Tree-Subbag? (wb-bag-contents b1) (wb-bag-contents b2) (tree-set-org-compare-fn tsorg)) (call-next-method))) @@ -2924,8 +3134,13 @@ (defmethod disjoint? ((b1 wb-bag) (b2 wb-bag)) (defmethod disjoint? ((b wb-bag) (s wb-set)) (bag-set-disjoint? b s)) +(defmethod disjoint? ((b wb-bag) (s ch-set)) + (bag-set-disjoint? b s)) + (defmethod disjoint? ((s wb-set) (b wb-bag)) (bag-set-disjoint? b s)) +(defmethod disjoint? ((s ch-set) (b wb-bag)) + (bag-set-disjoint? b s)) (defun bag-set-disjoint? (b s) ;; Too lazy to write the WB hedge algorithm. Maybe l8r. @@ -2995,27 +3210,30 @@ (defmethod fun-iterator ((s wb-bag) &key pairs? from-end?) (WB-Bag-Tree-Rev-Fun-Iter (wb-bag-contents s)) (WB-Bag-Tree-Fun-Iter (wb-bag-contents s))))) -(defmethod filter ((pred function) (b bag)) +(define-methods (filter fset2:filter) ((pred function) (b bag)) (bag-filter pred b)) -(defmethod filter ((pred symbol) (b bag)) +(define-methods (filter fset2:filter) ((pred symbol) (b bag)) (bag-filter (coerce-to-function pred) b)) (defmethod filter ((pred map) (b bag)) - (bag-filter pred b)) + (bag-filter (fn (x) (lookup pred x)) b)) +(defmethod fset2:filter ((pred map) (b bag)) + (bag-filter (fn (x) (fset2:lookup pred x)) b)) (defun bag-filter (pred b) (let ((result (empty-bag-like b))) (do-bag-pairs (x n b) - (when (@ pred x) + (when (funcall pred x) (setq result (with result x n)))) result)) -(defmethod filter ((pred set) (b bag)) +(define-methods (filter fset2:filter) ((pred set) (b bag)) (bag-product (convert 'bag pred) b)) -(defmethod filter ((pred bag) (b bag)) - (bag-filter pred b)) +(define-methods (filter fset2:filter) ((pred bag) (b bag)) + ;; Not quite the same as bag intersection. + (bag-filter (fn (x) (contains? pred x)) b)) (defmethod filter-pairs ((pred function) (b bag)) (bag-filter-pairs pred b)) @@ -3030,26 +3248,29 @@ (defmethod filter-pairs ((pred symbol) (b bag)) (setq result (with result x n)))) result)) -(defmethod image ((fn function) (b bag) &key compare-fn-name) +(define-methods (image fset2:image) ((fn function) (b bag) &key compare-fn-name) (bag-image fn b compare-fn-name)) -(defmethod image ((fn symbol) (b bag) &key compare-fn-name) +(define-methods (image fset2:image) ((fn symbol) (b bag) &key compare-fn-name) (bag-image (coerce-to-function fn) b compare-fn-name)) (defmethod image ((fn map) (b bag) &key compare-fn-name) - (bag-image fn b compare-fn-name)) + (bag-image (fn (x) (lookup fn x)) b compare-fn-name)) +(defmethod fset2:image ((fn map) (b bag) &key compare-fn-name) + (bag-image (fn (x) (fset2:lookup fn x)) b compare-fn-name)) -(defmethod image ((fn set) (b bag) &key compare-fn-name) - (bag-image fn b compare-fn-name)) +(define-methods (image fset2:image) ((fn set) (b bag) &key compare-fn-name) + (bag-image (fn (x) (lookup fn x)) b compare-fn-name)) -(defmethod image ((fn bag) (b bag) &key compare-fn-name) - (bag-image fn b compare-fn-name)) +(define-methods (image fset2:image) ((fn bag) (b bag) &key compare-fn-name) + (bag-image (fn (x) (lookup fn x)) b compare-fn-name)) (defun bag-image (fn b compare-fn-name) + (declare (type function fn)) (let ((org (wb-bag-org (if compare-fn-name (empty-wb-bag compare-fn-name) b))) (result nil)) (do-bag-pairs (x n b) - (setq result (WB-Bag-Tree-With result (@ fn x) (tree-set-org-compare-fn org) n))) + (setq result (WB-Bag-Tree-With result (funcall fn x) (tree-set-org-compare-fn org) n))) (make-wb-bag result org))) (defmethod reduce ((fn function) (b bag) &key key (initial-value nil init?)) @@ -3089,7 +3310,7 @@ (defmethod convert ((to-type (eql 'wb-bag)) (b wb-bag) &key compare-fn-name) (do-wb-bag-tree-pairs (x n (wb-bag-contents b) tree) (setq tree (WB-Bag-Tree-With tree x compare-fn n)))))) -(defmethod convert ((to-type (eql 'set)) (b wb-bag) &key) +(define-convert-methods (set fset2:set) ((b wb-bag) &key) (make-wb-set (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)) (wb-bag-org b))) (defmethod convert ((to-type (eql 'wb-set)) (b wb-bag) &key compare-fn-name) @@ -3175,19 +3396,19 @@ (defmethod convert ((to-type (eql 'wb-bag)) (s sequence) &key input-sorted? pair (defmethod find (item (b bag) &key key test) (declare (optimize (speed 3) (safety 0))) - (let ((test (coerce-to-function-or-equal? test))) + (let ((test default? (coerce-to-function-or-equal? test))) (if key (let ((key (coerce-to-function key))) (do-bag-pairs (x n b nil) (declare (ignore n)) (when (funcall test item (funcall key x)) (return x)))) - (if (not (eq test #'equal?)) - (do-bag-pairs (x n b nil) - (declare (ignore n)) - (when (funcall test item x) - (return x))) - (nth-value 1 (lookup b item)))))) + (if (and default? (eq (compare-fn b) #'compare)) + (nth-value 1 (lookup b item)) + (do-bag-pairs (x n b nil) + (declare (ignore n)) + (when (funcall test item x) + (return x))))))) (defmethod find-if (pred (b bag) &key key) (declare (optimize (speed 3) (safety 0))) @@ -3217,12 +3438,12 @@ (defmethod count (item (b bag) &key key test) (do-bag-pairs (x n b total) (when (funcall test item (funcall key x)) (setq total (gen + total n))))) - (if default? + (if (and default? (eq (compare-fn b) #'compare)) (multiplicity b item) - (let ((total 0)) - (do-bag-pairs (x n b total) - (when (funcall test item x) - (setq total (gen + total n))))))))) + (let ((total 0)) + (do-bag-pairs (x n b total) + (when (funcall test item x) + (setq total (gen + total n))))))))) (defmethod count-if (pred (b bag) &key key) (declare (optimize (speed 3) (safety 0))) @@ -3281,7 +3502,7 @@ (defstruct (tree-map-org (val-compare-fn-name nil :type symbol :read-only t) (val-compare-fn nil :type function :read-only t)) -(deflex +fset-default-tree-map-org+ (make-tree-map-org 'compare #'compare 'compare #'compare)) +(defparameter +fset-default-tree-map-org+ (make-tree-map-org 'compare #'compare 'compare #'compare)) (declaim (inline make-wb-map)) @@ -3296,25 +3517,50 @@ (defstruct (wb-map (contents nil :read-only t) (org nil :type tree-map-org :read-only t)) -(defparameter *empty-wb-map* (make-wb-map nil +fset-default-tree-map-org+ nil)) +(defparameter +empty-wb-map+ (make-wb-map nil +fset-default-tree-map-org+ nil)) + +(defparameter +empty-wb-map/no-default+ (make-wb-map nil +fset-default-tree-map-org+ 'no-default)) + +(declaim (inline fset2-default)) +(defun fset2-default (default? default no-default?) + (if (and default? no-default?) + (error "Both a default and `no-default?' specified") + (cond (default? default) + (no-default? 'no-default) + (t nil)))) (declaim (inline empty-map)) (defun empty-map (&optional default) "Returns an empty map of the default implementation." (if default (make-wb-map nil +fset-default-tree-map-org+ default) - *empty-wb-map*)) + +empty-wb-map+)) +;;; `fset2:empty-map' is below -(defmethod empty-instance-function ((class-name (eql 'map))) - `empty-map) - -(declaim (inline empty-wb-map)) +(declaim (inline empty-wb-map fset2:empty-wb-map)) (defun empty-wb-map (&optional default key-compare-fn-name val-compare-fn-name) - "Returns an empty wb-map." + "Returns an empty wb-map with the specified default and comparison functions." (if (and (null key-compare-fn-name) (null val-compare-fn-name)) (if (null default) - *empty-wb-map* + +empty-wb-map+ (make-wb-map nil +fset-default-tree-map-org+ default)) (empty-wb-custom-map default (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare)))) +(defun fset2:empty-wb-map (&key (default nil default?) no-default? key-compare-fn-name val-compare-fn-name) + "Returns an empty wb-map with the specified default and comparison functions. +The map's default is `nil' unless a different default is supplied, or +`no-default?' is true." + ;; The idea here is to inline the keyword argument processing and the default selection, hopefully + ;; all of which will constant-fold down to just the default in almost all cases. + (empty-wb-map-internal (fset2-default default? default no-default?) key-compare-fn-name val-compare-fn-name)) + +(defun empty-wb-map-internal (default key-compare-fn-name val-compare-fn-name) + ;; This has gotten too big to inline. + (cond ((or key-compare-fn-name val-compare-fn-name) + (empty-wb-custom-map default (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare))) + ((null default) + +empty-wb-map+) + ((eq default 'no-default) + +empty-wb-map/no-default+) + (t (make-wb-map nil +fset-default-tree-map-org+ default)))) (deflex +empty-wb-custom-map-cache+ (make-hash-table :test 'equal)) @@ -3326,7 +3572,7 @@ (defmethod empty-instance-function ((class-name (eql 'map))) (symbol-package val-compare-fn-name)) () "val-compare-fn-name must be a nonnull interned symbol") (if (and (eq key-compare-fn-name 'compare) (eq val-compare-fn-name 'compare)) - (if (null default) *empty-wb-map* + (if (null default) +empty-wb-map+ (make-wb-map nil +fset-default-tree-map-org+ default)) ;; &&& This caches one default per type. We could use a two-level map to cache multiple defaults, ;; but the inner maps would have to be custom wb-maps, whose creation couldn't call this function (!). @@ -3338,16 +3584,20 @@ (defmethod empty-instance-function ((class-name (eql 'map))) (if (and prev-instance (let ((prev-org (wb-map-org prev-instance))) (and (eq key-compare-fn (tree-map-org-key-compare-fn prev-org)) - (eq val-compare-fn (tree-map-org-val-compare-fn prev-org)) - (equal?-cmp default (map-default prev-instance) val-compare-fn)))) - prev-instance + (eq val-compare-fn (tree-map-org-val-compare-fn prev-org))))) + (if (equal?-cmp default (map-default prev-instance) val-compare-fn) + prev-instance + (setf (gethash cache-key +empty-wb-custom-map-cache+) + (make-wb-map nil (wb-map-org prev-instance) default))) (setf (gethash cache-key +empty-wb-custom-map-cache+) (make-wb-map nil (make-tree-map-org key-compare-fn-name key-compare-fn val-compare-fn-name val-compare-fn) default)))))) -(defmethod empty-instance-function ((class-name (eql 'wb-map))) - `empty-wb-map) +(defgeneric empty-map-like (m) + (:documentation + "Returns an empty map of the same implementation, and using the same compare +or hash functions, as `m'.")) (defmethod empty-map-like ((m wb-map)) (let ((tmorg (wb-map-org m))) @@ -3367,11 +3617,16 @@ (defmethod val-compare-fn-name ((m wb-map)) (tree-map-org-val-compare-fn-name (wb-map-org m))) (defmethod default ((m map)) - (map-default m)) + (let ((dflt (map-default m))) + (if (eq dflt 'no-default) (values nil nil) + (values dflt t)))) (defmethod with-default ((m wb-map) new-default) (make-wb-map (wb-map-contents m) (wb-map-org m) new-default)) +(defmethod fset2:without-default ((m wb-map)) + (make-wb-map (wb-map-contents m) (wb-map-org m) 'no-default)) + (defmethod empty? ((m wb-map)) (null (wb-map-contents m))) @@ -3405,16 +3660,39 @@ (defmethod contains? ((m wb-map) x &optional (y nil y?)) ((val? val (WB-Map-Tree-Lookup (wb-map-contents m) x (tree-map-org-key-compare-fn comp))))) (and val? (equal?-cmp val y (tree-map-org-val-compare-fn comp))))) -(defmethod lookup ((m wb-map) key) - (let ((val? val (WB-Map-Tree-Lookup (wb-map-contents m) key - (tree-map-org-key-compare-fn (wb-map-org m))))) +(define-condition fset2:lookup-error (error) + ()) + +(define-condition fset2:map-domain-error (fset2:lookup-error) + ((map :initarg :map :reader fset2:map-domain-error-map) + (key :initarg :key :reader fset2:map-domain-error-key)) + (:report (lambda (mde stream) + (let ((*print-length* 8) + (*print-level* 3)) + (format stream "Key ~S not found in map ~A, which has no default" + (fset2:map-domain-error-key mde) (fset2:map-domain-error-map mde)))))) + +;;; Even though FSet 1 code will never generate a map with no default, we could have a mixed +;;; FSet 1/2 codebase, so we should still check for that in `fset:lookup'. +(define-methods (lookup fset2:lookup) ((m wb-map) key) + (let ((val? val mkey (WB-Map-Tree-Lookup (wb-map-contents m) key + (tree-map-org-key-compare-fn (wb-map-org m))))) ;; Our internal convention is the reverse of the external one. - (values (if val? val (map-default m)) val?))) + (values (if val? val + (let ((dflt (map-default m))) + (if (eq dflt 'no-default) + (error 'fset2:map-domain-error :map m :key key) + dflt))) + val? mkey))) (defmethod rank ((m wb-map) x) (let ((found? rank (WB-Map-Tree-Rank (wb-map-contents m) x (tree-map-org-key-compare-fn (wb-map-org m))))) (values (if found? rank (1- rank)) found?))) +(defmethod fset2:rank ((m wb-map) x) + (let ((found? rank (WB-Map-Tree-Rank (wb-map-contents m) x + (tree-map-org-key-compare-fn (wb-map-org m))))) + (values rank found?))) (defmethod at-rank ((m wb-map) rank) (let ((contents (wb-map-contents m)) @@ -3554,29 +3832,35 @@ (defmethod fun-iterator ((s wb-map) &key from-end?) (WB-Map-Tree-Rev-Fun-Iter (wb-map-contents s)) (WB-Map-Tree-Fun-Iter (wb-map-contents s)))) -(defmethod filter ((pred function) (m wb-map)) - (let ((tmorg (wb-map-org m))) - (make-wb-map (wb-map-filter pred m (tree-map-org-key-compare-fn tmorg) (tree-map-org-val-compare-fn tmorg)) - tmorg (map-default m)))) +(define-methods (filter fset2:filter) ((pred function) (m wb-map)) + (wb-map-filter pred m)) -(defmethod filter ((pred symbol) (m wb-map)) - (let ((tmorg (wb-map-org m))) - (make-wb-map (wb-map-filter (coerce-to-function pred) m - (tree-map-org-key-compare-fn tmorg) (tree-map-org-val-compare-fn tmorg)) - tmorg (map-default m)))) +(define-methods (filter fset2:filter) ((pred symbol) (m wb-map)) + (wb-map-filter (coerce-to-function pred) m)) -(defun wb-map-filter (pred m key-compare-fn val-compare-fn) - (let ((result nil)) +(defun wb-map-filter (pred m) + (declare (optimize (speed 3) (safety 0)) (type function pred)) + (let ((tmorg (wb-map-org m)) + ((key-compare-fn (tree-map-org-key-compare-fn tmorg)) + (val-compare-fn (tree-map-org-val-compare-fn tmorg))) + (result nil)) (do-map (x y m) (when (funcall pred x y) (setq result (WB-Map-Tree-With result x y key-compare-fn val-compare-fn)))) - result)) + (make-wb-map result tmorg (map-default m)))) (defmethod image ((fn function) (m wb-map) &key key-compare-fn-name val-compare-fn-name) (wb-map-image fn m key-compare-fn-name val-compare-fn-name (map-default m))) +(defmethod fset2:image ((fn function) (m wb-map) &key key-compare-fn-name val-compare-fn-name) + ;; We can't call `fn' to compute a new default, because we don't have a corresponding + ;; domain value. Copying the default from `m', as FSet1 did, doesn't make sense either; + ;; in general, the range type is different. + (wb-map-image fn m key-compare-fn-name val-compare-fn-name 'no-default)) (defmethod image ((fn symbol) (m wb-map) &key key-compare-fn-name val-compare-fn-name) (wb-map-image (coerce-to-function fn) m key-compare-fn-name val-compare-fn-name (map-default m))) +(defmethod fset2:image ((fn symbol) (m wb-map) &key key-compare-fn-name val-compare-fn-name) + (wb-map-image (coerce-to-function fn) m key-compare-fn-name val-compare-fn-name 'no-default)) (defun wb-map-image (fn m key-compare-fn-name val-compare-fn-name default) (declare (type function fn)) @@ -3633,73 +3917,166 @@ (defmethod range-contains? ((m map) x) (defmethod map-union ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2))) "Fallback method for mixed implementations." + (generic-map-union m1 m2 val-fn (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (and (or dflt1 dflt2) (funcall val-fn dflt1 dflt2))))) +(defmethod fset2:map-union ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2))) + "Fallback method for mixed implementations." + (generic-map-union m1 m2 val-fn (map-union-default m1 m2 val-fn))) + +(defun generic-map-union (m1 m2 val-fn default) (let ((result m1) - (vcf1 (val-compare-fn m1))) - (do-map (k v2 m2) - (let ((v1 v1? (lookup m1 k))) + (vcf1 (val-compare-fn m1)) + (m1d (with-default m1 nil))) ; so `lookup' doesn't error + (do-map (k2 v2 m2) + (let ((v1 v1? k1 (lookup m1d k2))) (if (not v1?) - (setf (lookup result k) v2) + (setf (lookup result k2) v2) (unless (equal?-cmp v1 v2 vcf1) (let ((new-v second-val (funcall val-fn v1 v2))) - (unless (eq second-val ':no-value) - (setf (lookup result k) new-v))))))) - result)) - -(defmethod map-union ((map1 wb-map) (map2 wb-map) + (if (eq second-val ':no-value) + (excludef result k1) + (setf (lookup result k1) new-v))))))) + (with-default result default))) + +(defun map-union-default (m1 m2 val-fn) + (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (if (eq dflt1 'no-default) dflt2 + (if (eq dflt2 'no-default) dflt1 + (let ((v second-val (funcall val-fn dflt1 dflt2))) + (if (eq second-val ':no-value) 'no-default + v)))))) + +(defmethod map-union ((m1 wb-map) (m2 wb-map) &optional (val-fn (fn (_v1 v2) v2))) - (if-same-wb-map-orgs (map1 map2 tmorg) - (make-wb-map (WB-Map-Tree-Union (wb-map-contents map1) (wb-map-contents map2) - (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg)) - tmorg (let ((def1 (map-default map1)) - (def2 (map-default map2))) - (and (or def1 def2) (funcall val-fn def1 def2)))) + (if-same-wb-map-orgs (m1 m2 tmorg) + (make-wb-map (WB-Map-Tree-Union (wb-map-contents m1) (wb-map-contents m2) + (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg) + (tree-map-org-val-compare-fn tmorg)) + tmorg (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (and (or dflt1 dflt2) (funcall val-fn dflt1 dflt2)))) + (call-next-method))) +(defmethod fset2:map-union ((m1 wb-map) (m2 wb-map) + &optional (val-fn (fn (_v1 v2) v2))) + (if-same-wb-map-orgs (m1 m2 tmorg) + (make-wb-map (WB-Map-Tree-Union (wb-map-contents m1) (wb-map-contents m2) + (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg) + (tree-map-org-val-compare-fn tmorg)) + tmorg (map-union-default m1 m2 val-fn)) (call-next-method))) (defmethod map-intersection ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2))) "Fallback method for mixed implementations." + (generic-map-intersection m1 m2 val-fn (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (and (or dflt1 dflt2) (funcall val-fn dflt1 dflt2))))) +(defmethod fset2:map-intersection ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2))) + "Fallback method for mixed implementations." + (generic-map-intersection m1 m2 val-fn (map-intersection-default m1 m2 val-fn))) + +(defun generic-map-intersection (m1 m2 val-fn default) (let ((result (empty-map-like m1)) - (vcf1 (val-compare-fn m1))) + (vcf1 (val-compare-fn m1)) + (m2d (with-default m2 nil))) ; prevent `lookup' errors (do-map (k v1 m1) - (let ((v2 v2? (lookup m2 k))) - (when (and v2? (not (equal?-cmp v1 v2 vcf1))) - (let ((new-v second-val (funcall val-fn v1 v2))) - (unless (eq second-val ':no-value) - (setf (lookup result k) new-v)))))) - result)) - -(defmethod map-intersection ((map1 wb-map) (map2 wb-map) + (let ((v2 v2? (lookup m2d k))) + (when v2? + (if (equal?-cmp v1 v2 vcf1) + (setf (lookup result k) v1) + (let ((new-v second-val (funcall val-fn v1 v2))) + (unless (eq second-val ':no-value) + (setf (lookup result k) new-v))))))) + (with-default result default))) + +(defun map-intersection-default (m1 m2 val-fn) + (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (if (and (not (eq dflt1 'no-default)) (not (eq dflt2 'no-default))) + (let ((v second-val (funcall val-fn dflt1 dflt2))) + (if (eq second-val ':no-value) 'no-default + v)) + 'no-default))) + +(defmethod map-intersection ((m1 wb-map) (m2 wb-map) &optional (val-fn (fn (_v1 v2) v2))) - (if-same-wb-map-orgs (map1 map2 tmorg) - (make-wb-map (WB-Map-Tree-Intersect (wb-map-contents map1) (wb-map-contents map2) - (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg)) - tmorg (let ((def1 (map-default map1)) - (def2 (map-default map2))) - (and (or def1 def2) (funcall val-fn def1 def2)))) + (if-same-wb-map-orgs (m1 m2 tmorg) + (make-wb-map (WB-Map-Tree-Intersect (wb-map-contents m1) (wb-map-contents m2) + (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg) + (tree-map-org-val-compare-fn tmorg)) + tmorg (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (and (or dflt1 dflt2) (funcall val-fn dflt1 dflt2)))) + (call-next-method))) +(defmethod fset2:map-intersection ((m1 wb-map) (m2 wb-map) + &optional (val-fn (fn (_v1 v2) v2))) + (if-same-wb-map-orgs (m1 m2 tmorg) + (make-wb-map (WB-Map-Tree-Intersect (wb-map-contents m1) (wb-map-contents m2) + (coerce val-fn 'function) (tree-map-org-key-compare-fn tmorg) + (tree-map-org-val-compare-fn tmorg)) + tmorg (map-intersection-default m1 m2 val-fn)) (call-next-method))) (defmethod map-difference-2 ((m1 map) (m2 map)) "Fallback method for mixed implementations." + (let ((result1 result2 (generic-map-difference-2 m1 m2))) + (values (with-default result1 (map-default m1)) + (with-default result2 (map-default m2))))) +(defmethod fset2:map-difference-2 ((m1 map) (m2 map)) + "Fallback method for mixed implementations." + (let ((result1 result2 (generic-map-difference-2 m1 m2)) + (dflt1 dflt2 (map-difference-2-defaults m1 m2))) + (values (with-default result1 dflt1) + (with-default result2 dflt2)))) + +(defun generic-map-difference-2 (m1 m2) (let ((result1 (empty-map-like m1)) (result2 (empty-map-like m2)) (vcf1 (val-compare-fn m1)) - (vcf2 (val-compare-fn m2))) + (vcf2 (val-compare-fn m2)) + (m1d (with-default m1 nil)) + (m2d (with-default m2 nil))) (do-map (k v1 m1) - (let ((v2 v2? (lookup m2 k))) + (let ((v2 v2? (lookup m2d k))) (unless (and v2? (equal?-cmp v1 v2 vcf1)) (setf (lookup result1 k) v1)))) (do-map (k v2 m2) - (let ((v1 v1? (lookup m1 k))) + (let ((v1 v1? (lookup m1d k))) (unless (and v1? (equal?-cmp v1 v2 vcf2)) (setf (lookup result2 k) v2)))) (values result1 result2))) -(defmethod map-difference-2 ((map1 wb-map) (map2 wb-map)) - (if-same-wb-map-orgs (map1 map2 tmorg) - (let ((newc1 newc2 (WB-Map-Tree-Diff-2 (wb-map-contents map1) (wb-map-contents map2) +(defun map-difference-2-defaults (m1 m2) + (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (values (if (eq dflt1 'no-default) 'no-default + (if (eq dflt2 'no-default) dflt1 + (if (equal?-cmp dflt1 dflt2 (val-compare-fn m1)) + 'no-default + dflt1))) + (if (eq dflt2 'no-default) 'no-default + (if (eq dflt1 'no-default) dflt2 + (if (equal?-cmp dflt1 dflt2 (val-compare-fn m2)) + 'no-default + dflt2)))))) + +(defmethod map-difference-2 ((m1 wb-map) (m2 wb-map)) + (if-same-wb-map-orgs (m1 m2 tmorg) + (let ((newc1 newc2 (WB-Map-Tree-Diff-2 (wb-map-contents m1) (wb-map-contents m2) (tree-map-org-key-compare-fn tmorg) (tree-map-org-val-compare-fn tmorg)))) - (values (make-wb-map newc1 tmorg (map-default map1)) - (make-wb-map newc2 tmorg (map-default map2)))) + (values (make-wb-map newc1 tmorg (map-default m1)) + (make-wb-map newc2 tmorg (map-default m2)))) + (call-next-method))) +(defmethod fset2:map-difference-2 ((m1 wb-map) (m2 wb-map)) + (if-same-wb-map-orgs (m1 m2 tmorg) + (let ((newc1 newc2 (WB-Map-Tree-Diff-2 (wb-map-contents m1) (wb-map-contents m2) + (tree-map-org-key-compare-fn tmorg) + (tree-map-org-val-compare-fn tmorg))) + (dflt1 dflt2 (map-difference-2-defaults m1 m2))) + (values (make-wb-map newc1 tmorg dflt1) + (make-wb-map newc2 tmorg dflt2))) (call-next-method))) (defmethod restrict ((m map) (s set)) @@ -3740,16 +4117,16 @@ (defmethod restrict-not ((m wb-map) (s wb-set)) (defun compose-functions (f1 f2) (lambda (&rest args) (multiple-value-call f2 (apply f1 args)))) -(defmethod compose ((f1 function) (f2 function) &key) +(define-methods (compose fset2:compose) ((f1 function) (f2 function) &key) (compose-functions f1 f2)) -(defmethod compose ((f1 symbol) (f2 function) &key) +(define-methods (compose fset2:compose) ((f1 symbol) (f2 function) &key) (compose-functions (symbol-function f1) f2)) -(defmethod compose ((f1 function) (f2 symbol) &key) +(define-methods (compose fset2:compose) ((f1 function) (f2 symbol) &key) (compose-functions f1 (symbol-function f2))) -(defmethod compose ((f1 symbol) (f2 symbol) &key) +(define-methods (compose fset2:compose) ((f1 symbol) (f2 symbol) &key) (compose-functions (symbol-function f1) (symbol-function f2))) ;;; I've removed the fallback method for `compose', as it's not needed -- the maps @@ -3758,30 +4135,44 @@ (defmethod compose ((f1 symbol) (f2 symbol) &key) (defmethod compose ((map1 wb-map) (map2 map) &key val-compare-fn-name) "The returned map's `val-compare-fn-name' can be specified; it defaults to `compare'." - (make-wb-map (WB-Map-Tree-Compose (wb-map-contents map1) - (fn (x) - (let ((val2 val2? (lookup map2 x))) - (if val2? val2 (map-default map2))))) - (wb-map-org (empty-wb-map nil (key-compare-fn-name map1) val-compare-fn-name)) - (let ((new-default new-default? (lookup map2 (map-default map1)))) - (if new-default? new-default (map-default map2))))) - -(defmethod compose ((m wb-map) (fn function) &key val-compare-fn-name) + (if (and (empty? map1) (eq (map-default map1) 'no-default)) + map1 + (make-wb-map (WB-Map-Tree-Compose (wb-map-contents map1) + ;; This can fail if `map2' is an FSet 2 map with no default. + (fn (x) (lookup map2 x))) + (wb-map-org (empty-wb-map nil (key-compare-fn-name map1) val-compare-fn-name)) + (let ((new-default new-default? (lookup map2 (map-default map1)))) + (if new-default? new-default (map-default map2)))))) +(defmethod fset2:compose ((map1 wb-map) (map2 map) &key val-compare-fn-name) + "The returned map's `val-compare-fn-name' can be specified; it defaults +to `compare'." + (if (and (empty? map1) (eq (map-default map1) 'no-default)) + map1 + (make-wb-map (WB-Map-Tree-Compose (wb-map-contents map1) (fn (x) (fset2:lookup map2 x))) + (wb-map-org (empty-wb-map nil (key-compare-fn-name map1) val-compare-fn-name)) + (let ((dflt1 (map-default map1))) + (if (eq dflt1 'no-default) 'no-default + (let ((new-default new-default? (fset2:lookup map2 dflt1))) + (if new-default? new-default (map-default map2)))))))) + +(define-methods (compose fset2:compose) ((m wb-map) (fn function) &key val-compare-fn-name) (wb-map-fn-compose m fn val-compare-fn-name)) -(defmethod compose ((m wb-map) (fn symbol) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((m wb-map) (fn symbol) &key val-compare-fn-name) (wb-map-fn-compose m (symbol-function fn) val-compare-fn-name)) -(defmethod compose ((m wb-map) (s seq) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((m wb-map) (s seq) &key val-compare-fn-name) (wb-map-fn-compose m (fn (x) (lookup s x)) val-compare-fn-name)) (defun wb-map-fn-compose (m fn val-compare-fn-name) (declare (type function fn)) (make-wb-map (WB-Map-Tree-Compose (wb-map-contents m) fn) (wb-map-org (empty-wb-map nil (key-compare-fn-name m) val-compare-fn-name)) - (funcall fn (map-default m)))) + (let ((dflt1 (map-default m))) + (if (eq dflt1 'no-default) 'no-default + (funcall fn dflt1))))) -(defmethod convert ((to-type (eql 'map)) (m map) &key) +(define-convert-methods (map fset2:map) ((m map) &key) m) (defmethod convert ((to-type (eql 'wb-map)) (m wb-map) @@ -3795,6 +4186,19 @@ (defmethod convert ((to-type (eql 'wb-map)) (m wb-map) (let ((tree nil)) (Do-WB-Map-Tree-Pairs (k v (wb-map-contents m) tree) (setq tree (WB-Map-Tree-With tree k v key-compare-fn val-compare-fn)))))) +(defmethod convert ((to-type (eql 'fset2:wb-map)) (m wb-map) + &key (default nil default?) no-default? key-compare-fn-name val-compare-fn-name) + "The result uses `default' if supplied, otherwise has the same default as `m'." + (when (and default? no-default?) + (error "Both a default and `no-default?' specified")) + (convert-to-wb-map m (if default? default (if no-default? 'no-default (map-default m))) + (let ((m-tmorg (wb-map-org m))) + (or (eq m-tmorg tmorg) + (and (eq key-compare-fn (tree-map-org-key-compare-fn m-tmorg)) + (eq val-compare-fn (tree-map-org-val-compare-fn m-tmorg))))) + (let ((tree nil)) + (Do-WB-Map-Tree-Pairs (k v (wb-map-contents m) tree) + (setq tree (WB-Map-Tree-With tree k v key-compare-fn val-compare-fn)))))) (defmethod convert ((to-type (eql 'list)) (m map) &key (pair-fn #'cons)) (let ((result nil)) @@ -3820,15 +4224,20 @@ (defmethod convert ((to-type (eql 'set)) (m map) &key (pair-fn #'cons)) (do-map (key val m) (setq result (WB-Set-Tree-With result (funcall pair-fn key val) #'compare))) (make-wb-set result))) +(defmethod convert ((to-type (eql 'fset2:set)) (m map) &key (pair-fn #'cons)) + (let ((result nil)) + (do-map (key val m) + (setq result (ch-set-tree-with result (funcall pair-fn key val) #'hash-value #'compare))) + (make-ch-set result +fset-default-hash-set-org+))) ;;; &&& Plist support? (defmethod convert ((to-type (eql 'map)) (l list) &key (key-fn #'car) (value-fn #'cdr) input-sorted?) (wb-map-from-sequence l key-fn value-fn input-sorted?)) -(defmethod convert ((to-type (eql 'wb-map)) (l list) - &key (key-fn #'car) (value-fn #'cdr) input-sorted? - key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-map fset2:wb-map) ((l list) + &key (key-fn #'car) (value-fn #'cdr) input-sorted? + key-compare-fn-name val-compare-fn-name) (wb-map-from-sequence l key-fn value-fn input-sorted? key-compare-fn-name val-compare-fn-name)) (defmethod convert ((to-type (eql 'map)) (s seq) @@ -3836,19 +4245,19 @@ (defmethod convert ((to-type (eql 'map)) (s seq) (with-default (wb-map-from-sequence s key-fn value-fn input-sorted?) (seq-default s))) -(defmethod convert ((to-type (eql 'wb-map)) (s seq) - &key (key-fn #'car) (value-fn #'cdr) input-sorted? - key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-map fset2:wb-map) + ((s seq) &key (key-fn #'car) (value-fn #'cdr) input-sorted? + key-compare-fn-name val-compare-fn-name) (with-default (wb-map-from-sequence s key-fn value-fn input-sorted? key-compare-fn-name val-compare-fn-name) - (seq-default s))) + (seq-default s))) (defmethod convert ((to-type (eql 'map)) (s sequence) &key (key-fn #'car) (value-fn #'cdr) input-sorted?) (wb-map-from-sequence s key-fn value-fn input-sorted?)) -(defmethod convert ((to-type (eql 'wb-map)) (s sequence) - &key (key-fn #'car) (value-fn #'cdr) input-sorted? - key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-map fset2:wb-map) + ((s sequence) &key (key-fn #'car) (value-fn #'cdr) input-sorted? + key-compare-fn-name val-compare-fn-name) (wb-map-from-sequence s key-fn value-fn input-sorted? key-compare-fn-name val-compare-fn-name)) (defun wb-map-from-sequence (s key-fn value-fn input-sorted? &optional key-compare-fn-name val-compare-fn-name) @@ -3864,10 +4273,10 @@ (defmethod convert ((to-type (eql 'wb-map)) (s sequence) (WB-Map-Tree-From-Iterable (iterator s) key-fn value-fn key-compare-fn val-compare-fn)))))) -(defmethod convert ((to-type (eql 'map)) (b bag) &key) +(define-convert-methods (map fset2:map) ((b bag) &key) (convert 'wb-map b)) -(defmethod convert ((to-type (eql 'wb-map)) (b bag) &key key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-map fset2:wb-map) ((b bag) &key key-compare-fn-name val-compare-fn-name) ;; &&& 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. (But only if the compare-fns match.) (convert-to-wb-map b nil nil @@ -3875,10 +4284,10 @@ (defmethod convert ((to-type (eql 'wb-map)) (b bag) &key key-compare-fn-name val (do-bag-pairs (x n b tree) (setq tree (WB-Map-Tree-With tree x n key-compare-fn val-compare-fn)))))) -(defmethod convert ((to-type (eql 'map)) (ht hash-table) &key) +(define-convert-methods (map fset2:map) ((ht hash-table) &key) (convert 'wb-map ht)) -(defmethod convert ((to-type (eql 'wb-map)) (ht hash-table) &key key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-map fset2:wb-map) ((ht hash-table) &key key-compare-fn-name val-compare-fn-name) (convert-to-wb-map ht nil nil (let ((tree nil)) (maphash (lambda (k v) @@ -3895,19 +4304,19 @@ (defmethod convert ((to-type (eql 'hash-table)) (m map) (defmethod find (item (m map) &key key test) (declare (optimize (speed 3) (safety 0))) - (let ((test (coerce-to-function-or-equal? test))) + (let ((test default? (coerce-to-function-or-equal? test))) (if key (let ((key (coerce-to-function key))) (do-map (x y m nil) (when (funcall test item (funcall key x)) (return (values x y))))) - (if (not (eq test #'equal?)) - (do-map (x y m nil) - (when (funcall test item x) - (return (values x y)))) + (if (and default? (eq (key-compare-fn m) #'compare)) (let ((val val? (lookup m item))) (if val? (values item val) - (values nil nil))))))) + (values nil nil))) + (do-map (x y m nil) + (when (funcall test item x) + (return (values x y)))))))) (defmethod find-if (pred (m map) &key key) (declare (optimize (speed 3) (safety 0))) @@ -3937,14 +4346,14 @@ (defmethod count (item (m map) &key key test) (declare (ignore y)) (when (funcall test item (funcall key x)) (incf total)))) - (if default? + (if (and default? (eq (key-compare-fn m) #'compare)) (if (lookup m item) 1 0) - (let ((total 0)) - (declare (fixnum total)) - (do-map (x y m total) - (declare (ignore y)) - (when (funcall test item x) - (incf total)))))))) + (let ((total 0)) + (declare (fixnum total)) + (do-map (x y m total) + (declare (ignore y)) + (when (funcall test item x) + (incf total)))))))) (defmethod count-if (pred (m map) &key key) (declare (optimize (speed 3) (safety 0))) @@ -3974,11 +4383,12 @@ (defmethod count-if-not (pred (m map) &key key) ((key-cf-name (tree-map-org-key-compare-fn-name tmorg)) (val-cf-name (tree-map-org-val-compare-fn-name tmorg)) ((key-default? (eq key-cf-name 'compare)) - (val-default? (eq val-cf-name 'compare))))) - (format nil " |}~:[[~:[~S~;~*~];~:[~S~;~*~]]~;~4*~]~@[/~S~]" + (val-default? (eq val-cf-name 'compare)))) + (dflt (map-default map))) + (format nil " |}~:[[~:[~S~;~*~];~:[~S~;~*~]]~;~4*~]~:[/~S~;~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (map-default map)))) + (eq dflt 'no-default) dflt))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) @@ -3989,8 +4399,10 @@ (defmethod count-if-not (pred (m map) &key key) (defmethod make-load-form ((m wb-map) &optional environment) (declare (ignore environment)) - `(convert 'wb-map ',(convert 'list m) :key-compare-fn-name ',(tree-map-org-key-compare-fn-name (wb-map-org m)) - :val-compare-fn-name ',(tree-map-org-val-compare-fn-name (wb-map-org m)))) + `(with-default (convert 'wb-map ',(convert 'list m) + :key-compare-fn-name ',(tree-map-org-key-compare-fn-name (wb-map-org m)) + :val-compare-fn-name ',(tree-map-org-val-compare-fn-name (wb-map-org m))) + ',(map-default m))) ;;; ================================================================================ @@ -4008,6 +4420,9 @@ (defstruct (hash-map-org (val-compare-fn nil :type function :read-only t) (val-hash-fn nil :type function :read-only t)) +(defparameter +fset-default-hash-map-org+ + (make-hash-map-org 'compare #'compare #'hash-value 'compare #'compare #'hash-value)) + (declaim (inline make-ch-map)) (defstruct (ch-map @@ -4019,17 +4434,37 @@ (defstruct (ch-map (contents nil :read-only t) (org nil :type hash-map-org :read-only t)) -(defparameter *empty-ch-map* - (make-ch-map nil (make-hash-map-org 'compare #'compare #'hash-value 'compare #'compare #'hash-value) - nil)) +(defparameter +empty-ch-map+ (make-ch-map nil +fset-default-hash-map-org+ nil)) + +(defparameter +empty-ch-map/no-default+ (make-ch-map nil +fset-default-hash-map-org+ 'no-default)) -(declaim (inline empty-ch-map)) +(declaim (inline fset2:empty-map)) +(defun fset2:empty-map (&key (default nil default?) no-default?) + "Returns an empty map of the default implementation, with the specified +default or lack of default." + (empty-ch-map-internal (fset2-default default? default no-default?) nil nil)) + +(declaim (inline empty-ch-map fset2:empty-ch-map)) (defun empty-ch-map (&optional default key-compare-fn-name val-compare-fn-name) (if (and (null key-compare-fn-name) (null val-compare-fn-name)) (if (null default) - *empty-ch-map* - (make-ch-map nil (ch-map-org *empty-ch-map*) default)) + +empty-ch-map+ + (make-ch-map nil +fset-default-hash-map-org+ default)) (empty-ch-custom-map default (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare)))) +(defun fset2:empty-ch-map (&key (default nil default?) no-default? key-compare-fn-name val-compare-fn-name) + "Returns an empty ch-map with the specified default and comparison functions. +The map's default is `nil' unless a different default is supplied, or +`no-default?' is true." + (empty-ch-map-internal (fset2-default default? default no-default?) key-compare-fn-name val-compare-fn-name)) + +(defun empty-ch-map-internal (default key-compare-fn-name val-compare-fn-name) + (cond ((or key-compare-fn-name val-compare-fn-name) + (empty-ch-custom-map default (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare))) + ((null default) + +empty-ch-map+) + ((eq default 'no-default) + +empty-ch-map/no-default+) + (t (make-ch-map nil +fset-default-hash-map-org+ default)))) (deflex +empty-ch-custom-map-cache+ (make-hash-table :test 'equal)) @@ -4041,9 +4476,8 @@ (defstruct (ch-map (symbol-package val-compare-fn-name)) () "val-compare-fn-name must be a nonnull interned symbol") (if (and (eq key-compare-fn-name 'compare) (eq val-compare-fn-name 'compare)) - (if (null default) *empty-ch-map* - (make-ch-map nil (ch-map-org *empty-ch-map*) default)) - ;; See note in `empty-wb-custom-map'. + (if (null default) +empty-ch-map+ + (make-ch-map nil +fset-default-hash-map-org+ default)) (let ((cache-key (list key-compare-fn-name val-compare-fn-name)) ((prev-instance (gethash cache-key +empty-ch-custom-map-cache+))) (key-hash-fn-name (or (get key-compare-fn-name 'hash-function) @@ -4061,17 +4495,16 @@ (defstruct (ch-map (and (eq key-compare-fn (hash-map-org-key-compare-fn prev-org)) (eq key-hash-fn (hash-map-org-key-hash-fn prev-org)) (eq val-compare-fn (hash-map-org-val-compare-fn prev-org)) - (eq val-hash-fn (hash-map-org-val-hash-fn prev-org)) - (equal?-cmp default (map-default prev-instance) val-compare-fn)))) - prev-instance + (eq val-hash-fn (hash-map-org-val-hash-fn prev-org))))) + (if (equal?-cmp default (map-default prev-instance) val-compare-fn) + prev-instance + (setf (gethash cache-key +empty-ch-custom-map-cache+) + (make-ch-map nil (ch-map-org prev-instance) default))) (setf (gethash cache-key +empty-ch-custom-map-cache+) (make-ch-map nil (make-hash-map-org key-compare-fn-name key-compare-fn key-hash-fn val-compare-fn-name val-compare-fn val-hash-fn) default)))))) -(defmethod empty-instance-function ((class-name (eql 'ch-map))) - `empty-ch-map) - (defmethod empty-map-like ((m ch-map)) (let ((hmorg (ch-map-org m))) (empty-ch-custom-map (map-default m) (hash-map-org-key-compare-fn-name hmorg) @@ -4098,6 +4531,9 @@ (defmethod val-hash-fn ((m ch-map)) (defmethod with-default ((m ch-map) new-default) (make-ch-map (ch-map-contents m) (ch-map-org m) new-default)) +(defmethod fset2:without-default ((m ch-map)) + (make-ch-map (ch-map-contents m) (ch-map-org m) 'no-default)) + (defmethod empty? ((m ch-map)) (null (ch-map-contents m))) @@ -4141,15 +4577,19 @@ (defmethod less ((m ch-map) key &optional (arg2 nil arg2?)) m (values (make-ch-map new-contents hmorg (map-default m)) range-val)))) -(defmethod lookup ((m ch-map) key) +(define-methods (lookup fset2:lookup) ((m ch-map) key) (let ((hmorg (ch-map-org m)) - ((val? val (ch-map-tree-lookup (ch-map-contents m) key - (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg))))) + ((val? val mkey (ch-map-tree-lookup (ch-map-contents m) key + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg))))) ;; Our internal convention is the reverse of the external one. - (values (if val? val (map-default m)) val?))) + (values (if val? val + (let ((dflt (map-default m))) + (if (eq dflt 'no-default) + (error 'fset2:map-domain-error :map m :key key) + dflt))) + val? mkey))) (defmethod index ((m ch-map) key) - (declare (optimize (debug 3))) (let ((hmorg (ch-map-org m))) (ch-map-tree-index (ch-map-contents m) key (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg)))) @@ -4222,9 +4662,17 @@ (defmethod map-union ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2) (coerce val-fn 'function) (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg)) - hmorg (let ((def1 (map-default m1)) - (def2 (map-default m2))) - (and (or def1 def2) (funcall val-fn def1 def2)))) + hmorg (let ((dflt1 (map-default m1)) + (dflt2 (map-default m2))) + (and (or dflt1 dflt2) (funcall val-fn dflt1 dflt2)))) + (call-next-method))) +(defmethod fset2:map-union ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2))) + (if-same-ch-map-orgs (m1 m2 hmorg) + (make-ch-map (ch-map-tree-union (ch-map-contents m1) (ch-map-contents m2) + (coerce val-fn 'function) + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) + (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg)) + hmorg (map-union-default m1 m2 val-fn)) (call-next-method))) (defmethod map-intersection ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2))) @@ -4237,14 +4685,31 @@ (defmethod map-intersection ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 (def2 (map-default m2))) (and (or def1 def2) (funcall val-fn def1 def2)))) (call-next-method))) +(defmethod fset2:map-intersection ((m1 ch-map) (m2 ch-map) &optional (val-fn (fn (_v1 v2) v2))) + (if-same-ch-map-orgs (m1 m2 hmorg) + (make-ch-map (ch-map-tree-intersection (ch-map-contents m1) (ch-map-contents m2) + (coerce val-fn 'function) + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) + (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg)) + hmorg (map-intersection-default m1 m2 val-fn)) + (call-next-method))) -(defmethod map-difference-2 ((map1 ch-map) (map2 ch-map)) - (if-same-ch-map-orgs (map1 map2 hmorg) - (let ((newc1 newc2 (ch-map-tree-diff-2 (ch-map-contents map1) (ch-map-contents map2) +(defmethod map-difference-2 ((m1 ch-map) (m2 ch-map)) + (if-same-ch-map-orgs (m1 m2 hmorg) + (let ((newc1 newc2 (ch-map-tree-diff-2 (ch-map-contents m1) (ch-map-contents m2) (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg)))) - (values (make-ch-map newc1 hmorg (map-default map1)) - (make-ch-map newc2 hmorg (map-default map2)))) + (values (make-ch-map newc1 hmorg (map-default m1)) + (make-ch-map newc2 hmorg (map-default m2)))) + (call-next-method))) +(defmethod fset2:map-difference-2 ((m1 ch-map) (m2 ch-map)) + (if-same-ch-map-orgs (m1 m2 hmorg) + (let ((newc1 newc2 (ch-map-tree-diff-2 (ch-map-contents m1) (ch-map-contents m2) + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg) + (hash-map-org-val-hash-fn hmorg) (hash-map-org-val-compare-fn hmorg))) + (dflt1 dflt2 (map-difference-2-defaults m1 m2))) + (values (make-ch-map newc1 hmorg dflt1) + (make-ch-map newc2 hmorg dflt2))) (call-next-method))) (defmethod restrict ((m ch-map) (s ch-set)) @@ -4268,23 +4733,34 @@ (defmethod restrict-not ((m ch-map) (s ch-set)) (call-next-method)))) (defmethod compose ((map1 ch-map) (map2 map) &key val-compare-fn-name) - (let ((prototype (empty-ch-map nil (key-compare-fn-name map1) val-compare-fn-name))) - (make-ch-map (ch-map-tree-compose (ch-map-contents map1) - (fn (x) - (let ((val2 val2? (lookup map2 x))) - (if val2? val2 (map-default map2))))) - (ch-map-org prototype) - (let ((new-default? new-default - (lookup map2 (map-default map1)))) - (if new-default? new-default (map-default map2)))))) - -(defmethod compose ((m ch-map) (fn function) &key val-compare-fn-name) + (if (and (empty? map1) (eq (map-default map1) 'no-default)) + map1 + (let ((prototype (empty-ch-map nil (key-compare-fn-name map1) val-compare-fn-name))) + (make-ch-map (ch-map-tree-compose (ch-map-contents map1) + ;; This can fail if `map2' is an FSet 2 map with no default. + (fn (x) (lookup map2 x))) + (ch-map-org prototype) + (let ((new-default? new-default + (lookup map2 (map-default map1)))) + (if new-default? new-default (map-default map2))))))) +(defmethod fset2:compose ((map1 ch-map) (map2 map) &key val-compare-fn-name) + (if (and (empty? map1) (eq (map-default map1) 'no-default)) + map1 + (let ((prototype (empty-ch-map nil (key-compare-fn-name map1) val-compare-fn-name))) + (make-ch-map (ch-map-tree-compose (ch-map-contents map1) (fn (x) (lookup map2 x))) + (ch-map-org prototype) + (let ((dflt1 (map-default map1))) + (if (eq dflt1 'no-default) 'no-default + (let ((new-default new-default? (fset2:lookup map2 dflt1))) + (if new-default? new-default (map-default map2))))))))) + +(define-methods (compose fset2:compose) ((m ch-map) (fn function) &key val-compare-fn-name) (ch-map-fn-compose m fn val-compare-fn-name)) -(defmethod compose ((m ch-map) (fn symbol) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((m ch-map) (fn symbol) &key val-compare-fn-name) (ch-map-fn-compose m (symbol-function fn) val-compare-fn-name)) -(defmethod compose ((m ch-map) (s seq) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((m ch-map) (s seq) &key val-compare-fn-name) (ch-map-fn-compose m (fn (x) (lookup s x)) val-compare-fn-name)) (defun ch-map-fn-compose (m fn val-compare-fn-name) @@ -4292,7 +4768,9 @@ (defmethod compose ((m ch-map) (s seq) &key val-compare-fn-name) (let ((prototype (empty-ch-map nil (key-compare-fn-name m) val-compare-fn-name))) (make-ch-map (ch-map-tree-compose (ch-map-contents m) fn) (ch-map-org prototype) - (funcall fn (map-default m))))) + (let ((dflt1 (map-default m))) + (if (eq dflt1 'no-default) 'no-default + (funcall fn dflt1)))))) (defmethod internal-do-map ((m ch-map) elt-fn value-fn) (declare (optimize (speed 3) (safety 0)) @@ -4300,10 +4778,10 @@ (defmethod internal-do-map ((m ch-map) elt-fn value-fn) (do-ch-map-tree-pairs (x y (ch-map-contents m) (funcall value-fn)) (funcall elt-fn x y))) -(defmethod filter ((pred function) (m ch-map)) +(define-methods (filter fset2:filter) ((pred function) (m ch-map)) (ch-map-filter pred m)) -(defmethod filter ((pred symbol) (m ch-map)) +(define-methods (filter fset2:filter) ((pred symbol) (m ch-map)) (ch-map-filter (coerce-to-function pred) m)) (defun ch-map-filter (pred m) @@ -4322,9 +4800,13 @@ (defmethod filter ((pred symbol) (m ch-map)) (defmethod image ((fn function) (m ch-map) &key key-compare-fn-name val-compare-fn-name) (ch-map-image fn m key-compare-fn-name val-compare-fn-name (map-default m))) +(defmethod fset2:image ((fn function) (m ch-map) &key key-compare-fn-name val-compare-fn-name) + (ch-map-image fn m key-compare-fn-name val-compare-fn-name 'no-default)) (defmethod image ((fn symbol) (m ch-map) &key key-compare-fn-name val-compare-fn-name) (ch-map-image (coerce-to-function fn) m key-compare-fn-name val-compare-fn-name (map-default m))) +(defmethod fset2:image ((fn symbol) (m ch-map) &key key-compare-fn-name val-compare-fn-name) + (ch-map-image (coerce-to-function fn) m key-compare-fn-name val-compare-fn-name 'no-default)) (defun ch-map-image (fn m key-compare-fn-name val-compare-fn-name default) (declare (type function fn)) @@ -4349,26 +4831,21 @@ (defmethod fun-iterator ((s ch-map) &key from-end?) (ch-map-tree-rev-fun-iter (ch-map-contents s)) (ch-map-tree-fun-iter (ch-map-contents s)))) -(defmethod convert ((to-type (eql 'wb-map)) (m ch-map) &key key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-map fset2:wb-map) ((m ch-map) &key key-compare-fn-name val-compare-fn-name) (convert-to-wb-map m nil nil (let ((tree nil)) (do-ch-map-tree-pairs (k v (ch-map-contents m) tree) (setq tree (WB-Map-Tree-With tree k v key-compare-fn val-compare-fn)))))) -(defmethod convert ((to-type (eql 'ch-map)) (m map) &key key-compare-fn-name val-compare-fn-name) - (let ((prototype (empty-ch-map nil key-compare-fn-name val-compare-fn-name)) - ((hmorg (ch-map-org prototype)) - ((key-hash-fn (hash-map-org-key-hash-fn hmorg)) - (key-compare-fn (hash-map-org-key-compare-fn hmorg)) - (val-hash-fn (hash-map-org-val-hash-fn hmorg)) - (val-compare-fn (hash-map-org-val-compare-fn hmorg)))) - (result nil)) - (do-map (k v m) - (setq result (ch-map-tree-with result k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) - (make-ch-map result hmorg (map-default m)))) +(define-convert-methods (ch-map fset2:ch-map) ((m map) &key key-compare-fn-name val-compare-fn-name) + (convert-to-ch-map m (map-default m) nil + (let ((tree nil)) + (do-map (k v m) + (setq tree (ch-map-tree-with tree k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) + tree))) -(defmethod convert ((to-type (eql 'ch-map)) (m ch-map) - &key (default nil default?) key-compare-fn-name val-compare-fn-name) +(define-convert-methods (ch-map fset2:ch-map) + ((m ch-map) &key (default nil default?) key-compare-fn-name val-compare-fn-name) "The result uses `default' if supplied, otherwise has the same default as `m'." (convert-to-ch-map m (if default? default (map-default m)) (let ((m-hmorg (ch-map-org m))) @@ -4382,9 +4859,8 @@ (defmethod convert ((to-type (eql 'ch-map)) (m ch-map) (setq tree (ch-map-tree-with tree k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) tree))) -(defmethod convert ((to-type (eql 'ch-map)) (l list) - &key (key-fn #'car) (value-fn #'cdr) - key-compare-fn-name val-compare-fn-name) +(define-convert-methods (ch-map fset2:map fset2:ch-map) + ((l list) &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) (declare (type function key-fn value-fn)) (convert-to-ch-map l nil nil (let ((tree nil)) @@ -4393,9 +4869,8 @@ (defmethod convert ((to-type (eql 'ch-map)) (l list) key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) tree))) -(defmethod convert ((to-type (eql 'ch-map)) (s seq) - &key (key-fn #'car) (value-fn #'cdr) - key-compare-fn-name val-compare-fn-name) +(define-convert-methods (ch-map fset2:map fset2:ch-map) + ((s seq) &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) (declare (type function key-fn value-fn)) (convert-to-ch-map l nil nil (let ((tree nil)) @@ -4404,9 +4879,8 @@ (defmethod convert ((to-type (eql 'ch-map)) (s seq) key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) tree))) -(defmethod convert ((to-type (eql 'ch-map)) (s sequence) - &key (key-fn #'car) (value-fn #'cdr) - key-compare-fn-name val-compare-fn-name) +(define-convert-methods (ch-map fset2:map fset2:ch-map) + ((s sequence) &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) (declare (type function key-fn value-fn)) (convert-to-ch-map l nil nil (let ((tree nil)) @@ -4416,7 +4890,13 @@ (defmethod convert ((to-type (eql 'ch-map)) (s sequence) key-hash-fn key-compare-fn val-hash-fn val-compare-fn)))) tree))) -(defmethod convert ((to-type (eql 'ch-map)) (ht hash-table) &key key-compare-fn-name val-compare-fn-name) +(define-convert-methods (ch-map fset2:ch-map) ((b bag) &key key-compare-fn-name val-compare-fn-name) + (convert-to-ch-map b nil nil + (let ((tree nil)) + (do-bag-pairs (x n b tree) + (setq tree (ch-map-tree-with tree x n key-hash-fn key-compare-fn val-hash-fn val-compare-fn)))))) + +(define-convert-methods (ch-map fset2:ch-map) ((ht hash-table) &key key-compare-fn-name val-compare-fn-name) (convert-to-ch-map ht nil nil (let ((tree nil)) (maphash (lambda (k v) @@ -4431,11 +4911,12 @@ (defmethod convert ((to-type (eql 'ch-map)) (ht hash-table) &key key-compare-fn- ((key-cf-name (hash-map-org-key-compare-fn-name hmorg)) (val-cf-name (hash-map-org-val-compare-fn-name hmorg)) ((key-default? (eq key-cf-name 'compare)) - (val-default? (eq val-cf-name 'compare))))) - (format nil " |}~:[[~:[~S~;~*~];~:[~S~;~*~]]~;~4*~]~@[/~S~]" + (val-default? (eq val-cf-name 'compare)))) + (dflt (map-default map))) + (format nil " |}~:[[~:[~S~;~*~];~:[~S~;~*~]]~;~4*~]~:[/~S~;~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (map-default map)))) + (eq dflt 'no-default) dflt))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) @@ -4457,7 +4938,7 @@ (defmethod make-load-form ((m ch-map) &optional environment) (defstruct (wb-seq (:include seq) - (:constructor make-wb-seq (contents &optional default)) + (:constructor make-wb-seq (contents default)) (:predicate wb-seq?) (:print-function print-wb-seq) (:copier nil)) @@ -4467,52 +4948,98 @@ (defstruct (wb-seq (contents nil :read-only t)) -(defparameter *empty-wb-seq* (make-wb-seq nil)) +(defparameter +empty-wb-seq+ (make-wb-seq nil nil)) -(declaim (inline empty-seq)) +(defparameter +empty-wb-seq/no-default+ (make-wb-seq nil 'no-default)) + +(declaim (inline empty-seq fset2:empty-seq)) (defun empty-seq (&optional default) "Returns an empty seq of the default implementation." (if default (make-wb-seq nil default) - *empty-wb-seq*)) - -(defmethod empty-instance-function ((class-name (eql 'seq))) - 'empty-seq) - -(declaim (inline empty-wb-seq)) -(defun empty-wb-seq () + +empty-wb-seq+)) +(defun fset2:empty-seq (&key (default nil default?) no-default?) + "Returns an empty seq of the default implementation. The seq's default is +`nil' unless a different default is supplied, or `no-default?' is true." + (empty-wb-seq-internal (fset2-default default? default no-default?))) + +(declaim (inline empty-wb-seq fset2:empty-wb-seq)) +(defun empty-wb-seq (&optional default) + "Returns an empty wb-seq." + (if default (make-wb-seq nil default) + +empty-wb-seq+)) +(defun fset2:empty-wb-seq (&key (default nil default?) no-default?) "Returns an empty wb-seq." - *empty-wb-seq*) + (empty-wb-seq-internal (fset2-default default? default no-default?))) -(defmethod empty-instance-function ((class-name (eql 'wb-seq))) - 'empty-wb-seq) +(defun empty-wb-seq-internal (default) + (cond ((null default) + +empty-wb-seq+) + ((eq default 'no-default) + +empty-wb-seq/no-default+) + (t (make-wb-seq nil default)))) (defmethod empty? ((s wb-seq)) (null (wb-seq-contents s))) (defmethod default ((s seq)) - (seq-default s)) + (let ((dflt (seq-default s))) + (if (eq dflt 'no-default) (values nil nil) + (values dflt t)))) (defmethod with-default ((s wb-seq) new-default) (make-wb-seq (wb-seq-contents s) new-default)) +(defmethod fset2:without-default ((s wb-seq)) + (make-wb-seq (wb-seq-contents s) 'no-default)) + (defmethod size ((s wb-seq)) (WB-Seq-Tree-Size (wb-seq-contents s))) -(defmethod lookup ((s wb-seq) key) - (if (typep key 'fixnum) - (locally (declare (type fixnum key)) - (let ((val? val (WB-Seq-Tree-Subscript (wb-seq-contents s) key))) - (values (if val? val (seq-default s)) val?))) - (values nil nil))) +(define-condition fset2:seq-bounds-error (fset2:lookup-error) + ((fset2:seq :initarg :seq :reader fset2:seq-bounds-error-seq) + (fset2:index :initarg :index :reader fset2:seq-bounds-error-index)) + (:report (lambda (sbe stream) + (let ((*print-length* 8) + (*print-level* 3)) + (format stream "Index ~D out of bounds for seq ~A, which has no default" + (fset2:seq-bounds-error-index sbe) (fset2:seq-bounds-error-seq sbe)))))) + +(define-methods (lookup fset2:lookup) ((s wb-seq) index) + (let ((val? val (if (typep index 'fixnum) (WB-Seq-Tree-Subscript (wb-seq-contents s) index) + (values nil nil)))) + (values (if val? val + (let ((dflt (seq-default s))) + (if (eq dflt 'no-default) + (error 'fset2:seq-bounds-error :seq s :index index) + dflt))) + val?))) + +(define-condition fset2:empty-seq-error (fset2:lookup-error) + ((fset2:seq :initarg :seq :reader fset2:empty-seq-error-seq)) + (:report (lambda (sbe stream) + (let ((*print-length* 8) + (*print-level* 3)) + (format stream "Seq ~A, which has no default, is empty" + (fset2:empty-seq-error-seq sbe)))))) (defmethod first ((s wb-seq)) (let ((val? val (WB-Seq-Tree-Subscript (wb-seq-contents s) 0))) - (values (if val? val (seq-default s)) val?))) + (values (if val? val + (let ((dflt (seq-default s))) + (if (eq dflt 'no-default) + (error 'fset2:empty-seq-error :seq s) + dflt))) + val?))) (defmethod last ((s wb-seq)) (let ((tree (wb-seq-contents s)) ((val? val (WB-Seq-Tree-Subscript tree (1- (WB-Seq-Tree-Size tree)))))) - (values (if val? val (seq-default s)) val?))) + (values (if val? val + (let ((dflt (seq-default s))) + (if (eq dflt 'no-default) + (error 'fset2:empty-seq-error :esq s) + dflt))) + val?))) (defmethod with-first ((s wb-seq) val) (make-wb-seq (WB-Seq-Tree-Insert (wb-seq-contents s) 0 val) @@ -4538,12 +5065,16 @@ (defmethod with ((s wb-seq) idx &optional (val nil val?)) (let ((tree (wb-seq-contents s)) ((size (WB-Seq-Tree-Size tree)))) (when (< idx -1) + (when (eq (seq-default s) 'no-default) + (error 'fset2:seq-bounds-error :seq s :index idx)) (setq tree (WB-Seq-Tree-Concat (WB-Seq-Tree-From-Vector (make-array (- -1 idx) :initial-element (seq-default s))) tree)) (setq idx -1)) (when (> idx size) + (when (eq (seq-default s) 'no-default) + (error 'fset2:seq-bounds-error :seq s :index idx)) (setq tree (WB-Seq-Tree-Concat tree (WB-Seq-Tree-From-Vector (make-array (- idx size) :initial-element (seq-default s))))) @@ -4559,12 +5090,16 @@ (defmethod insert ((s wb-seq) idx val) (let ((tree (wb-seq-contents s)) ((size (WB-Seq-Tree-Size tree)))) (when (< idx 0) + (when (eq (seq-default s) 'no-default) + (error 'fset2:seq-bounds-error :seq s :index idx)) (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) + (when (eq (seq-default s) 'no-default) + (error 'fset2:seq-bounds-error :seq s :index idx)) (setq tree (WB-Seq-Tree-Concat tree (WB-Seq-Tree-From-Vector (make-array (- idx size) :initial-element (seq-default s))))) @@ -4577,17 +5112,19 @@ (defmethod splice ((s wb-seq) idx subseq) ((size (WB-Seq-Tree-Size tree))) (subseq-tree (wb-seq-contents (convert 'wb-seq subseq)))) (when (< idx 0) + (when (eq (seq-default s) 'no-default) + (error 'fset2:seq-bounds-error :seq s :index idx)) (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) + (when (eq (seq-default s) 'no-default) + (error 'fset2:seq-bounds-error :seq s :index idx)) (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-array (- idx size) :initial-element (seq-default s)))))) (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))) @@ -4602,7 +5139,7 @@ (defmethod less ((s wb-seq) idx &optional (arg2 nil arg2?)) (make-wb-seq (WB-Seq-Tree-Remove tree idx) (seq-default s)) s))) -(defmethod concat ((s1 seq) &rest seqs) +(define-methods (concat fset2: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))))) @@ -4639,17 +5176,8 @@ (defmethod domain ((s wb-seq)) (defmethod range ((s wb-seq)) (convert 'set s)) -(defmethod convert ((to-type (eql 'seq)) (s seq) &key) - s) - -(defmethod convert ((to-type (eql 'wb-seq)) (s wb-seq) &key) - s) - -(defmethod convert ((to-type (eql 'seq)) (vec vector) &key) - (make-wb-seq (WB-Seq-Tree-From-Vector vec))) - -(defmethod convert ((to-type (eql 'wb-seq)) (vec vector) &key) - (make-wb-seq (WB-Seq-Tree-From-Vector vec))) +(defmethod convert ((to-type (eql 'list)) (s wb-seq) &key) + (WB-Seq-Tree-To-List (wb-seq-contents s))) (defmethod convert ((to-type (eql 'vector)) (s wb-seq) &key) (WB-Seq-Tree-To-Vector (wb-seq-contents s))) @@ -4657,25 +5185,42 @@ (defmethod convert ((to-type (eql 'vector)) (s wb-seq) &key) (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))) +(define-convert-methods (seq fset2:seq) ((s seq) &key) + s) -(defmethod convert ((to-type (eql 'wb-seq)) (l list) &key) - (make-wb-seq (WB-Seq-Tree-From-List l))) +(define-convert-methods (wb-seq fset2:wb-seq) ((s wb-seq) &key) + s) -(defmethod convert ((to-type (eql 'list)) (s wb-seq) &key) - (WB-Seq-Tree-To-List (wb-seq-contents s))) +(define-convert-methods (seq wb-seq) ((vec vector) &key) + (make-wb-seq (WB-Seq-Tree-From-Vector vec) nil)) + +(define-convert-methods (fset2:seq fset2:wb-seq) ((vec vector) &key (default nil default?) no-default?) + (make-wb-seq (WB-Seq-Tree-From-Vector vec) (fset2-default default? default no-default?))) + +(define-convert-methods (seq wb-seq) ((l list) &key reverse?) + (make-wb-seq (if reverse? (WB-Seq-Tree-From-List-Reverse l) + (WB-Seq-Tree-From-List l)) + nil)) + +(define-convert-methods (fset2:seq fset2:wb-seq) ((l list) &key reverse? (default nil default?) no-default?) + (make-wb-seq (if reverse? (WB-Seq-Tree-From-List-Reverse l) + (WB-Seq-Tree-From-List l)) + (fset2-default default? default no-default?))) + +(define-convert-methods (seq wb-seq) ((s set) &key) + (make-wb-seq (wb-seq-tree-from-iterable (iterator s) (size s)) nil)) -(defmethod convert ((to-type (eql 'seq)) (s set) &key) - (make-wb-seq (wb-seq-tree-from-iterable (iterator s) (size s)))) +(define-convert-methods (fset2:seq fset2:wb-seq) ((s set) &key (default nil default?) no-default?) + (make-wb-seq (wb-seq-tree-from-iterable (iterator s) (size s)) (fset2-default default? default no-default?))) -(defmethod convert ((to-type (eql 'wb-seq)) (s set) &key) - (make-wb-seq (wb-seq-tree-from-iterable (iterator s) (size s)))) +(define-convert-methods (seq wb-seq) ((b bag) &key pairs? (pair-fn #'cons)) + (bag-to-seq b pairs? pair-fn nil)) -(defmethod convert ((to-type (eql 'seq)) (b bag) &key pairs? (pair-fn #'cons)) - (convert 'wb-seq b :pairs? pairs? :pair-fn pair-fn)) +(define-convert-methods (fset2:seq fset2:wb-seq) + ((b bag) &key pairs? (pair-fn #'cons) (default nil default?) no-default?) + (bag-to-seq b pairs? pair-fn (fset2-default default? default no-default?))) -(defmethod convert ((to-type (eql 'wb-seq)) (b bag) &key pairs? (pair-fn #'cons)) +(defun bag-to-seq (b pairs? pair-fn default) (make-wb-seq (wb-seq-tree-from-iterable (if pairs? (let ((it (iterator b :pairs? t))) (lambda (op) @@ -4684,19 +5229,23 @@ (defmethod convert ((to-type (eql 'wb-seq)) (b bag) &key pairs? (pair-fn #'cons) (funcall pair-fn v n)) (funcall it op)))) (iterator b)) - (if pairs? (set-size b) (size b))))) + (if pairs? (set-size b) (size b))) + default)) -(defmethod convert ((to-type (eql 'seq)) (m map) &key (pair-fn #'cons)) - (convert 'wb-seq m :pair-fn pair-fn)) +(define-convert-methods (seq wb-seq) ((m map) &key (pair-fn #'cons)) + (map-to-seq m pair-fn nil)) -(defmethod convert ((to-type (eql 'wb-seq)) (m map) &key (pair-fn #'cons)) +(define-convert-methods (fset2:seq fset2:wb-seq) ((m map) &key (pair-fn #'cons)) + (map-to-seq m pair-fn (map-default m))) + +(defun map-to-seq (m pair-fn default) (make-wb-seq (wb-seq-tree-from-iterable (let ((m-it (iterator m))) (lambda (op) (ecase op (:get (let ((k v (funcall m-it ':get))) (funcall pair-fn k v)))))) (size m)) - (map-default m))) + default)) ;;; Prior to FSet 1.4.0, this method ignored the defaults, so two seqs with the same ;;; elements but different defaults compared `:equal'. While that was clearly a bug, @@ -4712,6 +5261,9 @@ (defmethod compare ((s1 wb-seq) (s2 wb-seq)) ':unequal ':equal)))))) +(defun compare-seqs-lexicographically (a b &optional (val-compare-fn #'compare)) + (WB-Seq-Tree-Compare-Lexicographically (wb-seq-contents a) (wb-seq-contents b) val-compare-fn)) + (defmethod hash-value ((s wb-seq)) ;; Currently doing bounded hashing, but &&& am considering changing it to do caching ;; with incremental update. @@ -4746,7 +5298,6 @@ (defmethod internal-do-seq ((s wb-seq) elt-fn value-fn index? (declare (optimize (speed 3) (safety 0)) (type function elt-fn value-fn)) (assert (and (typep start 'fixnum) (typep end 'fixnum))) - ;; Expect Python notes about "can't use known return convention" (if index? (let ((i start)) (declare (type fixnum i)) @@ -4777,20 +5328,22 @@ (defmethod range-contains? ((s seq) x) (when (equal? y x) (return t)))) -(defmethod filter ((fn function) (s seq)) +(define-methods (filter fset2:filter) ((fn function) (s seq)) (seq-filter fn s)) -(defmethod filter ((fn symbol) (s seq)) +(define-methods (filter fset2:filter) ((fn symbol) (s seq)) (seq-filter (coerce-to-function fn) s)) (defmethod filter ((fn map) (s seq)) (seq-filter #'(lambda (x) (lookup fn x)) s)) +(defmethod fset2:filter ((fn map) (s seq)) + (seq-filter #'(lambda (x) (fset2:lookup fn x)) s)) -(defmethod filter ((fn set) (s seq)) - (seq-filter #'(lambda (x) (lookup fn x)) s)) +(define-methods (filter fset2:filter) ((fn set) (s seq)) + (seq-filter #'(lambda (x) (contains? fn x)) s)) -(defmethod filter ((fn bag) (s seq)) - (seq-filter #'(lambda (x) (lookup fn x)) s)) +(define-methods (filter fset2:filter) ((fn bag) (s seq)) + (seq-filter #'(lambda (x) (contains? fn x)) s)) (defun seq-filter (fn s) (declare (optimize (speed 3) (safety 0)) @@ -4802,20 +5355,22 @@ (defmethod filter ((fn bag) (s seq)) (make-wb-seq (WB-Seq-Tree-From-List (nreverse result)) (seq-default s)))) -(defmethod partition ((fn function) (s seq)) +(define-methods (partition fset2:partition) ((fn function) (s seq)) (seq-partition fn s)) -(defmethod partition ((fn symbol) (s seq)) +(define-methods (partition fset2:partition) ((fn symbol) (s seq)) (seq-partition (coerce-to-function fn) s)) (defmethod partition ((fn map) (s seq)) (seq-partition #'(lambda (x) (lookup fn x)) s)) +(defmethod fset2:partition ((fn map) (s seq)) + (seq-partition #'(lambda (x) (fset2:lookup fn x)) s)) -(defmethod partition ((fn set) (s seq)) - (seq-partition #'(lambda (x) (lookup fn x)) s)) +(define-methods (partition fset2:partition) ((fn set) (s seq)) + (seq-partition #'(lambda (x) (contains? fn x)) s)) -(defmethod partition ((fn bag) (s seq)) - (seq-partition #'(lambda (x) (lookup fn x)) s)) +(define-methods (partition fset2:partition) ((fn bag) (s seq)) + (seq-partition #'(lambda (x) (contains? fn x)) s)) (defun seq-partition (fn s) (declare (optimize (speed 3) (safety 0)) @@ -4849,21 +5404,31 @@ (defmethod sort-and-group ((s seq) pred &key key) (with-last result group)))) (defmethod image ((fn function) (s seq) &key) - (seq-image fn s)) + (seq-image fn s (seq-default s))) +(defmethod fset2:image ((fn function) (s seq) &key (default nil default?) no-default?) + (seq-image fn s (fset2-default default? default no-default?))) (defmethod image ((fn symbol) (s seq) &key) - (seq-image (coerce-to-function fn) s)) + (seq-image (coerce-to-function fn) s (seq-default s))) +(defmethod fset2:image ((fn symbol) (s seq) &key (default nil default?) no-default?) + (seq-image (coerce-to-function fn) s (fset2-default default? default no-default?))) (defmethod image ((fn map) (s seq) &key) - (seq-image #'(lambda (x) (lookup fn x)) s)) + (seq-image #'(lambda (x) (lookup fn x)) s (seq-default s))) +(defmethod fset2:image ((fn map) (s seq) &key (default nil default?) no-default?) + (seq-image #'(lambda (x) (fset2:lookup fn x)) s (fset2-default default? default no-default?))) (defmethod image ((fn set) (s seq) &key) - (seq-image #'(lambda (x) (lookup fn x)) s)) + (seq-image #'(lambda (x) (lookup fn x)) s (seq-default s))) +(defmethod fset2:image ((fn set) (s seq) &key (default nil default?) no-default?) + (seq-image #'(lambda (x) (fset2:lookup fn x)) s (fset2-default default? default no-default?))) (defmethod image ((fn bag) (s seq) &key) - (seq-image #'(lambda (x) (lookup fn x)) s)) + (seq-image #'(lambda (x) (lookup fn x)) s (seq-default s))) +(defmethod fset2:image ((fn bag) (s seq) &key (default nil default?) no-default?) + (seq-image #'(lambda (x) (fset2:lookup fn x)) s (fset2-default default? default no-default?))) -(defun seq-image (fn s) +(defun seq-image (fn s default) (declare (optimize (speed 3) (safety 0)) (type function fn)) ;; This is not bad, but we could do better by walking the tree of `s' and building @@ -4871,8 +5436,7 @@ (defmethod image ((fn bag) (s seq) &key) (let ((result nil)) (do-seq (x s) (push (funcall fn x) result)) - (make-wb-seq (WB-Seq-Tree-From-List (nreverse result)) - (seq-default s)))) + (make-wb-seq (WB-Seq-Tree-From-List (nreverse result)) default))) (defmethod reduce ((fn function) (s seq) &key key (initial-value nil init?) @@ -4895,21 +5459,11 @@ (defmethod reduce ((fn symbol) (s seq) (call-fn? init?)) (if (and (not init?) (empty? s)) (setq result (funcall fn)) - (if (and (= start 0) (= end (the fixnum (size s))) (not from-end?)) - (do-seq (x s) - (if call-fn? - (setq result (funcall fn result (if key (funcall key x) x))) - (setq result (if key (funcall key x) x) - call-fn? t))) - ;; &&& Would be nice if our iterators were up to this. - (dotimes (i (- end start)) - (declare (type fixnum i)) - (let ((x (lookup s (if from-end? (the fixnum (- end i 1)) - (the fixnum (+ i start)))))) - (if call-fn? - (setq result (funcall fn result (if key (funcall key x) x))) - (setq result (if key (funcall key x) x) - call-fn? t)))))) + (do-seq (x s :start start :end end :from-end? from-end?) + (if call-fn? + (setq result (funcall fn result (if key (funcall key x) x))) + (setq result (if key (funcall key x) x) + call-fn? t)))) result)) (defmethod find (item (s seq) &key key test start end from-end) @@ -4989,7 +5543,7 @@ (defmethod count-if-not (pred (s seq) &key key start end from-end) (defmethod position (item (s seq) &key key test start end from-end) (declare (optimize (speed 3) (safety 0)) (type (or fixnum null) start end)) - (let ((test default? (coerce-to-function-or-equal? test)) + (let ((test (coerce-to-function-or-equal? test)) (start (or start 0)) ((pos start)) (end (or end (size s)))) @@ -4999,24 +5553,14 @@ (defmethod position (item (s seq) &key key test start end from-end) (if from-end (the fixnum (+ start (the fixnum (- end pos 1)))) pos)))) (if key (let ((key (coerce-to-function key))) - (if default? - (do-seq (x s :start start :end end :from-end? from-end) - (when (equal? item (funcall key x)) - (done)) - (incf pos)) - (do-seq (x s :start start :end end :from-end? from-end) - (when (funcall test item (funcall key x)) - (done)) - (incf pos)))) - (if default? - (do-seq (x s :start start :end end :from-end? from-end) - (when (equal? item x) - (done)) - (incf pos)) (do-seq (x s :start start :end end :from-end? from-end) - (when (funcall test item x) + (when (funcall test item (funcall key x)) (done)) - (incf pos)))))))) + (incf pos))) + (do-seq (x s :start start :end end :from-end? from-end) + (when (funcall test item x) + (done)) + (incf pos))))))) (defmethod position-if (pred (s seq) &key key start end from-end) (declare (optimize (speed 3) (safety 0)) @@ -5136,17 +5680,19 @@ (defmethod substitute-if-not (newitem pred (s seq) &key key start end from-end c (defun print-wb-seq (seq stream level) (declare (ignore level)) - (pprint-logical-block (stream nil :prefix "#[") + (pprint-logical-block (stream nil :prefix "#[" + :suffix (let ((dflt (seq-default seq))) + (format nil " ]~:[/~A~;~]" + (eq dflt 'no-default) dflt))) (do-seq (x seq) (pprint-pop) (write-char #\Space stream) (pprint-newline :linear stream) - (write x :stream stream)) - (format stream " ]~:[~;/~:*~S~]" (seq-default seq)))) + (write x :stream stream)))) (defmethod make-load-form ((s wb-seq) &optional environment) (declare (ignore environment)) - `(convert 'wb-seq ',(convert 'list s))) + `(with-default (convert 'wb-seq ',(convert 'list s)) ',(seq-default s))) ;;; ================================================================================ @@ -5163,13 +5709,13 @@ (defmethod empty? ((s sequence)) (defmethod size ((s sequence)) (length s)) -(defmethod lookup ((s sequence) (idx integer)) +(define-methods (lookup fset2:lookup) ((s sequence) (idx integer)) (values (elt s idx) t)) -(defmethod lookup ((fn function) (v t)) +(define-methods (lookup fset2:lookup) ((fn function) (v t)) (funcall fn v)) -(defmethod lookup ((fn symbol) (v t)) +(define-methods (lookup fset2:lookup) ((fn symbol) (v t)) (funcall fn v)) (defmethod convert ((to-type (eql 'list)) (v vector) &key) @@ -5179,39 +5725,32 @@ (defmethod convert ((to-type (eql 'vector)) (l list) &key) (coerce l 'vector)) (defmethod convert ((to-type (eql 'list)) (s sequence) &key) - (let ((result nil)) - (dotimes (i (length s)) - (push (elt s i) result)) - (nreverse result))) + (coerce s 'list)) (defmethod convert ((to-type (eql 'vector)) (s sequence) &key) - (let* ((seq-len (length s)) - (result (make-array seq-len))) - (dotimes (i seq-len result) - (setf (svref result i) (elt s i))))) + (coerce s 'vector)) (declaim (inline compose-with-key-fn)) (defun compose-with-key-fn (fn collection) + (declare (type function fn)) (lambda (key) (lookup collection (funcall fn key)))) -(defmethod compose ((fn function) (m map) &key) - (compose-with-key-fn fn m)) - -(defmethod compose ((fn symbol) (m map) &key) +(define-methods (compose fset2:compose) ((fn function) (m map) &key) (compose-with-key-fn fn m)) -(defmethod compose ((fn function) (s seq) &key) - (compose-with-key-fn fn s)) +(define-methods (compose fset2:compose) ((fn symbol) (m map) &key) + (compose-with-key-fn (coerce fn 'function) m)) -(defmethod compose ((fn symbol) (s seq) &key) +(define-methods (compose fset2:compose) ((fn function) (s seq) &key) (compose-with-key-fn fn s)) +(define-methods (compose fset2:compose) ((fn symbol) (s seq) &key) + (compose-with-key-fn (coerce fn 'function) s)) ;;; ================================================================================ ;;; Miscellany -;;; Oooops -- I somehow thought CL already had this. (define-condition simple-program-error (simple-condition program-error) ()) diff --git a/Code/macros.lisp b/Code/macros.lisp index 0bf20e097ebcfb769dd085c2da2c2662337f2bda..becfaba9ff463756f62a0da65e63c82e4227e800 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -24,6 +24,15 @@ ;; seems to give better code, at least on SBCL on AMD64. `(1- (incf ,place ,delta))) +(defmacro n-values (n expr) + "Forces the return of exactly `n' values from `expr'. `n' must be a compile-time +constant." + (assert (typep n 'fixnum)) + (let ((vars (gmap (:result list) (fn (_i) (gensym)) + (:index 0 n)))) + `(multiple-value-bind ,vars ,expr + (values . ,vars)))) + ;;; ================================================================================ ;;; Macros related to order.lisp @@ -85,6 +94,8 @@ (defmethod compare ((f1 frob) (f2 frob)) ((and (listp fn) (eq (car fn) 'lambda)) `(,fn ,arg)) + ((and (listp fn) (eq (car fn) 'fn)) + (call (macroexpand fn) arg)) ((and (listp fn) (eq (car fn) 'quote) (symbolp (cadr fn))) @@ -168,6 +179,23 @@ (defmethod compare ((f1 frob) (f2 frob)) been generated, and against which subsequent such methods will be generated. This is a list in reverse order.")) +(defmacro define-generics (names parameter-list &body body) + `(progn . ,(mapcar (fn (name) + `(defgeneric ,name ,parameter-list . ,body)) + names))) + +(defmacro define-methods (methods parameter-list &body body) + `(progn . ,(mapcar (fn (method) + `(defmethod ,method ,parameter-list . ,body)) + methods))) + +(defmacro define-convert-methods (to-types parameter-list-rest &body body) + `(progn . ,(mapcar (fn (to-type) + `(defmethod convert ,(cons `(to-type (eql ',to-type)) + parameter-list-rest) + . ,body)) + to-types))) + ;;; Handy macro to generate the cross-comparison methods. (defmacro define-cross-type-compare-methods (type) "Generates cross-type comparison methods for `type' against the types on @@ -254,7 +282,7 @@ (define-class part ((part-number :equality ...) ...))" (defmethod compare ((a ,class) (b ,class)) (compare-slots a b . ,slots/accessors)) (defmethod hash-value ((x ,class)) - (hash-slots x . ,(if (eq (last slots/accessors) ':eql) (butlast slots/accessors) + (hash-slots x . ,(if (eq (car (cl:last slots/accessors)) ':eql) (butlast slots/accessors) slots/accessors))))) (defmacro define-comparison-slots (class &rest slots/accessors) @@ -263,6 +291,23 @@ (defmethod hash-value ((x ,class)) ;;; &&& Add `(:cache slot/acc)' syntax for auto-caching (defmacro hash-slots (obj &rest slots/accessors) + "A handy macro for writing the bodies of `hash-value' methods for user classes. +Computes a hash value by combining the hash values of the specified slots +and/or accessors applied to the object. For standard classes, best performance +is gotten by supplying the slot names as \(quoted\) symbols; for structure +classes, it is best to supply accessor functions. \(Actually, any function on +the object can be used.\) For example: + + (defstruct point x y) + (defmethod hash-value ((p point)) + (hash-slots p #'x #'y)) + + (defclass part () ((part-number ...) ...)) + (defmethod hash-value ((p part)) + (hash-slots part 'part-number)) + +In most cases, it is better to use `define-equality-slots' instead of calling +this macro directly, to keep the `hash-value' and `compare' methods consistent." (unless slots/accessors (error "At least one slot/accessor must be supplied")) (let ((x-var (gensymx #:x-))) @@ -281,6 +326,8 @@ (defmethod hash-value ((x ,class)) ((and (listp fn) (eq (car fn) 'lambda)) `(,fn ,arg)) + ((and (listp fn) (eq (car fn) 'fn)) + (call (macroexpand fn) arg)) ((and (listp fn) (eq (car fn) 'quote) (symbolp (cadr fn))) @@ -334,7 +381,9 @@ (defmethod hash-value ((x ,class)) (defmacro internal-concat (&rest args) `(concat . ,args)) (defmacro internal-insert (&rest args) - `(insert . ,args))) + `(insert . ,args)) + (defmacro internal-splice (&rest args) + `(splice . ,args))) #-FSet-Use-Package-Locks (progn @@ -391,7 +440,10 @@ (defmethod hash-value ((x ,class)) (apply #'concat seq1 seqs)) (declaim (inline internal-insert)) (defun internal-insert (seq idx val) - (insert seq idx val))) + (insert seq idx val)) + (declaim (inline internal-splice)) + (defun internal-splice (seq idx val) + (splice seq idx val))) ;;; -------------------------------- ;;; Modify macros @@ -495,6 +547,9 @@ (define-modify-macro prependf (seq) (define-modify-macro insertf (idx value) internal-insert) +(define-modify-macro splicef (idx subseq) + internal-splice) + (declaim (inline xconcat)) (defun xconcat (seq1 seq2) (concat seq2 seq1)) @@ -509,20 +564,31 @@ (define-setf-expander lookup (collection key &environment env) sequence; it modifies the place (generalized variable) HOLDING the map or sequence (just like `(setf (ldb ...) ...)'). That is, the `collection' subform must be `setf'able itself." + (expand-setf-of-lookup 'lookup collection key env)) +(define-setf-expander fset2:lookup (collection key &environment env) + "Adds a pair to a map or updates an existing pair, or adds an element to a +sequence or updates an existing element. This does NOT modify the map or +sequence; it modifies the place (generalized variable) HOLDING the map or +sequence (just like `(setf (ldb ...) ...)'). That is, the `collection' subform +must be `setf'able itself." + (expand-setf-of-lookup 'fset2:lookup collection key env)) + +(defun expand-setf-of-lookup (name collection key env) (let ((temps vals stores store-form access-form (get-setf-expansion collection env)) (key-temp (gensymx #:key-)) (val-temp (gensymx #:val-)) - ((coll-temp (car stores)))) + ((coll-temp (car stores))) + (lookup-fn (intern (string 'internal-lookup) (symbol-package name)))) (when (cdr stores) - (error "Too many values required in `setf' of `lookup'")) + (error "Too many values required in `setf' of `~A'" name)) (values (cons key-temp temps) (cons key vals) (list val-temp) `(let ((,coll-temp (internal-with ,access-form ,key-temp ,val-temp))) ,store-form ,val-temp) - `(internal-lookup ,access-form ,key-temp)))) + `(,lookup-fn ,access-form ,key-temp)))) (defmacro @ (fn-or-collection &rest args) "A little hack with two purposes: (1) to make it easy to make FSet maps @@ -537,14 +603,32 @@ (define-setf-expander lookup (collection key &environment env) side-effect-free functions. Also, though this doc string has spoken only of FSet maps, `@' can be used with any type that `lookup' works on. Can be used with `setf', but only on collections, not functions, of course." + (expand-@ '@ fn-or-collection args)) +(defmacro fset2:@ (fn-or-collection &rest args) + "A little hack with two purposes: (1) to make it easy to make FSet maps +behave like Lisp functions in certain contexts; and (2) to somewhat lessen the +pain of writing higher-order code in a two-namespace Lisp like Common Lisp. +The idea is that you can write `(@ fn arg)', and if `fn' is a Lisp function, +it will be funcalled on the argument; otherwise `lookup' (q.v.) will be called +on `fn' and `arg'. To allow for `@' to be used in more contexts, it actually +can take any number of `args', though `lookup' always takes exactly two. Thus +you can write `(@ fn arg1 arg2 ...)' when you just want a shorter name for +`funcall'. As a matter of style, it is suggested that `@' be used only for +side-effect-free functions. Also, though this doc string has spoken only of +FSet maps, `@' can be used with any type that `lookup' works on. Can be used +with `setf', but only on collections, not functions, of course." + (expand-@ 'fset2:@ fn-or-collection args)) + +(defun expand-@ (name fn-or-collection args) (if (= (length args) 1) (let ((fn-var (gensymx #:fn-)) - (arg-var (gensymx #:arg-))) + (arg-var (gensymx #:arg-)) + (lookup-fn (intern (string 'internal-lookup) (symbol-package name)))) `(let ((,fn-var ,fn-or-collection) (,arg-var ,(car args))) (if (functionp ,fn-var) (funcall ,fn-var ,arg-var) - (internal-lookup ,fn-var ,arg-var)))) + (,lookup-fn ,fn-var ,arg-var)))) `(funcall ,fn-or-collection . ,args))) ;;; Have to do the same thing for `@', since `setf' would not know what to @@ -555,24 +639,21 @@ (define-setf-expander @ (collection key &environment env) sequence; it modifies the place (generalized variable) HOLDING the map or sequence (just like `(setf (ldb ...) ...)'). That is, the `collection' subform must be `setf'able itself." - (let ((temps vals stores store-form access-form - (get-setf-expansion collection env)) - (key-temp (gensymx #:key-)) - (val-temp (gensymx #:val-)) - ((coll-temp (car stores)))) - (when (cdr stores) - (error "Too many values required in `setf' of `@'")) - (values (cons key-temp temps) - (cons key vals) - (list val-temp) - `(let ((,coll-temp (internal-with ,access-form ,key-temp ,val-temp))) - ,store-form - ,val-temp) - `(internal-lookup ,access-form ,key-temp)))) + (expand-setf-of-lookup '@ collection key env)) +(define-setf-expander fset2:@ (collection key &environment env) + "Adds a pair to a map or updates an existing pair, or adds an element to a +sequence or updates an existing element. This does NOT modify the map or +sequence; it modifies the place (generalized variable) HOLDING the map or +sequence (just like `(setf (ldb ...) ...)'). That is, the `collection' subform +must be `setf'able itself." + (expand-setf-of-lookup 'fset2:@ collection key env)) (declaim (inline internal-lookup)) (defun internal-lookup (&rest args) (apply #'lookup args)) +(declaim (inline fset2::internal-lookup)) +(defun fset2::internal-lookup (&rest args) + (apply #'fset2:lookup args)) ;;; -------------------------------- @@ -765,19 +846,34 @@ (define-setf-expander @ (collection key &environment env) "Yields the elements of `set'." `((the function (iterator ,set)) #'(lambda (it) (funcall it ':done?)) - #'(lambda (it) (funcall it ':get)))) + #'(lambda (it) (funcall it ':get)) + nil nil nil + (do-set ,set))) + +(gmap:def-arg-type-synonym fset2:set set) -(gmap:def-gmap-res-type set (&key filterp) +(gmap:def-arg-type-synonym fun-set fun-sequence) + +;;; The only reason to use the functional iterators in `gmap' forms is that you want +;;; to iterate in reverse order for some reason. But I do want to test them +(gmap:def-gmap-arg-type fun-set (set &key from-end?) + `((fun-iterator ,set :from-end? ,from-end?) + #'(lambda (it) (funcall it ':empty?)) + #'(lambda (it) (funcall it ':first)) + #'(lambda (it) (funcall it ':rest)))) + +(gmap:def-result-type set (&key filterp) "Returns a set of the values, optionally filtered by `filterp'." `(nil #'(lambda (s x) (WB-Set-Tree-With s x #'compare)) #'make-wb-set ,filterp)) - -;;; A bit faster than `set', if you know it's a `wb-set'. +;;; Faster than `set', if you know it's a `wb-set'. (gmap:def-gmap-arg-type wb-set (set) "Yields the elements of `set'." `((Make-WB-Set-Tree-Iterator-Internal (wb-set-contents ,set)) #'WB-Set-Tree-Iterator-Done? - #'WB-Set-Tree-Iterator-Get)) + #'WB-Set-Tree-Iterator-Get + nil nil nil + (Do-WB-Set-Tree-Members (wb-set-contents ,set)))) (gmap:def-gmap-res-type wb-set (&key filterp compare-fn-name) "Returns a set of the values, optionally filtered by `filterp'. If @@ -793,27 +889,20 @@ (define-setf-expander @ (collection key &environment env) ((,org-var (wb-set-org (empty-wb-set ,compare-fn-name))) ((,cf-var (tree-set-org-compare-fn ,org-var))))))) - -(gmap:def-gmap-res-type union (&key filterp) - "Returns the union of the sets, optionally filtered by `filterp'." - ;; Written to take the implementation and organization from the first value. - `(nil #'(lambda (s x) (if (null s) x (union s x))) - #'(lambda (s) (or s (set))) - ,filterp)) - -(gmap:def-gmap-res-type intersection (&key filterp) - "Returns the intersection of the sets, optionally filtered by `filterp'. -\(If zero sets are supplied, returns the full set; see `full-set'.\)" - ;; Written to take the implementation and organization from the first value. - `(nil #'(lambda (s x) (if (null s) x (intersection s x))) - #'(lambda (s) (or s (full-set))) - ,filterp)) - -;;; A bit faster than `set', if you know it's a `ch-set'. +;;; Faster than `set', if you know it's a `ch-set'. (gmap:def-gmap-arg-type ch-set (set) `((make-ch-set-tree-iterator-internal (ch-set-contents ,set)) #'ch-set-tree-iterator-done? - #'ch-set-tree-iterator-get)) + #'ch-set-tree-iterator-get + nil nil nil + (do-ch-set-tree-members (ch-set-contents ,set)))) + +(gmap:def-result-type fset2:set (&key filterp) + "Returns a set of the values, optionally filtered by `filterp'. If +`compare-fn-name' is nonnull, it specifies a custom ordering." + `(nil #'(lambda (s x) (ch-set-tree-with s x #'hash-value #'compare)) + #'(lambda (s) (make-ch-set s +fset-default-hash-set-org+)) + ,filterp)) (gmap:def-gmap-res-type ch-set (&key filterp compare-fn-name) "Returns a set of the values, optionally filtered by `filterp'. If @@ -828,6 +917,21 @@ (define-setf-expander @ (collection key &environment env) ((,hf-var (hash-set-org-hash-fn ,org-var)) (,cf-var (hash-set-org-compare-fn ,org-var))))))) +(gmap:def-gmap-res-type union (&key filterp) + "Returns the union of the sets, optionally filtered by `filterp'." + ;; Written to take the implementation and organization from the first value. + `(nil #'(lambda (s x) (if (null s) x (union s x))) + #'(lambda (s) (or s (set))) + ,filterp)) + +(gmap:def-gmap-res-type intersection (&key filterp) + "Returns the intersection of the sets, optionally filtered by `filterp'. +\(If zero sets are supplied, returns the full set; see `full-set'.\)" + ;; Written to take the implementation and organization from the first value. + `(nil #'(lambda (s x) (if (null s) x (intersection s x))) + #'(lambda (s) (or s (full-set))) + ,filterp)) + ;;; ---------------- ;;; Bags @@ -835,25 +939,33 @@ (define-setf-expander @ (collection key &environment env) "Yields each element of `bag', as many times as its multiplicity." `((the function (iterator ,bag)) #'(lambda (it) (funcall it ':done?)) - #'(lambda (it) (funcall it ':get)))) + #'(lambda (it) (funcall it ':get)) + nil nil nil + (do-bag ,bag))) (gmap:def-gmap-arg-type bag-pairs (bag) "Yields each element of `bag' and its multiplicity as two values." `((the function (iterator ,bag :pairs? t)) #'(lambda (it) (funcall it ':done?)) - (:values 2 #'(lambda (it) (funcall it ':get))))) + (:values 2 #'(lambda (it) (funcall it ':get))) + nil nil nil + (do-bag-pairs ,bag))) (gmap:def-gmap-arg-type wb-bag (bag) "Yields each element of `bag', as many times as its multiplicity." `((Make-WB-Bag-Tree-Iterator-Internal (wb-bag-contents ,bag)) #'WB-Bag-Tree-Iterator-Done? - #'WB-Bag-Tree-Iterator-Get)) + #'WB-Bag-Tree-Iterator-Get)) ; no `Do-WB-Bag-Tree-Elements' (gmap:def-gmap-arg-type wb-bag-pairs (bag) "Yields each element of `bag' and its multiplicity as two values." `((Make-WB-Bag-Tree-Pair-Iterator-Internal (wb-bag-contents ,bag)) #'WB-Bag-Tree-Pair-Iterator-Done? - (:values 2 #'WB-Bag-Tree-Pair-Iterator-Get))) + (:values 2 #'WB-Bag-Tree-Pair-Iterator-Get) + nil nil nil + (Do-WB-Bag-Tree-Pairs (wb-bag-contents ,bag)))) + +(gmap:def-arg-type-synonym fun-bag fun-sequence) (gmap:def-arg-type fun-bag-pairs (bag &key from-end?) `((fun-iterator ,bag :pairs? t :from-end? ,from-end?) @@ -914,13 +1026,21 @@ (define-setf-expander @ (collection key &environment env) "Yields each pair of `map', as two values." `((the function (iterator ,map)) #'(lambda (it) (funcall it ':done?)) - (:values 2 #'(lambda (it) (funcall it ':get))))) + (:values 2 #'(lambda (it) (funcall it ':get))) + nil nil nil + (do-map ,map))) + +(gmap:def-arg-type-synonym fset2:map map) (gmap:def-gmap-arg-type wb-map (map) "Yields each pair of `map', as two values." `((Make-WB-Map-Tree-Iterator-Internal (wb-map-contents ,map)) #'WB-Map-Tree-Iterator-Done? - (:values 2 #'WB-Map-Tree-Iterator-Get))) + (:values 2 #'WB-Map-Tree-Iterator-Get) + nil nil nil + (Do-WB-Map-Tree-Pairs (wb-map-contents ,map)))) + +(gmap:def-arg-type-synonym fset2:wb-map wb-map) (gmap:def-arg-type fun-map (map &key from-end?) `((fun-iterator ,map :from-end? ,from-end?) @@ -928,14 +1048,22 @@ (define-setf-expander @ (collection key &environment env) (:values 2 #'(lambda (it) (funcall it ':first))) #'(lambda (it) (funcall it ':rest)))) -(gmap:def-gmap-res-type map (&key filterp default) +(gmap:def-result-type map (&key filterp default) "Consumes two values from the mapped function; returns a map of the pairs. Note that `filterp', if supplied, must take two arguments." `(nil (:consume 2 #'(lambda (m x y) (WB-Map-Tree-With m x y #'compare #'compare))) - #'(lambda (tree) (make-wb-map tree (wb-map-org *empty-wb-map*) ,default)) - ,filterp)) + #'(lambda (tree) (make-wb-map tree +fset-default-tree-map-org+ ,default)) + ,filterp)) -(gmap:def-gmap-res-type wb-map (&key filterp default key-compare-fn-name val-compare-fn-name) +(gmap:def-result-type fset2:map (&key filterp (default nil default?) no-default?) + "Consumes two values from the mapped function; returns a map of the pairs. +Note that `filterp', if supplied, must take two arguments." + `(nil (:consume 2 #'(lambda (m x y) (ch-map-tree-with m x y #'hash-value #'compare #'hash-value #'compare))) + #'(lambda (tree) (make-ch-map tree +fset-default-hash-map-org+ + (fset2-default ,default? ,default ,no-default?))) + ,filterp)) + +(gmap:def-result-type wb-map (&key filterp default key-compare-fn-name val-compare-fn-name) "Consumes two values from the mapped function; returns a wb-map of the pairs. Note that `filterp', if supplied, must take two arguments." (let ((proto-var (gensymx #:prototype-)) @@ -948,6 +1076,66 @@ (define-setf-expander @ (collection key &environment env) ((,kcf-var (tree-map-org-key-compare-fn (wb-map-org ,proto-var))) (,vcf-var (tree-map-org-val-compare-fn (wb-map-org ,proto-var)))))))) +(gmap:def-result-type fset2:wb-map (&key filterp (default nil default?) no-default? + key-compare-fn-name val-compare-fn-name) + "Consumes two values from the mapped function; returns a wb-map of the pairs. +Note that `filterp', if supplied, must take two arguments." + (let ((proto-var (gensymx #:prototype-)) + (kcf-var (gensymx #:key-cmp-)) + (vcf-var (gensymx #:val-cmp-))) + `(nil (:consume 2 #'(lambda (tree k v) (WB-Map-Tree-With tree k v ,kcf-var ,vcf-var))) + #'(lambda (tree) (make-wb-map tree (wb-map-org ,proto-var) + (fset2-default ,default? ,default ,no-default?))) + ,filterp + ((,proto-var (empty-wb-map nil ,key-compare-fn-name ,val-compare-fn-name)) + ((,kcf-var (tree-map-org-key-compare-fn (wb-map-org ,proto-var))) + (,vcf-var (tree-map-org-val-compare-fn (wb-map-org ,proto-var)))))))) + +(gmap:def-gmap-arg-type ch-map (map) + "Yields each pair of `map', as two values." + `((make-ch-map-tree-iterator-internal (ch-map-contents ,map)) + #'ch-map-tree-iterator-done? + (:values 2 #'ch-map-tree-iterator-get) + nil nil nil + (do-ch-map-tree-pairs (ch-map-contents ,map)))) + +(gmap:def-arg-type-synonym fset2:ch-map ch-map) + +(gmap:def-result-type ch-map (&key filterp default key-compare-fn-name val-compare-fn-name) + "Consumes two values from the mapped function; returns a wb-map of the pairs. +Note that `filterp', if supplied, must take two arguments." + (let ((org-var (gensymx #:org-)) + (khf-var (gensymx #:key-hash-)) + (kcf-var (gensymx #:key-cmp-)) + (vhf-var (gensymx #:val-hash-)) + (vcf-var (gensymx #:val-cmp-))) + `(nil (:consume 2 #'(lambda (tree k v) (ch-map-tree-with tree k v ,khf-var ,kcf-var ,vhf-var ,vcf-var))) + #'(lambda (tree) (make-ch-map tree ,org-var ,default)) + ,filterp + ((,org-var (ch-map-org (empty-ch-map nil ,key-compare-fn-name ,val-compare-fn-name))) + ((,khf-var (hash-map-org-key-hash-fn ,org-var)) + (,kcf-var (hash-map-org-key-compare-fn ,org-var)) + (,vhf-var (hash-map-org-val-hash-fn ,org-var)) + (,vcf-var (hash-map-org-val-compare-fn ,org-var))))))) + +(gmap:def-result-type fset2:ch-map (&key filterp (default nil default?) no-default? + key-compare-fn-name val-compare-fn-name) + "Consumes two values from the mapped function; returns a wb-map of the pairs. +Note that `filterp', if supplied, must take two arguments." + (let ((org-var (gensymx #:org-)) + (khf-var (gensymx #:key-hash-)) + (kcf-var (gensymx #:key-cmp-)) + (vhf-var (gensymx #:val-hash-)) + (vcf-var (gensymx #:val-cmp-))) + `(nil (:consume 2 #'(lambda (tree k v) (ch-map-tree-with tree k v ,khf-var ,kcf-var ,vhf-var ,vcf-var))) + #'(lambda (tree) (make-ch-map tree ,org-var (fset2-default ,default? ,default ,no-default?))) + ,filterp + ((,org-var (ch-map-org (empty-ch-map nil ,key-compare-fn-name ,val-compare-fn-name))) + ((,khf-var (hash-map-org-key-hash-fn ,org-var)) + (,kcf-var (hash-map-org-key-compare-fn ,org-var)) + (,vhf-var (hash-map-org-val-hash-fn ,org-var)) + (,vcf-var (hash-map-org-val-compare-fn ,org-var))))))) + (gmap:def-gmap-res-type map-union (&key (val-fn nil val-fn?) (default nil default?) filterp) "Returns the map-union of the values, optionally filtered by `filterp'. If `val-fn' @@ -957,10 +1145,12 @@ (define-setf-expander @ (collection key &environment env) `(nil #'(lambda (prev-m m) (if (null prev-m) m - ,(if val-fn? `(map-union prev-m m ,val-fn-var) '#'map-union))) + ,(if val-fn? `(map-union prev-m m ,val-fn-var) '(map-union prev-m m)))) ,(and default? `#'(lambda (m) (with-default (or m (empty-wb-map)) ,default))) ,filterp - ((,val-fn-var ,val-fn))))) + (,@(and val-fn? `((,val-fn-var ,val-fn))))))) + +(gmap:def-result-type-synonym fset2:map-union map-union) (gmap:def-gmap-res-type map-intersection (&key (val-fn nil val-fn?) (default nil default?) filterp) @@ -972,42 +1162,36 @@ (define-setf-expander @ (collection key &environment env) `(nil #'(lambda (prev-m m) (if (null prev-m) m - ,(if val-fn? `(map-intersection prev-m m ,val-fn-var) '#'map-intersection))) + ,(if val-fn? `(map-intersection prev-m m ,val-fn-var) '(map-intersection prev-m m)))) ,(and default? `#'(lambda (m) (and m (with-default m ,default)))) ,filterp - ((,val-fn-var ,val-fn))))) + (,@(and val-fn? `((,val-fn-var ,val-fn))))))) + +(gmap:def-result-type-synonym fset2:map-intersection map-intersection) -(gmap:def-gmap-res-type map-to-sets (&key filterp key-compare-fn-name val-compare-fn-name) +(gmap:def-result-type map-to-sets (&key filterp key-compare-fn-name val-compare-fn-name) "Consumes two values from the mapped function. Returns a map from the first values, with each one mapped to a set of the corresponding second values. -Note that `filterp', if supplied, must take two arguments." - `((empty-wb-map (set) ,key-compare-fn-name ,val-compare-fn-name) - ;; &&& Could use `WB-Map-Tree-Update-Value' here. - (:consume 2 #'(lambda (m x y) (with m x (with (lookup m x) y)))) - nil ,filterp)) +Note, if you supply `val-compare-fn-name', to customize the ordering of the +range sets, the returned map will use `eql-compare' as its `val-compare-fn'. +Also note that `filterp', if supplied, must take two arguments." + (let ((vcfn-var (gensymx #:vcfn-))) + `((empty-wb-map (empty-wb-set ,vcfn-var) ,key-compare-fn-name (and ,vcfn-var 'eql-compare)) + (:consume 2 #'(lambda (m x y) (with m x (with (lookup m x) y)))) + nil ,filterp + ((,vcfn-var ,val-compare-fn-name))))) +(gmap:def-result-type fset2:map-to-sets (&key filterp key-compare-fn-name val-compare-fn-name) + "Consumes two values from the mapped function. Returns a map from the first +values, with each one mapped to a set of the corresponding second values. +Note, if you supply `val-compare-fn-name', to customize the ordering of the +range sets, the returned map will use `eql-compare' as its `val-compare-fn'. +Also note that `filterp', if supplied, must take two arguments." + (let ((vcfn-var (gensymx #:vcfn-))) + `((empty-ch-map (empty-ch-set ,vcfn-var) ,key-compare-fn-name (and ,vcfn-var 'eql-compare)) + (:consume 2 #'(lambda (m x y) (with m x (with (lookup m x) y)))) + nil ,filterp + ((,vcfn-var ,val-compare-fn-name))))) -(gmap:def-gmap-arg-type ch-map (map) - "Yields each pair of `map', as two values." - `((make-ch-map-tree-iterator-internal (ch-map-contents ,map)) - #'ch-map-tree-iterator-done? - (:values 2 #'ch-map-tree-iterator-get))) - -(gmap:def-gmap-res-type ch-map (&key filterp default key-compare-fn-name val-compare-fn-name) - "Consumes two values from the mapped function; returns a wb-map of the pairs. -Note that `filterp', if supplied, must take two arguments." - (let ((org-var (gensymx #:org-)) - (khf-var (gensymx #:key-hash-)) - (kcf-var (gensymx #:key-cmp-)) - (vhf-var (gensymx #:val-hash-)) - (vcf-var (gensymx #:val-cmp-))) - `(nil (:consume 2 #'(lambda (tree k v) (ch-map-tree-with tree k v ,khf-var ,kcf-var ,vhf-var ,vcf-var))) - #'(lambda (tree) (make-ch-map tree ,org-var ,default)) - ,filterp - ((,org-var (ch-map-org (empty-ch-map nil ,key-compare-fn-name ,val-compare-fn-name))) - ((,khf-var (hash-map-org-key-hash-fn ,org-var)) - (,kcf-var (hash-map-org-key-compare-fn ,org-var)) - (,vhf-var (hash-map-org-val-hash-fn ,org-var)) - (,vcf-var (hash-map-org-val-compare-fn ,org-var))))))) ;;; ---------------- ;;; Seqs @@ -1021,41 +1205,64 @@ (define-setf-expander @ (collection key &environment env) #'(lambda (it) (funcall it ':done?)) #'(lambda (it) (funcall it ':get)))) +(gmap:def-arg-type-synonym fset2:seq seq) + (gmap:def-gmap-arg-type wb-seq (seq &key start end from-end?) "Yields the elements of `seq'. The keyword arguments `start' and `end' can be supplied to restrict the range of the iteration; `start' is inclusive and defaults to 0, while `end' is exclusive and defaults to the size of the seq. If `from-end?' is true, the elements will be yielded in reverse order." - (flet ((fwd () - `((Make-WB-Seq-Tree-Iterator-Internal (wb-seq-contents ,seq) ,start ,end) - #'WB-Seq-Tree-Iterator-Done? - #'WB-Seq-Tree-Iterator-Get)) - (rev () - `((Make-WB-Seq-Tree-Rev-Iterator-Internal (wb-seq-contents ,seq) ,start ,end) - #'WB-Seq-Tree-Rev-Iterator-Done? - #'WB-Seq-Tree-Rev-Iterator-Get))) - (cond ((null from-end?) (fwd)) - ((atom from-end?) (rev)) - (t `(if ,from-end? ,(rev) ,(fwd)))))) - -(gmap:def-gmap-res-type seq (&key filterp) + (let ((seq-var (gensymx #:seq-))) + (cond ((null from-end?) + `((Make-WB-Seq-Tree-Iterator-Internal (wb-seq-contents ,seq-var) ,start ,end) + #'WB-Seq-Tree-Iterator-Done? + #'WB-Seq-Tree-Iterator-Get + nil ((,seq-var ,seq)) nil + (Do-WB-Seq-Tree-Members-Gen (wb-seq-contents ,seq-var) + (or ,start 0) (or ,end (size ,seq-var)) nil))) + ((eq from-end? 't) + `((Make-WB-Seq-Tree-Rev-Iterator-Internal (wb-seq-contents ,seq-var) ,start ,end) + #'WB-Seq-Tree-Rev-Iterator-Done? + #'WB-Seq-Tree-Rev-Iterator-Get + nil ((,seq-var ,seq)) nil + (Do-WB-Seq-Tree-Members-Gen (wb-seq-contents ,seq-var) + (or ,start 0) (or ,end (size ,seq-var)) t))) + (t + ;; Can't do much better than this if we don't statically know the direction. + `((the function (iterator ,seq :start ,start :end ,end :from-end? ,from-end?)) + #'(lambda (it) (funcall it ':done?)) + #'(lambda (it) (funcall it ':get))))))) + +(gmap:def-arg-type-synonym fset2:wb-seq wb-seq) + +(gmap:def-result-type-synonym seq wb-seq) + +(gmap:def-result-type wb-seq (&key filterp) "Returns a seq of the values, optionally filtered by `filterp'." `(nil #'(lambda (a b) (cons b a)) #'(lambda (s) (convert 'seq (nreverse s))) ,filterp)) -(gmap:def-gmap-res-type wb-seq (&key filterp) +(gmap:def-result-type-synonym fset2:seq fset2:wb-seq) + +(gmap:def-result-type fset2:wb-seq (&key filterp default no-default?) "Returns a seq of the values, optionally filtered by `filterp'." `(nil #'(lambda (a b) (cons b a)) - #'(lambda (s) (convert 'seq (nreverse s))) + #'(lambda (s) (convert 'fset2:seq (nreverse s) + ,@(and default `(:default ,default)) + ,@(and no-default? `(:no-default? ,no-default?)))) ,filterp)) -(gmap:def-gmap-res-type concat (&key filterp) +(gmap:def-result-type concat (&key filterp) "Returns the concatenation of the seq values, optionally filtered by `filterp'." `((empty-seq) #'concat nil ,filterp)) +(gmap:def-result-type fset2:concat (&key filterp) + "Returns the concatenation of the seq values, optionally filtered by `filterp'." + `((fset2:empty-seq) #'fset2:concat nil ,filterp)) + ;;; ---------------- ;;; Tuples @@ -1072,22 +1279,23 @@ (define-setf-expander @ (collection key &environment env) ;;; ---------------- ;;; Relations -(gmap:def-arg-type-synonym 2-relation wb-2-relation) - -(gmap:def-gmap-arg-type wb-2-relation (rel) +(gmap:def-arg-type 2-relation (rel) "Yields each pair of `rel', as two values." `((the function (iterator ,rel)) #'(lambda (it) (funcall it ':done?)) - (:values 2 #'(lambda (it) (funcall it ':get))))) + (:values 2 #'(lambda (it) (funcall it ':get))) + nil nil nil + (do-2-relation ,rel))) -(gmap:def-arg-type-synonym ch-2-relation wb-2-relation) +(gmap:def-arg-type-synonym wb-2-relation 2-relation) +(gmap:def-arg-type-synonym ch-2-relation 2-relation) ;;; People might expect it under this name. (gmap:def-arg-type-synonym fun-2-relation fun-map) -(gmap:def-result-type-synonym 2-relation wb-2-relation) +(gmap:def-result-type-synonym 2-relation ch-2-relation) -(gmap:def-gmap-res-type wb-2-relation (&key filterp key-compare-fn-name val-compare-fn-name) +(gmap:def-result-type wb-2-relation (&key filterp key-compare-fn-name val-compare-fn-name) "Consumes two values from the mapped function; returns a wb-2-relation of the pairs. Note that `filterp', if supplied, must take two arguments." (let ((org-var (gensymx #:org-)) @@ -1109,7 +1317,7 @@ (define-setf-expander @ (collection key &environment env) (,vcf-var (tree-map-org-val-compare-fn ,org-var))) (,size-var 0))))) -(gmap:def-gmap-res-type ch-2-relation (&key filterp key-compare-fn-name val-compare-fn-name) +(gmap:def-result-type ch-2-relation (&key filterp key-compare-fn-name val-compare-fn-name) "Consumes two values from the mapped function; returns a ch-2-relation of the pairs. Note that `filterp', if supplied, must take two arguments." (let ((org-var (gensymx #:org-)) @@ -1136,28 +1344,37 @@ (define-setf-expander @ (collection key &environment env) (,vhf-var (hash-map-org-val-hash-fn ,org-var))) (,size-var 0))))) -(gmap:def-gmap-arg-type list-relation (rel) - `((Make-WB-Set-Tree-Iterator-Internal (wb-set-contents (wb-list-relation-tuples ,rel))) +(gmap:def-arg-type list-relation (rel) + `((the function (iterator (convert 'set ,rel))) + #'(lambda (it) (funcall it ':done?)) + (:values 2 #'(lambda (it) (funcall it ':get))))) + +(gmap:def-arg-type wb-list-relation (rel) + `((Make-WB-Set-Tree-Iterator-Internal (wb-list-relation-tuples ,rel)) #'WB-Set-Tree-Iterator-Done? - #'WB-Set-Tree-Iterator-Get)) + #'WB-Set-Tree-Iterator-Get + nil nil nil + (Do-WB-Set-Tree-Members (wb-list-relation-tuples ,rel)))) + +(gmap:def-arg-type ch-list-relation (rel) + `((make-ch-set-tree-iterator-internal (ch-list-relation-tuples ,rel)) + #'ch-set-tree-iterator-done? + #'ch-set-tree-iterator-get + nil nil nil + (do-ch-set-tree-members (ch-list-relation-tuples ,rel)))) ;;; ---------------- ;;; Replay sets -;;; A bit faster than `set', if you know it's a `replay-set'. +;;; Faster than `set', if you know it's a `replay-set'. (gmap:def-arg-type replay-set (set) "Yields the elements of `set'." `((make-wb-seq-tree-iterator-internal (replay-set-ordering ,set)) #'wb-seq-tree-iterator-done? - #'wb-seq-tree-iterator-get)) - -;;; Deprecated in favor of arg type `replay-set', above. -(gmap:def-gmap-arg-type wb-replay-set (set) - "Yields the elements of `set'." - `((make-wb-seq-tree-iterator-internal (replay-set-ordering ,set)) - #'wb-seq-tree-iterator-done? - #'wb-seq-tree-iterator-get)) + #'wb-seq-tree-iterator-get + nil nil nil + (Do-WB-Seq-Tree-Members (replay-set-ordering ,set)))) ;;; CHAMP is the default now. (gmap:def-result-type replay-set (&key filterp) @@ -1169,7 +1386,7 @@ (define-setf-expander @ (collection key &environment env) (push x ,ordering-var)) ts)) #'(lambda (s) (make-ch-replay-set s (wb-seq-tree-from-list (nreverse ,ordering-var)) - (ch-set-org *empty-ch-set*))) + +fset-default-hash-set-org+)) ,filterp ((,ordering-var nil))))) @@ -1177,21 +1394,12 @@ (define-setf-expander @ (collection key &environment env) "Returns a wb-replay-set of the values, optionally filtered by `filterp'. If `compare-fn-name' is nonnull, it specifies a custom ordering for the internal set, though, of course, this doesn't affect the iteration order." + ;; I don't care enough about this now to rewrite it to use internal trees. `((empty-wb-replay-set ,compare-fn-name) #'with nil ,filterp)) -(gmap:def-gmap-res-type append-unique () - "Returns a list of the unique elements of the lists returned by the -mapped function, in the order in which they were first encountered." - `((empty-ch-replay-set) - #'(lambda (rs new-elts) - (dolist (x new-elts) - (includef rs x)) - rs) - #'(lambda (rs) (convert 'list rs)))) - (gmap:def-result-type ch-replay-set (&key filterp compare-fn-name) "Returns a ch-replay-set of the values, optionally filtered by `filterp'. If `compare-fn-name' is nonnull, it specifies a custom ordering for the internal @@ -1213,6 +1421,16 @@ (define-setf-expander @ (collection key &environment env) (,cf-var (hash-set-org-compare-fn ,org-var))) (,ordering-var nil))))) +(gmap:def-gmap-res-type append-unique () + "Returns a list of the unique elements of the lists returned by the +mapped function, in the order in which they were first encountered." + `((empty-ch-replay-set) + #'(lambda (rs new-elts) + (dolist (x new-elts) + (includef rs x)) + rs) + #'(lambda (rs) (convert 'list rs)))) + ;;; ---------------- ;;; Replay maps @@ -1236,11 +1454,11 @@ (define-setf-expander @ (collection key &environment env) (let ((ordering-var (gensymx #:ordering-))) `(nil (:consume 2 #'(lambda (s k v) (let ((ts (ch-map-tree-with s k v #'hash-value #'compare #'hash-value #'compare))) - (unless (eq ts s) + (unless (= (ch-map-tree-size ts) (ch-map-tree-size s)) (push k ,ordering-var)) ts))) #'(lambda (s) (make-ch-replay-map s (wb-seq-tree-from-list (nreverse ,ordering-var)) - (ch-map-org *empty-ch-map*) ,default)) + +fset-default-hash-map-org+ ,default)) ,filterp ((,ordering-var nil))))) @@ -1256,7 +1474,7 @@ (define-setf-expander @ (collection key &environment env) (ordering-var (gensymx #:ordering-))) `(nil (:consume 2 #'(lambda (s k v) (let ((ts (wb-map-tree-with s k v ,kcf-var ,vcf-var))) - (unless (eq ts s) + (unless (= (wb-map-tree-size ts) (wb-map-tree-size s)) (push k ,ordering-var)) ts))) #'(lambda (s) (make-wb-replay-map s (wb-seq-tree-from-list (nreverse ,ordering-var)) @@ -1281,7 +1499,7 @@ (define-setf-expander @ (collection key &environment env) (ordering-var (gensymx #:ordering-))) `(nil (:consume 2 #'(lambda (s k v) (let ((ts (ch-map-tree-with s k v ,khf-var ,kcf-var ,vhf-var ,vcf-var))) - (unless (eq ts s) + (unless (= (ch-map-tree-size ts) (ch-map-tree-size s)) (push k ,ordering-var)) ts))) #'(lambda (s) (make-ch-replay-map s (wb-seq-tree-from-list (nreverse ,ordering-var)) @@ -1310,6 +1528,18 @@ (define-setf-expander @ (collection key &environment env) :format-control "~A on a ~A takes three arguments" :format-arguments (list ,(copy-tree op) ,(copy-tree type))))) +(defmacro equal?-fn (cmp-fn) + `(lambda (a b) (eq (funcall ,cmp-fn a b) ':equal))) + +(defmacro equal?-cmp (a b cmp-fn) + `(eq (funcall ,cmp-fn ,a ,b) ':equal)) + +(defmacro less-than?-cmp (a b cmp-fn) + `(eq (funcall ,cmp-fn ,a ,b) ':less)) + +(defmacro greater-than?-cmp (a b cmp-fn) + `(eq (funcall ,cmp-fn ,a ,b) ':greater)) + (defmacro define-wb-set-method (name param-list &body body) (let ((decls nil) (doc-string body (if (stringp (car body)) (values (car body) (cdr body)) @@ -1358,7 +1588,7 @@ (defmethod ,name ,(mod-param-list 'wb-custom-set) ;; the O(n) algorithms. The downside, of course, would have been that if you did ;; actually change the function, things would have broken badly. This way, changing ;; the function could cause reduced performance, but correctness is maintained - ;; (unless you're depending on how `compare` orders two sets). + ;; (unless you're depending on how `compare' orders two sets). `(if (eq (wb-set-compare-fn ,coll1) (wb-set-compare-fn ,coll2)) ,then @@ -1367,6 +1597,11 @@ (defmethod ,name ,(mod-param-list 'wb-custom-set) `(make-wb-custom-set ,contents (wb-custom-set-org ,like-coll)))) . ,body)))))) +(defmacro define-wb-set-methods (methods parameter-list &body body) + `(progn . ,(mapcar (fn (method) + `(define-wb-set-method ,method ,parameter-list . ,body)) + methods))) + (defmacro if-same-ch-set-orgs ((s1 s2 hsorg-var) then else) (let ((s1-var (gensymx #:s1-)) (s2-var (gensymx #:s2-)) diff --git a/Code/order.lisp b/Code/order.lisp index ca557a2d1645a9eedf47634da566364965e18974..290b9ae449efdafbd749161de59d127c281d0ec5 100644 --- a/Code/order.lisp +++ b/Code/order.lisp @@ -19,12 +19,6 @@ compares `:less' or `:greater' to C, then B must compare to C the same way; and no more than one of A and B can compare `:equal' to C.")) -(defun less-than? (a b) - (eq (compare a b) ':less)) - -(defun greater-than? (a b) - (eq (compare a b) ':greater)) - (defun equal? (a b) (or (eql a b) (eq (compare a b) ':equal))) @@ -174,6 +168,7 @@ (define-cross-type-compare-methods list) (define-cross-type-compare-methods package) (define-cross-type-compare-methods pathname) (define-cross-type-compare-methods array) +(define-cross-type-compare-methods class) ;;; FSet types (define-cross-type-compare-methods set) @@ -409,6 +404,10 @@ (defmethod compare ((a sequence) (b sequence)) (setq unequal? t))))))))))) +;;; Classes +;;; [Moved to `post.lisp'] + + ;;; ================================================================================ ;;; Lexicographic comparison of sequences @@ -420,6 +419,9 @@ (defmethod compare ((a sequence) (b sequence)) can be strings, vectors, lists, or seqs.")) (defmethod compare-lexicographically ((a string) (b string) &key) + (compare-strings-lexicographically a b)) + +(defun compare-strings-lexicographically (a b) (if (eq a b) ':equal (let ((len-a (length a)) @@ -446,6 +448,9 @@ (defmethod compare-lexicographically ((a list) (b list) &key (val-compare-fn #'c (compare-lists-lexicographically a b val-compare-fn)) (defmethod compare-lexicographically ((a vector) (b vector) &key (val-compare-fn #'compare)) + (compare-vectors-lexicographically a b val-compare-fn)) + +(defun compare-vectors-lexicographically (a b &optional (val-compare-fn #'compare)) (declare (type function val-compare-fn)) (if (eq a b) ':equal @@ -471,3 +476,4 @@ (defmethod compare-lexicographically ((a vector) (b vector) &key (val-compare-fn (return res)) (when (eq res ':unequal) (setq default ':unequal)))))))) + diff --git a/Code/port.lisp b/Code/port.lisp index 5595b662246b277ea6bcad3b749e27d9c0703409..f138650520ca2f79a24aff74a80003f2462f13a7 100644 --- a/Code/port.lisp +++ b/Code/port.lisp @@ -288,19 +288,22 @@ ;;; package the same way that `cl:' is locked, so that an attempt to fbind one of its exported ;;; functions or macros will cause a warning or error. For the rest, the best we can do is to ;;; define unexported aliases, and use those in the macro expansions instead. -#+(or) ; #+sbcl +#+(and sbcl (not FSet-Disable-Package-Lock)) (progn (pushnew ':FSet-Use-Package-Locks *features*) - (defun lock-fset-package () - (sb-ext:lock-package (symbol-package 'lock-fset-package)))) + (defun lock-fset-packages () + (sb-ext:lock-package (symbol-package 'lookup)) + (sb-ext:lock-package (symbol-package 'fset2:lookup)))) -#+(or) ; #+allegro +#+(and allegro (not FSet-Disable-Package-Lock)) (progn (pushnew ':FSet-Use-Package-Locks *features*) - (defun lock-fset-package () - (let ((pkg (symbol-package 'lock-fset-package))) - (setf (excl:package-lock pkg) t) - (setf (excl:package-definition-lock pkg) t)))) + (defun lock-fset-packages () + (flet ((lock-pkg (pkg) + (setf (excl:package-lock pkg) t) + (setf (excl:package-definition-lock pkg) t))) + (lock-pkg (symbol-package 'lookup)) + (lock-pkg (symbol-package 'fset2:lookup))))) ;;; ---------------- @@ -492,6 +495,7 @@ (define-modify-macro hash-unmixf (hash &rest to-unmix) (and (or (eq a b) (and a b)) (gmap (:result and) (fn (x) (or (eq x a) (and x a))) (:arg list more)))) +(declaim (inline swap-if)) (defun swap-if (pred x y) (if pred (values y x) (values x y))) diff --git a/Code/post.lisp b/Code/post.lisp index bd31b9ad0731c7f0d39b82f94324ac672a3d62ff..a9f80647ffce069f6a41f3c5a37cc592efcf3de3 100644 --- a/Code/post.lisp +++ b/Code/post.lisp @@ -16,5 +16,21 @@ (declaim (ftype (function (t &key (:from-end? t) &allow-other-keys) function) fun-iterator)) +;;; Copy class definitions from `fset:' symbols to `fset2:' symbols that shadow them, +;;; so `defmethod', `typep', etc. will work without package prefixes. +(dolist (sym '(set map wb-map ch-map seq wb-seq replay-map wb-replay-map ch-replay-map)) + (let ((fset2-sym (intern (string sym) :fset2))) + (setf (find-class fset2-sym) (find-class sym)) + ;; Needed in CCL for `typep' to work. + #+ccl (setf (ccl::info-type-kind fset2-sym) ':instance))) + + +;;; Moved here from `order.lisp' because its expansion depends on stuff after that file. +(define-equality-slots class + #'class-name) + + +;;; Must be last! #+FSet-Use-Package-Locks -(lock-fset-package) +(lock-fset-packages) + diff --git a/Code/reader.lisp b/Code/reader.lisp index be1af08a6ed70bffd0e36a20236d87415bdaa337..2274b716039049a9273e8d22bc11e3be2a92463e 100644 --- a/Code/reader.lisp +++ b/Code/reader.lisp @@ -11,9 +11,9 @@ ;;; This file defines two different kinds of convenience syntax for constructing ;;; the FSet datatypes: constructor macros, and reader macros that expand to -;;; invocations of the constructor macros. (Note 2008-10-25: the reader macros +;;; invocations of the constructor macros. My impression is that the reader macros ;;; haven't been used much; the constructor macros seem to be as much syntax as -;;; is desirable in Lisp. But, they're here if you want them.) +;;; is desirable in Lisp. But, they're here if you want them. ;;; ;;; Each constructor macro has the same name as the type it constructs (making ;;; them somewhat like `cl:list', but with some additional features). Some @@ -34,13 +34,17 @@ ;;; The reader macros expand directly into invocations of the constructor macros, ;;; so the syntax is similar. Loading this file does _not_ cause these macros ;;; to be defined in the current readtable. To use them, the recommended approach -;;; is to load system Named-Readables (it's in Quicklisp), and then do: +;;; is to do: ;;; ;;; > (named-readtables:in-readtable fset:fset-readtable) ;;; -;;; If you don't want to do that, you can use `*fset-readtable', or call +;;; If you don't want to do that, you can use `*fset-readtable*', or call ;;; `fset-setup-readtable' on an existing readtable. ;;; +;;; The syntaxes shown here are all for the older WB implementations. The syntaxes +;;; for the newer CHAMP implementations all start with `##' instead of `#' (the +;;; first `#' is pronounced "sharp", and the second `#' is pronounced "hash" :-) +;;; ;;; Set syntax: ;;; ;;; #{
* } @@ -100,7 +104,7 @@ ;;; must all be instances of `tuple-key'. Examples: ;;; ;;; #~< (k1 2) (k3 x) > ; maps k1 to 2, and k3 to the value of X -;;; #{| #$x (k1 2) |} ; equivalent to `(tuple-merge x #< (1 2) >)' +;;; #~< #$x (k1 2) > ; equivalent to `(tuple-merge x #< (1 2) >)' ;;; ;;; In any case where more than one value is provided for a given key, the rightmost ;;; subexpression takes precedence. @@ -113,22 +117,8 @@ ;;; expression that constructs a vector but evaluates some of its operands, you must ;;; either just call `vector', or use backquote: `#(1 2 ,x) ;;; -;;; I didn't want these reader macros to work that way, partly because I've never -;;; been very fond of backquote, and partly because FSet was inspired by Refine, and -;;; in Refine syntax, collection expressions evaluate their operands. Also, in -;;; Refine, these expressions are used for pattern matching: -;;; -;;; ( s = [ $x, 'foo, $y ] --> ...) -;;; -;;; which searches sequence `s' for an occurrence of symbol `foo', and if it finds -;;; one, binds `x' and `y' to the left and right subsequences of `s' defined by that -;;; occurrence of `foo', and evaluates the expression to the right of the arrow. I -;;; eventually want to add this kind of pattern matching to FSet, and I think the -;;; reader macros will be handy for that purpose (though not required; one can use -;;; the constructor macros instead). If the reader macros worked the same as #(...), -;;; though, the only way to make them work for this would be to extend backquote to -;;; support the FSet types; and CL defines no portable interface for extending -;;; backquote. +;;; I think the reader macros are more useful when they evaluate their operands, as +;;; then nothing like backquote is necessary. ;;; ;;; The downside, though, of having the FSet reader macros work the way they do, is ;;; the loss of readable printing: even though the reader macros accept the same @@ -139,32 +129,8 @@ ;;; lists or non-keyword symbols, the form returned by the reader macro will attempt ;;; to evaluate these (and presumably fail). ;;; -;;; To me, the ideal solution would be to modify the Lisp printer so that when -;;; printing a non-self-evaluating object -- a non-keyword symbol or list -- it would -;;; quote it, thus: -;;; -;;; * 'a -;;; 'A -;;; * (list 'a 'b) -;;; '(A B) -;;; -;;; This is, or is similar to, an approach of Brian C. Smith in his semantically -;;; normalized "2-Lisp". Given this change, one could arrange for readable printing -;;; of the FSet types: -;;; -;;; * #{ 1 'x } -;;; #{ 1 'X } -;;; -;;; I think this would be a better way to do things, but there's no question it -;;; would confuse current users of CL (and also, of course, it can't be implemented -;;; portably). -;;; -;;; So, what to do? All I can come up with at the moment is to provide two sets of -;;; reader macros: one that functions as described above (evaluating operands), and -;;; a second "rereading" set that is non-evaluating, like #(...), and so can be used -;;; to reread printed FSet values. -;;; -;;; It remains to be seen whether anyone uses the reader macros, anyway. +;;; So FSet provides an alternate set of reader macros that can be used to reread +;;; FSet's printed representations, called the "rereading" versions. ;;; ;;; UPDATE: this file now consists mostly of constructor macros. The reader macro ;;; stuff is at the bottom. @@ -176,7 +142,14 @@ will be a member of the result set; or a list of the form ($ `expression'), in which case the expression must evaluate to a set, all of whose members become members of the result set." - (expand-set-constructor-form 'set args)) + (expand-set-constructor-form 'set 'empty-set args)) +(defmacro fset2:set (&rest args) + "Constructs a set of the default implementation according to the supplied +argument subforms. Each argument subform can be an expression, whose value +will be a member of the result set; or a list of the form ($ `expression'), in +which case the expression must evaluate to a set, all of whose members become +members of the result set." + (expand-set-constructor-form 'fset2:set 'fset2:empty-set args)) (defmacro wb-set (&rest args) "Constructs a wb-set according to the supplied argument subforms. Each @@ -184,7 +157,7 @@ result set; or a list of the form ($ `expression'), in which case the expression must evaluate to a set, all of whose members become members of the result set." - (expand-set-constructor-form 'wb-set args)) + (expand-set-constructor-form 'wb-set 'empty-wb-set args)) (defmacro wb-custom-set (compare-fn-name &rest args) "Constructs a wb-set with a custom ordering, according to the supplied @@ -193,7 +166,7 @@ will be a member of the result set; or a list of the form ($ `expression'), in which case the expression must evaluate to a set, all of whose members become members of the result set." - (expand-set-constructor-form 'wb-set args compare-fn-name)) + (expand-set-constructor-form 'wb-set 'empty-wb-set args compare-fn-name)) (defmacro ch-set (&rest args) "Constructs a ch-set according to the supplied argument subforms. Each @@ -201,7 +174,7 @@ result set; or a list of the form ($ `expression'), in which case the expression must evaluate to a set, all of whose members become members of the result set." - (expand-set-constructor-form 'ch-set args)) + (expand-set-constructor-form 'ch-set 'empty-ch-set args)) (defmacro ch-custom-set (compare-fn-name &rest args) "Constructs a ch-set of a custom type, according to the supplied argument @@ -211,16 +184,16 @@ will be a member of the result set; or a list of the form ($ `expression'), in which case the expression must evaluate to a set, all of whose members become members of the result set." - (expand-set-constructor-form 'ch-set args compare-fn-name)) + (expand-set-constructor-form 'ch-set 'empty-ch-set args compare-fn-name)) -(defun expand-set-constructor-form (type-name args &optional compare-fn-name) +(defun expand-set-constructor-form (type-name empty-fn args &optional compare-fn-name) (let ((normal-args (remove-if #'(lambda (arg) (and (listp arg) (eq (car arg) '$))) args)) (splice-args (remove-if-not #'(lambda (arg) (and (listp arg) (eq (car arg) '$))) args)) ((start (if normal-args `(convert ',type-name (list . ,normal-args) ,@(and compare-fn-name `(:compare-fn-name ,compare-fn-name))) - `(,(empty-instance-function type-name) . ,(and compare-fn-name `(,compare-fn-name))))))) + `(,empty-fn . ,(and compare-fn-name `(,compare-fn-name))))))) (labels ((recur (splice-args result) (if (null splice-args) result (if (= (length (car splice-args)) 2) @@ -235,7 +208,7 @@ whose value will be a member of the result set; or a list of the form \($ `expression'), in which case the expression must evaluate to a set, all of whose members become members of the result set." - (expand-replay-set-constructor-form 'replay-set args)) + (expand-replay-set-constructor-form 'replay-set 'empty-replay-set args)) (defmacro wb-replay-set (&rest args) "Constructs a wb-replay-set according to the supplied argument subforms. Each @@ -243,7 +216,7 @@ result set; or a list of the form ($ `expression'), in which case the expression must evaluate to a set, all of whose members become members of the result set." - (expand-replay-set-constructor-form 'wb-replay-set args)) + (expand-replay-set-constructor-form 'wb-replay-set 'empty-wb-replay-set args)) (defmacro wb-custom-replay-set (compare-fn-name &rest args) "Constructs a wb-replay-set with a custom ordering, according to the supplied @@ -252,7 +225,7 @@ will be a member of the result set; or a list of the form ($ `expression'), in which case the expression must evaluate to a set, all of whose members become members of the result set." - (expand-replay-set-constructor-form 'wb-replay-set args compare-fn-name)) + (expand-replay-set-constructor-form 'wb-replay-set 'empty-wb-replay-set args compare-fn-name)) (defmacro ch-replay-set (&rest args) "Constructs a ch-replay-set according to the supplied argument subforms. Each @@ -260,7 +233,7 @@ result set; or a list of the form ($ `expression'), in which case the expression must evaluate to a set, all of whose members become members of the result set." - (expand-replay-set-constructor-form 'ch-replay-set args)) + (expand-replay-set-constructor-form 'ch-replay-set 'empty-ch-replay-set args)) (defmacro ch-custom-replay-set (compare-fn-name &rest args) "Constructs a ch-replay-set with a custom ordering, according to the supplied @@ -269,12 +242,12 @@ will be a member of the result set; or a list of the form ($ `expression'), in which case the expression must evaluate to a set, all of whose members become members of the result set." - (expand-replay-set-constructor-form 'ch-replay-set args compare-fn-name)) + (expand-replay-set-constructor-form 'ch-replay-set 'empty-ch-replay-set args compare-fn-name)) -(defun expand-replay-set-constructor-form (type-name args &optional compare-fn-name) +(defun expand-replay-set-constructor-form (type-name empty-fn args &optional compare-fn-name) + (declare (ignore type-name)) ; might need it for an error message? ;; We MUST maintain ORDER!!! Yow!!! - (let ((result `(,(empty-instance-function type-name) - . ,(and compare-fn-name `(,compare-fn-name))))) + (let ((result `(,empty-fn . ,(and compare-fn-name `(,compare-fn-name))))) (dolist (arg args result) (if (and (listp arg) (eq (car arg) '$)) (let ((tmp (gensymx #:tmp-))) @@ -296,7 +269,7 @@ given by the value of `expression2'. That is, the multiplicity of each member of the result bag is the sum of its multiplicities as supplied by each of the argument subforms." - (expand-bag-constructor-form 'bag args)) + (expand-bag-constructor-form 'bag 'empty-bag args)) (defmacro wb-bag (&rest args) "Constructs a wb-bag according to the supplied argument subforms. Each @@ -308,7 +281,7 @@ into the result with multiplicity given by the value of `expression2'. That is, the multiplicity of each member of the result bag is the sum of its multiplicities as supplied by each of the argument subforms." - (expand-bag-constructor-form 'wb-bag args)) + (expand-bag-constructor-form 'wb-bag 'empty-wb-bag args)) (defmacro wb-custom-bag (compare-fn-name &rest args) "Constructs a wb-bag with a custom ordering, according to the supplied @@ -322,9 +295,9 @@ given by the value of `expression2'. That is, the multiplicity of each member of the result bag is the sum of its multiplicities as supplied by each of the argument subforms." - (expand-set-constructor-form 'wb-bag args compare-fn-name)) + (expand-bag-constructor-form 'wb-bag 'empty-wb-bag args compare-fn-name)) -(defun expand-bag-constructor-form (type-name args &optional compare-fn-name) +(defun expand-bag-constructor-form (type-name empty-fn args &optional compare-fn-name) (let ((normal-args (remove-if #'(lambda (arg) (and (listp arg) (member (car arg) '($ %)))) args)) @@ -334,7 +307,7 @@ args)) ((start (if normal-args `(convert ',type-name (list . ,normal-args) ,@(and compare-fn-name `(:compare-fn-name ,compare-fn-name))) - `(,(empty-instance-function type-name) . ,(and compare-fn-name `(,compare-fn-name))))))) + `(,empty-fn . ,(and compare-fn-name `(,compare-fn-name))))))) (labels ((add-splice-args (splice-args result) (if (null splice-args) result (if (= (length (car splice-args)) 2) @@ -368,7 +341,24 @@ 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)) + (expand-map-constructor-form 'map 'empty-map args)) +(defmacro fset2:map (&rest args) + "Constructs a map 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 map, denoting all its mappings; or the symbol +`:default' followed by a form; or the symbol `:no-default'. If `:default' is +supplied, the map's default is the value of the subsequent form; if +`:no-default' is supplied, the map has no default; if neither, the map's +default is `nil'. + +As a convenience, if a subform is ($ `expression') and the expression evaluates +to `nil', it will be treated as an empty map. 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 'fset2:map 'fset2:empty-map args)) (defmacro wb-map (&rest args) "Constructs a wb-map according to the supplied argument subforms. Each @@ -382,7 +372,23 @@ 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)) + (expand-map-constructor-form 'wb-map 'empty-wb-map args)) +(defmacro fset2:wb-map (&rest args) + "Constructs a wb-map 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 +map, denoting all its mappings; or the symbol `:default' followed by a form; +or the symbol `:no-default'. If `:default' is supplied, the map's default is +the value of the subsequent form; if `:no-default' is supplied, the map has no +default; if neither, the map's default is `nil'. + +As a convenience, if a subform is ($ `expression') and the expression evaluates +to `nil', it will be treated as an empty map. 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 'fset2:wb-map 'fset2:empty-wb-map args)) (defmacro wb-custom-map (key-compare-fn-name val-compare-fn-name &rest args) "Constructs a wb-map with a custom ordering, according to the supplied @@ -400,7 +406,27 @@ 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 key-compare-fn-name val-compare-fn-name)) + (expand-map-constructor-form 'wb-map 'empty-wb-map args key-compare-fn-name val-compare-fn-name)) +(defmacro fset2:wb-custom-map (key-compare-fn-name val-compare-fn-name &rest args) + "Constructs a wb-map with a custom ordering, according to the supplied +argument subforms. `key-compare-fn-name' and `val-compare-fn-name' must be +symbols naming the comparison functions to be used for keys and values +respectively. \(The value comparison is used for detecting redundant `with' +operations, and a few other things, such as `range' and `map-difference-2'.\) +Each of `args' 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; or the symbol `:default' followed by a form; +or the symbol `:no-default'. If `:default' is supplied, the map's default is +the value of the subsequent form; if `:no-default' is supplied, the map has no +default; if neither, the map's default is `nil'. + +As a convenience, if a subform is ($ `expression') and the expression evaluates +to `nil', it will be treated as an empty map. 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 'fset2:wb-map 'fset2:empty-wb-map args key-compare-fn-name val-compare-fn-name)) (defmacro ch-map (&rest args) "Constructs a ch-map according to the supplied argument subforms. Each @@ -414,7 +440,23 @@ 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 'ch-map args)) + (expand-map-constructor-form 'ch-map 'empty-ch-map args)) +(defmacro fset2:ch-map (&rest args) + "Constructs a ch-map 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 +map, denoting all its mappings; or the symbol `:default' followed by a form; +or the symbol `:no-default'. If `:default' is supplied, the map's default is +the value of the subsequent form; if `:no-default' is supplied, the map has no +default; if neither, the map's default is `nil'. + +As a convenience, if a subform is ($ `expression') and the expression evaluates +to `nil', it will be treated as an empty map. 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 'fset2:ch-map 'fset2:empty-ch-map args)) (defmacro ch-custom-map (key-compare-fn-name val-compare-fn-name &rest args) "Constructs a ch-map with a custom ordering, according to the supplied @@ -432,16 +474,49 @@ 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 'ch-map args key-compare-fn-name val-compare-fn-name)) - -(defun expand-map-constructor-form (type-name args &optional key-compare-fn-name val-compare-fn-name) - (let ((default (cadr (member ':default args))) - ((empty-form `(,(empty-instance-function type-name) ,default - . ,(and key-compare-fn-name `(,key-compare-fn-name ,val-compare-fn-name)))))) + (expand-map-constructor-form 'ch-map 'empty-ch-map args key-compare-fn-name val-compare-fn-name)) +(defmacro fset2:ch-custom-map (key-compare-fn-name val-compare-fn-name &rest args) + "Constructs a ch-map with a custom ordering, according to the supplied +argument subforms. `key-compare-fn-name' and `val-compare-fn-name' must be +symbols naming the comparison functions to be used for keys and values +respectively. \(The value comparison is used for detecting redundant `with' +operations, and a few other things, such as `range' and `map-difference-2'.\) +Each of `args' 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; or the symbol `:default' followed by a form; +or the symbol `:no-default'. If `:default' is supplied, the map's default is +the value of the subsequent form; if `:no-default' is supplied, the map has no +default; if neither, the map's default is `nil'. + +As a convenience, if a subform is ($ `expression') and the expression evaluates +to `nil', it will be treated as an empty map. 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 'fset2:ch-map 'fset2:empty-ch-map args key-compare-fn-name val-compare-fn-name)) + +(defun expand-map-constructor-form (type-name empty-fn args + &optional key-compare-fn-name val-compare-fn-name) + (let ((default? (member ':default args)) + (no-default? (member ':no-default args)) + (fset1? (eq (symbol-package empty-fn) (symbol-package 'map))) + ((empty-form (if fset1? + `(,empty-fn ,(cadr default?) + . ,(and (or key-compare-fn-name val-compare-fn-name) + `(,key-compare-fn-name ,val-compare-fn-name))) + `(,empty-fn ,@(and default? `(:default ,(cadr default?))) + ,@(and no-default? '(:no-default? t)) + ,@(and key-compare-fn-name `(:key-compare-fn-name ,key-compare-fn-name)) + ,@(and val-compare-fn-name `(:val-compare-fn-name ,val-compare-fn-name))))))) + (when (and default? no-default?) + (error "In map constructor, both `:default' and `:no-default' specified")) (labels ((recur (args result) (cond ((null args) result) ((eq (car args) ':default) (recur (cddr args) result)) + ((eq (car args) ':no-default) + (recur (cdr args) result)) ((not (and (listp (car args)) (= (length (car args)) 2))) (error "Arguments to ~S must all be pairs expressed as 2-element~@ @@ -464,23 +539,59 @@ `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; 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-replay-map-constructor-form 'replay-map args)) +`:default' followed by a form; or the symbol `:no-default'. If `:default' is +supplied, the map's default is the value of the subsequent form; if +`:no-default' is supplied, the map has no default; if neither, the map's +default is `nil'. + +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-replay-map-constructor-form 'replay-map 'empty-replay-map args)) +(defmacro fset2:replay-map (&rest args) + "Constructs a replay-map 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 map, denoting all its mappings; or the symbol +`:default' followed by a form; or the symbol `:no-default'. If `:default' is +supplied, the map's default is the value of the subsequent form; if +`:no-default' is supplied, the map has no default; if neither, the map's +default is `nil'. + +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-replay-map-constructor-form 'fset2:replay-map 'fset2:empty-replay-map args)) (defmacro wb-replay-map (&rest args) "Constructs a wb-replay-map 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 -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-replay-map-constructor-form 'wb-replay-map args)) +map, denoting all its mappings; or the symbol `:default' followed by a form; or +the symbol `:no-default'. If `:default' is supplied, the map's default is the +value of the subsequent form; if `:no-default' is supplied, the map has no +default; if neither, the map's default is `nil'. + +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-replay-map-constructor-form 'wb-replay-map 'empty-wb-replay-map args)) +(defmacro fset2:wb-replay-map (&rest args) + "Constructs a wb-replay-map 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 +map, denoting all its mappings; or the symbol `:default' followed by a form; or +the symbol `:no-default'. If `:default' is supplied, the map's default is the +value of the subsequent form; if `:no-default' is supplied, the map has no +default; if neither, the map's default is `nil'. + +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-replay-map-constructor-form 'fset2:wb-replay-map 'fset2:empty-wb-replay-map args)) (defmacro wb-custom-replay-map (key-compare-fn-name val-compare-fn-name &rest args) "Constructs a wb-replay-map with a custom ordering, according to the supplied @@ -488,23 +599,61 @@ `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; or the symbol -`:default', in which case the value of the next argument subform 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-replay-map-constructor-form 'wb-replay-map args key-compare-fn-name val-compare-fn-name)) +`:default' followed by a form; or the symbol `:no-default'. If `:default' is +supplied, the map's default is the value of the subsequent form; if +`:no-default' is supplied, the map has no default; if neither, the map's +default is `nil'. + +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-replay-map-constructor-form 'wb-replay-map 'empty-wb-replay-map args + key-compare-fn-name val-compare-fn-name)) +(defmacro fset2:wb-custom-replay-map (key-compare-fn-name val-compare-fn-name &rest args) + "Constructs a wb-replay-map with a custom ordering, according to the supplied +argument subforms. Each of `args' 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; or the symbol +`:default' followed by a form; or the symbol `:no-default'. If `:default' is +supplied, the map's default is the value of the subsequent form; if +`:no-default' is supplied, the map has no default; if neither, the map's +default is `nil'. + +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-replay-map-constructor-form 'fset2:wb-replay-map 'fset2:empty-wb-replay-map args + key-compare-fn-name val-compare-fn-name)) (defmacro ch-replay-map (&rest args) "Constructs a ch-replay-map 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 -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-replay-map-constructor-form 'ch-replay-map args)) +map, denoting all its mappings; or the symbol `:default' followed by a form; or +the symbol `:no-default'. If `:default' is supplied, the map's default is the +value of the subsequent form; if `:no-default' is supplied, the map has no +default; if neither, the map's default is `nil'. + +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-replay-map-constructor-form 'ch-replay-map 'empty-ch-replay-map args)) +(defmacro fset2:ch-replay-map (&rest args) + "Constructs a ch-replay-map 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 +map, denoting all its mappings; or the symbol `:default' followed by a form; or +the symbol `:no-default'. If `:default' is supplied, the map's default is the +value of the subsequent form; if `:no-default' is supplied, the map has no +default; if neither, the map's default is `nil'. + +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-replay-map-constructor-form 'fset2:ch-replay-map 'fset2:empty-ch-replay-map args)) (defmacro ch-custom-replay-map (key-compare-fn-name val-compare-fn-name &rest args) "Constructs a ch-replay-map with a custom ordering, according to the supplied @@ -512,21 +661,53 @@ `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; or the symbol -`:default', in which case the value of the next argument subform 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-replay-map-constructor-form 'ch-replay-map args key-compare-fn-name val-compare-fn-name)) +`:default' followed by a form; or the symbol `:no-default'. If `:default' is +supplied, the map's default is the value of the subsequent form; if +`:no-default' is supplied, the map has no default; if neither, the map's +default is `nil'. -(defun expand-replay-map-constructor-form (type-name args &optional key-compare-fn-name val-compare-fn-name) +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-replay-map-constructor-form 'ch-replay-map 'empty-ch-replay-map args + key-compare-fn-name val-compare-fn-name)) +(defmacro fset2:ch-custom-replay-map (key-compare-fn-name val-compare-fn-name &rest args) + "Constructs a ch-replay-map with a custom ordering, according to the supplied +argument subforms. Each of `args' 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; or the symbol +`:default' followed by a form; or the symbol `:no-default'. If `:default' is +supplied, the map's default is the value of the subsequent form; if +`:no-default' is supplied, the map has no default; if neither, the map's +default is `nil'. + +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-replay-map-constructor-form 'fset2:ch-replay-map 'fset2:empty-ch-replay-map args + key-compare-fn-name val-compare-fn-name)) + +(defun expand-replay-map-constructor-form (type-name empty-fn args &optional key-compare-fn-name val-compare-fn-name) + (declare (ignore type-name)) ; might need it for an error message? ;; We MUST maintain ORDER!!! Yow!!! - (let ((default (cadr (member ':default args))) - ((result `(,(empty-instance-function type-name) ,default - . ,(and key-compare-fn-name `(,key-compare-fn-name ,val-compare-fn-name)))))) + (let ((default? (member ':default args)) + (no-default? (member ':no-default args)) + (fset1? (eq (symbol-package empty-fn) (symbol-package 'map))) + ((result (if fset1? + `(,empty-fn ,(cadr default?) + . ,(and key-compare-fn-name `(,key-compare-fn-name ,val-compare-fn-name))) + `(,empty-fn ,@(and default? `(:default ,(cadr default?))) + ,@(and no-default? '(:no-default? t)) + ,@(and key-compare-fn-name `(:key-compare-fn-name ,key-compare-fn-name)) + ,@(and val-compare-fn-name `(:val-compare-fn-name ,val-compare-fn-name))))))) + (when (and default? no-default?) + (error "In replay-map constructor, both `:default' and `:no-default' specified")) (do ((args args (cdr args))) ((null args) result) (let ((arg (car args))) (cond ((eq arg ':default) (pop args)) + ((eq arg ':no-default)) ((and (listp arg) (eq (car arg) '$)) (let ((tmp (gensymx #:tmp-))) (setq result `(let ((,tmp ,result)) @@ -544,7 +725,15 @@ case the expression must evaluate to a sequence, all of whose values appear in the result sequence. The order of the result sequence reflects the order of the argument subforms." - (expand-seq-constructor-form 'seq args)) + (expand-seq-constructor-form 'seq 'empty-seq args)) +(defmacro fset2:seq (&rest args) + "Constructs a seq of the default implementation according to the supplied +argument subforms. Each argument subform can be an expression whose value is +to appear in the sequence; or a list of the form ($ `expression'), in which +case the expression must evaluate to a sequence, all of whose values appear in +the result sequence. The order of the result sequence reflects the order of +the argument subforms." + (expand-seq-constructor-form 'fset2:seq 'fset2:empty-seq args)) (defmacro wb-seq (&rest args) "Constructs a wb-seq according to the supplied argument subforms. Each @@ -552,14 +741,21 @@ or a list of the form ($ `expression'), in which case the expression must evaluate to a sequence, all of whose values appear in the result sequence. The order of the result sequence reflects the order of the argument subforms." - (expand-seq-constructor-form 'wb-seq args)) + (expand-seq-constructor-form 'wb-seq 'empty-wb-seq args)) +(defmacro fset2:wb-seq (&rest args) + "Constructs a wb-seq according to the supplied argument subforms. Each +argument subform can be an expression whose value is to appear in the sequence; +or a list of the form ($ `expression'), in which case the expression must +evaluate to a sequence, all of whose values appear in the result sequence. The +order of the result sequence reflects the order of the argument subforms." + (expand-seq-constructor-form 'fset2:wb-seq 'fset2:empty-wb-seq args)) -(defun expand-seq-constructor-form (type-name args) +(defun expand-seq-constructor-form (type-name empty-fn args) (labels ((recur (args nonsplice-args) (cond ((null args) (if nonsplice-args `(convert ',type-name (list . ,(cl:reverse nonsplice-args))) - `(,(empty-instance-function type-name)))) + `(,empty-fn))) ((and (listp (car args)) (eq (caar args) '$)) (unless (= (length (car args)) 2) @@ -635,7 +831,7 @@ (2-relation (($ (set 1 2)) ($ (set 'a 'b)))) contains the pairs <1, a>, <1, b>, <2, a>, and <2, b>." - (expand-2-relation-constructor-form '2-relation args)) + (expand-2-relation-constructor-form '2-relation 'empty-2-relation args)) (defmacro wb-2-relation (&rest args) "Constructs a wb-2-relation according to the supplied argument subforms. @@ -651,7 +847,7 @@ (wb-2-relation (($ (set 1 2)) ($ (set 'a 'b)))) contains the pairs <1, a>, <1, b>, <2, a>, and <2, b>." - (expand-2-relation-constructor-form 'wb-2-relation args)) + (expand-2-relation-constructor-form 'wb-2-relation 'empty-wb-2-relation args)) (defmacro wb-custom-2-relation (key-compare-fn-name val-compare-fn-name &rest args) "Constructs a wb-2-relation with a custom ordering, according to the supplied @@ -667,7 +863,8 @@ (wb-custom-2-relation 'key-cmp 'val-cmp (($ (set 1 2)) ($ (set 'a 'b)))) contains the pairs <1, a>, <1, b>, <2, a>, and <2, b>." - (expand-2-relation-constructor-form 'wb-2-relation args key-compare-fn-name val-compare-fn-name)) + (expand-2-relation-constructor-form 'wb-2-relation 'empty-wb-2-relation args + key-compare-fn-name val-compare-fn-name)) (defmacro ch-2-relation (&rest args) "Constructs a ch-2-relation according to the supplied argument subforms. @@ -683,7 +880,7 @@ (ch-2-relation (($ (set 1 2)) ($ (set 'a 'b)))) contains the pairs <1, a>, <1, b>, <2, a>, and <2, b>." - (expand-2-relation-constructor-form 'ch-2-relation args)) + (expand-2-relation-constructor-form 'ch-2-relation 'empty-ch-2-relation args)) (defmacro ch-custom-2-relation (key-compare-fn-name val-compare-fn-name &rest args) "Constructs a ch-2-relation with a custom ordering, according to the supplied @@ -699,11 +896,13 @@ (ch-custom-2-relation 'key-cmp 'val-cmp (($ (set 1 2)) ($ (set 'a 'b)))) contains the pairs <1, a>, <1, b>, <2, a>, and <2, b>." - (expand-2-relation-constructor-form 'ch-2-relation args key-compare-fn-name val-compare-fn-name)) + (expand-2-relation-constructor-form 'ch-2-relation 'empty-ch-2-relation args + key-compare-fn-name val-compare-fn-name)) -(defun expand-2-relation-constructor-form (type-name subforms &optional key-compare-fn-name val-compare-fn-name) - (let ((empty-form `(,(empty-instance-function type-name) - . ,(and key-compare-fn-name `(,key-compare-fn-name ,val-compare-fn-name))))) +(defun expand-2-relation-constructor-form (type-name empty-fn subforms + &optional key-compare-fn-name val-compare-fn-name) + (let ((empty-form `(,empty-fn . ,(and (or key-compare-fn-name val-compare-fn-name) + `(,key-compare-fn-name ,val-compare-fn-name))))) (labels ((recur (subforms result) (if (null subforms) result (let ((subform (car subforms))) @@ -760,28 +959,28 @@ (case (peek-char nil stream t nil t) (#\| (read-char stream t nil t) - `(map . ,(prog1 - (read-delimited-list #\| stream t) - (unless (eql (read-char stream) #\}) - (error "Incorrect #{| ... |} syntax"))))) + `(wb-map . ,(prog1 + (read-delimited-list #\| stream t) + (unless (eql (read-char stream) #\}) + (error "Incorrect #{| ... |} syntax"))))) (#\% (read-char stream t nil t) - `(bag . ,(prog1 - (read-delimited-list #\% stream t) - (unless (eql (read-char stream) #\}) - (error "Incorrect #{% ... %} syntax"))))) + `(wb-bag . ,(prog1 + (read-delimited-list #\% stream t) + (unless (eql (read-char stream) #\}) + (error "Incorrect #{% ... %} syntax"))))) (#\= (read-char stream t nil t) (if (eql (peek-char nil stream t nil t) #\|) (progn (read-char stream t nil t) - `(replay-map . ,(prog1 - (read-delimited-list #\| stream t) - (unless (eql (read-char stream) #\}) - (error "Incorrect #{=| ... |} syntax"))))) - `(replay-set . ,(read-delimited-list #\} stream t)))) + `(wb-replay-map . ,(prog1 + (read-delimited-list #\| stream t) + (unless (eql (read-char stream) #\}) + (error "Incorrect #{=| ... |} syntax"))))) + `(wb-replay-set . ,(read-delimited-list #\} stream t)))) (otherwise - `(set . ,(read-delimited-list #\} stream t))))) + `(wb-set . ,(read-delimited-list #\} stream t))))) (defun |#[-reader| (stream subchar arg) (declare (ignore subchar arg)) @@ -804,6 +1003,41 @@ (error "\"#%\" must be followed by a 2-element list.")) `(% . ,subform))) +;;; The new CHAMP types are printed with a double `#'. +(defun |##-reader| (stream subchar arg) + (declare (ignore subchar arg)) + (case (peek-char nil stream t nil t) + (#\{ + (read-char stream t nil t) + (case (peek-char nil stream t nil t) + (#\| + (read-char stream t nil t) + `(ch-map . ,(prog1 + (read-delimited-list #\| stream t) + (unless (eql (read-char stream) #\}) + (error "Incorrect #{| ... |} syntax"))))) + (#\% + (read-char stream t nil t) + `(ch-bag . ,(prog1 + (read-delimited-list #\% stream t) + (unless (eql (read-char stream) #\}) + (error "Incorrect #{% ... %} syntax"))))) + (#\= + (read-char stream t nil t) + (if (eql (peek-char nil stream t nil t) #\|) + (progn + (read-char stream t nil t) + `(ch-replay-map . ,(prog1 + (read-delimited-list #\| stream t) + (unless (eql (read-char stream) #\}) + (error "Incorrect #{=| ... |} syntax"))))) + `(ch-replay-set . ,(read-delimited-list #\} stream t)))) + (otherwise + `(ch-set . ,(read-delimited-list #\} stream t))))) + ;; No other options, currently. + (otherwise + (error "\"##\" is expected to be followed by \"{\"")))) + (defun fset-setup-readtable (readtable) "Adds FSet reader macros to `readtable'. Returns `readtable'." @@ -814,6 +1048,7 @@ (set-dispatch-macro-character #\# #\~ #'|#~-reader| readtable) (set-dispatch-macro-character #\# #\$ #'|#$-reader| readtable) (set-dispatch-macro-character #\# #\% #'|#%-reader| readtable) + (set-dispatch-macro-character #\# #\# #'|##-reader| readtable) readtable) (defvar *fset-readtable* (fset-setup-readtable (copy-readtable nil)) @@ -828,48 +1063,71 @@ (:macro-char #\] (get-macro-character #\)) nil) (:dispatch-macro-char #\# #\~ #'|#~-reader|) (:dispatch-macro-char #\# #\$ #'|#$-reader|) - (:dispatch-macro-char #\# #\% #'|#%-reader|)) + (:dispatch-macro-char #\# #\% #'|#%-reader|) + (:dispatch-macro-char #\# #\# #'|##-reader|)) ;;; These function in the traditional Lisp manner, constructing the structures ;;; at read time. They can therefore be used to read back previously printed ;;; structure containing FSet collections. (defun |rereading-#{-reader| (stream subchar arg) - (declare (ignore subchar arg) - (notinline empty-bag)) + (declare (ignore subchar arg)) + (|rereading-#{-read-internal| stream 'wb-set 'wb-bag 'wb-map 'wb-replay-set 'wb-replay-map)) + +(defun |rereading-#{-read-internal| (stream set-type bag-type map-type replay-set-type replay-map-type) (flet ((read-map (tag) (read-char stream t nil t) (let ((pairs (read-delimited-list #\| stream t))) (unless (eql (read-char stream) #\}) (error "Incorrect #{~A| ... |} syntax" tag)) - (if (eql #\/ (peek-char nil stream nil nil t)) - (progn - (read-char stream t nil t) - (values pairs (read stream t nil t))) - (values pairs nil))))) + (let ((key-cfn-name val-cfn-name + (and (eql #\[ (peek-char nil stream nil nil t)) + (progn + (read-char stream) + (values (if (eql #\; (peek-char nil stream t nil t)) + (progn (read-char stream) nil) + (car (read-delimited-list #\; stream t))) + (if (eql #\] (peek-char nil stream t nil t)) + (progn (read-char stream) nil) + (car (read-delimited-list #\] stream t)))))))) + (if (eql #\/ (peek-char nil stream nil nil t)) + (progn + (read-char stream t nil t) + (values pairs (read stream t nil t) key-cfn-name val-cfn-name)) + (values pairs 'no-default key-cfn-name val-cfn-name))))) + (read-compare-fn () + (and (eql #\[ (peek-char nil stream nil nil t)) + (progn + (read-char stream) + (car (read-delimited-list #\] stream t)))))) (case (peek-char nil stream t nil t) (#\| - (let ((pairs default (read-map ""))) - (with-default (convert 'map pairs :value-fn #'cadr) default))) + (let ((pairs default key-cfn-name val-cfn-name (read-map ""))) + (with-default (convert map-type pairs :value-fn #'cadr :key-compare-fn-name key-cfn-name + :val-compare-fn-name val-cfn-name) + default))) (#\% (read-char stream t nil t) - (let ((stuff (read-delimited-list #\% stream t)) - (result (empty-bag))) + (let ((stuff (read-delimited-list #\% stream t))) (unless (eql (read-char stream) #\}) - (error "Incorrect #{% ... %} syntax")) - (dolist (x stuff) - (if (and (consp x) (eq (car x) '%%)) - (adjoinf result (cadr x) (caddr x)) - (adjoinf result x))) - result)) + (error "Incorrect #{% ... %} (bag) syntax")) + (let ((cfn (read-compare-fn)) + ((result (convert bag-type nil :compare-fn-name cfn)))) + (dolist (x stuff) + (if (and (consp x) (eq (car x) '%%)) + (adjoinf result (cadr x) (caddr x)) + (adjoinf result x))) + result))) (#\= (read-char stream t nil t) (if (eql (peek-char nil stream t nil t) #\|) - (let ((pairs default (read-map "="))) - (with-default (convert 'replay-map pairs :value-fn #'cadr) default)) - (convert 'replay-set (read-delimited-list #\} stream t)))) + (let ((pairs default key-cfn-name val-cfn-name (read-map "="))) + (with-default (convert replay-map-type pairs :value-fn #'cadr :key-compare-fn-name key-cfn-name + :val-compare-fn-name val-cfn-name) + default)) + (convert replay-set-type (read-delimited-list #\} stream t) :compare-fn-name (read-compare-fn)))) (otherwise - (convert 'set (read-delimited-list #\} stream t)))))) + (convert set-type (read-delimited-list #\} stream t) :compare-fn-name (read-compare-fn)))))) (defun |rereading-#[-reader| (stream subchar arg) (declare (ignore subchar arg)) @@ -878,7 +1136,7 @@ (progn (read-char stream t nil t) (with-default seq (read stream t nil t))) - seq))) + (fset2:without-default seq)))) (defun |rereading-#~-reader| (stream subchar arg) (declare (ignore subchar arg)) @@ -901,6 +1159,15 @@ ;; to have a list starting with `%' in their bag, we would screw up. `(%% . ,subform))) +(defun |rereading-##-reader| (stream subchar arg) + (declare (ignore subchar arg)) + (case (peek-char nil stream t nil t) + (#\{ + (read-char stream t nil t) + (|rereading-#{-read-internal| stream 'ch-set 'ch-bag 'ch-map 'ch-replay-set 'ch-replay-map)) + (otherwise + (error "\"##\" is expected to be followed by \"{\"")))) + (defun fset-setup-rereading-readtable (readtable) "Adds the FSet rereading reader macros to `readtable'. These reader macros will correctly read structure printed by the FSet print functions. Returns @@ -911,6 +1178,7 @@ (set-macro-character #\] (get-macro-character #\)) nil readtable) (set-dispatch-macro-character #\# #\~ #'|rereading-#~-reader| readtable) (set-dispatch-macro-character #\# #\% #'|rereading-#%-reader| readtable) + (set-dispatch-macro-character #\# #\# #'|rereading-##-reader| readtable) readtable) (defvar *fset-rereading-readtable* (fset-setup-rereading-readtable (copy-readtable nil)) @@ -925,4 +1193,5 @@ (:dispatch-macro-char #\# #\[ #'|rereading-#[-reader|) (:macro-char #\] (get-macro-character #\)) nil) (:dispatch-macro-char #\# #\~ #'|rereading-#~-reader|) - (:dispatch-macro-char #\# #\% #'|rereading-#%-reader|)) + (:dispatch-macro-char #\# #\% #'|rereading-#%-reader|) + (:dispatch-macro-char #\# #\# #'|rereading-##-reader|)) diff --git a/Code/relations.lisp b/Code/relations.lisp index e4f28017be1a0d1ecd5ae7af4e52295eb159b41f..ed4716e346dc8b8dbeb18ce2626df9d3e132431f 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -38,13 +38,7 @@ (defstruct (2-relation (defmethod arity ((rel 2-relation)) 2) -(declaim (inline empty-2-relation)) -(defun empty-2-relation () - (declare (special *empty-wb-2-relation*)) - *empty-wb-2-relation*) - -(defmethod empty-instance-function ((class-name (eql '2-relation))) - 'empty-2-relation) +;;; `empty-2-relation' is below. (defgeneric lookup-inv (2-relation y) (:documentation "Does an inverse lookup on a binary relation.")) @@ -119,14 +113,20 @@ (defstruct (wb-2-relation (map1 nil) ; a cache, so we leave it mutable (org nil :type tree-map-org :read-only t)) -(defparameter *empty-wb-2-relation* (make-wb-2-relation 0 nil nil (wb-map-org *empty-wb-map*))) +(defparameter +empty-wb-2-relation+ (make-wb-2-relation 0 nil nil +fset-default-tree-map-org+)) -(declaim (inline empty-wb-2-relation)) +(declaim (inline empty-wb-2-relation fset2:empty-wb-2-relation)) (defun empty-wb-2-relation (&optional key-compare-fn-name val-compare-fn-name) "In this case, \"keys\" are the left values, and \"values\" are the right values." (if (and (null key-compare-fn-name) (null val-compare-fn-name)) - *empty-wb-2-relation* + +empty-wb-2-relation+ + (empty-wb-custom-2-relation (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare)))) +(defun fset2:empty-wb-2-relation (&key key-compare-fn-name val-compare-fn-name) + "In this case, \"keys\" are the left values, and \"values\" are the right +values." + (if (and (null key-compare-fn-name) (null val-compare-fn-name)) + +empty-wb-2-relation+ (empty-wb-custom-2-relation (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare)))) (deflex +empty-wb-custom-2-relation-cache+ (make-hash-table :test 'equal)) @@ -139,7 +139,7 @@ (defstruct (wb-2-relation (symbol-package val-compare-fn-name)) () "val-compare-fn-name must be a nonnull interned symbol") (if (and (eq key-compare-fn-name 'compare) (eq val-compare-fn-name 'compare)) - *empty-wb-2-relation* + +empty-wb-2-relation+ (let ((cache-key (list key-compare-fn-name val-compare-fn-name)) ((prev-instance (gethash cache-key +empty-wb-custom-2-relation-cache+))) (key-compare-fn (symbol-function key-compare-fn-name)) @@ -153,9 +153,6 @@ (defstruct (wb-2-relation (make-wb-2-relation 0 nil nil (make-tree-map-org key-compare-fn-name key-compare-fn val-compare-fn-name val-compare-fn))))))) -(defmethod empty-instance-function ((class-name (eql 'wb-2-relation))) - 'empty-wb-2-relation) - (defmethod empty-relation-like ((rel wb-2-relation)) (let ((org (wb-2-relation-org rel))) (empty-wb-2-relation (tree-map-org-key-compare-fn-name org) (tree-map-org-val-compare-fn-name org)))) @@ -179,28 +176,21 @@ (defmethod contains? ((rel wb-2-relation) x &optional (y nil y?)) ((found? set-tree (WB-Map-Tree-Lookup (wb-2-relation-map0 rel) x (tree-map-org-key-compare-fn org))))) (and found? (WB-Set-Tree-Contains? set-tree y (tree-map-org-val-compare-fn org))))) -;;; &&& 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... -;;; [Later] No, I don't think this is a problem. (setf (lookup ...) ...) just doesn't -;;; make sense on a relation, any more than it does on a set. -(defmethod lookup ((rel wb-2-relation) x) +;;; Note that `(setf (lookup rel x) y)' is the same as `(includef rel x y)'. +(define-methods (lookup fset2:lookup) ((rel wb-2-relation) x) "Returns the set of values that the relation pairs `x' with." (let ((org (wb-2-relation-org rel)) ((found? set-tree (WB-Map-Tree-Lookup (wb-2-relation-map0 rel) x (tree-map-org-key-compare-fn org))))) ;; We don't go through `empty-wb-set' here, because that would retrieve the current ;; `symbol-function' of the `key-compare-fn-name', which might have been changed since ;; the relation was created. - (if found? (make-wb-set set-tree (wb-2-relation-range-set-org rel)) - *empty-wb-set*))) + (make-wb-set (and found? set-tree) (wb-2-relation-range-set-org rel)))) (defmethod lookup-inv ((rel wb-2-relation) y) (wb-2-relation-get-inverse rel) (let ((org (wb-2-relation-org rel)) ((found? set-tree (WB-Map-Tree-Lookup (wb-2-relation-map1 rel) y (tree-map-org-val-compare-fn org))))) - (if found? (make-wb-set set-tree (wb-2-relation-domain-set-org rel)) - *empty-wb-set*))) + (make-wb-set (and found? set-tree) (wb-2-relation-domain-set-org rel)))) (defmethod domain ((rel wb-2-relation)) (make-wb-set (WB-Map-Tree-Domain (wb-2-relation-map0 rel)) @@ -361,13 +351,16 @@ (defmethod union ((rel1 wb-2-relation) (rel2 wb-2-relation) &key) (- (+ (WB-Set-Tree-Size s1) (WB-Set-Tree-Size s2)) (WB-Set-Tree-Size s))) s)) - map0-cmp-fn)) + ;; Passing `(constantly ':unequal)' forces the previous lambda + ;; to be called whenever keys match. + map0-cmp-fn (constantly ':unequal))) (new-map1 (and (or (wb-2-relation-map1 rel1) (wb-2-relation-map1 rel2)) (progn (wb-2-relation-get-inverse rel1) (wb-2-relation-get-inverse rel2) (WB-Map-Tree-Union (wb-2-relation-map1 rel1) (wb-2-relation-map1 rel2) - (fn (a b) (WB-Set-Tree-Union a b map0-cmp-fn)) map1-cmp-fn)))))) + (fn (a b) (WB-Set-Tree-Union a b map0-cmp-fn)) + map1-cmp-fn (constantly ':unequal))))))) (make-wb-2-relation new-size new-map0 new-map1 org)) (call-next-method))) @@ -382,7 +375,7 @@ (defmethod intersection ((rel1 wb-2-relation) (rel2 wb-2-relation) &key) (let ((s (WB-Set-Tree-Intersect s1 s2 map1-cmp-fn))) (incf new-size (WB-Set-Tree-Size s)) (values s (and (null s) ':no-value)))) - map0-cmp-fn)) + map0-cmp-fn (constantly ':unequal))) (new-map1 (and (or (wb-2-relation-map1 rel1) (wb-2-relation-map1 rel2)) (progn (wb-2-relation-get-inverse rel1) @@ -391,7 +384,7 @@ (defmethod intersection ((rel1 wb-2-relation) (rel2 wb-2-relation) &key) (lambda (s1 s2) (let ((s (WB-Set-Tree-Intersect s1 s2 map0-cmp-fn))) (values s (and (null s) ':no-value)))) - map1-cmp-fn)))))) + map1-cmp-fn (constantly ':unequal))))))) (make-wb-2-relation new-size new-map0 new-map1 org)) (call-next-method))) @@ -448,38 +441,39 @@ (defmethod join ((rela wb-2-relation) cola (relb wb-2-relation) colb) (make-tree-map-org cmp-fn-0a-name cmp-fn-0a cmp-fn-1b-name cmp-fn-1b)))) -(defmethod compose ((rel wb-2-relation) (fn function) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((rel wb-2-relation) (fn function) &key val-compare-fn-name) (wb-2-relation-fn-compose rel fn val-compare-fn-name)) -(defmethod compose ((rel wb-2-relation) (fn symbol) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((rel wb-2-relation) (fn symbol) &key val-compare-fn-name) (wb-2-relation-fn-compose rel (coerce fn 'function) val-compare-fn-name)) -(defmethod compose ((rel wb-2-relation) (fn map) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((rel wb-2-relation) (fn map) &key val-compare-fn-name) (wb-2-relation-fn-compose rel fn (or val-compare-fn-name (tree-map-org-val-compare-fn-name (wb-2-relation-org rel))))) -(defmethod compose ((rel wb-2-relation) (fn seq) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((rel wb-2-relation) (fn seq) &key val-compare-fn-name) (wb-2-relation-fn-compose rel fn val-compare-fn-name)) -(defmethod compose ((rel1 wb-2-relation) (rel2 wb-2-relation) &key) +(define-methods (compose fset2:compose) ((rel1 wb-2-relation) (rel2 wb-2-relation) &key) (join rel1 1 rel2 0)) (defun wb-2-relation-fn-compose (rel fn val-compare-fn-name) (let ((new-size 0) - (org (wb-2-relation-org (empty-wb-custom-2-relation (tree-map-org-key-compare-fn-name (wb-2-relation-org rel)) - (or val-compare-fn-name 'compare)))) - ((new-map0 (gmap (:result wb-map) - (fn (x ys) - (let ((result nil)) - (Do-WB-Set-Tree-Members (y ys) - (setq result (WB-Set-Tree-With result (@ fn y) (tree-map-org-val-compare-fn org)))) - (incf new-size (WB-Set-Tree-Size result)) - (values x result))) - (:arg wb-map (make-wb-map (wb-2-relation-map0 rel) +fset-default-tree-map-org+ nil)))))) + (rel-org (wb-2-relation-org rel)) + ((org (wb-2-relation-org (empty-wb-custom-2-relation (tree-map-org-key-compare-fn-name rel-org) + (or val-compare-fn-name 'compare)))) + ((new-map0 (gmap (:result wb-map) + (fn (x ys) + (let ((result nil)) + (Do-WB-Set-Tree-Members (y ys) + (setq result (WB-Set-Tree-With result (@ fn y) (tree-map-org-val-compare-fn org)))) + (incf new-size (WB-Set-Tree-Size result)) + (values x result))) + (:arg wb-map (make-wb-map (wb-2-relation-map0 rel) rel-org nil))))))) (make-wb-2-relation new-size (wb-map-contents new-map0) nil org))) -(define-wb-set-method image ((fn 2-relation) (s wb-set) &key compare-fn-name) - (wb-set-image fn (contents s) (or compare-fn-name (compare-fn-name s)))) +(define-wb-set-methods (image fset2:image) ((fn 2-relation) (s wb-set) &key compare-fn-name) + (wb-set-image (fn (x) (lookup fn x)) (contents s) (or compare-fn-name (compare-fn-name s)))) (defmethod internal-do-2-relation ((rel wb-2-relation) elt-fn value-fn) @@ -508,11 +502,21 @@ (defmethod convert ((to-type (eql 'wb-2-relation)) (rel wb-2-relation) &key key- (incf size))) (make-wb-2-relation size map0 nil org))))) +(defmethod convert ((to-type (eql 'wb-2-relation)) (pairs set) + &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) + (let ((key-fn (coerce key-fn 'function)) + (value-fn (coerce value-fn 'function))) + (gmap (:result wb-2-relation :key-compare-fn-name key-compare-fn-name :val-compare-fn-name val-compare-fn-name) + (fn (pr) (values (funcall key-fn pr) (funcall value-fn pr))) + (:arg set pairs)))) + (defmethod convert ((to-type (eql 'list)) (rel 2-relation) &key (pair-fn #'cons)) (gmap (:result list) pair-fn (:arg 2-relation rel))) (defmethod convert ((to-type (eql 'set)) (rel wb-2-relation) &key (pair-fn #'cons)) (convert 'wb-set rel :pair-fn pair-fn)) +(defmethod convert ((to-type (eql 'fset2:set)) (rel wb-2-relation) &key (pair-fn #'cons)) + (convert 'wb-set rel :pair-fn pair-fn)) (defmethod convert ((to-type (eql 'wb-set)) (rel 2-relation) &key (pair-fn #'cons) compare-fn-name) (let ((set-org (wb-set-org (empty-wb-set compare-fn-name))) @@ -534,7 +538,7 @@ (defmethod convert ((to-type (eql '2-relation)) (m wb-map) &key from-type) sets, and the result pairs each domain element with each member of the corresponding range set. Otherwise, the result pairs each domain element with the corresponding range element directly." - (if (eq from-type 'map-to-sets) + (if (member from-type '(map-to-sets fset2:map-to-sets)) (wb-map-to-sets-to-wb-2-relation m nil nil) (wb-map-to-wb-2-relation m nil nil))) @@ -546,7 +550,7 @@ (defmethod convert ((to-type (eql 'wb-2-relation)) (m wb-map) &key from-type key The key and value compare-fns of the result are taken from `m' unless explicitly overridden in the call." - (if (eq from-type 'map-to-sets) + (if (member from-type '(map-to-sets fset2:map-to-sets)) (wb-map-to-sets-to-wb-2-relation m key-compare-fn-name val-compare-fn-name) (wb-map-to-wb-2-relation m key-compare-fn-name val-compare-fn-name))) @@ -568,7 +572,6 @@ (defmethod convert ((to-type (eql 'wb-2-relation)) (m wb-map) &key from-type key :val-compare-fn-name vcfn-name))) (defun wb-map-to-wb-2-relation (m key-compare-fn-name val-compare-fn-name) - (declare (optimize (debug 3))) (let ((map-org (wb-map-org m)) ((new-tree (WB-Map-Tree-Compose (wb-map-contents m) (fn (x) (WB-Set-Tree-With nil x (tree-map-org-val-compare-fn map-org))))))) @@ -576,34 +579,19 @@ (defmethod convert ((to-type (eql 'wb-2-relation)) (m wb-map) &key from-type key :key-compare-fn-name (or key-compare-fn-name (tree-map-org-key-compare-fn-name map-org)) :val-compare-fn-name (or val-compare-fn-name (tree-map-org-val-compare-fn-name map-org))))) -(defmethod convert ((to-type (eql '2-relation)) (lst list) - &key (key-fn #'car) (value-fn #'cdr)) - (declare (optimize (debug 3))) - (let ((key-fn (coerce key-fn 'function)) - (value-fn (coerce value-fn 'function))) - (gmap (:result 2-relation) (fn (pr) (values (funcall key-fn pr) (funcall value-fn pr))) - (:list lst)))) - (defmethod convert ((to-type (eql 'wb-2-relation)) (lst list) &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) (let ((key-fn (coerce key-fn 'function)) (value-fn (coerce value-fn 'function))) - (gmap (:result 2-relation :key-compare-fn-name key-compare-fn-name :val-compare-fn-name val-compare-fn-name) + (gmap (:result wb-2-relation :key-compare-fn-name key-compare-fn-name :val-compare-fn-name val-compare-fn-name) (fn (pr) (values (funcall key-fn pr) (funcall value-fn pr))) (:list lst)))) -(defmethod convert ((to-type (eql '2-relation)) (s seq) - &key (key-fn #'car) (value-fn #'cdr)) - (let ((key-fn (coerce key-fn 'function)) - (value-fn (coerce value-fn 'function))) - (gmap (:result 2-relation) (fn (pr) (values (funcall key-fn pr) (funcall value-fn pr))) - (:seq s)))) - (defmethod convert ((to-type (eql 'wb-2-relation)) (s seq) &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) (let ((key-fn (coerce key-fn 'function)) (value-fn (coerce value-fn 'function))) - (gmap (:result 2-relation :key-compare-fn-name key-compare-fn-name :val-compare-fn-name val-compare-fn-name) + (gmap (:result wb-2-relation :key-compare-fn-name key-compare-fn-name :val-compare-fn-name val-compare-fn-name) (fn (pr) (values (funcall key-fn pr) (funcall value-fn pr))) (:seq s)))) @@ -612,16 +600,29 @@ (defmethod convert ((to-type (eql 'map)) (rel wb-2-relation) &key) 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." - (wb-2-relation-to-wb-map rel nil nil)) + (wb-2-relation-to-wb-map rel nil nil nil)) +(defmethod convert ((to-type (eql 'fset2:map)) (rel 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." + (wb-2-relation-to-wb-map rel nil nil nil)) (defmethod convert ((to-type (eql 'wb-map)) (rel wb-2-relation) &key key-compare-fn-name val-compare-fn-name) "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." - (wb-2-relation-to-wb-map rel key-compare-fn-name val-compare-fn-name)) + (wb-2-relation-to-wb-map rel key-compare-fn-name val-compare-fn-name nil)) +(defmethod convert ((to-type (eql 'fset2:wb-map)) (rel wb-2-relation) &key key-compare-fn-name val-compare-fn-name) + "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." + (wb-2-relation-to-wb-map rel key-compare-fn-name val-compare-fn-name nil)) -(defun wb-2-relation-to-wb-map (rel key-compare-fn-name val-compare-fn-name) +;;; `default' is always `nil' now, but for a while, it wasn't. +(defun wb-2-relation-to-wb-map (rel key-compare-fn-name val-compare-fn-name default) (let ((m nil) (rel-org (wb-2-relation-org rel)) ((org (wb-2-relation-org (empty-wb-2-relation @@ -634,14 +635,37 @@ (defmethod convert ((to-type (eql 'wb-map)) (rel wb-2-relation) &key key-compare (unless (= 1 sz) (error "2-relation maps ~A to ~D values" x sz)) (setq m (WB-Map-Tree-With m x (WB-Set-Tree-Arb s) key-compare-fn val-compare-fn)))) - (make-wb-map m org nil))) + (make-wb-map m org default))) (defmethod convert ((to-type (eql 'map-to-sets)) (rel wb-2-relation) &key) "This conversion returns a map mapping each domain value to the set of -corresponding range values." - (let ((set-org (wb-2-relation-range-set-org rel))) - (make-wb-map (WB-Map-Tree-Compose (wb-2-relation-map0 rel) (fn (tree) (make-wb-set tree set-org))) - (wb-2-relation-org rel) nil))) +corresponding range values. If the val-compare-fn of the relation is not +`compare', the returned map will use `eql-compare' as its `val-compare-fn'." + (wb-2-relation-to-map-to-sets rel nil)) + +(defmethod convert ((to-type (eql 'fset2:map-to-sets)) (rel wb-2-relation) + &key (default nil default?) no-default?) + "This conversion returns a map mapping each domain value to the set of +corresponding range values. If the val-compare-fn of the relation is not +`compare', the returned map will use `eql-compare' as its `val-compare-fn'." + (wb-2-relation-to-map-to-sets rel (fset2-default default? default no-default?))) + +(defun wb-2-relation-to-map-to-sets (rel default) + (let ((rel-org (wb-2-relation-org rel)) + (set-org (wb-2-relation-range-set-org rel)) + ((vcfn-nm (tree-map-org-val-compare-fn-name rel-org)) + ((map-val-cfn-nm (if (eq vcfn-nm 'compare) 'compare 'eql-compare)) + ((new-contents + ;; The `convert' is because the val-compare-fn may have been redefined (or at least + ;; recompiled; we can't tell the difference). We may have to rebuild the set trees. + (WB-Map-Tree-Compose (wb-2-relation-map0 rel) + (fn (tree) + (convert 'wb-set (make-wb-set tree set-org) :compare-fn-name vcfn-nm)))))))) + (make-wb-map new-contents + (make-tree-map-org (tree-map-org-key-compare-fn-name rel-org) + (tree-map-org-key-compare-fn rel-org) + map-val-cfn-nm (symbol-function map-val-cfn-nm)) + default))) (defmethod conflicts ((rel wb-2-relation)) (let ((m0 nil) @@ -775,14 +799,27 @@ (defstruct (ch-2-relation (map1 nil) ; a cache, so we leave it mutable (org nil :type hash-map-org :read-only t)) -(defparameter *empty-ch-2-relation* (make-ch-2-relation 0 nil nil (ch-map-org *empty-ch-map*))) +(defparameter +empty-ch-2-relation+ (make-ch-2-relation 0 nil nil +fset-default-hash-map-org+)) + +;;; Moved here from above because forward-referencing `+empty-ch-2-relation+' ran afoul of +;;; https://bugs.launchpad.net/sbcl/+bug/2129827 . +(declaim (inline empty-2-relation)) +(defun empty-2-relation () + ;; Now CHAMP! + +empty-ch-2-relation+) -(declaim (inline empty-ch-2-relation)) +(declaim (inline empty-ch-2-relation fset2:empty-ch-2-relation)) (defun empty-ch-2-relation (&optional key-compare-fn-name val-compare-fn-name) "In this case, \"keys\" are the left values, and \"values\" are the right values." (if (and (null key-compare-fn-name) (null val-compare-fn-name)) - *empty-ch-2-relation* + +empty-ch-2-relation+ + (empty-ch-custom-2-relation (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare)))) +(defun fset2:empty-ch-2-relation (&key key-compare-fn-name val-compare-fn-name) + "In this case, \"keys\" are the left values, and \"values\" are the right +values." + (if (and (null key-compare-fn-name) (null val-compare-fn-name)) + +empty-ch-2-relation+ (empty-ch-custom-2-relation (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare)))) (deflex +empty-ch-custom-2-relation-cache+ (make-hash-table :test 'equal)) @@ -795,7 +832,7 @@ (defstruct (ch-2-relation (symbol-package val-compare-fn-name)) () "val-compare-fn-name must be a nonnull interned symbol") (if (and (eq key-compare-fn-name 'compare) (eq val-compare-fn-name 'compare)) - *empty-ch-2-relation* + +empty-ch-2-relation+ (let ((cache-key (list key-compare-fn-name val-compare-fn-name)) ((prev-instance (gethash cache-key +empty-ch-custom-2-relation-cache+))) (key-hash-fn-name (or (get key-compare-fn-name 'hash-function) @@ -819,9 +856,6 @@ (defstruct (ch-2-relation (make-ch-2-relation 0 nil nil (make-hash-map-org key-compare-fn-name key-compare-fn key-hash-fn val-compare-fn-name val-compare-fn val-hash-fn))))))) -(defmethod empty-instance-function ((class-name (eql 'ch-2-relation))) - 'empty-ch-2-relation) - (defmethod empty-relation-like ((rel ch-2-relation)) (let ((org (ch-2-relation-org rel))) (empty-ch-2-relation (hash-map-org-key-compare-fn-name org) (hash-map-org-val-compare-fn-name org)))) @@ -846,13 +880,7 @@ (defmethod contains? ((rel ch-2-relation) x &optional (y nil y?)) (hash-map-org-key-hash-fn org) (hash-map-org-key-compare-fn org))))) (and found? (ch-set-tree-contains? set-tree y (hash-map-org-val-hash-fn org) (hash-map-org-val-compare-fn org))))) -;;; &&& 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... -;;; [Later] No, I don't think this is a problem. (setf (lookup ...) ...) just doesn't -;;; make sense on a relation, any more than it does on a set. -(defmethod lookup ((rel ch-2-relation) x) +(define-methods (lookup fset2:lookup) ((rel ch-2-relation) x) "Returns the set of values that the relation pairs `x' with." (let ((org (ch-2-relation-org rel)) ((found? set-tree (ch-map-tree-lookup (ch-2-relation-map0 rel) x @@ -860,16 +888,14 @@ (defmethod lookup ((rel ch-2-relation) x) ;; We don't go through `empty-ch-set' here, because that would retrieve the current ;; `symbol-function' of the `key-compare-fn-name', which might have been changed since ;; the relation was created. - (if found? (make-ch-set set-tree (ch-2-relation-range-set-org rel)) - *empty-ch-set*))) + (make-ch-set (and found? set-tree) (ch-2-relation-range-set-org rel)))) (defmethod lookup-inv ((rel ch-2-relation) y) (ch-2-relation-get-inverse rel) (let ((org (ch-2-relation-org rel)) ((found? set-tree (ch-map-tree-lookup (ch-2-relation-map1 rel) y (hash-map-org-val-hash-fn org) (hash-map-org-val-compare-fn org))))) - (if found? (make-ch-set set-tree (ch-2-relation-domain-set-org rel)) - *empty-ch-set*))) + (make-ch-set (and found? set-tree) (ch-2-relation-domain-set-org rel)))) (defmethod domain ((rel ch-2-relation)) (let ((org (ch-2-relation-org rel))) @@ -1012,14 +1038,17 @@ (defmethod union ((rel1 ch-2-relation) (rel2 ch-2-relation) &key) (- (+ (ch-set-tree-size s1) (ch-set-tree-size s2)) (ch-set-tree-size s))) s)) - map0-hash-fn map0-cmp-fn map1-hash-fn map1-cmp-fn)) + ;; Passing `(constantly ':unequal)' forces the previous lambda + ;; to be called whenever keys match. + map0-hash-fn map0-cmp-fn #'ch-set-tree-hash-value (constantly ':unequal))) (new-map1 (and (or (ch-2-relation-map1 rel1) (ch-2-relation-map1 rel2)) (progn (ch-2-relation-get-inverse rel1) (ch-2-relation-get-inverse rel2) (ch-map-tree-union (ch-2-relation-map1 rel1) (ch-2-relation-map1 rel2) (fn (a b) (ch-set-tree-union a b map0-hash-fn map0-cmp-fn)) - map1-hash-fn map1-cmp-fn map0-hash-fn map0-cmp-fn)))))) + map1-hash-fn map1-cmp-fn #'ch-set-tree-hash-value + (constantly ':unequal))))))) (make-ch-2-relation new-size new-map0 new-map1 org)) (call-next-method))) @@ -1036,7 +1065,7 @@ (defmethod intersection ((rel1 ch-2-relation) (rel2 ch-2-relation) &key) (let ((s (ch-set-tree-intersection s1 s2 map1-hash-fn map1-cmp-fn))) (incf new-size (ch-set-tree-size s)) (values s (and (null s) ':no-value)))) - map0-hash-fn map0-cmp-fn map1-hash-fn map1-cmp-fn)) + map0-hash-fn map0-cmp-fn map1-hash-fn (constantly ':unequal))) (new-map1 (and (or (ch-2-relation-map1 rel1) (ch-2-relation-map1 rel2)) (progn (ch-2-relation-get-inverse rel1) @@ -1046,7 +1075,8 @@ (defmethod intersection ((rel1 ch-2-relation) (rel2 ch-2-relation) &key) (let ((s (ch-set-tree-intersection s1 s2 map0-hash-fn map0-cmp-fn))) (values s (and (null s) ':no-value)))) - map1-hash-fn map1-cmp-fn map0-hash-fn map0-cmp-fn)))))) + map1-hash-fn map1-cmp-fn + map0-hash-fn (constantly ':unequal))))))) (make-ch-2-relation new-size new-map0 new-map1 org)) (call-next-method))) @@ -1108,39 +1138,40 @@ (defmethod join ((rela ch-2-relation) cola (relb ch-2-relation) colb) cmp-fn-1b-name cmp-fn-1b hash-fn-1b)))) -(defmethod compose ((rel ch-2-relation) (fn function) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((rel ch-2-relation) (fn function) &key val-compare-fn-name) (ch-2-relation-fn-compose rel fn val-compare-fn-name)) -(defmethod compose ((rel ch-2-relation) (fn symbol) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((rel ch-2-relation) (fn symbol) &key val-compare-fn-name) (ch-2-relation-fn-compose rel (coerce fn 'function) val-compare-fn-name)) -(defmethod compose ((rel ch-2-relation) (fn map) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((rel ch-2-relation) (fn map) &key val-compare-fn-name) (ch-2-relation-fn-compose rel fn (or val-compare-fn-name (hash-map-org-val-compare-fn-name (ch-2-relation-org rel))))) -(defmethod compose ((rel ch-2-relation) (fn seq) &key val-compare-fn-name) +(define-methods (compose fset2:compose) ((rel ch-2-relation) (fn seq) &key val-compare-fn-name) (ch-2-relation-fn-compose rel fn val-compare-fn-name)) -(defmethod compose ((rel1 ch-2-relation) (rel2 ch-2-relation) &key) +(define-methods (compose fset2:compose) ((rel1 ch-2-relation) (rel2 ch-2-relation) &key) (join rel1 1 rel2 0)) (defun ch-2-relation-fn-compose (rel fn val-compare-fn-name) (let ((new-size 0) - (org (ch-2-relation-org (empty-ch-custom-2-relation (hash-map-org-key-compare-fn-name (ch-2-relation-org rel)) - (or val-compare-fn-name 'compare)))) - ((new-map0 (gmap (:result ch-map) - (fn (x ys) - (let ((result nil)) - (do-ch-set-tree-members (y ys) - (setq result (ch-set-tree-with result (@ fn y) (hash-map-org-val-hash-fn org) - (hash-map-org-val-compare-fn org)))) - (incf new-size (ch-set-tree-size result)) - (values x result))) - (:arg ch-map (make-ch-map (ch-2-relation-map0 rel) (ch-map-org *empty-ch-map*) nil)))))) + (rel-org (ch-2-relation-org rel)) + ((org (ch-2-relation-org (empty-ch-custom-2-relation (hash-map-org-key-compare-fn-name rel-org) + (or val-compare-fn-name 'compare)))) + ((new-map0 (gmap (:result ch-map) + (fn (x ys) + (let ((result nil)) + (do-ch-set-tree-members (y ys) + (setq result (ch-set-tree-with result (@ fn y) (hash-map-org-val-hash-fn org) + (hash-map-org-val-compare-fn org)))) + (incf new-size (ch-set-tree-size result)) + (values x result))) + (:arg ch-map (make-ch-map (ch-2-relation-map0 rel) rel-org nil))))))) (make-ch-2-relation new-size (ch-map-contents new-map0) nil org))) -(defmethod image ((fn 2-relation) (s ch-set) &key compare-fn-name) - (ch-set-image fn s compare-fn-name)) +(define-methods (image fset2:image) ((fn 2-relation) (s ch-set) &key compare-fn-name) + (ch-set-image (fn (x) (lookup fn x)) s compare-fn-name)) (defmethod internal-do-2-relation ((rel ch-2-relation) elt-fn value-fn) @@ -1172,11 +1203,23 @@ (defmethod convert ((to-type (eql 'ch-2-relation)) (rel ch-2-relation) &key key- (incf size))) (make-ch-2-relation size map0 nil org))))) -(defmethod convert ((to-type (eql 'list)) (rel 2-relation) &key (pair-fn #'cons)) - (gmap (:result list) pair-fn (:arg 2-relation rel))) +(defmethod convert ((to-type (eql '2-relation)) (pairs set) + &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) + (convert 'ch-2-relation pairs :key-fn key-fn :value-fn value-fn + :key-compare-fn-name key-compare-fn-name :val-compare-fn-name val-compare-fn-name)) + +(defmethod convert ((to-type (eql 'ch-2-relation)) (pairs set) + &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) + (let ((key-fn (coerce key-fn 'function)) + (value-fn (coerce value-fn 'function))) + (gmap (:result ch-2-relation :key-compare-fn-name key-compare-fn-name :val-compare-fn-name val-compare-fn-name) + (fn (pr) (values (funcall key-fn pr) (funcall value-fn pr))) + (:arg set pairs)))) (defmethod convert ((to-type (eql 'set)) (rel ch-2-relation) &key (pair-fn #'cons)) (convert 'ch-set rel :pair-fn pair-fn)) +(defmethod convert ((to-type (eql 'fset2:set)) (rel ch-2-relation) &key (pair-fn #'cons)) + (convert 'ch-set rel :pair-fn pair-fn)) (defmethod convert ((to-type (eql 'ch-set)) (rel 2-relation) &key (pair-fn #'cons) compare-fn-name) (let ((set-org (ch-set-org (empty-ch-set compare-fn-name))) @@ -1192,7 +1235,7 @@ (defmethod convert ((to-type (eql '2-relation)) (m ch-map) &key from-type) sets, and the result pairs each domain element with each member of the corresponding range set. Otherwise, the result pairs each domain element with the corresponding range element directly." - (if (eq from-type 'map-to-sets) + (if (member from-type '(map-to-sets fset2:map-to-sets)) (ch-map-to-sets-to-ch-2-relation m nil nil) (ch-map-to-ch-2-relation m nil nil))) @@ -1204,7 +1247,7 @@ (defmethod convert ((to-type (eql 'ch-2-relation)) (m ch-map) &key from-type key The key and value compare-fns of the result are taken from `m' unless explicitly overridden in the call." - (if (eq from-type 'map-to-sets) + (if (member from-type '(map-to-sets fset2:map-to-sets)) (ch-map-to-sets-to-ch-2-relation m key-compare-fn-name val-compare-fn-name) (ch-map-to-ch-2-relation m key-compare-fn-name val-compare-fn-name))) @@ -1226,7 +1269,6 @@ (defmethod convert ((to-type (eql 'ch-2-relation)) (m ch-map) &key from-type key :val-compare-fn-name vcfn-name))) (defun ch-map-to-ch-2-relation (m kcfn-name vcfn-name) - (declare (optimize (debug 3))) (let ((map-org (ch-map-org m)) ((new-tree (ch-map-tree-compose (ch-map-contents m) (fn (x) (ch-set-tree-with nil x (hash-map-org-val-hash-fn map-org) @@ -1235,6 +1277,13 @@ (defmethod convert ((to-type (eql 'ch-2-relation)) (m ch-map) &key from-type key :key-compare-fn-name (or kcfn-name (hash-map-org-key-compare-fn-name map-org)) :val-compare-fn-name (or vcfn-name (hash-map-org-val-compare-fn-name map-org))))) +(defmethod convert ((to-type (eql '2-relation)) (lst list) + &key (key-fn #'car) (value-fn #'cdr)) + (let ((key-fn (coerce key-fn 'function)) + (value-fn (coerce value-fn 'function))) + (gmap (:result 2-relation) (fn (pr) (values (funcall key-fn pr) (funcall value-fn pr))) + (:list lst)))) + (defmethod convert ((to-type (eql 'ch-2-relation)) (lst list) &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) (let ((key-fn (coerce key-fn 'function)) @@ -1243,6 +1292,13 @@ (defmethod convert ((to-type (eql 'ch-2-relation)) (lst list) (fn (pr) (values (funcall key-fn pr) (funcall value-fn pr))) (:list lst)))) +(defmethod convert ((to-type (eql '2-relation)) (s seq) + &key (key-fn #'car) (value-fn #'cdr)) + (let ((key-fn (coerce key-fn 'function)) + (value-fn (coerce value-fn 'function))) + (gmap (:result 2-relation) (fn (pr) (values (funcall key-fn pr) (funcall value-fn pr))) + (:seq s)))) + (defmethod convert ((to-type (eql 'ch-2-relation)) (s seq) &key (key-fn #'car) (value-fn #'cdr) key-compare-fn-name val-compare-fn-name) (let ((key-fn (coerce key-fn 'function)) @@ -1256,16 +1312,28 @@ (defmethod convert ((to-type (eql 'map)) (rel ch-2-relation) &key) 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." - (ch-2-relation-to-ch-map rel nil nil)) + (ch-2-relation-to-ch-map rel nil nil nil)) +(defmethod convert ((to-type (eql 'fset2:map)) (rel ch-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." + (ch-2-relation-to-ch-map rel nil nil nil)) (defmethod convert ((to-type (eql 'ch-map)) (rel ch-2-relation) &key key-compare-fn-name val-compare-fn-name) "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." - (ch-2-relation-to-ch-map rel key-compare-fn-name val-compare-fn-name)) + (ch-2-relation-to-ch-map rel key-compare-fn-name val-compare-fn-name nil)) +(defmethod convert ((to-type (eql 'fset2:ch-map)) (rel ch-2-relation) &key key-compare-fn-name val-compare-fn-name) + "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." + (ch-2-relation-to-ch-map rel key-compare-fn-name val-compare-fn-name nil)) -(defun ch-2-relation-to-ch-map (rel key-compare-fn-name val-compare-fn-name) +(defun ch-2-relation-to-ch-map (rel key-compare-fn-name val-compare-fn-name default) (let ((m nil) (rel-org (ch-2-relation-org rel)) ((org (ch-2-relation-org (empty-ch-2-relation @@ -1280,14 +1348,41 @@ (defmethod convert ((to-type (eql 'ch-map)) (rel ch-2-relation) &key key-compare (unless (= 1 sz) (error "2-relation maps ~A to ~D values" x sz)) (setq m (ch-map-tree-with m x (ch-set-tree-arb s) key-hash-fn key-compare-fn val-hash-fn val-compare-fn)))) - (make-ch-map m org nil))) + (make-ch-map m org default))) (defmethod convert ((to-type (eql 'map-to-sets)) (rel ch-2-relation) &key) "This conversion returns a map mapping each domain value to the set of -corresponding range values." - (let ((set-org (ch-2-relation-range-set-org rel))) - (make-ch-map (ch-map-tree-compose (ch-2-relation-map0 rel) (fn (tree) (make-ch-set tree set-org))) - (ch-2-relation-org rel) nil))) +corresponding range values. If the val-compare-fn of the relation is not +`compare', the returned map will use `eql-compare' as its `val-compare-fn'." + (ch-2-relation-to-map-to-sets rel nil)) + +(defmethod convert ((to-type (eql 'fset2:map-to-sets)) (rel ch-2-relation) + &key (default nil default?) no-default?) + "This conversion returns a map mapping each domain value to the set of +corresponding range values. If the val-compare-fn of the relation is not +`compare', the returned map will use `eql-compare' as its `val-compare-fn'." + (ch-2-relation-to-map-to-sets rel (fset2-default default? default no-default?))) + +(defun ch-2-relation-to-map-to-sets (rel default) + (let ((rel-org (ch-2-relation-org rel)) + (set-org (ch-2-relation-range-set-org rel)) + ((vcfn-nm (hash-map-org-val-compare-fn-name rel-org)) + ((map-val-cfn-nm (if (eq vcfn-nm 'compare) 'compare 'eql-compare)) + ((new-contents + ;; The `convert' is because the val-compare-fn may have been redefined (or at least + ;; recompiled; we can't tell the difference). We may have to rebuild the set trees. + (ch-map-tree-compose (ch-2-relation-map0 rel) + (fn (tree) + (convert 'ch-set (make-ch-set tree set-org) :compare-fn-name vcfn-nm)))))))) + (make-ch-map new-contents + (make-hash-map-org (hash-map-org-key-compare-fn-name rel-org) + (hash-map-org-key-compare-fn rel-org) + (hash-map-org-key-hash-fn rel-org) + map-val-cfn-nm (symbol-function map-val-cfn-nm) + ;; By the time this is called, if the set trees had to be rebuilt, they + ;; will have their new hash values. + (symbol-function (get map-val-cfn-nm 'hash-function))) + default))) (defmethod conflicts ((rel ch-2-relation)) (let ((m0 nil) @@ -1509,6 +1604,12 @@ (defstruct (wb-list-relation (unless (or (null arity) (and (integerp arity) (>= arity 1))) (error "Invalid arity")) (empty-wb-list-relation arity)) +(defun fset2:empty-list-relation (&key arity) + "We allow the arity to be temporarily unspecified; it will be taken from +the first tuple added." + (unless (or (null arity) (and (integerp arity) (>= arity 1))) + (error "Invalid arity")) + (empty-ch-list-relation arity)) (defun empty-wb-list-relation (&optional arity compare-fn-name) "We allow the arity to be temporarily unspecified; it will be taken from @@ -1519,6 +1620,15 @@ (defstruct (wb-list-relation (unless (or (null arity) (and (integerp arity) (>= arity 1))) (error "Invalid arity")) (make-wb-list-relation arity nil nil (make-tree-list-relation-org (or compare-fn-name 'compare)))) +(defun fset2:empty-wb-list-relation (&key arity compare-fn-name) + "We allow the arity to be temporarily unspecified; it will be taken from +the first tuple added. If `compare-fn-name' is provided, the function must +be able to compare both tuples \(lists\) and their elements." + ;; -- Or, we could construct the tuple comparator from the element comparator... + ;; 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 nil nil (make-tree-list-relation-org (or compare-fn-name 'compare)))) (defmethod arity ((rel list-relation)) @@ -1545,6 +1655,8 @@ (defmethod at-rank ((rel wb-list-relation) rank) (defmethod convert ((to-type (eql 'set)) (rel wb-list-relation) &key) (convert 'wb-set rel)) +(defmethod convert ((to-type (eql 'fset2:set)) (rel wb-list-relation) &key) + (convert 'wb-set rel)) (defmethod convert ((to-type (eql 'wb-set)) (rel wb-list-relation) &key) (make-wb-set (wb-list-relation-tuples rel) @@ -1553,7 +1665,7 @@ (defmethod convert ((to-type (eql 'wb-set)) (rel wb-list-relation) &key) (defun wb-list-relation-result-org (rel) (let ((org (wb-list-relation-org rel))) (if (eq (tlrorg-compare-fn-name org) 'compare) - (wb-set-org *empty-wb-set*) + (wb-set-org +empty-wb-set+) (make-tree-set-org '?? (tlrorg-tuple-compare-fn org))))) (defmethod contains? ((rel wb-list-relation) tuple &optional (arg2 nil arg2?)) @@ -1926,12 +2038,17 @@ (defstruct (ch-list-relation (unless (or (null arity) (and (integerp arity) (>= arity 1))) (error "Invalid arity")) (make-ch-list-relation arity nil nil (make-hash-list-relation-org (or compare-fn-name 'compare)))) +(defun fset2:empty-ch-list-relation (&key arity compare-fn-name) + "We allow the arity to be temporarily unspecified; it will be taken from +the first tuple added. If `compare-fn-name' is provided, the function must +be able to compare both tuples \(lists\) and their elements." + ;; -- Or, we could construct the tuple comparator from the element comparator... + ;; 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-ch-list-relation arity nil nil (make-hash-list-relation-org (or compare-fn-name 'compare)))) -(defmethod arity ((rel list-relation)) - "Will return `nil' if the arity is not yet specified; see `empty-list-relation'." - (list-relation-arity rel)) - (defmethod empty? ((rel ch-list-relation)) (null (ch-list-relation-tuples rel))) @@ -1943,6 +2060,8 @@ (defmethod arb ((rel ch-list-relation)) (defmethod convert ((to-type (eql 'set)) (rel ch-list-relation) &key) (convert 'ch-set rel)) +(defmethod convert ((to-type (eql 'fset2:set)) (rel ch-list-relation) &key) + (convert 'ch-set rel)) (defmethod convert ((to-type (eql 'ch-set)) (rel ch-list-relation) &key) (make-ch-set (ch-list-relation-tuples rel) @@ -1951,7 +2070,7 @@ (defmethod convert ((to-type (eql 'ch-set)) (rel ch-list-relation) &key) (defun ch-list-relation-result-org (rel) (let ((org (ch-list-relation-org rel))) (if (eq (hlrorg-compare-fn-name org) 'compare) - (ch-set-org *empty-ch-set*) + +fset-default-hash-set-org+ (make-hash-set-org '?? (hlrorg-tuple-compare-fn org) (hlrorg-tuple-hash-fn org))))) (defmethod contains? ((rel ch-list-relation) tuple &optional (arg2 nil arg2?)) @@ -2342,6 +2461,9 @@ (defstruct (query-registry (defun empty-query-registry () (make-query-registry (empty-map (empty-list-relation)))) +(defun empty-wb-query-registry () + (make-query-registry (empty-ch-map (empty-wb-list-relation)))) + (defun empty-ch-query-registry () (make-query-registry (empty-ch-map (empty-ch-list-relation)))) @@ -2378,7 +2500,7 @@ (defmethod internal-do-all-queries ((reg query-registry) elt-fn value-fn) (do-list-relation (tuple rel) (funcall elt-fn (car tuple))))) -(defmethod lookup ((reg query-registry) tuple) +(define-methods (lookup fset2:lookup) ((reg query-registry) tuple) "Returns all queries in `reg' whose patterns match `tuple'." (gmap (:result union) (fn (mask list-rel) diff --git a/Code/replay.lisp b/Code/replay.lisp index 6defe2ad60ca26774fef153b48e1e7d0fe8e6c83..b9fa636fa6c1f79188089ec121c5ea20fe8bbbcd 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -13,15 +13,7 @@ ;;; Replay sets ;;; We have some implementation-generic methods. - -(defun empty-replay-set () - "Returns an empty replay set of the default implementation." - ;; Now CHAMP! - (declare (special *empty-ch-replay-set*)) - *empty-ch-replay-set*) - -(defmethod empty-instance-function ((class-name (eql 'replay-set))) - 'empty-replay-set) +;;; `empty-replay-set' is below. (defmethod convert ((to-type (eql 'replay-set)) (s replay-set) &key) s) @@ -32,9 +24,13 @@ (defmethod convert ((to-type (eql 'vector)) (s replay-set) &key) (convert 'vector (convert 'seq s))) (defmethod convert ((to-type (eql 'seq)) (s replay-set) &key) - (make-wb-seq (replay-set-ordering s))) + (make-wb-seq (replay-set-ordering s) nil)) +(defmethod convert ((to-type (eql 'fset2:seq)) (s replay-set) &key) + (make-wb-seq (replay-set-ordering s) nil)) (defmethod convert ((to-type (eql 'wb-seq)) (s replay-set) &key) - (make-wb-seq (replay-set-ordering s))) + (make-wb-seq (replay-set-ordering s) nil)) +(defmethod convert ((to-type (eql 'fset2:wb-seq)) (s replay-set) &key) + (make-wb-seq (replay-set-ordering s) nil)) (defmethod convert ((to-type (eql 'replay-set)) (l list) &key) (gmap (:result replay-set) nil (:arg list l))) @@ -71,12 +67,16 @@ (defstruct (wb-replay-set (contents nil :read-only t) (org nil :type tree-set-org :read-only t)) -(defparameter *empty-wb-replay-set* (make-wb-replay-set nil nil +fset-default-tree-set-org+)) +(defparameter +empty-wb-replay-set+ (make-wb-replay-set nil nil +fset-default-tree-set-org+)) -(declaim (inline empty-wb-replay-set)) +(declaim (inline empty-wb-replay-set fset2:empty-wb-replay-set)) (defun empty-wb-replay-set (&optional compare-fn-name) (if (null compare-fn-name) - *empty-wb-replay-set* + +empty-wb-replay-set+ + (empty-wb-custom-replay-set compare-fn-name))) +(defun fset2:empty-wb-replay-set (&key compare-fn-name) + (if (null compare-fn-name) + +empty-wb-replay-set+ (empty-wb-custom-replay-set compare-fn-name))) (deflex +empty-wb-custom-replay-set-cache+ (make-hash-table :test 'eq)) @@ -84,7 +84,7 @@ (defstruct (wb-replay-set (defun empty-wb-custom-replay-set (compare-fn-name) (assert (and (symbolp compare-fn-name) (not (null compare-fn-name)))) (if (eq compare-fn-name 'compare) - *empty-wb-replay-set* + +empty-wb-replay-set+ (let ((prev-instance (gethash compare-fn-name +empty-wb-custom-replay-set-cache+)) (compare-fn (symbol-function compare-fn-name))) (if (and prev-instance @@ -93,9 +93,6 @@ (defstruct (wb-replay-set (setf (gethash compare-fn-name +empty-wb-custom-replay-set-cache+) (make-wb-replay-set nil nil (make-tree-set-org compare-fn-name compare-fn))))))) -(defmethod empty-instance-function ((class-name (eql 'wb-replay-set))) - 'empty-wb-replay-set) - (defmethod compare-fn ((s wb-replay-set)) (tree-set-org-compare-fn (wb-replay-set-org s))) @@ -135,9 +132,10 @@ (defmethod greatest ((s wb-replay-set)) (defmethod index ((s wb-replay-set) x) (let ((idx 0) (compare-fn (tree-set-org-compare-fn (wb-replay-set-org s)))) - (do-wb-set-tree-members (e (wb-replay-set-contents s)) + (do-wb-seq-tree-members (e (replay-set-ordering s)) (when (equal?-cmp e x compare-fn) - (return idx))))) + (return idx)) + (incf idx)))) (defmethod at-index ((m wb-replay-set) index) (let ((ordering (replay-set-ordering m)) @@ -155,7 +153,7 @@ (defmethod contains? ((s wb-replay-set) x &optional (y nil y?)) (check-two-arguments y? 'contains? 'wb-replay-set) (wb-set-tree-contains? (wb-replay-set-contents s) x (tree-set-org-compare-fn (wb-replay-set-org s)))) -(defmethod lookup ((s wb-replay-set) value) +(define-methods (lookup fset2:lookup) ((s wb-replay-set) value) (wb-set-tree-find-equal (wb-replay-set-contents s) value (tree-set-org-compare-fn (wb-replay-set-org s)))) @@ -199,8 +197,12 @@ (defmethod hash-value ((rs wb-replay-set)) (defmethod convert ((to-type (eql 'set)) (s wb-replay-set) &key) (make-wb-set (wb-replay-set-contents s) (wb-replay-set-org s))) +(defmethod convert ((to-type (eql 'fset2:set)) (s wb-replay-set) &key) + (make-wb-set (wb-replay-set-contents s) (wb-replay-set-org s))) + (defmethod convert ((to-type (eql 'wb-set)) (s wb-replay-set) &key compare-fn-name) - (convert 'wb-set (make-wb-set (wb-replay-set-contents s)) :compare-fn-name compare-fn-name)) + (convert 'wb-set (make-wb-set (wb-replay-set-contents s) (wb-replay-set-org s)) + :compare-fn-name compare-fn-name)) (defmethod convert ((to-type (eql 'wb-replay-set)) (s replay-set) &key compare-fn-name) ;; If this method is called, `s' is not a `wb-replay-set'. @@ -278,7 +280,7 @@ (defmethod less ((s wb-replay-set) value &optional (arg2 nil arg2?)) (make-wb-replay-set new-contents (let ((tree (replay-set-ordering s))) (wb-seq-tree-remove tree - (or (position value (make-wb-seq tree) :test (equal?-fn compare-fn)) + (or (position value (make-wb-seq tree nil) :test (equal?-fn compare-fn)) (error "Bug in `less' on `wb-replay-set'")))) (wb-replay-set-org s))))) @@ -314,12 +316,24 @@ (defstruct (ch-replay-set (contents nil :read-only t) (org nil :type hash-set-org :read-only t)) -(defparameter *empty-ch-replay-set* (make-ch-replay-set nil nil (ch-set-org *empty-ch-set*))) +(defparameter +empty-ch-replay-set+ (make-ch-replay-set nil nil +fset-default-hash-set-org+)) -(declaim (inline empty-ch-replay-set)) +;;; Moved here from above because forward-referencing `+empty-ch-replay-set+' ran afoul of +;;; https://bugs.launchpad.net/sbcl/+bug/2129827 . +(declaim (inline empty-replay-set)) +(defun empty-replay-set () + "Returns an empty replay set of the default implementation." + ;; Now CHAMP! + +empty-ch-replay-set+) + +(declaim (inline empty-ch-replay-set fset2:empty-ch-replay-set)) (defun empty-ch-replay-set (&optional compare-fn-name) (if (null compare-fn-name) - *empty-ch-replay-set* + +empty-ch-replay-set+ + (empty-ch-custom-replay-set compare-fn-name))) +(defun fset2:empty-ch-replay-set (&key compare-fn-name) + (if (null compare-fn-name) + +empty-ch-replay-set+ (empty-ch-custom-replay-set compare-fn-name))) (deflex +empty-ch-custom-replay-set-cache+ (make-hash-table :test 'eq)) @@ -328,7 +342,7 @@ (defstruct (ch-replay-set (assert (and compare-fn-name (symbolp compare-fn-name) (symbol-package compare-fn-name)) () "compare-fn-name must be a nonnull interned symbol") (if (eq compare-fn-name 'compare) - *empty-ch-replay-set* + +empty-ch-replay-set+ (let ((prev-instance (gethash compare-fn-name +empty-ch-custom-replay-set-cache+)) (compare-fn (symbol-function compare-fn-name)) (hash-fn-name (or (get compare-fn-name 'hash-function) @@ -343,9 +357,6 @@ (defstruct (ch-replay-set (setf (gethash compare-fn-name +empty-ch-custom-replay-set-cache+) (make-ch-replay-set nil nil (make-hash-set-org compare-fn-name compare-fn hash-fn))))))) -(defmethod empty-instance-function ((class-name (eql 'ch-replay-set))) - 'empty-ch-replay-set) - (defmethod compare-fn ((s ch-replay-set)) (hash-set-org-compare-fn (ch-replay-set-org s))) @@ -376,9 +387,10 @@ (defmethod index ((s ch-replay-set) x) "WARNING: linear-time operation!" (let ((idx 0) (compare-fn (hash-set-org-compare-fn (ch-replay-set-org s)))) - (do-ch-set-tree-members (e (ch-replay-set-contents s)) + (do-wb-seq-tree-members (e (replay-set-ordering s)) (when (equal?-cmp e x compare-fn) - (return idx))))) + (return idx)) + (incf idx)))) (defmethod at-index ((m ch-replay-set) index) (let ((ordering (replay-set-ordering m)) @@ -398,7 +410,7 @@ (defmethod contains? ((s ch-replay-set) x &optional (y nil y?)) (ch-set-tree-contains? (ch-replay-set-contents s) x (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)))) -(defmethod lookup ((s ch-replay-set) value) +(define-methods (lookup fset2:lookup) ((s ch-replay-set) value) (let ((hsorg (ch-replay-set-org s))) (ch-set-tree-contains? (ch-replay-set-contents s) value (hash-set-org-hash-fn hsorg) (hash-set-org-compare-fn hsorg)))) @@ -438,6 +450,9 @@ (defmethod hash-value ((rs ch-replay-set)) (defmethod convert ((to-type (eql 'set)) (s ch-replay-set) &key) (make-ch-set (ch-replay-set-contents s) (ch-replay-set-org s))) +(defmethod convert ((to-type (eql 'fset2:set)) (s ch-replay-set) &key) + (make-ch-set (ch-replay-set-contents s) (ch-replay-set-org s))) + (defmethod convert ((to-type (eql 'ch-set)) (s ch-replay-set) &key compare-fn-name) (convert 'ch-set (make-ch-set (ch-replay-set-contents s) (ch-replay-set-org s)) :compare-fn-name compare-fn-name)) @@ -517,7 +532,7 @@ (defmethod less ((s ch-replay-set) value &optional (arg2 nil arg2?)) (make-ch-replay-set new-contents (let ((tree (replay-set-ordering s))) (wb-seq-tree-remove tree - (or (position value (make-wb-seq tree) :test (equal?-fn compare-fn)) + (or (position value (make-wb-seq tree nil) :test (equal?-fn compare-fn)) (error "Bug in `less' on `ch-replay-set'")))) hsorg)))) @@ -539,33 +554,34 @@ (defmethod less ((s ch-replay-set) value &optional (arg2 nil arg2?)) ;;; Replay maps ;;; We have some implementation-generic methods. - -(defun empty-replay-map (&optional default) - (declare (special *empty-ch-replay-map*)) - (if default (make-ch-replay-map nil nil (ch-map-org *empty-ch-map*) default) - *empty-ch-replay-map*)) - -(defmethod empty-instance-function ((class-name (eql 'replay-map))) - 'empty-replay-map) +;;; `empty-replay-map' is below. (defmethod convert ((to-type (eql 'replay-map)) (m replay-map) &key) m) -(defmethod convert ((to-type (eql 'list)) (m replay-map) &key (pair-fn #'cons)) - (let ((result nil)) - (do-wb-seq-tree-members (x (replay-map-ordering m)) - (let ((val val? (lookup m x))) - (unless val? - (error "Bug in replay-map")) - (push (funcall pair-fn x val) result))) - (nreverse result))) -(defmethod convert ((to-type (eql 'vector)) (m replay-map) &key (pair-fn #'cons)) - (convert 'vector (convert 'list m :pair-fn pair-fn))) - -(defmethod convert ((to-type (eql 'seq)) (m replay-map) &key (pair-fn #'cons)) - (convert 'seq (convert 'list m :pair-fn pair-fn))) -(defmethod convert ((to-type (eql 'wb-seq)) (m replay-map) &key (pair-fn #'cons)) - (convert 'wb-seq (convert 'list m :pair-fn pair-fn))) +(defmethod convert ((to-type (eql 'list)) (m replay-map) &key (pair-fn #'cons) keys-only?) + (if keys-only? + (convert 'list (make-wb-seq (replay-map-ordering m) nil)) + (let ((result nil)) + (do-wb-seq-tree-members (x (replay-map-ordering m)) + (let ((val val? (lookup m x))) + (unless val? + (error "Bug in replay-map")) + (push (funcall pair-fn x val) result))) + (nreverse result)))) + +(defmethod convert ((to-type (eql 'vector)) (m replay-map) &key (pair-fn #'cons) keys-only?) + (convert 'vector (convert 'list m :pair-fn pair-fn :keys-only? keys-only?))) + +(defmethod convert ((to-type (eql 'seq)) (m replay-map) &key (pair-fn #'cons) keys-only?) + (convert 'seq (convert 'list m :pair-fn pair-fn :keys-only? keys-only?))) +(defmethod convert ((to-type (eql 'fset2:seq)) (m replay-map) &key (pair-fn #'cons) keys-only?) + (convert 'fset2:seq (convert 'list m :pair-fn pair-fn :keys-only? keys-only?))) + +(defmethod convert ((to-type (eql 'wb-seq)) (m replay-map) &key (pair-fn #'cons) keys-only?) + (convert 'wb-seq (convert 'list m :pair-fn pair-fn :keys-only? keys-only?))) +(defmethod convert ((to-type (eql 'fset2:wb-seq)) (m replay-map) &key (pair-fn #'cons) keys-only?) + (convert 'fset2:wb-seq (convert 'list m :pair-fn pair-fn :keys-only? keys-only?))) (defmethod convert ((to-type (eql 'replay-map)) (list list) &key (key-fn #'car) (value-fn #'cdr) default) @@ -583,9 +599,6 @@ (defmethod convert ((to-type (eql 'replay-map)) (s sequence) (fn (x) (values (funcall key-fn x) (funcall value-fn x))) (:arg sequence s))) -(defmethod key-ordering ((m replay-map)) - (make-wb-seq (replay-map-ordering m))) - (defmethod iterator ((m replay-map) &key) (let ((iter (make-wb-seq-tree-iterator-internal (replay-map-ordering m)))) (lambda (op) @@ -613,7 +626,7 @@ (defmethod internal-do-map ((m replay-map) elt-fn value-fn) (defstruct (wb-replay-map (:include replay-map) - (:constructor make-wb-replay-map (contents ordering org &optional default)) + (:constructor make-wb-replay-map (contents ordering org default)) (:predicate wb-replay-map?) (:print-function print-wb-replay-map) (:copier nil)) @@ -626,14 +639,31 @@ (defstruct (wb-replay-map (contents nil :read-only t) (org nil :type tree-map-org :read-only t)) -(defparameter *empty-wb-replay-map* (make-wb-replay-map nil nil +fset-default-tree-map-org+)) +(defparameter +empty-wb-replay-map+ (make-wb-replay-map nil nil +fset-default-tree-map-org+ nil)) + +(defparameter +empty-wb-replay-map/no-default+ (make-wb-replay-map nil nil +fset-default-tree-map-org+ 'no-default)) +(declaim (inline empty-wb-replay-map fset2:empty-wb-replay-map)) (defun empty-wb-replay-map (&optional default key-compare-fn-name val-compare-fn-name) (if (and (null key-compare-fn-name) (null val-compare-fn-name)) (if (null default) - *empty-wb-replay-map* + +empty-wb-replay-map+ (make-wb-replay-map nil nil +fset-default-tree-map-org+ default)) (empty-wb-custom-replay-map default (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare)))) +(defun fset2:empty-wb-replay-map (&key (default nil default?) no-default? key-compare-fn-name val-compare-fn-name) + "Returns an empty wb-replay-map with the specified default and comparison +functions. The map's default is `nil' unless a different default is supplied, +or `no-default?' is true." + (empty-wb-replay-map-internal (fset2-default default? default no-default?) key-compare-fn-name val-compare-fn-name)) + +(defun empty-wb-replay-map-internal (default key-compare-fn-name val-compare-fn-name) + (cond ((or key-compare-fn-name val-compare-fn-name) + (empty-wb-custom-replay-map default (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare))) + ((null default) + +empty-wb-replay-map+) + ((eq default 'no-default) + +empty-wb-replay-map/no-default+) + (t (make-wb-replay-map nil nil +fset-default-tree-map-org+ default)))) (deflex +empty-wb-custom-replay-map-cache+ (make-hash-table :test 'equal)) @@ -645,7 +675,7 @@ (defstruct (wb-replay-map (symbol-package val-compare-fn-name)) () "val-compare-fn-name must be a nonnull interned symbol") (if (and (eq key-compare-fn-name 'compare) (eq val-compare-fn-name 'compare)) - (if (null default) *empty-wb-replay-map* + (if (null default) +empty-wb-replay-map+ (make-wb-replay-map nil nil +fset-default-tree-map-org+ default)) (let ((cache-key (list key-compare-fn-name val-compare-fn-name)) ((prev-instance (gethash cache-key +empty-wb-custom-replay-map-cache+))) @@ -662,12 +692,12 @@ (defstruct (wb-replay-map val-compare-fn-name val-compare-fn) default)))))) -(defmethod empty-instance-function ((class-name (eql 'wb-replay-map))) - 'empty-wb-replay-map) - (defmethod with-default ((m wb-replay-map) new-default) (make-wb-replay-map (wb-replay-map-contents m) (replay-map-ordering m) (wb-replay-map-org m) new-default)) +(defmethod fset2:without-default ((m wb-replay-map)) + (make-wb-replay-map (wb-replay-map-contents m) (replay-map-ordering m) (wb-replay-map-org m) 'no-default)) + (defmethod key-compare-fn ((m wb-replay-map)) (tree-map-org-key-compare-fn (wb-replay-map-org m))) @@ -714,10 +744,10 @@ (defmethod index ((m wb-replay-map) key) "WARNING: linear-time operation!" (let ((idx 0) (key-compare-fn (tree-map-org-key-compare-fn (wb-replay-map-org m)))) - (do-wb-map-tree-pairs (k v (wb-replay-map-contents m)) - (declare (ignore v)) + (do-wb-seq-tree-members (k (replay-map-ordering m)) (when (equal?-cmp k key key-compare-fn) - (return idx))))) + (return idx)) + (incf idx)))) (defmethod at-index ((m wb-replay-map) index) (let ((ordering (replay-map-ordering m)) @@ -735,12 +765,11 @@ (defmethod at-index ((m wb-replay-map) index) (defmethod size ((m wb-replay-map)) (WB-Map-Tree-Size (wb-replay-map-contents m))) -(defmethod convert ((to-type (eql 'replay-map)) (m replay-map) &key) +(defmethod convert ((to-type (eql 'fset2:replay-map)) (m replay-map) &key) m) -;;; Eventually, we may have `ch-replay-map'... -(defmethod convert ((to-type (eql 'wb-replay-map)) (m replay-map) - &key (default nil default?) key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-replay-map fset2:wb-replay-map) + ((m replay-map) &key (default nil default?) key-compare-fn-name val-compare-fn-name) "The result uses `default' if supplied, otherwise has the same default as `m'." (let ((prototype (empty-wb-map default key-compare-fn-name val-compare-fn-name)) ((proto-tmorg (wb-map-org prototype)) @@ -751,8 +780,8 @@ (defmethod convert ((to-type (eql 'wb-replay-map)) (m replay-map) (setq contents (WB-Map-Tree-With contents k v key-compare-fn val-compare-fn))) (make-wb-replay-map contents (replay-map-ordering m) proto-tmorg (if default? default (map-default m)))))) -(defmethod convert ((to-type (eql 'wb-replay-map)) (m wb-replay-map) - &key (default nil default?) key-compare-fn-name val-compare-fn-name) +(define-convert-methods (wb-replay-map fset2:wb-replay-map) + ((m wb-replay-map) &key (default nil default?) key-compare-fn-name val-compare-fn-name) "The result uses `default' if supplied, otherwise has the same default as `m'." (let ((prototype (empty-wb-map default key-compare-fn-name val-compare-fn-name)) ((proto-tmorg (wb-map-org prototype)) @@ -768,10 +797,11 @@ (defmethod convert ((to-type (eql 'wb-replay-map)) (m wb-replay-map) (setq contents (WB-Map-Tree-With contents k v key-compare-fn val-compare-fn))) (make-wb-replay-map contents (replay-map-ordering m) proto-tmorg (if default? default (map-default m))))))) -(defmethod convert ((to-type (eql 'map)) (m wb-replay-map) &key (default nil default?)) +(define-convert-methods (map fset2:map) ((m wb-replay-map) &key (default nil default?)) (make-wb-map (wb-replay-map-contents m) (wb-replay-map-org m) (if default? default (map-default m)))) -(defmethod convert ((to-type (eql 'wb-map)) (m wb-replay-map) - &key (default nil default?) key-compare-fn-name val-compare-fn-name) + +(define-convert-methods (wb-map fset2:wb-map) + ((m wb-replay-map) &key (default nil default?) key-compare-fn-name val-compare-fn-name) (convert 'wb-map (make-wb-map (wb-replay-map-contents m) (wb-replay-map-org m) (if default? default (map-default m))) :key-compare-fn-name key-compare-fn-name :val-compare-fn-name val-compare-fn-name)) @@ -808,6 +838,15 @@ (defmethod lookup ((m wb-replay-map) key) (let ((val? val (wb-map-tree-lookup (wb-replay-map-contents m) key (tree-map-org-key-compare-fn (wb-replay-map-org m))))) (values (if val? val (map-default m)) val?))) +(defmethod fset2:lookup ((m wb-replay-map) key) + (let ((val? val (wb-map-tree-lookup (wb-replay-map-contents m) key + (tree-map-org-key-compare-fn (wb-replay-map-org m))))) + (values (if val? val + (let ((dflt (map-default m))) + (if (eq dflt 'no-default) + (error 'fset2:map-domain-error :map m :key key) + dflt))) + val?))) (defmethod domain-contains? ((m wb-replay-map) x) (wb-map-tree-lookup (wb-replay-map-contents m) x (tree-map-org-key-compare-fn (wb-replay-map-org m)))) @@ -857,8 +896,8 @@ (defmethod with ((m wb-replay-map) key &optional (value nil value?)) (make-wb-replay-map new-contents (wb-seq-tree-append (replay-map-ordering m) key) tmorg (map-default m)))))) -;;; WARNING: linear-time operation! (defmethod less ((m wb-replay-map) key &optional (arg2 nil arg2?)) + "WARNING: linear-time operation!" (declare (ignore arg2)) (check-two-arguments arg2? 'less 'wb-replay-map) (let ((contents (wb-replay-map-contents m)) @@ -868,7 +907,7 @@ (defmethod less ((m wb-replay-map) key &optional (arg2 nil arg2?)) m (make-wb-replay-map new-contents (let ((tree (replay-map-ordering m))) - (wb-seq-tree-remove tree (or (position key (make-wb-seq tree)) + (wb-seq-tree-remove tree (or (position key (make-wb-seq tree nil)) (error "Bug in `less' on `wb-replay-map'")))) tmorg (map-default m))))) @@ -886,11 +925,12 @@ (defmethod domain ((m wb-replay-map)) ((key-cf-name (tree-map-org-key-compare-fn-name tmorg)) (val-cf-name (tree-map-org-val-compare-fn-name tmorg)) ((key-default? (eq key-cf-name 'compare)) - (val-default? (eq val-cf-name 'compare))))) - (format nil " |}~:[[~:[~S~;~*~]:~:[~S~;~*~]]~;~4*~]~@[/~S~]" + (val-default? (eq val-cf-name 'compare)))) + (dflt (map-default map))) + (format nil " |}~:[[~:[~S~;~*~]:~:[~S~;~*~]]~;~4*~]~:[/~S~;~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (map-default map)))) + (eq dflt 'no-default) dflt))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) @@ -905,7 +945,7 @@ (defmethod domain ((m wb-replay-map)) (defstruct (ch-replay-map (:include replay-map) - (:constructor make-ch-replay-map (contents ordering org &optional default)) + (:constructor make-ch-replay-map (contents ordering org default)) (:predicate ch-replay-map?) (:print-function print-ch-replay-map) (:copier nil)) @@ -914,18 +954,44 @@ (defstruct (ch-replay-map to a map. Note that in the current implementation, `less' on a replay map takes O(n) time. Also, two replay maps are equal only if they both contain the same pairs and have the same iteration order; if you just want to compare the contents, convert them to ordinary maps -first. Replay maps are printed as \"#{=| ... |}\"." +first. Replay maps are printed as \"##{=| ... |}\"." (contents nil :read-only t) (org nil :type hash-map-org :read-only t)) -(defparameter *empty-ch-replay-map* (make-ch-replay-map nil nil (ch-map-org *empty-ch-map*))) +(defparameter +empty-ch-replay-map+ (make-ch-replay-map nil nil +fset-default-hash-map-org+ nil)) + +(defparameter +empty-ch-replay-map/no-default+ (make-ch-replay-map nil nil +fset-default-hash-map-org+ 'no-default)) +;;; Moved here from above because forward-referencing `+empty-ch-replay-map+' ran afoul of +;;; https://bugs.launchpad.net/sbcl/+bug/2129827 . +(declaim (inline empty-replay-map fset2:empty-replay-map)) +(defun empty-replay-map (&optional default) + (if default (make-ch-replay-map nil nil +fset-default-hash-map-org+ default) + +empty-ch-replay-map+)) +(defun fset2:empty-replay-map (&key (default nil default?) no-default?) + (empty-ch-replay-map-internal (fset2-default default? default no-default?) nil nil)) + +(declaim (inline empty-ch-replay-map fset2:empty-ch-replay-map)) (defun empty-ch-replay-map (&optional default key-compare-fn-name val-compare-fn-name) (if (and (null key-compare-fn-name) (null val-compare-fn-name)) (if (null default) - *empty-ch-replay-map* - (make-ch-replay-map nil nil (ch-replay-map-org *empty-ch-replay-map*) default)) + +empty-ch-replay-map+ + (make-ch-replay-map nil nil +fset-default-hash-map-org+ default)) (empty-ch-custom-replay-map default (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare)))) +(defun fset2:empty-ch-replay-map (&key (default nil default?) no-default? key-compare-fn-name val-compare-fn-name) + "Returns an empty ch-replay-map with the specified default and comparison +functions. The map's default is `nil' unless a different default is supplied, +or `no-default?' is true." + (empty-ch-replay-map-internal (fset2-default default? default no-default?) key-compare-fn-name val-compare-fn-name)) + +(defun empty-ch-replay-map-internal (default key-compare-fn-name val-compare-fn-name) + (cond ((or key-compare-fn-name val-compare-fn-name) + (empty-ch-custom-replay-map default (or key-compare-fn-name 'compare) (or val-compare-fn-name 'compare))) + ((null default) + +empty-ch-replay-map+) + ((eq default 'no-default) + +empty-ch-replay-map/no-default+) + (t (make-ch-replay-map nil nil +fset-default-hash-map-org+ default)))) (deflex +empty-ch-custom-replay-map-cache+ (make-hash-table :test 'equal)) @@ -937,7 +1003,7 @@ (defstruct (ch-replay-map (symbol-package val-compare-fn-name)) () "val-compare-fn-name must be a nonnull interned symbol") (if (and (eq key-compare-fn-name 'compare) (eq val-compare-fn-name 'compare)) - (if (null default) *empty-ch-replay-map* + (if (null default) +empty-ch-replay-map+ (make-ch-replay-map nil nil +fset-default-tree-map-org+ default)) (let ((cache-key (list key-compare-fn-name val-compare-fn-name)) ((prev-instance (gethash cache-key +empty-ch-custom-replay-map-cache+))) @@ -952,7 +1018,7 @@ (defstruct (ch-replay-map (val-compare-fn (symbol-function val-compare-fn-name)) (val-hash-fn (symbol-function val-hash-fn-name)))) (if (and prev-instance - (let ((prev-org (ch-map-org prev-instance))) + (let ((prev-org (ch-replay-map-org prev-instance))) (and (eq key-compare-fn (hash-map-org-key-compare-fn prev-org)) (eq key-hash-fn (hash-map-org-key-hash-fn prev-org)) (eq val-compare-fn (hash-map-org-val-compare-fn prev-org)) @@ -964,12 +1030,12 @@ (defstruct (ch-replay-map val-compare-fn-name val-compare-fn val-hash-fn) default)))))) -(defmethod empty-instance-function ((class-name (eql 'ch-replay-map))) - 'empty-ch-replay-map) - (defmethod with-default ((m ch-replay-map) new-default) (make-ch-replay-map (ch-replay-map-contents m) (replay-map-ordering m) (ch-replay-map-org m) new-default)) +(defmethod fset2:without-default ((m ch-replay-map)) + (make-ch-replay-map (ch-replay-map-contents m) (replay-map-ordering m) (ch-replay-map-org m) 'no-default)) + (defmethod key-compare-fn ((m ch-replay-map)) (hash-map-org-key-compare-fn (ch-replay-map-org m))) @@ -1002,10 +1068,10 @@ (defmethod index ((m ch-replay-map) key) "WARNING: linear-time operation!" (let ((idx 0) (key-compare-fn (hash-map-org-key-compare-fn (ch-replay-map-org m)))) - (do-ch-map-tree-pairs (k v (ch-replay-map-contents m)) - (declare (ignore v)) + (do-wb-seq-tree-members (k (replay-map-ordering m)) (when (equal?-cmp k key key-compare-fn) - (return idx))))) + (return idx)) + (incf idx)))) (defmethod at-index ((m ch-replay-map) index) (let ((ordering (replay-map-ordering m)) @@ -1027,8 +1093,8 @@ (defmethod at-index ((m ch-replay-map) index) (defmethod size ((m ch-replay-map)) (ch-map-tree-size (ch-replay-map-contents m))) -(defmethod convert ((to-type (eql 'ch-replay-map)) (m replay-map) - &key (default nil default?) key-compare-fn-name val-compare-fn-name) +(define-convert-methods (ch-replay-map fset2:ch-replay-map) + ((m replay-map) &key (default nil default?) key-compare-fn-name val-compare-fn-name) ;; If this method is called, `m' is not a `ch-replay-map'. "The result uses `default' if supplied, otherwise has the same default as `m'." (let ((cm (convert 'ch-map (convert 'map m) @@ -1036,8 +1102,8 @@ (defmethod convert ((to-type (eql 'ch-replay-map)) (m replay-map) (make-ch-replay-map (ch-map-contents cm) (replay-map-ordering m) (ch-map-org cm) (if default? default (map-default m))))) -(defmethod convert ((to-type (eql 'ch-replay-map)) (m ch-replay-map) - &key (default nil default?) key-compare-fn-name val-compare-fn-name) +(define-convert-methods (ch-replay-map fset2:ch-replay-map) + ((m ch-replay-map) &key (default nil default?) key-compare-fn-name val-compare-fn-name) "The result uses `default' if supplied, otherwise has the same default as `m'." (let ((tm (convert 'map m)) ((cm (convert 'ch-map tm @@ -1046,10 +1112,11 @@ (defmethod convert ((to-type (eql 'ch-replay-map)) (m ch-replay-map) (make-ch-replay-map (ch-map-contents cm) (replay-map-ordering m) (ch-map-org cm) (if default? default (map-default m)))))) -(defmethod convert ((to-type (eql 'map)) (m ch-replay-map) &key (default nil default?)) +(define-convert-methods (map fset2:map) ((m ch-replay-map) &key (default nil default?)) (make-ch-map (ch-replay-map-contents m) (ch-replay-map-org m) (if default? default (map-default m)))) -(defmethod convert ((to-type (eql 'ch-map)) (m ch-replay-map) - &key (default nil default?) key-compare-fn-name val-compare-fn-name) + +(define-convert-methods (ch-map fset2:ch-map) + ((m ch-replay-map) &key (default nil default?) key-compare-fn-name val-compare-fn-name) (convert 'ch-map (make-ch-map (ch-replay-map-contents m) (ch-replay-map-org m) (if default? default (map-default m))) :key-compare-fn-name key-compare-fn-name :val-compare-fn-name val-compare-fn-name)) @@ -1067,6 +1134,8 @@ (defmethod convert ((to-type (eql 'vector)) (m ch-replay-map) &key (pair-fn #'co (convert 'vector (convert 'list m :pair-fn pair-fn))) (defmethod convert ((to-type (eql 'seq)) (m ch-replay-map) &key (pair-fn #'cons)) (convert 'seq (convert 'list m :pair-fn pair-fn))) +(defmethod convert ((to-type (eql 'fset2:seq)) (m ch-replay-map) &key (pair-fn #'cons)) + (convert 'fset2:seq (convert 'list m :pair-fn pair-fn))) (defmethod convert ((to-type (eql 'ch-replay-map)) (list list) &key (key-fn #'car) (value-fn #'cdr) default key-compare-fn-name val-compare-fn-name) @@ -1094,6 +1163,16 @@ (defmethod lookup ((m ch-replay-map) key) ((val? val (ch-map-tree-lookup (ch-replay-map-contents m) key (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg))))) (values (if val? val (map-default m)) val?))) +(defmethod fset2:lookup ((m ch-replay-map) key) + (let ((hmorg (ch-replay-map-org m)) + ((val? val (ch-map-tree-lookup (ch-replay-map-contents m) key + (hash-map-org-key-hash-fn hmorg) (hash-map-org-key-compare-fn hmorg))))) + (values (if val? val + (let ((dflt (map-default m))) + (if (eq dflt 'no-default) + (error 'fset2:map-domain-error :map m :key key) + dflt))) + val?))) (defmethod domain-contains? ((m ch-replay-map) x) (let ((hmorg (ch-replay-map-org m))) @@ -1152,8 +1231,8 @@ (defmethod with ((m ch-replay-map) key &optional (value nil value?)) (make-ch-replay-map new-contents (wb-seq-tree-append (replay-map-ordering m) key) hmorg (map-default m)))))) -;;; WARNING: linear-time operation! (defmethod less ((m ch-replay-map) key &optional (arg2 nil arg2?)) + "WARNING: linear-time operation!" (declare (ignore arg2)) (check-two-arguments arg2? 'less 'ch-replay-map) (let ((contents (ch-replay-map-contents m)) @@ -1165,7 +1244,7 @@ (defmethod less ((m ch-replay-map) key &optional (arg2 nil arg2?)) m (make-ch-replay-map new-contents (let ((tree (replay-map-ordering m))) - (wb-seq-tree-remove tree (or (position key (make-wb-seq tree)) + (wb-seq-tree-remove tree (or (position key (make-wb-seq tree nil)) (error "Bug in `less' on `ch-replay-map'")))) hmorg (map-default m))))) @@ -1183,11 +1262,12 @@ (defmethod domain ((m ch-replay-map)) ((key-cf-name (hash-map-org-key-compare-fn-name hmorg)) (val-cf-name (hash-map-org-val-compare-fn-name hmorg)) ((key-default? (eq key-cf-name 'compare)) - (val-default? (eq val-cf-name 'compare))))) - (format nil " |}~:[[~:[~S~;~*~]:~:[~S~;~*~]]~;~4*~]~@[/~S~]" + (val-default? (eq val-cf-name 'compare)))) + (dflt (map-default map))) + (format nil " |}~:[[~:[~S~;~*~]:~:[~S~;~*~]]~;~4*~]~:[/~S~;~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (map-default map)))) + (eq dflt 'no-default) dflt))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) diff --git a/Code/swank.lisp b/Code/swank.lisp index badf506411884f9c0d384d30da97b97eedd45eed..f006939dd251955ed6a0b81e0a3bba3fdb229b2c 100644 --- a/Code/swank.lisp +++ b/Code/swank.lisp @@ -29,7 +29,7 @@ (defmethod swank::emacs-inspect ((s set)) (append (emacs-inspect-partial s 0 (size s)) (emacs-inspect-footer s) (and *emacs-inspect-internals* - (cons '(:newline) (call-next-method))))) + (list* '(:newline) '(:newline) (call-next-method))))) (defmethod emacs-inspect-partial ((s set) lo hi) (append (if (<= hi (+ lo 32)) @@ -172,10 +172,12 @@ (defmethod emacs-inspect-partial ((b bag) lo hi) '(:newline)))))))) (defmethod emacs-inspect-footer append ((b bag)) - (let ((cmp-fn-name (compare-fn-name b))) - (and (not (eq cmp-fn-name 'compare)) - (cons '(:newline) - (swank::label-value-line "compare-fn" cmp-fn-name))))) + (append (let ((cmp-fn-name (compare-fn-name b))) + (and (not (eq cmp-fn-name 'compare)) + (cons '(:newline) + (swank::label-value-line "compare-fn" cmp-fn-name)))) + (list '(:newline) '(:newline) + `(:value ,(wb-bag-contents b) "[Show internal tree]")))) (defmethod swank::emacs-inspect ((tup tuple)) (append (emacs-inspect-partial tup 0 (size tup)) @@ -201,7 +203,8 @@ (defmethod emacs-inspect-partial ((tup tuple) lo hi) '(:newline))))))) (defmethod swank::emacs-inspect ((br 2-relation)) - (append (emacs-inspect-partial (convert 'map-to-sets br) 0 (size br)) + (append (let ((mts (convert 'map-to-sets br))) + (emacs-inspect-partial mts 0 (size mts))) (emacs-inspect-footer br) (and *emacs-inspect-internals* (cons '(:newline) (call-next-method))))) diff --git a/Code/testing.lisp b/Code/testing.lisp index a80b419b1a8204bab436a5187bcd9fec87931456..760a999aca45754ccbaefb8b9bff68672b2d967b 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -15,7 +15,7 @@ (defstruct (My-Integer Value) (def-tuple-key +K0+) -(def-tuple-key +K1+) +(def-tuple-key +K1+ (fn (tup) (@ tup +K0+))) (def-tuple-key +K2+) (def-tuple-key +K3+) (def-tuple-key +K4+) @@ -60,6 +60,14 @@ (defmethod sb-sequence:make-sequence-like ((obj my-sequence) len &rest args) (define-hash-function erapmoc hash-value-negated) +(defun int-compare (a b) + (declare (fixnum a b)) + (cond ((< a b) ':less) + ((> a b) ':greater) + (t ':equal))) + +(define-hash-function int-compare hash-value) + ;;; utility functions used in tests (defun add-to-front (list &rest vals) @@ -69,6 +77,7 @@ (define-hash-function erapmoc hash-value-negated) ;; `Test-Misc' was huge and wouldn't compile in ABCL (JVM function size limitations), ;; so I broke it up. (format t "Testing FSet...") + (Test-GMap) (Test-Misc-0) (Test-Misc-1) (Test-Misc-2) @@ -83,6 +92,7 @@ (define-hash-function erapmoc hash-value-negated) (Test-Complement-Sets) (Test-2-Relations) (Test-List-Relations) + (Test-FSet2) (let ((*random-state* (make-random-state random-seed))) ; for repeatability. (dotimes (i n-iterations) (when (zerop (mod i 10)) @@ -96,6 +106,176 @@ (define-hash-function erapmoc hash-value-negated) (format t "passed~%")) +(defun Test-GMap () + (macrolet ((test (form) + `(unless ,form + (error "Test failed: ~S" ',form)))) + (test (equal? (gmap (:result list) nil (:arg fun-sequence (list 3 'foo 42))) + '(3 foo 42))) + (test (equal? (gmap (:result list) nil (:arg fun-sequence (list 3 'foo 42) :from-end? t)) + '(42 foo 3))) + (test (equal? (gmap (:result list) nil (:arg fun-sequence (vector 3 'foo 42))) + '(3 foo 42))) + (test (equal? (gmap (:result list) nil (:arg fun-sequence (vector 3 'foo 42) :from-end? t)) + '(42 foo 3))) + (test (equal? (gmap (:result list) nil (:arg fun-sequence "3Q7")) + '(#\3 #\Q #\7))) + (test (equal? (gmap (:result list) nil (:arg fun-sequence "3Q7" :from-end? t)) + '(#\7 #\Q #\3))) + + (test (equal? (gmap (:result list) nil (:arg set (wb-set 13 7 41 2))) + '(2 7 13 41))) + (test (equal? (sort (gmap (:result list) nil (:arg set (ch-set 13 7 41 2))) #'<) + '(2 7 13 41))) + (test (equal? (gmap (:result list) nil (:arg wb-set (wb-set 13 7 41 2))) + '(2 7 13 41))) + (test (equal? (sort (gmap (:result list) nil (:arg ch-set (ch-set 13 7 41 2))) #'<) + '(2 7 13 41))) + (test (equal? (gmap (:result set) nil (:arg list '(8 3 14 6))) + (wb-set 8 3 14 6))) + (test (equal? (gmap (:result wb-set :compare-fn-name 'erapmoc) nil (:arg list '(8 3 14 6))) + (wb-custom-set 'erapmoc 8 3 14 6))) + (test (equal? (gmap (:result ch-set :compare-fn-name 'erapmoc) nil (:arg list '(8 3 14 6))) + (ch-custom-set 'erapmoc 8 3 14 6))) + (test (equal? (gmap (:result union) nil (:arg list (list (set 3 7) (set 9 1)))) + (wb-set 1 3 7 9))) + (test (equal? (gmap (:result intersection) nil (:arg list (list (set 3 7 9) (set 9 3)))) + (wb-set 3 9))) + + (test (equal? (gmap (:result list) nil (:arg bag (bag 3 7 (% 9 2)))) + '(3 7 9 9))) + (test (equal? (gmap (:result list) nil (:arg wb-bag (bag 3 7 (% 9 2)))) + '(3 7 9 9))) + (test (equal? (gmap (:result list) #'cons (:arg bag-pairs (bag 3 7 (% 9 2)))) + '((3 . 1) (7 . 1) (9 . 2)))) + (test (equal? (gmap (:result list) #'cons (:arg wb-bag-pairs (bag 3 7 (% 9 2)))) + '((3 . 1) (7 . 1) (9 . 2)))) + (test (equal? (gmap (:result list) #'cons (:arg fun-bag-pairs (bag 3 7 (% 9 2)))) + '((3 . 1) (7 . 1) (9 . 2)))) + (test (equal? (gmap (:result bag) nil (:arg list '(3 7 9 2 7 3))) + (wb-bag 2 (% 3 2) (% 7 2) 9))) + (test (equal? (gmap (:result bag-pairs) (fn (x) (values (car x) (cdr x))) + (:arg list '((a . 2) (b . 6) (q . 4)))) + (wb-bag (% 'a 2) (% 'b 6) (% 'q 4)))) + (test (equal? (gmap (:result wb-bag :compare-fn-name 'erapmoc) nil (:arg list '(3 7 9 2 7 3))) + (wb-custom-bag 'erapmoc 2 (% 3 2) (% 7 2) 9))) + (test (equal? (gmap (:result wb-bag-pairs :compare-fn-name 'erapmoc) (fn (x) (values (car x) (cdr x))) + (:arg list '((a . 2) (b . 6) (q . 4)))) + (wb-custom-bag 'erapmoc (% 'a 2) (% 'b 6) (% 'q 4)))) + (test (equal? (gmap (:result bag-sum) nil (:arg list (list (bag 2 2 3 3 3 4) (bag 1 2 4)))) + (bag 1 (% 2 3) (% 3 3) (% 4 2)))) + (test (equal? (gmap (:result bag-product) nil (:arg list (list (bag 2 2 3 3 3 4) (bag 1 2 2 4)))) + (bag (% 2 4) 4))) + + (test (equal? (gmap (:result list) #'cons (:arg map (map ('a 3) ('b 7) ('c 6)))) + '((a . 3) (b . 7) (c . 6)))) + (test (equal? (gmap (:result list) #'cons (:arg fun-map (map ('a 3) ('b 7) ('c 6)))) + '((a . 3) (b . 7) (c . 6)))) + (test (equal? (gmap (:result list) #'cons (:arg wb-map (map ('a 3) ('b 7) ('c 6)))) + '((a . 3) (b . 7) (c . 6)))) + (test (equal? (sort (gmap (:result list) #'cons (:arg ch-map (ch-map ('a 3) ('b 7) ('c 6)))) + #'string< :key #'car) + '((a . 3) (b . 7) (c . 6)))) + (test (equal? (gmap (:result map) #'values (:arg list '(foo bar baz)) (:arg list '(12 17 91))) + (wb-map ('foo 12) ('bar 17) ('baz 91)))) + (test (equal? (gmap (:result wb-map) #'values (:arg list '(foo bar baz)) (:arg list '(12 17 91))) + (wb-map ('foo 12) ('bar 17) ('baz 91)))) + (test (equal? (gmap (:result ch-map) #'values (:arg list '(foo bar baz)) (:arg list '(12 17 91))) + (ch-map ('foo 12) ('bar 17) ('baz 91)))) + (test (equal? (gmap (:result map-union) nil (:arg list (list (map ('a 7) ('b 4)) (map ('c 8) ('a 11))))) + (wb-map ('a 11) ('b 4) ('c 8)))) + (test (equal? (gmap (:result map-intersection) nil (:arg list (list (map ('a 7) ('b 4)) (map ('c 8) ('a 11))))) + (wb-map ('a 11)))) + (test (equal? (gmap (:result map-to-sets) #'values + (:arg list '(a b a c a b)) + (:arg list '(0 1 2 3 4 5))) + (wb-map ('a (wb-set 0 2 4)) ('b (wb-set 1 5)) ('c (wb-set 3)) :default (wb-set)))) + + (test (equal? (gmap (:result list) nil (:arg seq (seq 3 'foo 99))) + '(3 foo 99))) + (test (equal? (gmap (:result list) nil (:arg seq (seq 3 'foo 99 42 "hello" 'fizzbuzz) + :start 1 :end 5)) + '(foo 99 42 "hello"))) + (test (equal? (gmap (:result list) nil (:arg seq (seq 3 'foo 99) :from-end? t)) + '(99 foo 3))) + (test (equal? (gmap (:result list) nil (:arg seq (seq 3 'foo 99 42 "hello" 'fizzbuzz) + :start 1 :end 5 :from-end? t)) + '("hello" 42 99 foo))) + (test (equal? (gmap (:result list) nil (:arg wb-seq (seq 3 'foo 99))) + '(3 foo 99))) + (test (equal? (gmap (:result list) nil (:arg wb-seq (seq 3 'foo 99 42 "hello" 'fizzbuzz) + :start 1 :end 5)) + '(foo 99 42 "hello"))) + ;; Heh -- had to find something that wasn't `t' yet would still be guaranteed true. + (test (equal? (gmap (:result list) nil (:arg wb-seq (seq 3 'foo 99) :from-end? (> (get-universal-time) 1000000))) + '(99 foo 3))) + (test (equal? (gmap (:result list) nil (:arg wb-seq (seq 3 'foo 99 42 "hello" 'fizzbuzz) + :start 1 :end 5 :from-end? (> (get-universal-time) 1000000))) + '("hello" 42 99 foo))) + (test (equal? (gmap (:result seq :filterp #'integerp) nil (:arg list '(3 'bar 99))) + (seq 3 99))) + (test (equal? (gmap (:result concat) nil (:arg list (list (seq 'now 'is) (seq 'the 'time)))) + (seq 'now 'is 'the 'time))) + + (test (equal? (gmap (:result list) #'cons (:arg tuple (tuple (+k0+ 47) (+k2+ 32) (+k3+ 17)))) + `((,+k0+ . 47) (,+k2+ . 32) (,+k3+ . 17)))) + (test (equal? (gmap (:result tuple) #'values (:arg map (map (+k0+ 31) (+k1+ 91) (+k4+ 23)))) + (tuple (+k0+ 31) (+k1+ 91) (+k4+ 23)))) + + (test (equal? (gmap (:result list) #'cons (:arg 2-relation (wb-2-relation (1 7) (4 13) (2 9) (1 4) (2 3)))) + '((1 . 4) (1 . 7) (2 . 3) (2 . 9) (4 . 13)))) + (test (equal? (sort (gmap (:result list) #'cons (:arg 2-relation (ch-2-relation (1 7) (4 13) (2 9) (1 4) (2 3)))) + (fn (a b) (or (< (car a) (car b)) (and (= (car a) (car b)) (< (cdr a) (cdr b)))))) + '((1 . 4) (1 . 7) (2 . 3) (2 . 9) (4 . 13)))) + (test (equal? (gmap (:result wb-2-relation) #'values (:arg list '(a b a c a b)) (:arg index 0)) + (wb-2-relation ('a 0) ('a 2) ('a 4) ('b 1) ('b 5) ('c 3)))) + (test (equal? (gmap (:result ch-2-relation) #'values (:arg list '(a b a c a b)) (:arg index 0)) + (ch-2-relation ('a 0) ('a 2) ('a 4) ('b 1) ('b 5) ('c 3)))) + (test (equal? (gmap (:result list) nil (:arg list-relation + ;; No constructor macro yet. + (let ((rel (empty-wb-list-relation))) + (includef rel '(suzy age 9)) + (includef rel '(will age 7)) + rel))) + '((suzy age 9) (will age 7)))) + (test (equal? (gmap (:result list) nil (:arg wb-list-relation + ;; No constructor macro yet. + (let ((rel (empty-wb-list-relation))) + (includef rel '(suzy age 9)) + (includef rel '(will age 7)) + rel))) + '((suzy age 9) (will age 7)))) + (test (equal? (sort (gmap (:result list) nil (:arg ch-list-relation + ;; No constructor macro yet. + (let ((rel (empty-ch-list-relation))) + (includef rel '(suzy age 9)) + (includef rel '(will age 7)) + rel))) + #'string< :key #'car) + '((suzy age 9) (will age 7)))) + + (test (equal? (gmap (:result list) nil (:arg replay-set (wb-replay-set 3 17 6 12 4))) + '(3 17 6 12 4))) + (test (equal? (gmap (:result list) nil (:arg replay-set (ch-replay-set 3 17 6 12 4))) + '(3 17 6 12 4))) + (test (equal? (gmap (:result replay-set) nil (:arg list (list 3 17 6 12 4))) + (ch-replay-set 3 17 6 12 4))) + (test (equal? (gmap (:result wb-replay-set) nil (:arg list (list 3 17 6 12 4))) + (wb-replay-set 3 17 6 12 4))) + (test (equal? (gmap (:result ch-replay-set) nil (:arg list (list 3 17 6 12 4))) + (ch-replay-set 3 17 6 12 4))) + (test (equal? (gmap (:result append-unique) nil (:arg list (list (list 3 7 2) (list 7 4 1) (list 2 1 8)))) + '(3 7 2 4 1 8))) + + (test (equal? (gmap (:result list) #'list (:arg replay-map (replay-map ('c 31) ('b 29) ('d 37) ('a 13)))) + '((c 31) (b 29) (d 37) (a 13)))) + (test (equal? (gmap (:result replay-map) #'values (:arg list '(a c a b a c)) (:arg list '(19 23 47 11 37 43))) + (ch-replay-map ('a 37) ('c 43) ('b 11)))) + (test (equal? (gmap (:result wb-replay-map) #'values (:arg list '(a c a b a c)) (:arg list '(19 23 47 11 37 43))) + (wb-replay-map ('a 37) ('c 43) ('b 11)))) + (test (equal? (gmap (:result ch-replay-map) #'values (:arg list '(a c a b a c)) (:arg list '(19 23 47 11 37 43))) + (ch-replay-map ('a 37) ('c 43) ('b 11)))))) + (defun Test-Misc-0 () "Tests some things that don't need extensive random test cases generated." (macrolet ((test (form) @@ -105,8 +285,11 @@ (define-hash-function erapmoc hash-value-negated) (and (equal? a b) (equal? b a))) (less-than? (a b) - (and (less-than? a b) - (greater-than? b a))) + (and (less-than?-cmp a b #'compare) + (greater-than?-cmp b a #'compare))) + (greater-than? (a b) + (and (greater-than?-cmp a b #'compare) + (less-than?-cmp b a #'compare))) (unequal? (a b) (let ((ab (eq (compare a b) ':unequal)) (ba (eq (compare b a) ':unequal))) @@ -153,6 +336,7 @@ (define-hash-function erapmoc hash-value-negated) (test (not (unequal? x x)))) (test (equal? #(1 2) #(1 2))) (test (less-than? #(1) #(1 2))) + (test (less-than? #2A((0 1) (1 2)) #2A((0 1) (1 3)))) (test (equal? #(1 2) (make-array '(2) :initial-contents '(1 2) :adjustable t))) (test (equal? (make-array '(2) :initial-contents '(1 2) @@ -204,6 +388,11 @@ (define-hash-function erapmoc hash-value-negated) (test (less-than? #*110101001101 #*111001001101)) (test (greater-than? #*111001001101 #*110101001101)) + (test (equal? (with-first '(a b) 'x) '(x a b))) + (test (equal? (less-first '(a b)) '(b))) + (test (equal? (with-last '(a b) 'x) '(a b x))) + (test (equal? (less-last '(a b)) '(a))) + ;; Test subtle code in compare on renamed packages (let ((name1 "FSET-TESTING-PACKAGE-1") (name2 "FSET-TESTING-PACKAGE-2")) @@ -232,12 +421,18 @@ (define-hash-function erapmoc hash-value-negated) (test (less-than? (set 1 2) (set 1 2 0))) (test (unequal? (set 'a 3 'c) (set 'a 3.0 'c))) (test (less-than? (set 'a 3 'c) (set 'a 3.0 'd))) + (test (less-than? (wb-set 8 12) (wb-custom-set 'erapmoc 0 2))) ; because "compare" < "erapmoc" + (test (less-than? (ch-set 8 12) (ch-custom-set 'erapmoc 0 2))) + (test (less-than? (ch-set 8 12) (wb-custom-set 'erapmoc 0 2))) ; because "ch-..." < "wb-..." + (test (less-than? (ch-custom-set 'erapmoc 0 2) (wb-set 8 12))) (test (less-than? (set 1) (bag 1))) (test (equal (convert 'list (eval '(bag 1 ($ (bag 3 3)) (% "x" 3) 4 ($ (bag (% 7 2) 8 1))))) '(1 1 3 3 4 7 7 8 "x" "x" "x"))) (test (equal (convert 'list (bag 1 2 1)) '(1 1 2))) + (test (less-than? (bag 0 0 1 1 2) (wb-custom-bag 'erapmoc 0 1 1 1 2))) + (test (less-than? (bag 1) (map ('x 1)))) (test (equal (convert 'list (eval '(map ($ (map ('x 0) ('y 3) ('z 4))) ('x 1) @@ -248,6 +443,11 @@ (define-hash-function erapmoc hash-value-negated) (test (less-than? (map ('x 1)) (map ('x 2)))) (test (unequal? (map ('x 1) ('y 2)) (map ('x 1.0) ('y 2)))) (test (less-than? (map ('x 1)) (seq "x"))) + (test (less-than? (map ('c 43) ('d 17)) (map ('c 44) ('d 17)))) + (test (less-than? (map ('c 43) ('d 17)) (map ('c 43) ('e 17)))) + (test (less-than? (map ('c 43) ('d 17)) (wb-custom-map 'erapmoc nil ('c 43) ('d 17)))) + (test (less-than? (ch-map ('c 43) ('d 17)) (ch-map ('c 44) ('d 17)))) + (test (less-than? (ch-map ('c 43) ('d 17)) (ch-custom-map 'erapmoc nil ('c 43) ('d 17)))) (test (equal (convert 'list (eval '(seq 1 ($ (seq 8 'x 7)) 2 4 ($ (seq 'z 3))))) '(1 8 x 7 2 4 z 3))) (test (equal (convert 'list (seq 1 'x "u")) '(1 x "u"))) @@ -337,6 +537,8 @@ (define-hash-function erapmoc hash-value-negated) (test (subset? (set 1) (set 1 2))) (test (subset? (set 2) (set 1 2))) (test (not (subset? (set 2) (set 1 3)))) + (test (subset? (set 1) (ch-set 1 2))) + (test (not (subset? (set 1 3) (ch-set 1 2)))) (test (not (lookup (set 1 7 10) 8))) (test (equal? (split #'evenp (set 1 2)) (set 2))) @@ -349,17 +551,29 @@ (define-hash-function erapmoc hash-value-negated) (test (equal? (image #'1+ '(1 2 3)) '(2 3 4))) (test (equal? (image '1+ '(1 2 3)) '(2 3 4))) (test (equal? (image (set 1 3) '(1 2 3 4)) '(t nil t nil))) + (test (equal? (fset2:image (set 1 3) '(1 2 3 4)) '(t nil t nil))) + (test (equal? (image (set 1 3) #(1 2 3 4)) #(t nil t nil))) + (test (equal? (fset2:image (set 1 3) #(1 2 3 4)) #(t nil t nil))) (test (equal? (image '1+ (set 0 4 7)) (set 1 5 8))) (test (equal? (image #'1+ (set 9 3 17)) (set 4 10 18))) (test (equal? (image (map (1 4) (2 8) (3 10) :default 0) (set 1 2 7)) (set 0 4 8))) + (test (equal? (image '1+ (ch-set 0 4 7)) (ch-set 1 5 8))) + (test (equal? (image #'1+ (ch-set 9 3 17)) (ch-set 4 10 18))) + (test (equal? (image (map (1 4) (2 8) (3 10) :default 0) (ch-set 1 2 7)) + (ch-set 0 4 8))) (test (equal? (image (map (1 2) (3 4)) '(1 2 3)) '(2 nil 4))) + (test (equal? (fset2:image (map (1 2) (3 4)) '(1 2 3)) '(2 nil 4))) + (test (equal? (image (map (1 2) (3 4)) #(1 2 3)) #(2 nil 4))) + (test (equal? (fset2:image (map (1 2) (3 4)) #(1 2 3)) #(2 nil 4))) (test (equal? (image (set 1) (set 1)) (set t))) (test (equal? (image (set 1) (set 2)) (set nil))) (test (equal? (image (set 1) (set 1 2)) (set nil t))) + (test (equal? (image (set 1) (ch-set 1 2)) (ch-set nil t))) (test (equal? (image (bag 1) (set 1)) (set t))) (test (equal? (image (bag 1) (set 2)) (set nil))) (test (equal? (image (bag 1 1 2) (set 1 2 3)) (set nil t))) + (test (equal? (image (bag 1 1 2) (ch-set 1 2 3)) (ch-set nil t))) (test (equal? (reduce #'+ (set 1 2 3) :initial-value 0) 6)) (test (equal? (reduce #'+ (set 1 2 3) :initial-value 1 :key '1+) 10)) @@ -548,6 +762,22 @@ (define-hash-function erapmoc hash-value-negated) (test (not (subbag? (bag 1 2) (set 1)))) (test (subbag? (bag 1 4 8 10) (set 0 1 2 3 4 5 6 7 8 9 10 11))) (test (not (subbag? (bag 1 4 8 8 10) (set 0 1 2 3 4 5 6 7 8 9 10 11)))) + (test (subbag? (bag 1 3 3) (wb-custom-bag 'erapmoc 1 1 3 3 7 12))) + + (test (disjoint? (set 1 3 5) (set 0 2 4 6))) + (test (disjoint? (set 1 3 5) (wb-custom-set 'erapmoc 0 2 4 6))) + (test (disjoint? (ch-set 1 3 5) (ch-set 0 2 4 6))) + (test (not (disjoint? (set 1 3 5) (set 0 2 3 4 6)))) + (test (not (disjoint? (set 1 3 5) (wb-custom-set 'erapmoc 0 2 3 4 6)))) + (test (not (disjoint? (ch-set 1 3 5) (ch-set 0 2 3 4 6)))) + (test (disjoint? (set 1 3 5) (bag 0 2 4 6))) + (test (disjoint? (ch-set 1 3 5) (bag 0 2 4 6))) + (test (not (disjoint? (set 1 3 5) (bag 0 2 3 4 6)))) + (test (not (disjoint? (ch-set 1 3 5) (bag 0 2 3 4 6)))) + (test (disjoint? (bag 0 2 4 6) (set 1 3 5))) + (test (disjoint? (bag 0 2 4 6) (ch-set 1 3 5))) + (test (not (disjoint? (bag 0 2 3 4 6) (set 1 3 5)))) + (test (not (disjoint? (bag 0 2 3 4 6) (ch-set 1 3 5)))) (test (equal? (filter #'evenp (bag)) (bag))) (test (equal? (filter #'evenp (bag 1)) (bag))) @@ -606,8 +836,9 @@ (define-hash-function erapmoc hash-value-negated) (test (equal? (convert 'wb-bag (bag 0 1 1 2 3 3 4)) (wb-bag 0 1 1 2 3 3 4))) (test (equal? (convert 'set (bag 0 1 1 2 3 3 4)) (set 0 1 2 3 4))) (test (equal? (convert 'wb-set (bag 0 1 1 2 3 3 4)) (wb-set 0 1 2 3 4))) - (test (equal (convert 'list (bag 0 1 1 2 3 3 4)) '(0 1 1 2 3 3 4))) - (test (equal (convert 'list (bag 0 1 1 2 3 3 4) :pairs? t) + (test (equal? (convert 'list (bag 0 1 1 2 3 3 4)) '(0 1 1 2 3 3 4))) + (test (equal? (convert 'seq (bag 0 1 1 2 3 3 4)) (seq 0 1 1 2 3 3 4))) + (test (equal? (convert 'list (bag 0 1 1 2 3 3 4) :pairs? t) '((0 . 1) (1 . 2) (2 . 1) (3 . 2) (4 . 1)))) (test (equal? (convert 'seq (bag 0 1 1 2 3 3 4) :pairs? t) (seq '(0 . 1) '(1 . 2) '(2 . 1) '(3 . 2) '(4 . 1)))) @@ -627,6 +858,12 @@ (define-hash-function erapmoc hash-value-negated) (test (equal? (convert 'wb-bag '((1 . 2) (2 . 3)) :from-type 'alist) (bag 1 1 2 2 2))) + (test (equal? (convert 'seq #(foo 17 bar 42 baz)) + (seq 'foo 17 'bar 42 'baz))) + (test (equal? (convert 'seq '(foo 17 bar 42 baz)) + (seq 'foo 17 'bar 42 'baz))) + (test (equal? (convert 'seq '(foo 17 bar 42 baz) :reverse? t) + (seq 'baz 42 'bar 17 'foo))) (test (equal (find 0 (bag)) nil)) (test (equal (find 1 (bag 1)) 1)) @@ -685,7 +922,10 @@ (define-hash-function erapmoc hash-value-negated) (test (equal (count-if #'evenp (bag 1 2 3) :key '1+) 2)) (test (equal (count-if-not #'evenp (bag 1 2 2 3 4)) 2)) - (test (equal (count-if-not #'evenp (bag 1 2 2 3 4) :key #'1+) 3))))) + (test (equal (count-if-not #'evenp (bag 1 2 2 3 4) :key #'1+) 3)) + + (test (less-than? (wb-2-relation (1 1) (1 2)) (wb-custom-2-relation 'erapmoc 'erapmoc (1 1) (1 2)))) + (test (less-than? (ch-2-relation (1 1) (1 2)) (ch-custom-2-relation 'erapmoc 'erapmoc (1 1) (1 2))))))) (defun Test-Misc-1 () "Tests some things that don't need extensive random test cases generated." @@ -772,6 +1012,7 @@ (define-hash-function erapmoc hash-value-negated) (simple-program-error (e) e))) (test (equal? (range (map (1 3) (2 12))) (set 3 12))) + (test (equal? (range (ch-map (1 3) (2 12))) (ch-set 3 12))) (test (eql (range-contains? (map (4 8) (3 12) (6 7)) 7) t)) (test (not (range-contains? (map (4 8) (3 12) (6 7)) 4))) @@ -782,6 +1023,13 @@ (define-hash-function erapmoc hash-value-negated) (test (not (contains? (map (1 2)) 2 2))) (test (handler-case (progn (contains? (map (1 2)) 1) nil) (simple-program-error () t))) + (test (contains? (ch-map (1 2)) 1 2)) + (test (not (contains? (ch-map (1 2)) 1 3))) + (test (contains? (ch-map (1 nil)) 1 nil)) + (test (not (contains? (ch-map (2 3)) 1 nil))) + (test (not (contains? (ch-map (1 2)) 2 2))) + (test (handler-case (progn (contains? (ch-map (1 2)) 1) nil) + (simple-program-error () t))) (test (equal? (compose (map (1 2)) (map (2 3))) (map (1 3)))) @@ -809,12 +1057,19 @@ (define-hash-function erapmoc hash-value-negated) (map (2 nil) :default 5))) nil)) + (test (equal? (image (compose #'1+ (map (2 5) (3 7) (4 11) (5 13))) + (seq 1 3 4)) + (seq 5 11 13))) + (test (equal? (image (compose #'1+ (seq 2 3 5 7 11 13)) + (seq 1 3 4)) + (seq 5 11 13))) + (test (equal? (convert 'map (map (1 2) (4 8) :default 0)) (map (1 2) (4 8) :default 0))) (test (equal? (convert 'wb-map (map (1 2) (4 8) :default 0)) (map (1 2) (4 8) :default 0))) (test (equal? (convert 'seq (map (1 3) (2 10) :default 17)) - (with-default (seq '(1 . 3) '(2 . 10)) 17))) + (seq '(1 . 3) '(2 . 10)))) (test (equalp (convert 'vector (map (1 3) (2 10) :default 17)) #((1 . 3) (2 . 10)))) (test (equalp (convert 'set (map (1 3) (2 10) :default 17)) @@ -852,8 +1107,8 @@ (define-hash-function erapmoc hash-value-negated) (map (1 88) (2 104)))) (test (equal? (gmap (:result map-union :val-fn (fn (x y) (if (equal? (1+ x) y) (values nil ':no-value) y))) nil - (:arg seq (seq(map ((make-my-integer 0) 32) ((make-my-integer 1) 77)) - (map ((make-my-integer 0) 33) ((make-my-integer 1) 92))))) + (:arg seq (seq (map ((make-my-integer 0) 32) ((make-my-integer 1) 77)) + (map ((make-my-integer 0) 33) ((make-my-integer 1) 92))))) (map ((make-my-integer 1) 92)))) (test (equal? (map-union (map ((make-my-integer 0) 32) ((make-my-integer 1) 55)) (map ((make-my-integer 0) 33) ((make-my-integer 2) 84)) @@ -959,6 +1214,8 @@ (define-hash-function erapmoc hash-value-negated) (let ((ls '(0 1 2 3 4 5 6 7 8 9))) (test (equal (@ ls 'first) 0)) (test (equal (with ls 'first 10) '(10 1 2 3 4 5 6 7 8 9))) + (test (equal (@ ls 'cl:first) 0)) + (test (equal (with ls 'cl:first 10) '(10 1 2 3 4 5 6 7 8 9))) (test (equal (@ ls 'second) 1)) (test (equal (with ls 'second 11) '(0 11 2 3 4 5 6 7 8 9))) (test (equal (@ ls 'third) 2)) @@ -1426,24 +1683,58 @@ (define-hash-function erapmoc hash-value-negated) (test (equal? (split-through (set 0 3 5 8 10) 20) (set 0 3 5 8 10))) (test (equal? (split-below (set 7 3 1 2) 4) (set 1 2 3))) (test (equal? (split-below (set 7 3 1 2) 3) (set 1 2))) + + (test (equal? (split-from (bag 0 1 1 2 2) 1) (bag 1 1 2 2))) + (test (equal? (split-from (bag 0 0 2 4 4) 1) (bag 2 4 4))) + (test (equal? (split-above (bag 0 23 7 4 19 19) 7) (bag 19 19 23))) + (test (equal? (split-above (bag 0 23 23 7 4 19) 6) (bag 7 19 23 23))) + (test (equal? (split-through (bag 0 3 3 5 5 8 10) 5) (bag 0 3 3 5 5))) + (test (equal? (split-through (bag 0 0 3 5 5 8 10) 6) (bag 0 0 3 5 5))) + (test (equal? (split-through (bag 0 3 3 5 8 8 10) 20) (bag 0 3 3 5 8 8 10))) + (test (equal? (split-below (bag 7 3 1 1 1 2) 4) (bag 1 1 1 2 3))) + (test (equal? (split-below (bag 7 3 1 1 1 2) 3) (bag 1 1 1 2))) + + (test (equal? (split-from (map (0 'a) (1 'w) (2 'e)) 1) (map (1 'w) (2 'e)))) + (test (equal? (split-from (map (0 'f) (2 'r) (4 'd)) 1) (map (2 'r) (4 'd)))) + (test (equal? (split-above (map (0 'b) (23 'g) (7 'l) (4 'x) (19 'w)) 7) (map (19 'w) (23 'g)))) + (test (equal? (split-above (map (0 'm) (23 'p) (7 'e) (4 'o) (19 'q)) 6) (map (7 'e) (19 'q) (23 'p)))) + (test (equal? (split-through (map (0 'c) (3 'h) (5 's) (8 'e) (10 'h)) 5) (map (0 'c) (3 'h) (5 's)))) + (test (equal? (split-through (map (0 'c) (3 'h) (5 's) (8 'e) (10 'h)) 6) (map (0 'c) (3 'h) (5 's)))) + (test (equal? (split-through (map (0 'c) (3 'h) (5 's) (8 'e) (10 'h)) 20) + (map (0 'c) (3 'h) (5 's) (8 'e) (10 'h)))) + (test (equal? (split-below (map (7 'z) (3 'i) (1 'n) (2 'w)) 4) (map (1 'n) (2 'w) (3 'i)))) + (test (equal? (split-below (map (7 'z) (3 'i) (1 'n) (2 'w)) 3) (map (1 'n) (2 'w)))) + (test (equal? (filter 'evenp (set 1 2 3 7 8 12 17)) (set 2 8 12))) (test (equal? (filter #'evenp (set 1 2 3 7 8 12 17)) (set 2 8 12))) (test (equal? (filter (map (1 t) (2 nil) (4 t)) (set 0 1 2 3 4 5)) (set 1 4))) + (test (equal? (filter 'evenp (ch-set 1 2 3 7 8 12 17)) (ch-set 2 8 12))) + (test (equal? (filter #'evenp (ch-set 1 2 3 7 8 12 17)) (ch-set 2 8 12))) + (test (equal? (filter (map (1 t) (2 nil) (4 t)) (ch-set 0 1 2 3 4 5)) + (ch-set 1 4))) (test (equal? (filter (set) (set)) (set))) (test (equal? (filter (set 0 2 4 7) (set 0 1 2 3 5 6 7 8 9 10)) (set 0 2 7))) (test (equal? (filter (bag) (set)) (set))) (test (equal? (filter (bag 0 0 3 5 6 6 7) (set -1 0 2 5 8)) (set 0 5))) - (test (equal? (nth-value 0 (partition 'evenp (set 0 1 2 3 4 5 6 7))) - (set 0 2 4 6))) - (test (equal? (nth-value 1 (partition 'evenp (set 0 1 2 3 4 5 6 7))) - (set 1 3 5 7))) - (test (equal? (nth-value 0 (partition (map (1 nil) :default t) (set 0 1 2 3))) - (set 0 2 3))) - (test (equal? (nth-value 1 (partition (map (1 nil) :default t) (set 0 1 2 3))) - (set 1))) + (test (equal? (multiple-value-list (partition 'evenp (set 0 1 2 3 4 5 6 7))) + (list (set 0 2 4 6) (set 1 3 5 7)))) + (test (equal? (multiple-value-list (partition 'evenp (ch-set 0 1 2 3 4 5 6 7))) + (list (ch-set 0 2 4 6) (ch-set 1 3 5 7)))) + (test (equal? (multiple-value-list (fset2:partition 'evenp (set 0 1 2 3 4 5 6 7))) + (list (set 0 2 4 6) (set 1 3 5 7)))) + (test (equal? (multiple-value-list (fset2:partition 'evenp (ch-set 0 1 2 3 4 5 6 7))) + (list (ch-set 0 2 4 6) (ch-set 1 3 5 7)))) + (test (equal? (multiple-value-list (partition (map (1 t) (4 t) (7 t)) (set 0 1 2 3 4 5 6 7))) + (list (set 1 4 7) (set 0 2 3 5 6)))) + (test (equal? (multiple-value-list (partition (map (1 t) (4 t) (7 t)) (ch-set 0 1 2 3 4 5 6 7))) + (list (ch-set 1 4 7) (ch-set 0 2 3 5 6)))) + (test (equal? (multiple-value-list (fset2:partition (map (1 t) (4 t) (7 t)) (set 0 1 2 3 4 5 6 7))) + (list (set 1 4 7) (set 0 2 3 5 6)))) + (test (equal? (multiple-value-list (fset2:partition (map (1 t) (4 t) (7 t)) (ch-set 0 1 2 3 4 5 6 7))) + (list (ch-set 1 4 7) (ch-set 0 2 3 5 6)))) (test (equal? (with-last (seq 1 2 3) 4) (seq 1 2 3 4))) (test (equal? (with (seq 'a 'b 'c) 1 'd) (seq 'a 'd 'c))) @@ -1566,14 +1857,6 @@ (define-hash-function erapmoc hash-value-negated) (test (eql (range-contains? (seq 'a 'b 'c) 'b) t)) (test (not (range-contains? (seq 'a 'b 'c) 'd))) - (test (equal? (filter #'evenp (seq 1 2 3 4 5)) (seq 2 4))) - (test (equal? (filter #'evenp (with-default (seq 1 2 3 4 5) 17)) - (with-default (seq 2 4) 17))) - (test (equal? (filter 'evenp (seq 1 2 3 4 5)) (seq 2 4))) - (test (equal? (filter (map (1 t) (3 t)) (seq 1 2 3 4 5)) (seq 1 3))) - (test (equal? (filter (set 1 3 9) (seq 1 2 3 4 5)) (seq 1 3))) - (test (equal? (filter (bag 1 1 3 9) (seq 1 2 3 4 5)) (seq 1 3))) - (test (equal? (multiple-value-list (partition (constantly t) (seq 1 2 3))) (list (seq 1 2 3) (seq)))) (test (equal? (multiple-value-list (partition 'evenp (seq 1 2 3 4))) @@ -1899,6 +2182,9 @@ (define-hash-function erapmoc hash-value-negated) (test (equal? (first rs) 27)) (test (equal? (last rs) 92)) (test (contains? rs (arb rs))) + (test (equal? (least rs) 3)) + (test (equal? (greatest rs) 92)) + (test (equal? (index rs 3) 2)) (test (equal? (convert 'seq rs) (seq 27 14 3 92))) (test (equal? (let ((tmp nil)) (do-set (x rs) @@ -1910,11 +2196,17 @@ (define-hash-function erapmoc hash-value-negated) (test (equal? rs (convert 'wb-replay-set (convert 'seq rs)))) (test (equal? rs (convert 'wb-replay-set (convert 'vector rs)))) (test (equal? rs (convert 'wb-replay-set (convert 'ch-replay-set rs)))) + (test (equal? rs (convert 'wb-replay-set rs))) + (test (equal? (convert 'wb-set rs) (convert 'wb-set (convert 'wb-replay-set rs :compare-fn-name 'erapmoc)))) (test (equal? rs (gmap (:result wb-replay-set) nil (:arg replay-set rs)))) - (test (equal? rs (gmap (:result wb-replay-set) nil (:set rs)))) + (test (equal? rs (gmap (:result wb-replay-set) nil (:arg set rs)))) (test (equal? rs (gmap (:result wb-replay-set) (fn (i) (at-index rs i)) (:arg index 0 (size rs))))) (test (equal? rs (wb-replay-set 27 14 3 92))) - (test (not (equal? rs (wb-replay-set 27 3 14 92))))) + (test (not (equal? rs (wb-replay-set 27 3 14 92)))) + (test (equal? (union rs (wb-replay-set 38 14 6)) + (wb-replay-set 27 14 3 92 38 6))) + (test (equal? (intersection rs (set 14 27)) + (wb-replay-set 27 14)))) ;; Tests `ch-replay-set'. (let ((rs (replay-set 27 14 ($ (set 3 92))))) @@ -1924,6 +2216,7 @@ (define-hash-function erapmoc hash-value-negated) (test (equal? (first rs) 27)) (test (equal? (last rs) 92)) (test (contains? rs (arb rs))) + (test (equal? (index rs 3) 2)) (test (equal? (convert 'seq rs) (seq 27 14 3 92))) (test (equal? (let ((tmp nil)) (do-set (x rs) @@ -1934,25 +2227,42 @@ (define-hash-function erapmoc hash-value-negated) (test (equal? rs (convert 'replay-set (convert 'list rs)))) (test (equal? rs (convert 'replay-set (convert 'seq rs)))) (test (equal? rs (convert 'replay-set (convert 'vector rs)))) + (test (equal? rs (convert 'ch-replay-set rs))) (test (equal? rs (convert 'ch-replay-set (convert 'wb-replay-set rs)))) + (test (equal? (convert 'ch-set rs) (convert 'ch-set (convert 'ch-replay-set rs :compare-fn-name 'erapmoc)))) (test (equal? rs (gmap (:result ch-replay-set) nil (:arg replay-set rs)))) - (test (equal? rs (gmap (:result ch-replay-set) nil (:set rs)))) + (test (equal? rs (gmap (:result ch-replay-set) nil (:arg set rs)))) (test (equal? rs (gmap (:result ch-replay-set) (fn (i) (at-index rs i)) (:arg index 0 (size rs))))) (test (equal? rs (ch-replay-set 27 14 3 92))) - (test (not (equal? rs (ch-replay-set 27 3 14 92))))) + (test (not (equal? rs (ch-replay-set 27 3 14 92)))) + (test (equal? (union rs (ch-replay-set 38 14 6)) + (ch-replay-set 27 14 3 92 38 6))) + (test (equal? (intersection rs (ch-set 14 27)) + (ch-replay-set 27 14)))) ;; `wb-replay-map' is arguably obsolete, but we test it anyway. (let ((rm (wb-replay-map (19 'foo) (12 'bar) :default 'xyzzy (8 'quux) ($ (map (2 'gubbish) (34 'ork)))))) (let ((crm (convert 'wb-replay-map rm :key-compare-fn-name 'erapmoc :val-compare-fn-name 'eql-compare))) (test (eq (key-compare-fn-name crm) 'erapmoc)) (test (eq (val-compare-fn-name crm) 'eql-compare))) + (let ((crm (wb-custom-replay-map 'erapmoc 'eql-compare (19 'foo) (12 'bar) :default 'xyzzy (8 'quux) + ($ (map (2 'gubbish) (34 'ork)))))) + (test (eq (key-compare-fn-name crm) 'erapmoc)) + (test (eq (val-compare-fn-name crm) 'eql-compare))) (test (equal? (size rm) 5)) (test (equal? (@ rm 8) 'quux)) (let ((k v (first rm))) (test (and (equal? k 19) (equal? v 'foo)))) (let ((k v (last rm))) (test (and (equal? k 34) (equal? v 'ork)))) + (test (domain-contains? rm (arb rm))) + (let ((k v (least rm))) + (test (and (equal? k 2) (equal? v 'gubbish)))) + (let ((k v (greatest rm))) + (test (and (equal? k 34) (equal? v 'ork)))) + (test (equal? (index rm 8) 2)) (test (equal? (convert 'seq rm) (seq '(19 . foo) '(12 . bar) '(8 . quux) '(2 . gubbish) '(34 . ork)))) + (test (equal? (domain rm) (wb-replay-set 19 12 8 2 34))) (excludef rm 12) (setf (@ rm 8) 'the-great-quux) (test (equal? (let ((tmp nil)) @@ -1965,6 +2275,7 @@ (define-hash-function erapmoc hash-value-negated) (test (equal? (with-default rm nil) (convert 'wb-replay-map (convert 'vector rm)))) (test (equal? rm (convert 'wb-replay-map (convert 'ch-replay-map rm)))) (test (equal? (with-default rm nil) (gmap (:result wb-replay-map) nil (:arg replay-map rm)))) + (test (equal? (with-default rm nil) (gmap (:result wb-replay-map) nil (:arg map rm)))) (test (equal? rm (gmap (:result wb-replay-map :default 'xyzzy) nil (:arg map rm)))) (test (equal? rm (gmap (:result wb-replay-map) (fn (i) (at-index rm i)) (:arg index 0 (size rm))))) (test (equal? rm (wb-replay-map (19 'foo) (8 'the-great-quux) (2 'gubbish) (34 'ork) @@ -1979,13 +2290,20 @@ (define-hash-function erapmoc hash-value-negated) (let ((crm (convert 'ch-replay-map rm :key-compare-fn-name 'erapmoc :val-compare-fn-name 'eql-compare))) (test (eq (key-compare-fn-name crm) 'erapmoc)) (test (eq (val-compare-fn-name crm) 'eql-compare))) + (let ((crm (ch-custom-replay-map 'erapmoc 'eql-compare (19 'foo) (12 'bar) :default 'xyzzy (8 'quux) + ($ (map (2 'gubbish) (34 'ork)))))) + (test (eq (key-compare-fn-name crm) 'erapmoc)) + (test (eq (val-compare-fn-name crm) 'eql-compare))) (test (equal? (size rm) 5)) (test (equal? (@ rm 8) 'quux)) (let ((k v (first rm))) (test (and (equal? k 19) (equal? v 'foo)))) (let ((k v (last rm))) (test (and (equal? k 34) (equal? v 'ork)))) + (test (domain-contains? rm (arb rm))) + (test (equal? (index rm 8) 2)) (test (equal? (convert 'seq rm) (seq '(19 . foo) '(12 . bar) '(8 . quux) '(2 . gubbish) '(34 . ork)))) + (test (equal? (domain rm) (ch-replay-set 19 12 8 2 34))) (excludef rm 12) (setf (@ rm 8) 'the-great-quux) (test (equal? (let ((tmp nil)) @@ -1999,6 +2317,7 @@ (define-hash-function erapmoc hash-value-negated) (test (equal? (with-default rm nil) (convert 'replay-map (convert 'vector rm)))) (test (equal? rm (convert 'ch-replay-map (convert 'wb-replay-map rm)))) (test (equal? (with-default rm nil) (gmap (:result ch-replay-map) nil (:arg replay-map rm)))) + (test (equal? (with-default rm nil) (gmap (:result ch-replay-map) nil (:arg map rm)))) (test (equal? rm (gmap (:result ch-replay-map :default 'xyzzy) nil (:arg map rm)))) (test (equal? (with-default rm nil) (gmap (:result ch-replay-map) (fn (i) (at-index rm i)) (:arg index 0 (size rm))))) @@ -2063,6 +2382,7 @@ (define-hash-function erapmoc hash-value-negated) (test (handler-case (progn (contains? (bag 1) 1 nil) nil) (simple-program-error () t))) (test (domain-contains? (map ('x 0) ('y 1)) 'y)) + (test (domain-contains? (ch-map ('x 0) ('y 1)) 'y)) (test (domain-contains? (seq 'a 'e 'g 'x) 3)) (test (= (multiplicity (bag 1 2 1) 1) 2)) (test (= (multiplicity (bag 1 2 1) 2) 1)) @@ -2092,8 +2412,8 @@ (define-hash-function erapmoc hash-value-negated) (and (eq key 'y) (= val 7) (eq pr? t)))) (test (equal (multiple-value-list (greatest (map))) '(nil nil nil))) - (test (equal (multiple-value-list (lookup (map ('x 'a) ('y 'b)) 'x)) '(a t))) - (test (equal (multiple-value-list (lookup (map ('x 'a) ('y 'b)) 'z)) '(nil nil))) + (test (equal (multiple-value-list (lookup (map ('x 'a) ('y 'b)) 'x)) '(a t x))) + (test (equal (multiple-value-list (lookup (map ('x 'a) ('y 'b)) 'z)) '(nil nil nil))) (test (eq (lookup (seq 'a 'b 'c) 1) 'b)) (test (let ((s0 "x") (s1 "y") @@ -2293,15 +2613,15 @@ (define-hash-function erapmoc hash-value-negated) (defun Test-Reader () (macrolet ((test (str form) - (let ((r (with-standard-io-syntax - (let ((*readtable* *fset-readtable*) - (*package* (find-package :fset))) - (read-from-string str))))) - `(progn - ; (format t "Reader test: ~s, ~s, ~s~%" ,str ',r ',form) - (unless (equal? ,r ,form) - (error "Reader test failed: ~S, ~S" ,str ',form)))))) - (flet ((error-test (str) + `(let ((r (parse ',str))) + (unless (equal? (eval r) (eval ',form)) + (error "Reader test failed: ~S, ~S, ~S" ,str r ',form))))) + (flet ((parse (str) + (with-standard-io-syntax + (let ((*readtable* *fset-readtable*) + (*package* (find-package :fset))) + (read-from-string str)))) + (error-test (str) (with-standard-io-syntax (let ((*readtable* *fset-readtable*) (*package* (find-package :fset))) @@ -2313,14 +2633,14 @@ (define-hash-function erapmoc hash-value-negated) (test "#[1]" (seq 1)) (error-test "#[") - (let ((x (seq 3 4))) - (test "#[1 #$x]" (seq 1 3 4))) + (test "#[1 #$(seq 3 4)]" (seq 1 3 4)) (test "#{1 2}" (set 1 2)) (error-test "#{") - (let ((x (set 3 5))) - (test "#{1 2 #$x}" (set 1 2 3 5))) + (test "#{1 2 #$(set 3 5)}" (set 1 2 3 5)) (test "#{}" (empty-set)) + (test "##{17 42}" (ch-set 17 42)) (test "#{| (1 2) (3 4) |}" (map (1 2) (3 4))) + (test "##{| (1 2) (3 4) |}" (ch-map (1 2) (3 4))) (error-test "#{| |x") (error-test "#{|}") (test "#{%%}" (bag)) @@ -2333,14 +2653,12 @@ (define-hash-function erapmoc hash-value-negated) (error-test "#{% #%(1 . 2) %}") (error-test "#{% #%(1 2 . 3) %}") (error-test "#{% #%(1 2 3) %}") - (let ((x (map (1 2)))) - (test "#{| #$x (3 4) |}" (map (1 2) (3 4)))) + (test "#{| #$(map (1 2)) (3 4) |}" (map (1 2) (3 4))) (test "#~< >" (tuple)) (error-test "#~[") (error-test "#~<") (test "#~< (+K0+ 1) >" (tuple (+K0+ 1))) - (let ((x (tuple (+K0+ 1)))) - (test "#~< #$x (+K1+ 3) >" (tuple (+K0+ 1) (+K1+ 3))))))) + (test "#~< #$(tuple (+K0+ 1)) (+K1+ 3) >" (tuple (+K0+ 1) (+K1+ 3)))))) (defun Test-Rereader () (with-standard-io-syntax @@ -2348,14 +2666,22 @@ (define-hash-function erapmoc hash-value-negated) (*package* (find-package :fset)) (*print-readably* t)) (dolist (x (list (seq) (set) (seq 1 2 3) (set 'a 'b 2) + (wb-custom-set 'erapmoc 3 42) + (ch-set 32 19) + (ch-custom-set 'erapmoc 11 41) (map) (tuple) (bag) (map (1 2) (3 4)) + (wb-custom-map 'erapmoc nil ('foo 3) ('bar 19)) + (ch-custom-map 'erapmoc nil ('foo 3) ('bar 19)) (with-default (map (1 2) (3 4)) 'x) + (wb-custom-map 'erapmoc nil (1 2) (3 'xyzzy) :default 'fubar) + (ch-custom-map 'erapmoc nil (1 2) (3 'xyzzy) :default 'fubar) (with-default (seq 4 17 33) 42) (tuple (+K0+ 1)) (bag 1 '(% foo 3)) (bag 1 2) - (bag 1 1))) + (bag 1 1) + (wb-custom-bag 'erapmoc 1 1 2))) (let ((str (prin1-to-string x))) ;; (let ((*print-readably* nil)) (format t "str = ~s~%"str)) (let ((y (read-from-string str))) @@ -2454,6 +2780,7 @@ (define-hash-function erapmoc hash-value-negated) (vector (make-instance 'my-unhandled-obj))))))) (defun Test-Equivalent-Sets (&optional (size 20) (reps 1000)) + (declare (optimize (debug 3))) (macrolet ((test (form) `(unless ,form (error "Test in Test-Equivalent-Sets failed: ~S" ',form)))) @@ -2566,7 +2893,7 @@ (define-hash-function erapmoc hash-value-negated) s 1 1) (seq 1 (seq 2 :a) 4)) (equal? s (seq 1 (seq 2 3) 4)))) - (test (equal? (update #'- s 1 1) (seq 1 (seq 2 -3) 4)))))) + (test (equal? (update '- s 1 1) (seq 1 (seq 2 -3) 4)))))) (defun Test-Set-Operations (i) (declare (optimize (speed 0) (safety 3) (debug 3))) @@ -2590,7 +2917,9 @@ (define-hash-function erapmoc hash-value-negated) (unless (and (subset? fs0 tmp) (or (contains? fs0 r) (not (subset? tmp fs0)))) (error "Set subset? failed on iteration ~D" i)) - (setq fs0 tmp))) + (setq fs0 tmp) + ;; Can't say much about `hash-value', but at least we can check that it doesn't crash. + (hash-value fs0))) (dotimes (j 100) (let* ((r (Make-My-Integer (random 200))) (tmp (with fs1 r))) @@ -2645,16 +2974,16 @@ (define-hash-function erapmoc hash-value-negated) (error "Set arb/contains? failed (fs1) on iteration ~D" i)) (unless (member (compare (least fs0) (reduce (lambda (mi1 mi2) - (if (less?-cmp (My-Integer-Value mi1) (My-Integer-Value mi2) - (compare-fn fs0)) + (if (less-than?-cmp (My-Integer-Value mi1) (My-Integer-Value mi2) + (compare-fn fs0)) mi1 mi2)) s0)) '(:equal :unequal)) (error "Set least failed on iteration ~D" i)) (unless (member (compare (greatest fs0) (reduce (lambda (mi1 mi2) - (if (greater?-cmp (My-Integer-Value mi1) (My-Integer-Value mi2) - (compare-fn fs0)) + (if (greater-than?-cmp (My-Integer-Value mi1) (My-Integer-Value mi2) + (compare-fn fs0)) mi1 mi2)) s0)) '(:equal :unequal)) @@ -2667,16 +2996,17 @@ (define-hash-function erapmoc hash-value-negated) (error "Set iterator failed (fs0) on iteration ~D" i)) (unless (equal? fs1 (gmap (:result wb-set :compare-fn-name fs1-cfn) nil (:arg list (convert 'list fs1)))) (error "Set iterator or accumulator failed (fs1) on iteration ~D" i)) - (unless (equal? fs0 (convert 'wb-set (sort s0 #'less-than?) :input-sorted? t :compare-fn-name fs0-cfn)) + (unless (equal? fs0 (convert 'wb-set (sort s0 (fn (a b) (less-than?-cmp a b #'compare))) + :input-sorted? t :compare-fn-name fs0-cfn)) (error "Set conversion from sorted list failed (fs0) on iteration ~D" i)) (unless (equal? fs0 (convert 'wb-set (convert 'seq s0) :compare-fn-name fs0-cfn)) (error "Set conversion from seq failed (fs0) on iteration ~D" i)) - (unless (equal? fs0 (convert 'wb-set (sort (convert 'seq s0) #'less-than?) + (unless (equal? fs0 (convert 'wb-set (sort (convert 'seq s0) (fn (a b) (less-than?-cmp a b #'compare))) :input-sorted? t :compare-fn-name fs0-cfn)) (error "Set conversion from sorted seq failed (fs0) on iteration ~D" i)) (unless (equal? fs0 (convert 'wb-set (convert 'vector s0) :compare-fn-name fs0-cfn)) (error "Set conversion from vector failed (fs0) on iteration ~D" i)) - (unless (equal? fs0 (convert 'wb-set (sort (convert 'vector s0) #'less-than?) + (unless (equal? fs0 (convert 'wb-set (sort (convert 'vector s0) (fn (a b) (less-than?-cmp a b #'compare))) :input-sorted? t :compare-fn-name fs0-cfn)) (error "Set conversion from sorted vector failed (fs0) on iteration ~D" i)) (unless (equal? (gmap (:result list) nil (:arg fun-sequence fs0)) @@ -2685,25 +3015,36 @@ (define-hash-function erapmoc hash-value-negated) (unless (equal? (gmap (:result list) nil (:arg fun-sequence fs0 :from-end? t)) (reverse (convert 'list fs0))) (error "Set rev-fun-iterator failed on iteration ~D" i)) - (let ((fsu (union fs0 fs1)) - (su (cl:union s0 s1 :test #'equal?))) - (unless (and (verify fsu) (equal? fsu (convert 'wb-set su :compare-fn-name fs0-cfn))) - (error "Set union failed on iteration ~D " i))) - (let ((fsi (intersection fs0 fs1)) - (si (cl:intersection s0 s1 :test #'equal?))) - (unless (and (verify fsi) (equal? fsi (convert 'wb-set si :compare-fn-name fs0-cfn))) - (error "Set intersection failed on iteration ~D " i))) - (let ((fsd (set-difference fs0 fs1)) - (sd (cl:set-difference s0 s1 :test #'equal?))) - (unless (and (verify fsd) (equal? fsd (convert 'wb-set sd :compare-fn-name fs0-cfn))) - (error "Set-difference failed on iteration ~D " i))) - (let ((fsd1 fsd2 (set-difference-2 fs0 fs1)) - (sd1 (cl:set-difference s0 s1 :test #'equal?)) - (sd2 (cl:set-difference s1 s0 :test #'equal?))) - (unless (and (verify fsd1) (equal? fsd1 (convert 'wb-set sd1 :compare-fn-name fs0-cfn))) - (error "Set-difference-2 failed (fsd1) on iteration ~D " i)) - (unless (and (verify fsd2) (equal? fsd2 (convert 'wb-set sd2 :compare-fn-name fs1-cfn))) - (error "Set-difference-2 failed (fsd2) on iteration ~D " i))) + (flet ((check-pref (result label &optional right?) + (let ((bad (gmap :or (fn (x) (let ((val? val (lookup result x))) + (and val? (not (eq x val)) x))) + (:arg set (if right? fs1 fs0))))) + (when bad + (error "~A failed ~A preference on iteration ~D: ~A" label (if right? "right" "left") i bad))))) + (let ((fsu (union fs0 fs1)) + (su (cl:union s0 s1 :test #'equal?))) + (unless (and (verify fsu) (equal? fsu (convert 'wb-set su :compare-fn-name fs0-cfn))) + (error "Set union failed on iteration ~D " i)) + (check-pref fsu "Set union")) + (let ((fsi (intersection fs0 fs1)) + (si (cl:intersection s0 s1 :test #'equal?))) + (unless (and (verify fsi) (equal? fsi (convert 'wb-set si :compare-fn-name fs0-cfn))) + (error "Set intersection failed on iteration ~D " i)) + (check-pref fsi "Set intersection")) + (let ((fsd (set-difference fs0 fs1)) + (sd (cl:set-difference s0 s1 :test #'equal?))) + (unless (and (verify fsd) (equal? fsd (convert 'wb-set sd :compare-fn-name fs0-cfn))) + (error "Set difference failed on iteration ~D " i)) + (check-pref fsd "Set difference")) + (let ((fsd1 fsd2 (set-difference-2 fs0 fs1)) + (sd1 (cl:set-difference s0 s1 :test #'equal?)) + (sd2 (cl:set-difference s1 s0 :test #'equal?))) + (unless (and (verify fsd1) (equal? fsd1 (convert 'wb-set sd1 :compare-fn-name fs0-cfn))) + (error "Set-difference-2 failed (fsd1) on iteration ~D " i)) + (check-pref fsd1 "Set difference-2") + (unless (and (verify fsd2) (equal? fsd2 (convert 'wb-set sd2 :compare-fn-name fs1-cfn))) + (error "Set-difference-2 failed (fsd2) on iteration ~D " i)) + (check-pref fsd2 "Set difference-2" t))) (when (eq fs0-cfn fs1-cfn) (let ((fs0a (less fs0 (Pick fs0))) (fs0b (less fs0 (Pick fs0)))) @@ -2717,10 +3058,17 @@ (define-hash-function erapmoc hash-value-negated) (error "Set compare failed (fs1) on iteration ~D" i)))) (unless (gmap (:result and) (fn (x i) (and (eql (rank fs0 x) i) + (eql (fset2:rank fs0 x) i) (equal? x (at-rank fs0 i)))) (:arg set fs0) (:arg index 0 (size fs0))) (error "Set rank, at-rank, or iterator failed")) + (unless (gmap (:result and) (fn (x i) + (and (eql (index fs0 x) i) + (equal? x (at-index fs0 i)))) + (:arg set fs0) + (:arg index 0 (size fs0))) + (error "Set index, at-index, or iterator failed")) (let ((r (do ((r (random 200) (random 200))) ;; Equivalent-but-unequal `My-Integer's make this a little tricky. ((and (not (contains? fs0 (make-my-integer r))) @@ -2728,9 +3076,12 @@ (define-hash-function erapmoc hash-value-negated) r)))) (let ((ri (make-my-integer r)) ((fs0a (with fs0 ri)) - (ri-rank (rank fs0 ri)))) + (ri-rank (rank fs0 ri)) + (ri-rank2 (fset2:rank fs0 ri)))) (unless (= (1+ ri-rank) (rank fs0a ri)) - (error "Set rank of non-member failed: ~A ~A" r fs0)))) + (error "Set rank of non-member failed: ~A ~A" r fs0)) + (unless (= ri-rank2 (rank fs0a ri)) + (error "Set fset2:rank of non-member failed: ~A ~A" r fs0)))) fs0)) @@ -2753,7 +3104,9 @@ (define-hash-function erapmoc hash-value-negated) (unless (= (size tmp) (length m0)) (error "Map size or with failed (a) on iteration ~D, adding ~A -> ~A; ~D, ~D" i r v m0 tmp)) - (setq fm0 tmp))) + (setq fm0 tmp) + ;; Can't say much about `hash-value', but at least we can check that it doesn't crash. + (hash-value fm0))) (dotimes (j 100) (let* ((r (Make-My-Integer (random 100))) (v (random 3)) @@ -2767,8 +3120,11 @@ (define-hash-function erapmoc hash-value-negated) i r v m1 tmp)) (setq fm1 tmp))) (dotimes (j 20) - (let ((r (Make-My-Integer (random 100)))) - (unless (eql (lookup fm0 r) (cdr (assoc r m0 :test #'equal?))) + (let ((r (Make-My-Integer (random 100))) + ((val val? mkey (lookup fm0 r)))) + (unless (or (not val?) (and (equal? mkey r) (not (eq mkey r)))) + (error "Map lookup failed to return key on iteration ~D" i)) + (unless (eql val (cdr (assoc r m0 :test #'equal?))) (error "Map lookup failed (fm0) on iteration ~D: ~A, ~A, ~A" i fm0 m0 r)) (let ((tmp tval (less fm0 r))) (unless (or (equal? tmp fm0) (equal? tval (@ fm0 r))) @@ -2797,16 +3153,16 @@ (define-hash-function erapmoc hash-value-negated) (error "Map arb/contains? failed (fm1) on iteration ~D" i)) (unless (member (compare (least fm0) (reduce (lambda (mi1 mi2) - (if (less?-cmp (My-Integer-Value mi1) (My-Integer-Value mi2) - (key-compare-fn fm0)) + (if (less-than?-cmp (My-Integer-Value mi1) (My-Integer-Value mi2) + (key-compare-fn fm0)) mi1 mi2)) (mapcar #'car m0))) '(:equal :unequal)) (error "Map least failed on iteration ~D" i)) (unless (member (compare (greatest fm0) (reduce (lambda (mi1 mi2) - (if (greater?-cmp (My-Integer-Value mi1) (My-Integer-Value mi2) - (key-compare-fn fm0)) + (if (greater-than?-cmp (My-Integer-Value mi1) (My-Integer-Value mi2) + (key-compare-fn fm0)) mi1 mi2)) (mapcar #'car m0))) '(:equal :unequal)) @@ -2825,12 +3181,14 @@ (define-hash-function erapmoc hash-value-negated) (error "Map conversion from sorted list failed (fm0) on iteration ~D" i)) (unless (equal? fm0 (convert 'wb-map (convert 'seq m0) :key-compare-fn-name fm0-cfn)) (error "Map conversion from seq failed (fm0) on iteration ~D" i)) - (unless (equal? fm0 (convert 'wb-map (sort (convert 'seq m0) #'less-than? :key #'car) + (unless (equal? fm0 (convert 'wb-map (sort (convert 'seq m0) (fn (a b) (less-than?-cmp a b #'compare)) + :key #'car) :input-sorted? t :key-compare-fn-name fm0-cfn)) (error "Map conversion from sorted seq failed (fm0) on iteration ~D" i)) (unless (equal? fm0 (convert 'wb-map (convert 'vector m0) :key-compare-fn-name fm0-cfn)) (error "Map conversion from vector failed (fm0) on iteration ~D" i)) - (unless (equal? fm0 (convert 'wb-map (sort (convert 'vector m0) #'less-than? :key #'car) + (unless (equal? fm0 (convert 'wb-map (sort (convert 'vector m0) (fn (a b) (less-than?-cmp a b #'compare)) + :key #'car) :input-sorted? t :key-compare-fn-name fm0-cfn)) (error "Map conversion from sorted vector failed (fm0) on iteration ~D" i)) (unless (equal? (gmap (:result alist) nil (:arg fun-map fm0)) @@ -2855,7 +3213,15 @@ (define-hash-function erapmoc hash-value-negated) (unless (eq (compare fm1a fm1b) (Map-Compare (convert 'list fm1a) (convert 'list fm1b) (eq fm1-cfn 'erapmoc))) (error "Map compare failed (fm1) on iteration ~D" i)))) - (when (eq fm0-cfn fm1-cfn) + (flet ((check-pref (result source label &optional right?) + (let ((bad (gmap :or (fn (k v) (let ((mv mv? mk (lookup result k))) + (and mv? (or (not (eq k mk)) + (and (equal? v mv) (not (eql v mv)))) + k))) + (:arg map source)))) + (when bad + (error "~A failed ~:[left~;right~] preference on iteration ~D: ~A" + label right? i bad))))) (let ((fmu (map-union fm0 fm1)) (mu m0)) (dolist (pr m1) @@ -2863,10 +3229,14 @@ (define-hash-function erapmoc hash-value-negated) (unless (and (verify fmu) (equal? fmu (convert 'wb-map mu :key-compare-fn-name fm0-cfn))) (error "Map union failed on iteration ~D: ~A, ~A, ~A, ~A" i mu fmu fm0 fm1)) + (check-pref fmu fm0 "Map union") (let ((fmd1 fmd2 (map-difference-2 fmu fm0))) (unless (and (equal? fm0 (map-union (restrict fmu (domain fm0)) fmd2)) - (equal? fm1 (map-union (restrict fmu (domain fm1)) fmd1))) - (error "Map difference failed on iteration ~D" i)))) + (equal? (convert 'wb-map fm1 :key-compare-fn-name fm0-cfn) + (map-union (restrict fmu (domain fm1)) fmd1))) + (error "Map difference failed on iteration ~D" i)) + (check-pref fmu fmd1 "Map difference") + (check-pref fm0 fmd2 "Map difference" t))) (let ((fmi (map-intersection fm0 fm1)) (mi nil)) (dolist (pr m1) @@ -2875,7 +3245,8 @@ (define-hash-function erapmoc hash-value-negated) (unless (and (verify fmi) (equal? fmi (convert 'wb-map mi :key-compare-fn-name fm0-cfn))) (error "Map intersection failed on iteration ~D: ~A, ~A, ~A, ~A" - i mi fmi fm0 fm1)))) + i mi fmi fm0 fm1)) + (check-pref fmi fm0 "Map intersection"))) (let ((fmr (restrict fm0 a-set)) (mr (remove-if-not #'(lambda (pr) (contains? a-set (car pr))) m0))) (unless (and (verify fmr) @@ -2886,8 +3257,15 @@ (define-hash-function erapmoc hash-value-negated) (unless (and (verify fmr) (equal? fmr (convert 'wb-map mr :key-compare-fn-name fm0-cfn))) (error "Map restrict-not failed on iteration ~D: ~A, ~A, ~A" i fmr mr fm0))) + (unless (gmap (:result and) (fn (x _n i) + (and (eql (index fm0 x) i) + (equal? x (at-index fm0 i)))) + (:arg map fm0) + (:arg index 0 (size fm0))) + (error "Map index, at-index, or iterator failed")) (unless (gmap (:result and) (fn (x y i) (and (eql (rank fm0 x) i) + (eql (fset2:rank fm0 x) i) (let ((rx ry (at-rank fm0 i))) (and (equal? x rx) (= y ry))))) @@ -2901,9 +3279,12 @@ (define-hash-function erapmoc hash-value-negated) r)))) (let ((ri (make-my-integer r)) ((fm0a (with fm0 ri 42)) - (ri-rank (rank fm0 ri)))) + (ri-rank (rank fm0 ri)) + (ri-rank2 (fset2:rank fm0 ri)))) (unless (= (1+ ri-rank) (rank fm0a ri)) - (error "Map rank of non-member failed: ~A ~A" r fm0)))))) + (error "Map rank of non-member failed: ~A ~A" r fm0)) + (unless (= ri-rank2 (rank fm0a ri)) + (error "Map fset2:rank of non-member failed: ~A ~A" r fm0)))))) (defun Test-Bag-Operations (i) @@ -2927,7 +3308,9 @@ (define-hash-function erapmoc hash-value-negated) (error "Bag set-size failed (fb0) on iteration ~D" i)) (unless (and (subbag? fb0 tmp) (not (subbag? tmp fb0))) (error "Bag subbag? failed (fb0) on iteration ~D" i)) - (setq fb0 tmp))) + (setq fb0 tmp) + ;; Can't say much about `hash-value', but at least we can check that it doesn't crash. + (hash-value fb0))) (dotimes (j 100) (let* ((r (Make-My-Integer (random 200))) (tmp (with fb1 r))) @@ -2989,16 +3372,16 @@ (define-hash-function erapmoc hash-value-negated) (error "Bag arb/contains? failed (fb1) on iteration ~D" i)) (unless (member (compare (least fb0) (reduce (lambda (mi1 mi2) - (if (less?-cmp (My-Integer-Value mi1) (My-Integer-Value mi2) - (compare-fn fb0)) + (if (less-than?-cmp (My-Integer-Value mi1) (My-Integer-Value mi2) + (compare-fn fb0)) mi1 mi2)) (mapcar #'car b0))) '(:equal :unequal)) (error "Bag least failed on iteration ~D" i)) (unless (member (compare (greatest fb0) (reduce (lambda (mi1 mi2) - (if (greater?-cmp (My-Integer-Value mi1) (My-Integer-Value mi2) - (compare-fn fb0)) + (if (greater-than?-cmp (My-Integer-Value mi1) (My-Integer-Value mi2) + (compare-fn fb0)) mi1 mi2)) (mapcar #'car b0))) '(:equal :unequal)) @@ -3032,7 +3415,8 @@ (define-hash-function erapmoc hash-value-negated) (unless (equal? fb0 (convert 'wb-bag (convert 'seq fb0) :input-sorted? t :compare-fn-name fb0-cfn)) (error "Bag conversion from sorted seq failed (fb0) on iteration ~D" i)) - (unless (equal? fb0 (convert 'wb-bag (sort (convert 'seq b0) #'less-than? :key #'car) + (unless (equal? fb0 (convert 'wb-bag (sort (convert 'seq b0) (fn (a b) (less-than?-cmp a b #'compare)) + :key #'car) :pairs? t :input-sorted? t :compare-fn-name fb0-cfn)) (error "Bag conversion from sorted seq-of-pairs failed (fb0) on iteration ~D" i)) @@ -3042,7 +3426,8 @@ (define-hash-function erapmoc hash-value-negated) (error "Bag conversion from vector-of-pairs failed (fb0) on iteration ~D" i)) (unless (equal? fb0 (convert 'wb-bag (convert 'vector fb0) :input-sorted? t :compare-fn-name fb0-cfn)) (error "Bag conversion from sorted vector failed (fb0) on iteration ~D" i)) - (unless (equal? fb0 (convert 'wb-bag (sort (convert 'vector b0) #'less-than? :key #'car) + (unless (equal? fb0 (convert 'wb-bag (sort (convert 'vector b0) (fn (a b) (less-than?-cmp a b #'compare)) + :key #'car) :pairs? t :input-sorted? t :compare-fn-name fb0-cfn)) (error "Bag conversion from sorted vector-of-pairs failed (fb0) on iteration ~D" i)) @@ -3058,26 +3443,69 @@ (define-hash-function erapmoc hash-value-negated) (unless (equal? (gmap (:result alist) nil (:arg fun-bag-pairs fb0 :from-end? t)) (reverse (convert 'alist fb0))) (error "Bag pair fun-iterator failed on iteration ~D" i)) - (let ((fbu (union fb0 fb1)) - (bu (Alist-Bag-Union b0 b1))) - (unless (and (verify fbu) (equal? fbu (convert 'wb-bag bu :from-type 'alist :compare-fn-name fb0-cfn))) - (error "Bag union failed on iteration ~D " i))) - (let ((fbi (intersection fb0 fb1)) - (bi (Alist-Bag-Intersection b0 b1))) - (unless (and (verify fbi) (equal? fbi (convert 'wb-bag bi :from-type 'alist :compare-fn-name fb0-cfn))) - (error "Bag intersection failed on iteration ~D " i))) - (let ((fbd (bag-difference fb0 fb1)) - (bd (Alist-Bag-Difference b0 b1))) - (unless (and (verify fbd) (equal? fbd (convert 'wb-bag bd :from-type 'alist :compare-fn-name fb0-cfn))) - (error "Bag-difference failed on iteration ~D " i))) - (let ((fbs (bag-sum fb0 fb1)) - (bs (Alist-Bag-Sum b0 b1))) - (unless (and (verify fbs) (equal? fbs (convert 'wb-bag bs :from-type 'alist :compare-fn-name fb0-cfn))) - (error "Bag-sum failed on iteration ~D " i))) - (let ((fbp (bag-product fb0 fb1)) - (bp (Alist-Bag-Product b0 b1))) - (unless (and (verify fbp) (equal? fbp (convert 'wb-bag bp :from-type 'alist :compare-fn-name fb0-cfn))) - (error "Bag-product failed on iteration ~D " i))) + (flet ((check-result (result label &optional ref) + (unless (or (null ref) (equal? result ref)) + (error "~A failed on iteration ~D" label i)) + (let ((bad (gmap :or (fn (x _c) (let ((val? val (lookup result x))) + (and val? (not (eq x val)) x))) + (:arg bag-pairs fb0)))) + (when bad + (error "~A failed left preference on iteration ~D: ~A" label i bad))))) + (let ((fbu (union fb0 fb1)) + (bu (Alist-Bag-Union b0 b1))) + (unless (and (verify fbu) (equal? fbu (convert 'wb-bag bu :from-type 'alist :compare-fn-name fb0-cfn))) + (error "Bag union failed on iteration ~D" i)) + (check-result fbu "Bag union")) + (let ((fbsu (union fb0 (convert 'set fb1))) + (fbbu (union fb0 (convert 'bag (convert 'set fb1))))) + (check-result fbsu "Bag-set union" fbbu)) + (let ((fsbu (union (convert 'set fb0) fb1)) + (fbbu (union (convert 'bag (convert 'set fb0)) fb1))) + (check-result fsbu "Set-bag union" fbbu)) + (let ((fbi (intersection fb0 fb1)) + (bi (Alist-Bag-Intersection b0 b1))) + (unless (and (verify fbi) (equal? fbi (convert 'wb-bag bi :from-type 'alist :compare-fn-name fb0-cfn))) + (error "Bag intersection failed on iteration ~D " i)) + (check-result fbi "Bag intersection")) + (let ((fbsi (intersection fb0 (convert 'set fb1))) + (fbbi (convert 'set (intersection fb0 (convert 'bag (convert 'set fb1)))))) + (check-result fbsi "Bag-set intersection" fbbi)) + (let ((fsbi (intersection (convert 'set fb0) fb1)) + (fbbi (convert 'set (intersection (convert 'bag (convert 'set fb0)) fb1)))) + (check-result fsbi "Set-bag intersection" fbbi)) + (let ((fbd (bag-difference fb0 fb1)) + (bd (Alist-Bag-Difference b0 b1))) + (unless (and (verify fbd) (equal? fbd (convert 'wb-bag bd :from-type 'alist :compare-fn-name fb0-cfn))) + (error "Bag difference failed on iteration ~D " i)) + (check-result fbd "Bag difference")) + (let ((fbsd (bag-difference fb0 (convert 'set fb1))) + (fbbd (bag-difference fb0 (convert 'bag (convert 'set fb1))))) + (check-result fbsd "Bag-set difference" fbbd)) + (let ((fsbd (bag-difference (convert 'set fb0) fb1)) + (fbbd (bag-difference (convert 'bag (convert 'set fb0)) fb1))) + (check-result fsbd "Set-bag difference" fbbd)) + (let ((fbs (bag-sum fb0 fb1)) + (bs (Alist-Bag-Sum b0 b1))) + (unless (and (verify fbs) (equal? fbs (convert 'wb-bag bs :from-type 'alist :compare-fn-name fb0-cfn))) + (error "Bag sum failed on iteration ~D " i)) + (check-result fbs "Bag sum")) + (let ((fbss (bag-sum fb0 (convert 'set fb1))) + (fbbs (bag-sum fb0 (convert 'bag (convert 'set fb1))))) + (check-result fbss "Bag-set sum" fbbs)) + (let ((fsbs (bag-sum (convert 'set fb0) fb1)) + (fbbs (bag-sum (convert 'bag (convert 'set fb0)) fb1))) + (check-result fsbs "Set-bag sum" fbbs)) + (let ((fbp (bag-product fb0 fb1)) + (bp (Alist-Bag-Product b0 b1))) + (unless (and (verify fbp) (equal? fbp (convert 'wb-bag bp :from-type 'alist :compare-fn-name fb0-cfn))) + (error "Bag product failed on iteration ~D " i)) + (check-result fbp "Bag product")) + (let ((fbsp (bag-product fb0 (convert 'set fb1))) + (fbbp (bag-product fb0 (convert 'bag (convert 'set fb1))))) + (check-result fbsp "Bag-set product" fbbp)) + (let ((fsbp (bag-product (convert 'set fb0) fb1)) + (fbbp (bag-product (convert 'bag (convert 'set fb0)) fb1))) + (check-result fsbp "Set-bag product" fbbp))) (when (eq fb0-cfn fb1-cfn) (let ((fb0a (less fb0 (Pick fb0))) (fb0b (less fb0 (Pick fb0)))) @@ -3091,8 +3519,15 @@ (define-hash-function erapmoc hash-value-negated) (Map-Compare (convert 'alist fb1a) (convert 'alist fb1b) (eq (compare-fn-name fb1) 'erapmoc))) (error "Bag compare failed (fb1) on iteration ~D" i)))) + (unless (gmap (:result and) (fn (x _n i) + (and (eql (index fb0 x) i) + (equal? x (at-index fb0 i)))) + (:arg bag-pairs fb0) + (:arg index 0 (size fb0))) + (error "Bag index, at-index, or iterator failed")) (unless (gmap (:result and) (fn (x n i) (and (eql (rank fb0 x) i) + (eql (fset2:rank fb0 x) i) (let ((rx rn (at-rank fb0 i))) (and (equal? x rx) (= n rn))))) @@ -3106,9 +3541,12 @@ (define-hash-function erapmoc hash-value-negated) r)))) (let ((ri (make-my-integer r)) ((fb0a (with fb0 ri)) - (ri-rank (rank fb0 ri)))) + (ri-rank (rank fb0 ri)) + (ri-rank2 (fset2:rank fb0 ri)))) (unless (= (1+ ri-rank) (rank fb0a ri)) - (error "Bag rank of non-member failed: ~A ~A" r fb0)))) + (error "Bag rank of non-member failed: ~A ~A" r fb0)) + (unless (= ri-rank2 (rank fb0a ri)) + (error "Bag fset2:rank of non-member failed: ~A ~A" r fb0)))) fb0)) @@ -3152,7 +3590,9 @@ (define-hash-function erapmoc hash-value-negated) (unless (verify tmp) (error "Seq verify (fs0) failed on iteration ~D (~A ~D ~D)" i (case which (0 "update") (1 "delete") (t "insert")) pos r)) - (setq fs0 tmp))) + (setq fs0 tmp) + ;; Can't say much about `hash-value', but at least we can check that it doesn't crash. + (hash-value fs0))) (dotimes (j 100) (let ((r (Make-My-Integer (random 200))) (pos (if (null s1) 0 (random (length s1)))) @@ -3178,6 +3618,8 @@ (define-hash-function erapmoc hash-value-negated) (error "Seq equality failed (fs0, A), on iteration ~D" i)) (unless (equal? fs0 (convert 'seq s0)) (error "Seq equality failed (fs0, B), on iteration ~D" i)) + (unless (equal? fs0 (convert 'seq (reverse s0) :reverse? t)) + (error "Seq reverse convert from list failed on iteration ~D" i)) (unless (gmap (:result and) #'equal? (:arg seq fs0) (:arg list s0)) (error "Seq iterator failed on iteration ~D" i)) (unless (equal? (gmap (:result list) nil (:arg fun-sequence fs0)) @@ -3245,8 +3687,8 @@ (define-hash-function erapmoc hash-value-negated) :start s :end e :key #'My-Integer-Value) (find (My-Integer-Value r) fs1 :start s :end e :key #'My-Integer-Value)) - (eql (find r s1 :start s :end e :test #'less-than?) - (find r fs1 :start s :end e :test #'less-than?)) + (eql (find r s1 :start s :end e :test (fn (a b) (less-than?-cmp a b #'compare))) + (find r fs1 :start s :end e :test (fn (a b) (less-than?-cmp a b #'compare)))) (eql (find (My-Integer-Value r) s1 :start s :end e :key #'My-Integer-Value :test #'>) (find (My-Integer-Value r) fs1 @@ -3303,12 +3745,6 @@ (define-hash-function erapmoc hash-value-negated) (when (eq cmp ':unequal) (setq unequal? t)))))))) -(defun less?-cmp (x y cmp) - (eq ':less (funcall cmp x y))) - -(defun greater?-cmp (x y cmp) - (eq ':greater (funcall cmp x y))) - (defun Map-Compare (m1 m2 keys-reversed?) ;; Rather too hairy to be a good reference implementation. Seems to be ;; correct, though. @@ -3348,10 +3784,8 @@ (define-hash-function erapmoc hash-value-negated) (let ((pr2 (assoc (car pr1) g2))) (and pr2 (= (cdr pr1) (cdr pr2))))) g1) - (let ((vals1 (reduce #'with (mapcar #'cdr g1) - :initial-value (empty-set))) - (vals2 (reduce #'with (mapcar #'cdr g2) - :initial-value (empty-set))) + (let ((vals1 (convert 'wb-set (mapcar #'cdr g1))) + (vals2 (convert 'wb-set (mapcar #'cdr g2))) ((comp (compare vals1 vals2)))) (if (eq comp ':equal) (setq result ':unequal) @@ -3698,9 +4132,12 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (test (equal? (union (complement (set 1 2 3 4 6)) (complement (set 2 5 6 7 8))) (complement (set 2 6)))) - (test (equal? (union (set 1 2 3) - (complement (set 3 5 7))) + (test (equal? (union (set 1 2 3) (complement (set 3 5 7))) (complement (set 5 7)))) + (test (equal? (union (set 1 2 3) (complement (ch-set 3 5 7))) + (complement (set 5 7)))) + (test (equal? (union (ch-set 1 2 3) (complement (ch-set 3 5 7))) + (complement (ch-set 5 7)))) (test (equal? (union (complement (set 3 5 7)) (set 1 2 3)) (complement (set 5 7)))) @@ -3750,85 +4187,124 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (macrolet ((test (form) `(unless ,form (error "Test failed: ~S" ',form)))) - (declare (notinline empty-2-relation empty-wb-2-relation)) - (test (equal? (empty-2-relation) (empty-2-relation))) - (test (empty? (empty-2-relation))) - (test (eql (size (empty-2-relation)) 0)) - (test (eql (size (2-relation (2 3) (2 4) (2 5))) 3)) - (test (equal (multiple-value-list (arb (empty-2-relation))) '(nil nil nil))) - (test (equal (multiple-value-list (arb (2-relation (1 2)))) + ;; WB + (test (equal? (empty-wb-2-relation) (empty-wb-2-relation))) + (test (empty? (empty-wb-2-relation))) + (test (eql (size (empty-wb-2-relation)) 0)) + (test (eql (size (wb-2-relation (2 3) (2 4) (2 5))) 3)) + (test (equal (multiple-value-list (arb (empty-wb-2-relation))) '(nil nil nil))) + (test (equal (multiple-value-list (arb (wb-2-relation (1 2)))) '(1 2 t))) - (test (contains? (2-relation (1 2) (1 3) (4 7)) 1 2)) - (test (not (contains? (2-relation (1 2)) 1 3))) - (test (equal? (lookup (empty-2-relation) 1) (set))) - (test (equal? (lookup (2-relation (1 2)) 1) (set 2))) - (test (equal? (lookup-inv (2-relation (1 2)) 2) (set 1))) - (test (equal? (domain (2-relation (1 2))) (set 1))) - (test (equal? (range (2-relation (1 2))) (set 2))) - (test (equal? (inverse (empty-2-relation)) (empty-2-relation))) - (test (equal? (inverse (2-relation (1 2))) - (2-relation (2 1)))) - - (test (equal (multiple-value-list (least (empty-2-relation))) + (test (contains? (wb-2-relation (1 2) (1 3) (4 7)) 1 2)) + (test (not (contains? (wb-2-relation (1 2)) 1 3))) + (test (equal? (lookup (empty-wb-2-relation) 1) (set))) + (test (equal? (lookup (wb-2-relation (1 2)) 1) (set 2))) + (test (equal? (lookup-inv (wb-2-relation (1 2)) 2) (set 1))) + (test (equal? (domain (wb-2-relation (1 2))) (set 1))) + (test (equal? (range (wb-2-relation (1 2))) (set 2))) + (test (equal? (inverse (empty-wb-2-relation)) (empty-wb-2-relation))) + (test (equal? (inverse (wb-2-relation (1 2))) + (wb-2-relation (2 1)))) + (hash-value (wb-2-relation (1 3) (1 7) (1 19) (1 32) (1 33) (1 47) (1 53) + (1 59) (1 61))) + (test (equal? (wb-2-relation (1 7) (($ (set 4 9)) 2) (($ (set 3 6)) ($ (set 8 12))) + (7 ($ (set 11 13)))) + (wb-2-relation (1 7) (4 2) (3 8) (3 12) (6 8) (6 12) (7 11) (7 13) (9 2)))) + + (test (equal (multiple-value-list (least (empty-wb-2-relation))) '(nil nil nil))) - (test (equal? (multiple-value-list (least (2-relation (1 2) (3 4)))) + (test (equal? (multiple-value-list (least (wb-2-relation (1 2) (3 4)))) (list 1 (set 2) t))) - (test (equal (multiple-value-list (greatest (empty-2-relation))) + (test (equal (multiple-value-list (greatest (empty-wb-2-relation))) '(nil nil nil))) - (test (equal? (multiple-value-list (greatest (2-relation (1 2) (3 4)))) + (test (equal? (multiple-value-list (greatest (wb-2-relation (1 2) (3 4)))) (list 3 (set 4) t))) - (test (= 1 (size (with (2-relation (1 2)) 1 2)))) - (test (equal? (2-relation (1 2) (1 3)) - (inverse (2-relation (3 1) (2 1))))) - (test (equal? (with (2-relation (1 2)) '(1 . 3)) - (convert '2-relation '((1 . 2) (1 . 3))))) - (test (equal? (with (2-relation (1 2)) 3 4) - (convert '2-relation '((1 . 2) (3 . 4))))) - (test (equal? (with (2-relation (1 2) (5 3)) 4 3) - (convert '2-relation '((1 . 2) (5 . 3) (4 . 3))))) - - (test (equal? (less (empty-2-relation) 1 2) (empty-2-relation))) - (test (equal? (less (2-relation (1 2)) '(1 . 2)) (empty-2-relation))) - (test (equal? (less (2-relation (1 2)) 1 3) - (2-relation (1 2)))) - (test (equal? (less (2-relation (1 2) (1 3)) 1 3) - (2-relation (1 2)))) - (test (equal? (less (2-relation (2 1) (3 1)) 3 1) - (2-relation (2 1)))) - - (test (equal? (union (empty-2-relation) (empty-2-relation)) (empty-2-relation))) - (test (equal? (union (2-relation (1 2)) (empty-2-relation)) - (2-relation (1 2)))) - (test (equal? (2-relation (1 2)) - (union (2-relation (1 2)) (empty-2-relation)))) - (test (equal? (union (2-relation (1 2)) (2-relation (1 2))) - (2-relation (1 2)))) - (test (equal? (union (2-relation (1 2)) (2-relation (1 3))) - (2-relation (1 2) (1 3)))) - (test (equal? (union (2-relation (2 1)) (2-relation (3 1))) - (2-relation (2 1) (3 1)))) - (test (equal? (union (wb-custom-2-relation 'erapmoc 'erapmoc (3 1)) (2-relation (2 1))) + (test (= 1 (size (with (wb-2-relation (1 2)) 1 2)))) + (test (equal? (wb-2-relation (1 2) (1 3)) + (inverse (wb-2-relation (3 1) (2 1))))) + (test (equal? (with (wb-2-relation (1 2)) '(1 . 3)) + (convert 'wb-2-relation '((1 . 2) (1 . 3))))) + (test (equal? (with (wb-2-relation (1 2)) 3 4) + (convert 'wb-2-relation '((1 . 2) (3 . 4))))) + (test (equal? (with (wb-2-relation (1 2) (5 3)) 4 3) + (convert 'wb-2-relation '((1 . 2) (5 . 3) (4 . 3))))) + (let ((rel (wb-2-relation (1 2) (2 3)))) + (inverse rel) + (let ((rel1 (with (with rel 1 3) 4 7))) + (verify rel1) + (test (equal? (image rel1 (set 1 4)) (wb-set (wb-set 2 3) (wb-set 7)))))) + (let ((rel (wb-2-relation (1 2) (2 3)))) + (inverse rel) + (let ((rel1 (with (with rel 1 3) 4 7))) + (verify rel1) + (test (equal? (image (inverse rel1) (wb-set 2 3)) (wb-set (wb-set 1) (wb-set 1 2)))))) + (let ((rela (wb-2-relation (1 3) (1 7) (1 19) (1 32) (1 33) (1 47) (1 53) + (1 59) (1 61))) + ((relb (with rela 1 67)))) + (test (= (size (union rela relb)) (size relb)))) + + (test (equal? (less (empty-wb-2-relation) 1 2) (empty-wb-2-relation))) + (test (equal? (less (wb-2-relation (1 2)) '(1 . 2)) (empty-wb-2-relation))) + (test (equal? (less (wb-2-relation (1 2)) 1 3) + (wb-2-relation (1 2)))) + (test (equal? (less (wb-2-relation (1 2) (1 3)) 1 3) + (wb-2-relation (1 2)))) + (test (equal? (less (wb-2-relation (2 1) (3 1)) 3 1) + (wb-2-relation (2 1)))) + (let ((rel (wb-2-relation (1 2) (2 3)))) + (inverse rel) + (let ((rel1 (with (less rel 1 2) 4 7))) + (verify rel1) + (test (equal? (image rel1 (wb-set 2 4)) (wb-set (wb-set 3) (wb-set 7)))))) + (let ((rel (wb-2-relation (1 2) (2 3)))) + (inverse rel) + (let ((rel1 (with (less rel 1 2) 4 3))) + (verify rel1) + (test (equal? (image (inverse rel1) (wb-set 3)) (wb-set (wb-set 2 4)))))) + + (test (equal? (union (empty-wb-2-relation) (empty-wb-2-relation)) (empty-wb-2-relation))) + (test (equal? (union (wb-2-relation (1 2)) (empty-wb-2-relation)) + (wb-2-relation (1 2)))) + (test (equal? (wb-2-relation (1 2)) + (union (wb-2-relation (1 2)) (empty-wb-2-relation)))) + (test (equal? (union (wb-2-relation (1 2)) (wb-2-relation (1 2))) + (wb-2-relation (1 2)))) + (test (equal? (union (wb-2-relation (1 2)) (wb-2-relation (1 3))) + (wb-2-relation (1 2) (1 3)))) + (test (equal? (union (wb-2-relation (2 1)) (wb-2-relation (3 1))) + (wb-2-relation (2 1) (3 1)))) + (test (equal? (union (wb-custom-2-relation 'erapmoc 'erapmoc (3 1)) (wb-2-relation (2 1))) (wb-custom-2-relation 'erapmoc 'erapmoc (2 1) (3 1)))) - - (test (equal? (intersection (empty-2-relation) (empty-2-relation)) (empty-2-relation))) - (test (equal? (intersection (2-relation (1 2)) (empty-2-relation)) (empty-2-relation))) - (test (equal? (intersection (empty-2-relation) (2-relation (1 2))) (empty-2-relation))) - (test (equal? (intersection (2-relation (3 4)) (2-relation (1 2))) (empty-2-relation))) - (test (equal? (intersection (2-relation (1 2)) (2-relation (1 2))) - (2-relation (1 2)))) - (test (equal? (intersection (2-relation (1 2)) (2-relation (1 3))) (empty-2-relation))) - (test (equal? (intersection (2-relation (2 1)) (2-relation (3 1))) (empty-2-relation))) - (test (equal? (intersection (2-relation ('a 7) ('b 12) ('c 17)) (2-relation ('b 12) ('c 22))) - (2-relation ('b 12)))) + (let ((rel (wb-2-relation (1 2) (1 3) (2 3)))) + (inverse rel) + (let ((rel1 (union rel (wb-2-relation (4 3))))) + (verify rel1) + (test (equal? (image (inverse rel1) (wb-set 3)) (wb-set (wb-set 1 2 4)))))) + + (test (equal? (intersection (empty-wb-2-relation) (empty-wb-2-relation)) (empty-wb-2-relation))) + (test (equal? (intersection (wb-2-relation (1 2)) (empty-wb-2-relation)) (empty-wb-2-relation))) + (test (equal? (intersection (empty-wb-2-relation) (wb-2-relation (1 2))) (empty-wb-2-relation))) + (test (equal? (intersection (wb-2-relation (3 4)) (wb-2-relation (1 2))) (empty-wb-2-relation))) + (test (equal? (intersection (wb-2-relation (1 2)) (wb-2-relation (1 2))) + (wb-2-relation (1 2)))) + (test (equal? (intersection (wb-2-relation (1 2)) (wb-2-relation (1 3))) (empty-wb-2-relation))) + (test (equal? (intersection (wb-2-relation (2 1)) (wb-2-relation (3 1))) (empty-wb-2-relation))) + (test (equal? (intersection (wb-2-relation ('a 7) ('b 12) ('c 17)) (wb-2-relation ('b 12) ('c 22))) + (wb-2-relation ('b 12)))) (test (equal? (intersection (wb-custom-2-relation 'erapmoc 'erapmoc ('a 7) ('b 12) ('c 17)) - (2-relation ('b 12) ('c 22))) + (wb-2-relation ('b 12) ('c 22))) (wb-custom-2-relation 'erapmoc 'erapmoc ('b 12)))) - - (test (equal? (join (2-relation ('a 3) ('a 5) ('b 7) ('b 8)) 1 - (2-relation (3 "yo") (7 "eek") (7 "mrr")) 0) - (2-relation ('a "yo") ('b "eek") ('b "mrr")))) + (let ((rel (wb-2-relation (1 2) (1 3) (2 3)))) + (inverse rel) + (let ((rel1 (intersection rel (wb-2-relation (1 3) (4 3))))) + (verify rel1) + (test (equal? (image (inverse rel1) (wb-set 3)) (wb-set (wb-set 1)))))) + + (test (equal? (join (wb-2-relation ('a 3) ('a 5) ('b 7) ('b 8)) 1 + (wb-2-relation (3 "yo") (7 "eek") (7 "mrr")) 0) + (wb-2-relation ('a "yo") ('b "eek") ('b "mrr")))) (test (equal? (convert 'list (join (wb-custom-2-relation 'erapmoc 'erapmoc ('a 3) ('a 5) ('b 7) ('b 8)) 1 (wb-2-relation (3 "hey") (7 "eek") (7 "mrr")) 0)) '((b . "eek") (b . "mrr") (a . "hey")))) @@ -3839,25 +4315,34 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (wb-custom-2-relation 'erapmoc 'erapmoc ('a 3) ('a 5) ('b 7) ('b 8)) 1)) '(("eek" . b) ("mrr" . b) ("mrr" . a)))) - (test (equal? (compose (2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8)) #'1+) - (2-relation ('a 4) ('a 6) ('b 4) ('c 5) ('c 9)))) - (test (equal? (compose (2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8)) - (map (3 7) (4 6) (5 11) (8 15))) - (2-relation ('a 7) ('a 11) ('b 7) ('c 6) ('c 15)))) + (test (equal? (convert 'wb-2-relation (set '(a . 85) '(b . 17) '(b . 280) '(b . 880))) + (wb-2-relation ('a 85) ('b 17) ('b 280) ('b 880)))) - (test (equal? (image (2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8)) + (test (equal? (compose (wb-2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8)) #'1+) + (wb-2-relation ('a 4) ('a 6) ('b 4) ('c 5) ('c 9)))) + (test (equal? (compose (wb-2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8)) + (map (3 7) (4 6) (5 11) (8 15))) + (wb-2-relation ('a 7) ('a 11) ('b 7) ('c 6) ('c 15)))) + (test (equal? (compose (wb-2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8)) + (seq 0 1 2 7 6 11 6 7 15)) + (wb-2-relation ('a 7) ('a 11) ('b 7) ('c 6) ('c 15)))) + (test (equal? (compose (wb-2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8)) + (wb-2-relation (3 7) (3 9) (5 11) (8 15))) + (wb-2-relation ('a 7) ('a 9) ('a 11) ('b 7) ('b 9) ('c 15)))) + + (test (equal? (image (wb-2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8)) (set 'a 'c)) (set (set 3 5) (set 4 8)))) - (test (equal? (convert 'list (2-relation ('a 3) ('a 5) ('b 7) ('b 8))) + (test (equal? (convert 'list (wb-2-relation ('a 3) ('a 5) ('b 7) ('b 8))) '((a . 3) (a . 5) (b . 7) (b . 8)))) (test (equal? (convert 'list (wb-custom-2-relation 'erapmoc 'erapmoc ('a 3) ('a 5) ('b 7) ('b 8))) '((b . 8) (b . 7) (a . 5) (a . 3)))) (test (equal? (gmap (:result list) #'cons - (:arg 2-relation (wb-custom-2-relation 'erapmoc 'erapmoc ('a 3) ('a 5) ('b 7) ('b 8)))) + (:arg wb-2-relation (wb-custom-2-relation 'erapmoc 'erapmoc ('a 3) ('a 5) ('b 7) ('b 8)))) '((b . 8) (b . 7) (a . 5) (a . 3)))) (test (equal? (gmap (:result list) #'cons - (:arg 2-relation (wb-2-relation ('a 3) ('a 5) ('b 7) ('b 8)))) + (:arg wb-2-relation (wb-2-relation ('a 3) ('a 5) ('b 7) ('b 8)))) '((a . 3) (a . 5) (b . 7) (b . 8)))) (test (equal? (gmap (:result list) #'cons (:arg fun-2-relation (wb-custom-2-relation 'erapmoc 'erapmoc ('a 3) ('a 5) ('b 7) ('b 8)))) @@ -3872,31 +4357,41 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (wb-custom-2-relation 'erapmoc 'erapmoc ('a 3) ('a 5) ('b 3) ('c 4)))) (test (equal? (convert 'set (wb-2-relation ('a 3) ('a 5) ('b 3) ('c 4))) (set '(a . 3) '(a . 5) '(b . 3) '(c . 4)))) - (test (equal? (convert '2-relation (map ('a 5) ('b 3) ('c 4))) - (2-relation ('a 5) ('b 3) ('c 4)))) + (test (equal? (convert 'wb-2-relation (seq '(a . 3) '(a . 5) '(b . 3) '(c . 4))) + (wb-2-relation ('a 3) ('a 5) ('b 3) ('c 4)))) + (test (equal? (convert 'wb-2-relation (map ('a 5) ('b 3) ('c 4))) + (wb-2-relation ('a 5) ('b 3) ('c 4)))) (test (equal? (convert '2-relation (map ('a (set 3 5)) ('b (set 2)) ('c (set 4 7))) :from-type 'map-to-sets) - (2-relation ('a 3) ('a 5) ('b 2) ('c 4) ('c 7)))) + (wb-2-relation ('a 3) ('a 5) ('b 2) ('c 4) ('c 7)))) (test (handler-case (progn - (convert 'map (2-relation ('a 3) ('b 2) ('c 4) ('c 7))) + (convert 'map (wb-2-relation ('a 3) ('b 2) ('c 4) ('c 7))) nil) (error () t))) - (test (equal? (convert 'map (2-relation ('a 3) ('b 2) ('c 4))) + (test (equal? (convert 'map (wb-2-relation ('a 3) ('b 2) ('c 4))) + (map ('a 3) ('b 2) ('c 4)))) + (test (equal? (convert 'wb-map (wb-2-relation ('a 3) ('b 2) ('c 4))) (map ('a 3) ('b 2) ('c 4)))) - (test (equal? (convert 'map-to-sets (2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8))) + (test (equal? (convert 'map-to-sets (wb-2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8))) (map ('a (set 3 5)) ('b (set 3)) ('c (set 4 8))))) - - (test (equal? (conflicts (2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8))) - (2-relation ('a 3) ('a 5) ('c 4) ('c 8)))) - - (test (eq (compare (2-relation ('a 3) ('a 5) ('b 6) ('b 8)) - (2-relation ('a 3) ('a 5) ('b 7) ('b 8))) + (let ((conv (convert 'map-to-sets (wb-custom-2-relation 'compare 'int-compare + ('a 3) ('a 5) ('b 3) ('c 4) ('c 8))))) + (test (gmap :and (fn (k s) (equal? s (@ conv k))) + (:arg map (wb-custom-map nil 'eql-compare + ('a (wb-custom-set 'int-compare 3 5)) ('b (wb-custom-set 'int-compare 3)) + ('c (wb-custom-set 'int-compare 4 8))))))) + + (test (equal? (conflicts (wb-2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8))) + (wb-2-relation ('a 3) ('a 5) ('c 4) ('c 8)))) + + (test (eq (compare (wb-2-relation ('a 3) ('a 5) ('b 6) ('b 8)) + (wb-2-relation ('a 3) ('a 5) ('b 7) ('b 8))) ':less)) - (test (eq (compare (2-relation ('a 3) ('a 5) ('b 7) ('b 8)) - (2-relation ('a 3) ('a 5) ('b 6) ('b 8))) + (test (eq (compare (wb-2-relation ('a 3) ('a 5) ('b 7) ('b 8)) + (wb-2-relation ('a 3) ('a 5) ('b 6) ('b 8))) ':greater)) - (test (equal? (transitive-closure (2-relation (1 3) (1 4) (3 7) (3 8) (4 11) (5 14) (6 12) (11 23)) + (test (equal? (transitive-closure (wb-2-relation (1 3) (1 4) (3 7) (3 8) (4 11) (5 14) (6 12) (11 23)) (set 1)) (set 1 3 4 7 8 11 23))) @@ -3928,6 +4423,16 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (convert 'ch-2-relation '((1 . 2) (3 . 4))))) (test (equal? (with (ch-2-relation (1 2) (5 3)) 4 3) (convert 'ch-2-relation '((1 . 2) (5 . 3) (4 . 3))))) + (let ((rel (ch-2-relation (1 2) (2 3)))) + (inverse rel) + (test (equal? (image (with (with rel 1 3) 4 7) (ch-set 1 4)) (ch-set (ch-set 2 3) (ch-set 7))))) + (let ((rel (ch-2-relation (1 2) (2 3)))) + (inverse rel) + (test (equal? (image (inverse (with (with rel 1 3) 4 7)) (ch-set 2 3)) (ch-set (ch-set 1) (ch-set 1 2))))) + (let ((rela (ch-2-relation (1 3) (1 7) (1 19) (1 32) (1 33) (1 47) (1 53) + (1 59) (1 61))) + ((relb (with rela 1 67)))) + (test (= (size (union rela relb)) (size relb)))) (test (equal? (less (empty-ch-2-relation) 1 2) (empty-ch-2-relation))) (test (equal? (less (ch-2-relation (1 2)) '(1 . 2)) (empty-ch-2-relation))) @@ -3937,6 +4442,12 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (ch-2-relation (1 2)))) (test (equal? (less (ch-2-relation (2 1) (3 1)) 3 1) (ch-2-relation (2 1)))) + (let ((rel (ch-2-relation (1 2) (2 3)))) + (inverse rel) + (test (equal? (image (with (less rel 1 2) 4 7) (ch-set 2 4)) (ch-set (ch-set 3) (ch-set 7))))) + (let ((rel (ch-2-relation (1 2) (2 3)))) + (inverse rel) + (test (equal? (image (inverse (with (less rel 1 2) 4 3)) (ch-set 3)) (ch-set (ch-set 2 4))))) (test (equal? (union (empty-ch-2-relation) (empty-ch-2-relation)) (empty-ch-2-relation))) (test (equal? (union (ch-2-relation (1 2)) (empty-ch-2-relation)) @@ -3951,6 +4462,9 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (ch-2-relation (2 1) (3 1)))) (test (equal? (union (ch-custom-2-relation 'erapmoc 'erapmoc (3 1)) (ch-2-relation (2 1))) (ch-custom-2-relation 'erapmoc 'erapmoc (2 1) (3 1)))) + (let ((rel (ch-2-relation (1 2) (1 3) (2 3)))) + (inverse rel) + (test (equal? (image (inverse (union rel (ch-2-relation (4 3)))) (ch-set 3)) (ch-set (ch-set 1 2 4))))) (test (equal? (intersection (empty-ch-2-relation) (empty-ch-2-relation)) (empty-ch-2-relation))) (test (equal? (intersection (ch-2-relation (1 2)) (empty-ch-2-relation)) (empty-ch-2-relation))) @@ -3966,6 +4480,9 @@ (defmethod compare ((x My-Integer) (y My-Integer)) ('a 7) ('b 12) ('c 17)) (ch-2-relation ('b 12) ('c 22))) (ch-custom-2-relation 'erapmoc 'erapmoc ('b 12)))) + (let ((rel (ch-2-relation (1 2) (1 3) (2 3)))) + (inverse rel) + (test (equal? (image (inverse (intersection rel (ch-2-relation (1 3) (4 3)))) (ch-set 3)) (ch-set (ch-set 1))))) (test (equal? (join (ch-2-relation ('a 3) ('a 5) ('b 7) ('b 8)) 1 (ch-2-relation (3 "yo") (7 "eek") (7 "mrr")) 0) @@ -4045,8 +4562,8 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (macrolet ((test (form) `(unless ,form (error "Test failed: ~S" ',form)))) - (let ((3-rel (with (empty-list-relation) '(age lydia 27))) - (q-reg (empty-query-registry))) + (let ((3-rel (with (empty-wb-list-relation) '(age lydia 27))) + (q-reg (empty-wb-query-registry))) (test (= (arity 3-rel) 3)) (test (= (size 3-rel) 1)) (test (equal? (arb 3-rel) '(age lydia 27))) @@ -4080,7 +4597,9 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (test (equal? (lookup q-reg '(age riley 25)) (set 'query0 'query1))) (test (equal? (lookup-multi q-reg (list (set 'age 'eye-color) (set 'lydia) (set 27 'blue))) - (set 'query0 'query2)))) + (set 'query0 'query2))) + (test (equal? (gmap (:result set) nil (:arg wb-list-relation 3-rel)) + (set '(age lydia 27) '(age riley 25) '(eye-color riley blue) '(age dana 31))))) (let ((3-rel (with (empty-ch-list-relation 3) '(age lydia 27))) (q-reg (empty-ch-query-registry))) (test (= (arity 3-rel) 3)) @@ -4116,7 +4635,10 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (test (equal? (lookup q-reg '(age riley 25)) (ch-set 'query0 'query1))) (test (equal? (lookup-multi q-reg (list (ch-set 'age 'eye-color) (ch-set 'lydia) (ch-set 27 'blue))) - (ch-set 'query0 'query2)))))) + (ch-set 'query0 'query2))) + + (test (equal? (gmap (:result set) nil (:arg ch-list-relation 3-rel)) + (set '(age lydia 27) '(age riley 25) '(eye-color riley blue) '(age dana 31))))))) ;;; ---------------- @@ -4136,32 +4658,32 @@ (defmethod verify ((s wb-seq)) (WB-Seq-Tree-Verify (wb-seq-contents s))) (defmethod verify ((br wb-2-relation)) - ;; Slow, but thorough. - (and (WB-Map-Tree-Verify (wb-2-relation-map0 br) #'compare) - (WB-Map-Tree-Verify (wb-2-relation-map1 br) #'compare) - (let ((size 0)) - (and (Do-WB-Map-Tree-Pairs (x s (wb-2-relation-map0 br) t) - (WB-Set-Tree-Verify s #'compare) - (incf size (WB-Set-Tree-Size s)) - (or (null (wb-2-relation-map1 br)) - (Do-WB-Set-Tree-Members (y s) - (let ((ignore s1 (WB-Map-Tree-Lookup (wb-2-relation-map1 br) y #'compare))) - (declare (ignore ignore)) - (unless (WB-Set-Tree-Contains? s1 x #'compare) - (format *debug-io* "Map discrepancy in wb-2-relation") - (return nil)))))) - (or (= size (wb-2-relation-size br)) - (progn (format *debug-io* "Size discrepancy in wb-2-relation") - nil)))) - (or (null (wb-2-relation-map1 br)) - (let ((size 0)) - (Do-WB-Map-Tree-Pairs (x s (wb-2-relation-map1 br)) - (declare (ignore x)) - (WB-Set-Tree-Verify s #'compare) - (incf size (WB-Set-Tree-Size s))) - (or (= size (wb-2-relation-size br)) - (progn (format *debug-io* "Size discrepancy in wb-2-relation") - nil)))))) + (let ((org (wb-2-relation-org br)) + (map0 (wb-2-relation-map0 br)) + (map1 (wb-2-relation-map1 br)) + ((map0-cmp-fn (tree-map-org-key-compare-fn org)) + (map1-cmp-fn (tree-map-org-val-compare-fn org)))) + (and (WB-Map-Tree-Verify map0 map0-cmp-fn) + (let ((size 0)) + (and (Do-WB-Map-Tree-Pairs (x ys (wb-2-relation-map0 br) t) + (WB-Set-Tree-Verify ys map1-cmp-fn) + (incf size (WB-Set-Tree-Size ys)) + (or (null map1) + (and (Do-WB-Set-Tree-Members (y ys t) + (unless (WB-Map-Tree-Lookup map1 y map1-cmp-fn) + (cerror "Ignore and proceed." + "No inverse entry for ~S, found in value set for ~S" y x)))))) + (or (= size (wb-2-relation-size br)) + (cerror "Ignore and proceed." + "Size discrepancy in wb-2-relation: expected ~D, found ~D" + size (wb-2-relation-size br))))) + (or (null map1) + (and (WB-Map-Tree-Verify map1 map1-cmp-fn) + (Do-WB-Map-Tree-Pairs (y xs map1 t) + (Do-WB-Set-Tree-Members (x xs) + (unless (WB-Map-Tree-Lookup map0 x map0-cmp-fn) + (cerror "Ignore and proceed." + "No entry for ~S, found in inverse value set for ~S" x y))))))))) (defun Time-Seq-Iter (seq n) @@ -4192,6 +4714,12 @@ (defmethod hash-value ((x my-integer)) (defmethod verify ((s ch-set)) (ch-set-tree-verify (ch-set-contents s) (hash-set-org-hash-fn (ch-set-org s)))) +(defparameter *seq-of-symbols* + (let ((syms (seq))) + (do-external-symbols (sym :cl) + (push-last syms sym)) + syms)) + (defun test-champ-sets (n) (declare (optimize (speed 0) (debug 3))) (macrolet ((test (form) @@ -4203,9 +4731,14 @@ (defmethod verify ((s ch-set)) (when (zerop (mod i 10)) (format t ".")) (let ((wbs (wb-set)) - (chs (ch-set))) - (dotimes (j 256) - (let ((mi (make-my-integer (random 1024))) + (chs (ch-set)) + (use-seq-of-symbols? (= 7 (ldb (byte 3 1) i)))) + ;; I had this at 256, but that was too high: it forced almost all the maps to have four + ;; full or nearly-full levels, making certain scenarios improbable -- and bugs lurked there. + (dotimes (j (+ 64 (random 128))) + (let ((mi (if use-seq-of-symbols? + (@ *seq-of-symbols* (random (size *seq-of-symbols*))) + (make-my-integer (random 1024)))) (prev-wbs wbs) (prev-chs chs)) (test (eqv (contains? chs mi) (contains? wbs mi))) @@ -4232,23 +4765,28 @@ (defmethod verify ((s ch-set)) (includef elts (at-index chs k))) (unless (equal? elts wbs) (error "ch-set at-index failed"))) - (let ((idx (random (size chs))) - ((elt (at-index chs idx)) - ((tmp-chs (with (less chs elt) - ;; Adding 4096 doesn't change the hash value. - (make-my-integer (+ (my-integer-value elt) 4096))))))) - ;; `ch-set-tree-compare' is tough to test thoroughly. This at least checks the case that is - ;; least obviously correct by inspection, where all the hash values are the same but two elements - ;; nonetheless differ. - (test (and (eq (compare chs tmp-chs) ':less) - (eq (compare tmp-chs chs) ':greater)))) + (unless use-seq-of-symbols? + (let ((idx (random (size chs))) + ((elt (at-index chs idx)) + ((tmp-chs (with (less chs elt) + ;; Adding 4096 doesn't change the hash value. + (make-my-integer (+ (my-integer-value elt) 4096))))))) + ;; `ch-set-tree-compare' is tough to test thoroughly. This at least checks the case that is + ;; least obviously correct by inspection, where all the hash values are the same but two elements + ;; nonetheless differ. + (test (and (eq (compare chs tmp-chs) ':less) + (eq (compare tmp-chs chs) ':greater)))) + (let ((chs-p0 chs-p1 (partition (fn (x) (evenp (my-integer-value x))) chs)) + (wbs-p0 wbs-p1 (partition (fn (x) (evenp (my-integer-value x))) wbs))) + (test (equal? (convert 'wb-set chs-p0) wbs-p0)) + (test (equal? chs-p1 (convert 'ch-set wbs-p1)))) + (let ((chs-p0 chs-p1 (fset2:partition (fn (x) (evenp (my-integer-value x))) chs)) + (wbs-p0 wbs-p1 (fset2:partition (fn (x) (evenp (my-integer-value x))) wbs))) + (test (equal? (convert 'wb-set chs-p0) wbs-p0)) + (test (equal? chs-p1 (convert 'ch-set wbs-p1))))) (test (equal? chs (convert 'ch-set wbs))) (test (equal? chs (convert 'ch-set (convert 'seq wbs)))) (test (equal? chs (convert 'ch-set (convert 'vector wbs)))) - (let ((chs-p0 chs-p1 (partition (fn (x) (evenp (my-integer-value x))) chs)) - (wbs-p0 wbs-p1 (partition (fn (x) (evenp (my-integer-value x))) wbs))) - (test (equal? (convert 'wb-set chs-p0) wbs-p0)) - (test (equal? chs-p1 (convert 'ch-set wbs-p1)))) (let ((k 0) (it (iterator chs)) (f-it (fun-iterator chs))) @@ -4268,20 +4806,32 @@ (defmethod verify ((s ch-set)) (test (equal? (reverse (convert 'seq chs)) (gmap (:result seq) nil (:arg fun-sequence chs :from-end? t))))))) (when saved-chs - (let ((chs-union (union chs saved-chs))) - (test (verify chs-union)) - (test (equal? (convert 'wb-set chs-union) (union wbs saved-wbs)))) - (let ((chs-intersection (intersection chs saved-chs))) - (test (verify chs-intersection)) - (test (equal? (convert 'wb-set chs-intersection) (intersection wbs saved-wbs)))) - (let ((chs-diff (set-difference chs saved-chs))) - (test (verify chs-diff)) - (test (equal? (convert 'wb-set chs-diff) (set-difference wbs saved-wbs))) - (let ((chs-diff-2a chs-diff-2b (set-difference-2 chs saved-chs))) - (test (verify chs-diff-2a)) - (test (verify chs-diff-2b)) - (test (equal? chs-diff-2a chs-diff)) - (test (equal? chs-diff-2b (set-difference saved-chs chs)))))) + (flet ((check-pref (result label &optional right?) + (let ((bad (gmap :or (fn (x) (let ((sx? sx (lookup result x))) + (and sx? (not (eq x sx)) x))) + (:arg set (if right? saved-chs chs))))) + (when bad + (error "~A failed ~:[left~;right~] preference: ~A" + label right? bad))))) + (let ((chs-union (union chs saved-chs))) + (test (verify chs-union)) + (test (equal? (convert 'wb-set chs-union) (union wbs saved-wbs))) + (check-pref chs-union "Set union")) + (let ((chs-intersection (intersection chs saved-chs))) + (test (verify chs-intersection)) + (test (equal? (convert 'wb-set chs-intersection) (intersection wbs saved-wbs))) + (check-pref chs-intersection "Set intersection")) + (let ((chs-diff (set-difference chs saved-chs))) + (test (verify chs-diff)) + (test (equal? (convert 'wb-set chs-diff) (set-difference wbs saved-wbs))) + (check-pref chs-diff "Set difference") + (let ((chs-diff-2a chs-diff-2b (set-difference-2 chs saved-chs))) + (test (verify chs-diff-2a)) + (test (verify chs-diff-2b)) + (test (equal? chs-diff-2a chs-diff)) + (test (equal? chs-diff-2b (set-difference saved-chs chs))) + (check-pref chs-diff-2a "Set difference-2") + (check-pref chs-diff-2b "Set difference-2" t))))) ;; To get a good test for `disjoint?', we need different statistics -- choosing 256 out of 1024, ;; disjointness is astronomically unlikely. Choosing 55 out of 4096 gives roughly 50% odds. ;; (Why so few? The Birthday Paradox.) @@ -4309,12 +4859,16 @@ (defmethod verify ((m ch-map)) (dotimes (i n) (when (zerop (mod i 10)) (format t ".")) - (let ((wbm (wb-map)) - (chm (ch-map))) + (let ((cfn (if (zerop (mod i 4)) 'erapmoc 'compare)) + (wbm (wb-map)) + ((chm (ch-custom-map cfn nil))) + (use-seq-of-symbols? (= 7 (ldb (byte 3 1) i)))) (setq *champ-map-test-pairs* (seq)) - (dotimes (j 256) - (let ((mi (make-my-integer (random 1024))) - (val (random 65536)) + (dotimes (j (+ 64 (random 128))) + (let ((mi (if use-seq-of-symbols? + (@ *seq-of-symbols* (random (size *seq-of-symbols*))) + (make-my-integer (random 1024)))) + (val (make-my-integer (random 128))) (prev-wbm wbm) (prev-chm chm)) (test (eql (lookup chm mi) (lookup wbm mi))) @@ -4331,6 +4885,9 @@ (defmethod verify ((m ch-map)) (push-last *champ-map-test-pairs* (list '+ mi val)) (setf (@ wbm mi) val) (setf (@ chm mi) val))) + (when (< (random 100) 5) + ;; Cause value hashes to be cached, triggering incremental updating. + (hash-value chm)) (test (verify chm)) (when (let ((quot rem (floor j 32))) (and (= 0 rem) (>= quot 1))) @@ -4341,21 +4898,23 @@ (defmethod verify ((m ch-map)) (let ((ch-dom (domain chm))) (test (verify ch-dom)) (test (equal? (convert 'wb-set ch-dom) (domain wbm)))) - (let ((idx (random (size chm))) - ((elt (at-index chm idx)) - ((chm-less-elt tval (less chm elt)) - ((tmp-chm (with chm-less-elt - ;; Adding 4096 doesn't change the hash value. - (make-my-integer (+ (my-integer-value elt) 4096)) - (@ chm elt))))))) - (test (verify chm-less-elt)) - (test (equal? tval (@ chm elt))) - (test (verify tmp-chm)) - ;; `ch-map-tree-compare' is tough to test thoroughly. This at least checks the case that is - ;; least obviously correct by inspection, where all the hash values are the same but two elements - ;; nonetheless differ. - (test (eq (compare chm tmp-chm) ':less)) - (test (eq (compare tmp-chm chm) ':greater))) + (unless use-seq-of-symbols? + (let ((idx (random (size chm))) + ((elt (at-index chm idx)) + ((chm-less-elt tval (less chm elt)) + ((tmp-chm (with chm-less-elt + ;; Adding 4096 doesn't change the hash value. + (make-my-integer (+ (my-integer-value elt) 4096)) + (@ chm elt))))))) + (test (verify chm-less-elt)) + (test (equal? tval (@ chm elt))) + (test (verify tmp-chm)) + ;; `ch-map-tree-compare' is tough to test thoroughly. This at least checks the case that is + ;; least obviously correct by inspection, where all the hash values are the same but two elements + ;; nonetheless differ. + (when (eq (key-compare-fn-name chm) 'compare) + (test (eq (compare chm tmp-chm) ':less)) + (test (eq (compare tmp-chm chm) ':greater))))) (let ((k 0) (it (iterator chm)) (f-it (fun-iterator chm))) @@ -4375,30 +4934,43 @@ (defmethod verify ((m ch-map)) (test (funcall f-it ':empty?))) (test (equal? (reverse (convert 'seq chm)) (gmap (:result seq) #'cons (:arg fun-map chm :from-end? t))))))) - (flet ((filter-mod-20 (x y) + (flet ((filter-mod-8 (x y) (declare (ignore x)) - (if (zerop (mod y 20)) + (if (zerop (mod (my-integer-value y) 8)) (values nil ':no-value) - y))) + y)) + (check-pref (result source label &optional right?) + (let ((bad (gmap :or (fn (k v) (let ((mv mv? mk (lookup result k))) + (and mv? (or (not (eq k mk)) + (and (equal? v mv) (not (eql v mv)))) + k))) + (:arg map source)))) + (when bad + (error "~A failed ~:[left~;right~] preference on iteration ~D: ~A" + label right? i bad))))) (when saved-chm - (let ((chm-union (map-union chm saved-chm #'filter-mod-20))) + (let ((chm-union (map-union chm saved-chm #'filter-mod-8))) (test (verify chm-union)) - (let ((wbm-union (map-union wbm saved-wbm #'filter-mod-20)) + (let ((wbm-union (map-union wbm saved-wbm #'filter-mod-8)) ((chm-union-as-wbm (convert 'wb-map chm-union)))) (unless (equal? chm-union-as-wbm wbm-union) (let ((ch-only wb-only (map-difference-2 chm-union-as-wbm wbm-union))) - (error "ch-map union failed: ~A, ~A" ch-only wb-only))))) - (let ((chm-intersection (map-intersection chm saved-chm #'filter-mod-20))) + (error "ch-map union failed: ~A, ~A" ch-only wb-only)))) + (check-pref chm-union chm "Map union")) + (let ((chm-intersection (map-intersection chm saved-chm #'filter-mod-8))) (test (verify chm-intersection)) - (let ((wbm-intersection (map-intersection wbm saved-wbm #'filter-mod-20)) + (let ((wbm-intersection (map-intersection wbm saved-wbm #'filter-mod-8)) ((chm-int-as-wbm (convert 'wb-map chm-intersection)))) - (test (equal? chm-int-as-wbm wbm-intersection)))) + (test (equal? chm-int-as-wbm wbm-intersection))) + (check-pref chm-intersection chm "Map intersection")) (let ((chm-diff-2a chm-diff-2b (map-difference-2 chm saved-chm)) (wbm-diff-2a wbm-diff-2b (map-difference-2 wbm saved-wbm))) (test (verify chm-diff-2a)) (test (verify chm-diff-2b)) (test (equal? (convert 'wb-map chm-diff-2a) wbm-diff-2a)) - (test (equal? (convert 'wb-map chm-diff-2b) wbm-diff-2b))) + (test (equal? (convert 'wb-map chm-diff-2b) wbm-diff-2b)) + (check-pref chm-diff-2a chm "Map difference-2") + (check-pref chm-diff-2b saved-chm "Map difference-2" t)) ;; &&& `restrict' and `restrict-not' (let ((saved-chm-dom (domain saved-chm)) (saved-wbm-dom (domain saved-wbm)) @@ -4412,3 +4984,394 @@ (defmethod verify ((m ch-map)) (test (equal? (convert 'wb-map ch-neg) wb-neg))))) (setq saved-wbm wbm) (setq saved-chm chm)))))) + + +;;; ==================================================================================================== +;;; ==================================================================================================== + +;;; FSet2 testing + +(in-package :fset2) + +(define-tuple-key +k5+ :default 'plugh) +(define-tuple-key +k6+) + +(defun fset::test-fset2 () + (declare (optimize (debug 3))) + (test-fset2-gmap) + (macrolet ((test (form) + `(unless ,form + (error "Test failed: ~S" ',form))) + (test-error (form) + `(unless (handler-case (progn ,form nil) + (error () t)) + (error "Test-error failed: ~S" ',form)))) + #+sbcl + ;; Check that each shadowed GF has the same methods in `fset:' and `fset2:'. + (flet ((methods (gf) + (gmap (:result set) + (fn (method) (caddr (getf (slot-value method 'sb-pcl::plist) ':name))) + (:arg list (slot-value gf 'sb-pcl::methods))))) + (dolist (gf-name '(lookup map-union map-intersection map-difference-2 compose image filter partition + rank)) + (let ((fset-gf (symbol-function (intern (string gf-name) ':fset))) + (fset2-gf (symbol-function gf-name)) + ((missing extra (set-difference-2 (methods fset-gf) (methods fset2-gf))))) + (unless (and (empty? missing) (empty? extra)) + (error "Methods on ~A missing: ~A~:[~;~%extra: ~A~]" gf-name missing (nonempty? extra) extra)))) + ;; Also check that all the shadowed symbols used in `eql' specializers on `convert' work in `fset2:'. + (let ((convert-methods (methods #'convert)) + (all-missing (map)) + (all-extra (map))) + (dolist (to-type '(set map wb-map ch-map map-to-sets seq wb-seq)) + (let ((fset-sym (intern (string to-type) ':fset)) + (fset2-methods (image #'cdr (gmap (:result set :filterp (fn (x) (equal (car x) `(eql ,to-type)))) + nil (:arg set convert-methods)))) + ((fset-methods (image #'cdr (gmap (:result set :filterp (fn (x) (equal (car x) `(eql ,fset-sym)))) + nil (:arg set convert-methods)))) + ((missing extra (set-difference-2 fset-methods fset2-methods))))) + (when (nonempty? missing) + (setf (@ all-missing to-type) missing)) + (when (nonempty? extra) + (setf (@ all-extra to-type) extra)) + ;; Also, a GMap check. + (when (and (or (get fset-sym 'gmap::arg-type-expander) (get fset-sym 'gmap::arg-type-synonym)) + (not (or (get to-type 'gmap::arg-type-expander) (get to-type 'gmap::arg-type-synonym)))) + (error "fset:~A is a GMap arg type, but its fset2: version isn't" fset-sym)) + (when (and (or (get fset-sym 'gmap::res-type-expander) (get fset-sym 'gmap::res-type-synonym)) + (not (or (get to-type 'gmap::res-type-expander) (get to-type 'gmap::res-type-synonym)))) + (error "fset:~A is a GMap result type, but its fset2: version isn't" fset-sym)))) + (unless (and (empty? all-missing) (empty? all-extra)) + (error "Convert methods missing: ~A~:[~;~%extra: ~A~]" all-missing (nonempty? all-extra) all-extra)))) + ;; Just checking that these `lookup' methods exist + (let ((ls '(0 1 2 3 4 5 6 7 8 9))) + (test (equal (@ ls 'first) 0)) + (test (equal (with ls 'first 10) '(10 1 2 3 4 5 6 7 8 9))) + (test (equal (@ ls 'second) 1)) + (test (equal (with ls 'second 11) '(0 11 2 3 4 5 6 7 8 9))) + (test (equal (@ ls 'third) 2)) + (test (equal (with ls 'third 12) '(0 1 12 3 4 5 6 7 8 9))) + (test (equal (@ ls 'fourth) 3)) + (test (equal (with ls 'fourth 13) '(0 1 2 13 4 5 6 7 8 9))) + (test (equal (@ ls 'fifth) 4)) + (test (equal (with ls 'fifth 14) '(0 1 2 3 14 5 6 7 8 9))) + (test (equal (@ ls 'sixth) 5)) + (test (equal (with ls 'sixth 15) '(0 1 2 3 4 15 6 7 8 9))) + (test (equal (@ ls 'seventh) 6)) + (test (equal (with ls 'seventh 16) '(0 1 2 3 4 5 16 7 8 9))) + (test (equal (@ ls 'eighth) 7)) + (test (equal (with ls 'eighth 17) '(0 1 2 3 4 5 6 17 8 9))) + (test (equal (@ ls 'ninth) 8)) + (test (equal (with ls 'ninth 18) '(0 1 2 3 4 5 6 7 18 9))) + (test (equal (@ ls 'tenth) 9)) + (test (equal (with ls 'tenth 19) '(0 1 2 3 4 5 6 7 8 19)))) + (test (equal? (multiple-value-list (@ (wb-set 2 3) 2)) + '(t 2))) + (test (equal? (multiple-value-list (@ (ch-set 2 3) 2)) + '(t 2))) + (test (equal? (@ (bag 1 1 2) 2) 1)) + (test (equal? (@ '1+ 1) 2)) + (test (equal? (@ #'1+ 1) 2)) + (test (equal? (@ #(foo bar baz) 1) 'bar)) + (test (equal? (multiple-value-list (@ (wb-replay-set 17 3) 3)) + '(t 3))) + (test (equal? (multiple-value-list (@ (ch-replay-set 17 3) 3)) + '(t 3))) + (test (equal? (multiple-value-list (@ (wb-replay-map ('foo 17) ('bar 3)) 'foo)) + '(17 t))) + (test-error (@ (replay-map :no-default ('foo 17) ('bar 3)) 'baz)) + (test-error (@ (ch-replay-map :no-default ('foo 17) ('bar 3)) 'baz)) + (test-error (@ (wb-replay-map :no-default ('foo 17) ('bar 3)) 'baz)) + (test (equal? (multiple-value-list (@ (ch-replay-set 17 3) 3)) + '(t 3))) + + (test (equal? (convert 'set (seq 3 19 'zot "xyzzy")) + (ch-set 3 19 'zot "xyzzy"))) + (test (equal? (convert 'set #(3 19 zot "xyzzy")) + (ch-set 3 19 'zot "xyzzy"))) + (test (equal? (convert 'wb-set (convert 'ch-set (set 3 19 'zot "xyzzy") :compare-fn-name 'erapmoc)) + (wb-set 3 19 'zot "xyzzy"))) + (test (equal? (convert 'set (map ('a 3) ('b 7))) + (set '(a . 3) '(b . 7)))) + (test (equal? (convert 'ch-map (bag (% 'a 7) 'b 'b 'c)) + (map ('a 7) ('b 2) ('c 1)))) + (test (equal? (convert 'seq (map (1 3) (2 10) :default 17)) + (with-default (seq '(1 . 3) '(2 . 10)) 17))) + + ;; New defaulting semantics for `map-union', `map-intersection', `map-difference-2', and `compose' + (let ((chm (map ('a 3))) + (chm-d (map ('a 3) :default 42)) + (chm-no-d (map ('a 2) :no-default)) + (wbm (wb-map ('c 7))) + (wbm-d (wb-map ('c 7) :default 21)) + (wbm-no-d (wb-map ('c 7) :no-default))) + (test (equal? (@ chm 'b) nil)) + (test (equal? (@ chm-d 'b) 42)) + (test-error (@ chm-no-d 'b)) + (test (equal? (incf (lookup chm-no-d 'a)) 3)) + (test-error (incf (@ chm-no-d 'b))) + (test-error (incf (lookup chm-no-d 'b))) + (test (equal? (let ((tmp chm-d)) + (decf (@ tmp 'b)) + tmp) + (map ('a 3) ('b 41) :default 42))) + (test (equal? (multiple-value-list (default chm)) '(nil t))) + (test (equal? (multiple-value-list (default chm-d)) '(42 t))) + (test (equal? (multiple-value-list (default chm-no-d)) '(nil nil))) + (test (equal? (multiple-value-list (default (seq))) '(nil t))) + (test (equal? (multiple-value-list (default (empty-seq :default 42))) '(42 t))) + (test (equal? (multiple-value-list (default (empty-seq :no-default? t))) '(nil nil))) + + (test (equal? (map-union chm (map ('b 4))) + (ch-map ('a 3) ('b 4)))) + (test (not (equal? (map-union chm (map ('b 4))) + (ch-map ('a 3) ('b 4) :default 7)))) + (test (equal? (map-union chm-d (map ('b 4))) + (map ('a 3) ('b 4)))) ; val-fn discards left default + (test (equal? (map-union (map ('b 4)) chm-no-d) + (map ('a 3) ('b 4)))) + (test (equal? (map-union (map ('b 4) :no-default) chm-no-d) + (map ('a 3) ('b 4) :no-default))) + (test (equal? (map-union (map ('b 4) :no-default) chm-d) + (map ('a 3) ('b 4) :default 42))) + (test (equal? (map-union (map ('b 4)) chm-d (fn (_x y) (if (= y 42) (values nil ':no-value) + y))) + (map ('a 3) ('b 4) :no-default))) + (test (equal? (map-union wbm-d (wb-map ('b 4))) + (wb-map ('b 4) ('c 7)))) ; val-fn discards left default + (test (equal? (map-union (wb-map ('b 4)) wbm-no-d) + (wb-map ('b 4) ('c 7)))) + (test (equal? (map-union (wb-map ('b 4) :no-default) wbm-no-d) + (wb-map ('b 4) ('c 7) :no-default))) + (test (equal? (map-union (wb-map ('b 4) :no-default) wbm-d) + (wb-map ('b 4) ('c 7) :default 21))) + (test (equal? (map-union (wb-map ('b 4)) wbm-d (fn (_x y) (if (= y 21) (values nil ':no-value) + y))) + (wb-map ('b 4) ('c 7) :no-default))) + (test (equal? (map-union chm wbm) + (ch-map ('a 3) ('c 7)))) + (test (equal? (map-union wbm-d chm-no-d) + (wb-map ('a 3) ('c 7) :default 21))) + (test (equal? (map-union chm-d wbm-no-d) + (ch-map ('a 3) ('c 7) :default 42))) + + (test (equal? (map-intersection chm chm-d) chm-d)) + (test (equal? (map-intersection chm chm-no-d) chm-no-d)) + (test (equal? (map-intersection chm-no-d chm) chm-no-d)) + (test (equal? (map-intersection chm chm-d (fn (_x y) (if (= y 42) (values nil ':no-value) + y))) + chm-no-d)) + (test (equal? (map-intersection wbm wbm-d) wbm-d)) + (test (equal? (map-intersection wbm wbm-no-d) wbm-no-d)) + (test (equal? (map-intersection wbm-no-d wbm) wbm-no-d)) + (test (equal? (map-intersection wbm wbm-d (fn (_x y) (if (= y 21) (values nil ':no-value) + y))) + wbm-no-d)) + (test (equal? (map-intersection chm (wb-map ('a 4) :default 17)) (ch-map ('a 4) :default 17))) + (test (equal? (map-intersection wbm chm-no-d) (wb-map :no-default))) + (test (equal? (map-intersection wbm (ch-map ('c 9) :default 42) + (fn (_x y) (if (= y 42) (values nil ':no-value) + y))) + (wb-map ('c 9) :no-default))) + + (test (equal? (multiple-value-list (map-difference-2 chm chm-d)) + (list (map) (map :default 42)))) + (test (equal? (multiple-value-list (map-difference-2 chm (map ('a 4)))) + (list (map ('a 3) :no-default) (map ('a 4) :no-default)))) + (test (equal? (multiple-value-list (map-difference-2 chm wbm-d)) + (list (map ('a 3)) (wb-map ('c 7) :default 21)))) + (test (equal? (multiple-value-list (map-difference-2 (wb-map ('c 7) ('z 14) :default 42) wbm-d)) + (list (wb-map ('z 14) :default 42) (wb-map :default 21)))) + (test (equal? (multiple-value-list (map-difference-2 wbm (map ('a 4)))) + (list (wb-map ('c 7) :no-default) (map ('a 4) :no-default)))) + + (test (equal? (filter #'evenp (seq 1 2 3 4 5)) (seq 2 4))) + (test (equal? (filter #'evenp (with-default (seq 1 2 3 4 5) 17)) + (with-default (seq 2 4) 17))) + (test (equal? (filter 'evenp (seq 1 2 3 4 5)) (seq 2 4))) + (test (equal? (filter (map (1 t) (3 t)) (seq 1 2 3 4 5)) (seq 1 3))) + (test (equal? (filter (set 1 3 9) (seq 1 2 3 4 5)) (seq 1 3))) + (test (equal? (filter (bag 1 1 3 9) (seq 1 2 3 4 5)) (seq 1 3))) + + (test (equal? (multiple-value-list (partition (map (1 t) (4 t) (7 t)) (wb-set 0 1 2 3 4 5 6 7))) + (list (wb-set 1 4 7) (wb-set 0 2 3 5 6)))) + (test (equal? (multiple-value-list (partition (map (1 t) (4 t) (7 t)) (ch-set 0 1 2 3 4 5 6 7))) + (list (ch-set 1 4 7) (ch-set 0 2 3 5 6)))) + + (test (equal? (compose (wb-map ('a 7)) (map (7 12) :default 3)) + (wb-map ('a 12) :default 3))) + (test (equal? (compose (wb-map ('a 7) :no-default) (map (7 12) :default 3)) + (wb-map ('a 12) :no-default))) + (test-error (compose (wb-map ('a 6)) (map (7 12) :no-default))) + (test-error (fset:compose (wb-map ('a 6)) (map (7 12) :no-default))) + (test-error (compose (wb-map ('a 6)) (map (7 12) :no-default))) + (test-error (fset:compose (wb-map ('a 6)) (map (7 12) :no-default))) + (test (equal? (compose (wb-map ('a 7) :no-default) (map (7 12) :no-default)) + (wb-map ('a 12) :no-default))) + (test (equal? (compose (ch-map ('a 7)) (map (7 12) :default 3)) + (ch-map ('a 12) :default 3))) + (test (equal? (compose (ch-map ('a 7) :no-default) (map (7 12) :default 3)) + (ch-map ('a 12) :no-default))) + (test-error (compose (ch-map ('a 6)) (map (7 12) :no-default))) + (test-error (fset:compose (ch-map ('a 6)) (map (7 12) :no-default))) + (test-error (compose (wb-map ('a 6)) (map (7 12) :no-default))) + (test-error (fset:compose (wb-map ('a 6)) (map (7 12) :no-default))) + (test (equal? (compose (ch-map ('a 7) :no-default) (map (7 12) :no-default)) + (ch-map ('a 12) :no-default))) + + (test (= (rank (wb-set 1 3 5) 2) 1)) + (test (equal? (@ (tuple) +k5+) 'plugh)) + (test (equal? (@ (tuple) +k6+) nil)) + (test (equal? (@ (tuple) (get-tuple-key 'fubar :default 11)) 11)) + (test-error (@ (tuple) (get-tuple-key 'fubar :no-default? t))) + (test (equal? (@ (tuple) (get-tuple-key 'fubar :default 0)) 0)) + (test (equal? (@ (tuple) (get-tuple-key 'zot)) nil)) + + (test (equal? (filter #'evenp (seq 1 2 3 4 5)) (seq 2 4))) + (test (equal? (filter #'evenp (with-default (seq 1 2 3 4 5) 17)) + (with-default (seq 2 4) 17))) + (test (equal? (filter 'evenp (seq 1 2 3 4 5)) (seq 2 4))) + (test (equal? (filter (map (1 t) (3 t)) (seq 1 2 3 4 5)) (seq 1 3))) + (test (equal? (filter (set 1 3 9) (seq 1 2 3 4 5)) (seq 1 3))) + (test (equal? (filter (bag 1 1 3 9) (seq 1 2 3 4 5)) (seq 1 3))) + + (test (equal? (image #'1+ (seq 1 7 5)) (seq 2 8 6))) + (test (equal? (image '1+ (seq 1 7 5)) (seq 2 8 6))) + (test (equal? (image #'1+ (with-default (seq 1 7 5) 0)) + (seq 2 8 6))) + (test (equal? (image (map (1 8) (3 10)) (seq 0 1 2 3 4 5)) + (seq nil 8 nil 10 nil nil))) + (test (equal? (image (set -3 1 3 21) (seq 0 1 2 3 4 5)) + (seq nil t nil t nil nil))) + (test (equal? (image (bag 1 3 3 10) (seq 0 1 2 3 4 5)) + (seq 0 1 0 2 0 0))) + (test (equal? (convert 'set (wb-2-relation ('a 3) ('a 5) ('b 3) ('c 4))) + (wb-set '(a . 3) '(a . 5) '(b . 3) '(c . 4)))) + (test (equal? (convert 'set (ch-2-relation ('a 3) ('a 5) ('b 3) ('c 4))) + (ch-set '(a . 3) '(a . 5) '(b . 3) '(c . 4)))) + (test (equal? (convert 'wb-2-relation (wb-map ('a 5) ('b 3) ('c 4))) + (wb-2-relation ('a 5) ('b 3) ('c 4)))) + (test (equal? (convert '2-relation (ch-map ('a 5) ('b 3) ('c 4))) + (2-relation ('a 5) ('b 3) ('c 4)))) + (test (equal? (convert 'wb-2-relation (wb-map ('a (set 3 5)) ('b (set 2)) ('c (set 4 7))) + :from-type 'map-to-sets) + (wb-2-relation ('a 3) ('a 5) ('b 2) ('c 4) ('c 7)))) + (test (equal? (convert '2-relation (map ('a (set 3 5)) ('b (set 2)) ('c (set 4 7))) + :from-type 'map-to-sets) + (ch-2-relation ('a 3) ('a 5) ('b 2) ('c 4) ('c 7)))) + (test (equal? (convert 'map (ch-2-relation ('a 3) ('b 2) ('c 4))) + (map ('a 3) ('b 2) ('c 4)))) + (test (equal? (convert 'wb-map (wb-2-relation ('a 3) ('b 2) ('c 4))) + (wb-map ('a 3) ('b 2) ('c 4)))) + (test (equal? (convert 'map (ch-2-relation ('a 3) ('b 2) ('c 4))) + (map ('a 3) ('b 2) ('c 4)))) + (test (equal? (convert 'ch-map (ch-2-relation ('a 3) ('b 2) ('c 4))) + (map ('a 3) ('b 2) ('c 4)))) + (test (equal? (convert 'map-to-sets (wb-2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8))) + (wb-map ('a (wb-set 3 5)) ('b (wb-set 3)) ('c (wb-set 4 8))))) + (test (equal? (convert 'map-to-sets (ch-2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8))) + (map ('a (set 3 5)) ('b (set 3)) ('c (set 4 8))))) + (let ((conv (convert 'map-to-sets (ch-custom-2-relation 'compare 'fset::int-compare + ('a 3) ('a 5) ('b 3) ('c 4) ('c 8))))) + (test (gmap :and (fn (k s) (equal? s (@ conv k))) + (:arg map (ch-custom-map nil 'eql-compare + ('a (ch-custom-set 'fset::int-compare 3 5)) + ('b (ch-custom-set 'fset::int-compare 3)) + ('c (ch-custom-set 'fset::int-compare 4 8)))))))))) + +(defun test-fset2-gmap () + (macrolet ((test (form) + `(unless ,form + (error "Test failed: ~S" ',form)))) + (test (equal? (gmap (:result list) nil (:arg set (wb-set 13 7 41 2))) + '(2 7 13 41))) + (test (equal? (sort (gmap (:result list) nil (:arg set (ch-set 13 7 41 2))) #'<) + '(2 7 13 41))) + (test (equal? (gmap (:result list) nil (:arg wb-set (wb-set 13 7 41 2))) + '(2 7 13 41))) + (test (equal? (sort (gmap (:result list) nil (:arg ch-set (ch-set 13 7 41 2))) #'<) + '(2 7 13 41))) + (test (equal? (gmap (:result set) nil (:arg list '(8 3 14 6))) + (ch-set 8 3 14 6))) + (test (equal? (gmap (:result wb-set :compare-fn-name 'erapmoc) nil (:arg list '(8 3 14 6))) + (wb-custom-set 'erapmoc 8 3 14 6))) + (test (equal? (gmap (:result ch-set :compare-fn-name 'erapmoc) nil (:arg list '(8 3 14 6))) + (ch-custom-set 'erapmoc 8 3 14 6))) + (test (equal? (gmap (:result union) nil (:arg list (list (set 3 7) (set 9 1)))) + (ch-set 1 3 7 9))) + (test (equal? (gmap (:result intersection) nil (:arg list (list (set 3 7 9) (set 9 3)))) + (ch-set 3 9))) + + (test (equal? (gmap (:result list) nil (:arg bag (bag 3 7 (% 9 2)))) + '(3 7 9 9))) + (test (equal? (gmap (:result list) nil (:arg wb-bag (bag 3 7 (% 9 2)))) + '(3 7 9 9))) + (test (equal? (gmap (:result list) #'cons (:arg bag-pairs (bag 3 7 (% 9 2)))) + '((3 . 1) (7 . 1) (9 . 2)))) + (test (equal? (gmap (:result list) #'cons (:arg wb-bag-pairs (bag 3 7 (% 9 2)))) + '((3 . 1) (7 . 1) (9 . 2)))) + (test (equal? (gmap (:result list) #'cons (:arg fun-bag-pairs (bag 3 7 (% 9 2)))) + '((3 . 1) (7 . 1) (9 . 2)))) + (test (equal? (gmap (:result bag) nil (:arg list '(3 7 9 2 7 3))) + (wb-bag 2 (% 3 2) (% 7 2) 9))) + (test (equal? (gmap (:result bag-pairs) (fn (x) (values (car x) (cdr x))) + (:arg list '((a . 2) (b . 6) (q . 4)))) + (wb-bag (% 'a 2) (% 'b 6) (% 'q 4)))) + (test (equal? (gmap (:result wb-bag :compare-fn-name 'erapmoc) nil (:arg list '(3 7 9 2 7 3))) + (wb-custom-bag 'erapmoc 2 (% 3 2) (% 7 2) 9))) + (test (equal? (gmap (:result wb-bag-pairs :compare-fn-name 'erapmoc) (fn (x) (values (car x) (cdr x))) + (:arg list '((a . 2) (b . 6) (q . 4)))) + (wb-custom-bag 'erapmoc (% 'a 2) (% 'b 6) (% 'q 4)))) + (test (equal? (gmap (:result bag-sum) nil (:arg list (list (bag 2 2 3 3 3 4) (bag 1 2 4)))) + (bag 1 (% 2 3) (% 3 3) (% 4 2)))) + (test (equal? (gmap (:result bag-product) nil (:arg list (list (bag 2 2 3 3 3 4) (bag 1 2 2 4)))) + (bag (% 2 4) 4))) + + (test (equal? (sort (gmap (:result list) #'cons (:arg map (map ('a 3) ('b 7) ('c 6)))) #'string< :key #'car) + '((a . 3) (b . 7) (c . 6)))) + (test (equal? (sort (gmap (:result list) #'cons (:arg fun-map (map ('a 3) ('b 7) ('c 6)))) #'string< :key #'car) + '((a . 3) (b . 7) (c . 6)))) + (test (equal? (gmap (:result list) #'cons (:arg wb-map (wb-map ('a 3) ('b 7) ('c 6)))) + '((a . 3) (b . 7) (c . 6)))) + (test (equal? (sort (gmap (:result list) #'cons (:arg ch-map (ch-map ('a 3) ('b 7) ('c 6)))) + #'string< :key #'car) + '((a . 3) (b . 7) (c . 6)))) + (test (equal? (gmap (:result map) #'values (:arg list '(foo bar baz)) (:arg list '(12 17 91))) + (ch-map ('foo 12) ('bar 17) ('baz 91)))) + (test (equal? (gmap (:result wb-map) #'values (:arg list '(foo bar baz)) (:arg list '(12 17 91))) + (wb-map ('foo 12) ('bar 17) ('baz 91)))) + (test (equal? (gmap (:result ch-map) #'values (:arg list '(foo bar baz)) (:arg list '(12 17 91))) + (ch-map ('foo 12) ('bar 17) ('baz 91)))) + (test (equal? (gmap (:result map-union) nil (:arg list (list (map ('a 7) ('b 4)) (map ('c 8) ('a 11))))) + (ch-map ('a 11) ('b 4) ('c 8)))) + (test (equal? (gmap (:result map-intersection) nil (:arg list (list (map ('a 7) ('b 4)) (map ('c 8) ('a 11))))) + (ch-map ('a 11)))) + (test (equal? (gmap (:result map-to-sets) #'values + (:arg list '(a b a b c a)) + (:arg list '(0 1 2 3 4 5))) + (ch-map ('a (ch-set 0 2 5)) ('b (ch-set 1 3)) ('c (ch-set 4)) :default (ch-set)))) + + (test (equal? (gmap (:result list) nil (:arg seq (seq 3 'foo 99))) + '(3 foo 99))) + (test (equal? (gmap (:result list) nil (:arg seq (seq 3 'foo 99 42 "hello" 'fizzbuzz) + :start 1 :end 5)) + '(foo 99 42 "hello"))) + (test (equal? (gmap (:result list) nil (:arg seq (seq 3 'foo 99) :from-end? t)) + '(99 foo 3))) + (test (equal? (gmap (:result list) nil (:arg seq (seq 3 'foo 99 42 "hello" 'fizzbuzz) + :start 1 :end 5 :from-end? t)) + '("hello" 42 99 foo))) + (test (equal? (gmap (:result list) nil (:arg wb-seq (seq 3 'foo 99))) + '(3 foo 99))) + (test (equal? (gmap (:result list) nil (:arg wb-seq (seq 3 'foo 99 42 "hello" 'fizzbuzz) + :start 1 :end 5)) + '(foo 99 42 "hello"))) + (test (equal? (gmap (:result list) nil (:arg wb-seq (seq 3 'foo 99) :from-end? (> (get-universal-time) 1000000))) + '(99 foo 3))) + (test (equal? (gmap (:result list) nil (:arg wb-seq (seq 3 'foo 99 42 "hello" 'fizzbuzz) + :start 1 :end 5 :from-end? (> (get-universal-time) 1000000))) + '("hello" 42 99 foo))) + (test (equal? (gmap (:result seq :filterp #'integerp) nil (:arg list '(3 'bar 99))) + (seq 3 99))) + (test (equal? (gmap (:result concat) nil (:arg list (list (seq 'now 'is) (seq 'the 'time)))) + (seq 'now 'is 'the 'time))))) diff --git a/Code/tuples.lisp b/Code/tuples.lisp index 074943fb324fd09ac537eabb621b28c731f593cc..aeb4055c32a323da1e1ebcb6f23351a8ad660b21 100644 --- a/Code/tuples.lisp +++ b/Code/tuples.lisp @@ -117,17 +117,16 @@ (defstruct (dyn-tuple (defstruct (tuple-key - (:constructor make-tuple-key (name default-fn number)) + (:constructor make-tuple-key (name default number)) (:predicate tuple-key?) (:print-function print-tuple-key)) (name nil :read-only t) ; a symbol (normally, but actually can be any type known to FSet) - (default-fn nil :type (or null function) - :read-only t) ; default function for tuples with no explicit entry for this key - ; (called with one argument, the tuple), or nil + (default 'no-default) ; default, if any, for tuples with no explicit entry for this key + ; (in FSet1, this was a function called on the tuple) (number nil :type fixnum :read-only t)) ; used for lookup and sorting -(deflex +Tuple-Key-Name-Map+ (empty-map)) +(deflex +Tuple-Key-Name-Map+ (empty-ch-map)) (deflex +Tuple-Key-Seq+ (empty-seq)) @@ -155,6 +154,32 @@ (defstruct (tuple-key (push-last +Tuple-Key-Seq+ key) key) (error "Tuple key space exhausted"))))))) +(defun fset2:get-tuple-key (name &key (default nil default?) no-default?) + "Finds or creates a tuple key named `name'. If `default' is supplied, sets +the key's default to it; this value will be returned from `lookup' when the +tuple has no explicit pair with this key. If `no-default?' is true, clears the +key's default, so that `lookup' will signal an error in this case. If neither +is specified, then if the key is being freshly created, it will have a default +of `nil'; if it already existed, its default will be unchanged." + (when (and default? no-default?) + (error "Both a default and `no-default?' specified")) + (with-lock (+Tuple-Key-Lock+) + (let ((key (lookup +Tuple-Key-Name-Map+ name)) + (key-idx (size +Tuple-Key-Seq+))) + (cond (key + (cond (default? + (setf (tuple-key-default key) default)) + (no-default? + (setf (tuple-key-default key) 'no-default))) + key) + ((<= key-idx Tuple-Key-Number-Mask) + (let ((key (make-tuple-key name (if default? default (and no-default? 'no-default)) + key-idx))) + (setf (lookup +Tuple-Key-Name-Map+ name) key) + (push-last +Tuple-Key-Seq+ key) + key)) + (t + (error "Tuple key space exhausted")))))) (defmacro def-tuple-key (name &optional default) "Deprecated; use `define-tuple-key'." @@ -171,9 +196,20 @@ (defstruct (tuple-key an extra lambda. To supply a doc string without a default, supply `nil' for `default'." (assert (symbolp name)) - (when doc-string - (setf (get name 'tuple-key-doc-string) doc-string)) - `(deflex ,name (get-tuple-key ',name ,default))) + `(deflex ,name (get-tuple-key ',name ,default) + . ,(and doc-string `(,doc-string)))) +(defmacro fset2:define-tuple-key (name &key (default nil default?) no-default? documentation) + "Defines a tuple key named `name' as a global lexical variable (see +`deflex'). If `default' is supplied, it will be returned from `lookup', +instead of `nil', when the tuple has no explicit pair with this key. +Alternatively, if `no-default?' is true, `lookup` will signal an error +in that case." + (assert (symbolp name)) + (when (and default? no-default?) + (error "Both a default and `no-default?' specified")) + `(deflex-reinit ,name (fset2:get-tuple-key ',name ,@(if default? `(:default ,default) + (and no-default? '(:no-default? t)))) + . ,(and documentation `(,documentation)))) (defun print-tuple-key (key stream level) (declare (ignore level)) @@ -641,11 +677,29 @@ (defmethod with ((tuple tuple) (key tuple-key) &optional (value nil value?)) (check-three-arguments value? 'with 'tuple) (Tuple-With tuple key value)) +(define-condition fset2:tuple-key-unbound-error (fset2:lookup-error) + ((tuple :initarg :tuple :reader fset2:tuple-key-unbound-error-tuple) + (key :initarg :key :reader fset2:tuple-key-unbound-error-key)) + (:report (lambda (tkue stream) + (format stream "Key ~S, which has no default, unbound in tuple ~A" + (tuple-key-name (fset2:tuple-key-unbound-error-key tkue)) + (fset2:tuple-key-unbound-error-tuple tkue))))) + (defmethod lookup ((tuple tuple) (key tuple-key)) (let ((val? val (Tuple-Lookup tuple key))) (if val? (values val t) - (let ((default-fn (tuple-key-default-fn key))) - (values (and default-fn (funcall default-fn tuple)) nil))))) + (let ((default-fn (tuple-key-default key))) + ;; The key might have been declared in FSet 2 code, even though we're accesing it in FSet 1 code. + (if (eq default-fn 'no-default) + (error 'fset2:tuple-key-unbound-error :tuple tuple :key key) + (values (and default-fn (funcall default-fn tuple)) nil)))))) +(defmethod fset2:lookup ((tuple tuple) (key tuple-key)) + (let ((val? val (Tuple-Lookup tuple key))) + (if val? (values val t) + (let ((dflt (tuple-key-default key))) + (if (eq dflt 'no-default) + (error 'fset2:tuple-key-unbound-error :tuple tuple :key key) + (values dflt nil)))))) (defmethod size ((tuple tuple)) (size (Tuple-Desc-Key-Set (dyn-tuple-descriptor tuple)))) @@ -687,16 +741,22 @@ (defmethod convert ((to-type (eql 'tuple)) (tup tuple) &key) (defmethod convert ((to-type (eql 'dyn-tuple)) (tup dyn-tuple) &key) tup) -;;; &&& These should be able to create custom maps. (defmethod convert ((to-type (eql 'map)) (tup tuple) &key) (wb-map-from-tuple tup)) -(defmethod convert ((to-type (eql 'wb-map)) (tup tuple) &key) +(defmethod convert ((to-type (eql 'fset2:map)) (tup tuple) &key) (wb-map-from-tuple tup)) -(defun wb-map-from-tuple (tup) - (let ((tree nil)) + +(defmethod convert ((to-type (eql 'wb-map)) (tup tuple) &key key-compare-fn-name val-compare-fn-name) + (wb-map-from-tuple tup key-compare-fn-name val-compare-fn-name)) +(defmethod convert ((to-type (eql 'fset2:wb-map)) (tup tuple) &key key-compare-fn-name val-compare-fn-name) + (wb-map-from-tuple tup key-compare-fn-name val-compare-fn-name)) + +(defun wb-map-from-tuple (tup &optional key-compare-fn-name val-compare-fn-name) + (let ((tree nil) + (tmorg (wb-map-org (empty-wb-map nil key-compare-fn-name val-compare-fn-name)))) (do-tuple (k v tup) - (setq tree (WB-Map-Tree-With tree k v #'compare #'compare))) - (make-wb-map tree +fset-default-tree-map-org+ nil))) + (setq tree (WB-Map-Tree-With tree k v (tree-map-org-key-compare-fn tmorg) (tree-map-org-val-compare-fn tmorg)))) + (make-wb-map tree tmorg nil))) (defmethod convert ((to-type (eql 'list)) (tup tuple) &key (pair-fn #'cons)) (let ((result nil) @@ -725,17 +785,19 @@ (defmethod make-load-form ((tup dyn-tuple) &optional environment) (defmethod make-load-form ((key tuple-key) &optional environment) (declare (ignore environment)) - `(get-tuple-key ',(tuple-key-name key) ',(tuple-key-default-fn key))) + `(get-tuple-key ',(tuple-key-name key) ',(tuple-key-default key))) ;;; ================================================================================ -(define-wb-set-method image ((key tuple-key) (s wb-set) &key compare-fn-name) +(define-wb-set-methods (image fset2:image) ((key tuple-key) (s wb-set) &key compare-fn-name) (wb-set-image #'(lambda (x) (lookup x key)) (contents s) (or compare-fn-name (compare-fn-name s)))) (defmethod image ((key tuple-key) (s seq) &key) - (seq-image #'(lambda (x) (lookup x key)) s)) + (seq-image #'(lambda (x) (lookup x key)) s nil)) +(defmethod fset2:image ((key tuple-key) (s seq) &key) + (seq-image #'(lambda (x) (fset2:lookup x key)) s 'no-default)) (defmethod restrict ((tup tuple) (s set)) (let ((result (empty-tuple))) diff --git a/Code/wb-trees.lisp b/Code/wb-trees.lisp index a7cb975f38427333358248ac322e4b5948632558..40f162b8e468c750d5b670debd744eca50ac3653 100644 --- a/Code/wb-trees.lisp +++ b/Code/wb-trees.lisp @@ -45,19 +45,6 @@ (in-package :fset) -(defmacro equal?-fn (cmp-fn) - `(lambda (a b) (eq (funcall ,cmp-fn a b) ':equal))) - -(defmacro equal?-cmp (a b cmp-fn) - `(eq (funcall ,cmp-fn ,a ,b) ':equal)) - -(defmacro less-than?-cmp (a b cmp-fn) - `(eq (funcall ,cmp-fn ,a ,b) ':less)) - -(defmacro greater-than?-cmp (a b cmp-fn) - `(eq (funcall ,cmp-fn ,a ,b) ':greater)) - - ;;; ================================================================================ ;;; ================================================================================ ;;; Weight-balanced trees @@ -533,26 +520,33 @@ (defstruct (Equivalent-Node ((and (simple-vector-p tree1) (simple-vector-p tree2)) (WB-Set-Tree-Vector-Union tree1 tree2 lo hi cmp-fn)) ((simple-vector-p tree1) - (WB-Set-Tree-Union-Rng tree2 tree1 lo hi cmp-fn)) + (let ((val2 (WB-Set-Tree-Node-Value tree2)) + ((eqvv1? eqvv1 (WB-Set-Tree-Find-Equivalent tree1 val2 cmp-fn)))) + (WB-Set-Tree-Concat (if eqvv1? (Equivalent-Set-Union eqvv1 val2 cmp-fn) + val2) + (WB-Set-Tree-Union-Rng (WB-Set-Tree-Trim tree1 lo val2 cmp-fn) + ;; We have to trim the children too, because their + ;; node values might be outside (lo, hi). + (WB-Set-Tree-Trim (WB-Set-Tree-Node-Left tree2) + lo val2 cmp-fn) + lo val2 cmp-fn) + (WB-Set-Tree-Union-Rng (WB-Set-Tree-Trim tree1 val2 hi cmp-fn) + (WB-Set-Tree-Trim (WB-Set-Tree-Node-Right tree2) + val2 hi cmp-fn) + val2 hi cmp-fn) + cmp-fn))) (t (let ((val1 (WB-Set-Tree-Node-Value tree1)) ((eqvv2? eqvv2 (WB-Set-Tree-Find-Equivalent tree2 val1 cmp-fn)))) - (WB-Set-Tree-Concat - (if eqvv2? (Equivalent-Set-Union val1 eqvv2 cmp-fn) - val1) - ;; Subtlety: we have to trim the children of `tree1' because of the - ;; previous `cond' clause, which swaps the two trees, thus destroying - ;; the invariant that all members of `tree1' are between `lo' and `hi'. - (WB-Set-Tree-Union-Rng (WB-Set-Tree-Trim (WB-Set-Tree-Node-Left tree1) + (WB-Set-Tree-Concat (if eqvv2? (Equivalent-Set-Union val1 eqvv2 cmp-fn) + val1) + (WB-Set-Tree-Union-Rng (WB-Set-Tree-Node-Left tree1) + (WB-Set-Tree-Trim tree2 lo val1 cmp-fn) lo val1 cmp-fn) - (WB-Set-Tree-Trim tree2 lo val1 cmp-fn) - lo val1 cmp-fn) - (WB-Set-Tree-Union-Rng (WB-Set-Tree-Trim (WB-Set-Tree-Node-Right tree1) + (WB-Set-Tree-Union-Rng (WB-Set-Tree-Node-Right tree1) + (WB-Set-Tree-Trim tree2 val1 hi cmp-fn) val1 hi cmp-fn) - (WB-Set-Tree-Trim tree2 val1 hi cmp-fn) - val1 hi cmp-fn) - cmp-fn))))) - + cmp-fn))))) (defun WB-Set-Tree-Intersect (tree1 tree2 cmp-fn) "Returns the intersection of `tree1' and `tree2'. Runs in time linear in @@ -574,8 +568,20 @@ (defstruct (Equivalent-Node ((and (simple-vector-p tree1) (simple-vector-p tree2)) (Vector-Set-Intersect tree1 tree2 lo hi cmp-fn)) ((simple-vector-p tree1) - (WB-Set-Tree-Intersect-Rng (WB-Set-Tree-Trim tree2 lo hi cmp-fn) - tree1 lo hi cmp-fn)) + (let ((val2 (WB-Set-Tree-Node-Value tree2)) + ((new-left + (WB-Set-Tree-Intersect-Rng (WB-Set-Tree-Trim tree1 lo val2 cmp-fn) + (WB-Set-Tree-Node-Left tree2) + lo val2 cmp-fn)) + (new-right + (WB-Set-Tree-Intersect-Rng (WB-Set-Tree-Trim tree1 val2 hi cmp-fn) + (WB-Set-Tree-Node-Right tree2) + val2 hi cmp-fn))) + ((eqvv1? eqvv1 (WB-Set-Tree-Find-Equivalent tree1 val2 cmp-fn)) + ((nonnull? isect (and eqvv1? (Equivalent-Set-Intersect eqvv1 val2 cmp-fn)))))) + (if nonnull? + (WB-Set-Tree-Concat isect new-left new-right cmp-fn) + (WB-Set-Tree-Join new-left new-right cmp-fn)))) (t (let ((val1 (WB-Set-Tree-Node-Value tree1)) ((new-left @@ -615,8 +621,6 @@ (defstruct (Equivalent-Node ((simple-vector-p tree1) (let ((val2 (WB-Set-Tree-Node-Value tree2)) ((new-left (WB-Set-Tree-Diff-Rng (WB-Set-Tree-Trim tree1 lo val2 cmp-fn) - ;; We trim here because `lo' didn't come - ;; from `tree2'. (WB-Set-Tree-Trim (WB-Set-Tree-Node-Left tree2) lo val2 cmp-fn) lo val2 cmp-fn)) (new-right (WB-Set-Tree-Diff-Rng (WB-Set-Tree-Trim tree1 val2 hi cmp-fn) @@ -1333,7 +1337,7 @@ (defstruct (Equivalent-Node ((comp (funcall cmp-fn v1 v2)))) (ecase comp ((:equal) - (push v1 res) + (push v1 res) ; prefer `v1' (incf i1) (incf i2)) ((:less) @@ -1386,7 +1390,7 @@ (defstruct (Equivalent-Node ((comp (funcall cmp-fn v1 v2)))) (ecase comp ((:equal) - (push v1 res) + (push v1 res) ; prefer `v1' (incf i1) (incf i2)) ((:less) @@ -1819,18 +1823,24 @@ (defstruct (Equivalent-Node (if (Equivalent-Node? val2) (let ((mems1 (Equivalent-Node-List val1)) (mems2 (Equivalent-Node-List val2)) - ((union (cl:union mems1 mems2 :test (equal?-fn cmp-fn))) - ((union-len (length union))))) - (cond ((= union-len (length mems1)) val1) - ((= union-len (length mems2)) val2) - (t (Make-Equivalent-Set union)))) + ((union mems1)) ; prefer `val1' values + (any-new? nil)) + (dolist (m2 mems2) + (unless (member m2 mems1 :test (equal?-fn cmp-fn)) + (push m2 union) + (setq any-new? t))) + (if any-new? (Make-Equivalent-Set union) + val1)) (if (member val2 (Equivalent-Node-List val1) :test (equal?-fn cmp-fn)) val1 (Make-Equivalent-Set (cons val2 (Equivalent-Node-List val1))))) (if (Equivalent-Node? val2) - (if (member val1 (Equivalent-Node-List val2) :test (equal?-fn cmp-fn)) - val2 - (Make-Equivalent-Set (cons val1 (Equivalent-Node-List val2)))) + (let ((mems2 (Equivalent-Node-List val2)) + ((pos (position val1 mems2 :test (equal?-fn cmp-fn))))) + (if pos + ;; prefer `val1', even in this case + (Make-Equivalent-Set (cons val1 (append (cl:subseq mems2 0 pos) (nthcdr (1+ pos) mems2)))) + (Make-Equivalent-Set (cons val1 mems2)))) (if (equal?-cmp val1 val2 cmp-fn) val1 (Make-Equivalent-Set (list val1 val2)))))) @@ -1846,15 +1856,18 @@ (defstruct (Equivalent-Node (if (Equivalent-Node? val2) (let ((mems1 (Equivalent-Node-List val1)) (mems2 (Equivalent-Node-List val2)) - ((isect (cl:intersection mems1 mems2 :test (equal?-fn cmp-fn))) - ((isect-len (length isect))))) - (cond ((null isect) nil) - ((= isect-len (length mems1)) (values t val1)) - ((= isect-len (length mems2)) (values t val2)) - ((= isect-len 1) (values t (car isect))) - (t (values t (Make-Equivalent-Set isect))))) - (and (member val2 (Equivalent-Node-List val1) :test (equal?-fn cmp-fn)) - (values t val2))) + ((isect nil))) + (dolist (m1 mems1) + (when (member m1 mems2 :test (equal?-fn cmp-fn)) + (push m1 isect))) + (let ((isect-len (length isect))) + (cond ((null isect) nil) + ((= isect-len (length mems1)) (values t val1)) + ((= isect-len 1) (values t (car isect))) + (t (values t (Make-Equivalent-Set isect)))))) + ;; prefer `val1' value + (let ((pos (position val2 (Equivalent-Node-List val1) :test (equal?-fn cmp-fn)))) + (and pos (values t (nth pos (Equivalent-Node-List val1)))))) (if (Equivalent-Node? val2) (and (member val1 (Equivalent-Node-List val2) :test (equal?-fn cmp-fn)) (values t val1)) @@ -2362,7 +2375,20 @@ (defstruct (WB-Bag-Tree-Node ((and (consp tree1) (consp tree2)) (WB-Bag-Tree-Vector-Pair-Union tree1 tree2 lo hi cmp-fn)) ((consp tree1) - (WB-Bag-Tree-Union-Rng tree2 tree1 lo hi cmp-fn)) + (let ((val2 (WB-Bag-Tree-Node-Value tree2)) + (count2 (WB-Bag-Tree-Node-Count tree2)) + ((eqvv1? eqvv1 eqvc1 (WB-Bag-Tree-Find-Equivalent tree1 val2 cmp-fn)) + ((val count (if eqvv1? (Equivalent-Bag-Union eqvv1 eqvc1 val2 count2 cmp-fn) + (values val2 count2)))))) + (WB-Bag-Tree-Concat + val count + (WB-Bag-Tree-Union-Rng (WB-Bag-Tree-Trim tree1 lo val2 cmp-fn) + (WB-Bag-Tree-Trim (WB-Bag-Tree-Node-Left tree2) lo val2 cmp-fn) + lo val2 cmp-fn) + (WB-Bag-Tree-Union-Rng (WB-Bag-Tree-Trim tree1 val2 hi cmp-fn) + (WB-Bag-Tree-Trim (WB-Bag-Tree-Node-Right tree2) val2 hi cmp-fn) + val2 hi cmp-fn) + cmp-fn))) (t (let ((val1 (WB-Bag-Tree-Node-Value tree1)) (count1 (WB-Bag-Tree-Node-Count tree1)) @@ -2394,7 +2420,20 @@ (defstruct (WB-Bag-Tree-Node ((and (consp tree1) (consp tree2)) (WB-Bag-Tree-Vector-Pair-Sum tree1 tree2 lo hi cmp-fn)) ((consp tree1) - (WB-Bag-Tree-Sum-Rng tree2 tree1 lo hi cmp-fn)) + (let ((val2 (WB-Bag-Tree-Node-Value tree2)) + (count2 (WB-Bag-Tree-Node-Count tree2)) + ((eqvv1? eqvv1 eqvc1 (WB-Bag-Tree-Find-Equivalent tree1 val2 cmp-fn)) + ((val count (if eqvv1? (Equivalent-Bag-Sum eqvv1 eqvc1 val2 count2 cmp-fn) + (values val2 count2)))))) + (WB-Bag-Tree-Concat + val count + (WB-Bag-Tree-Sum-Rng (WB-Bag-Tree-Trim tree1 lo val2 cmp-fn) + (WB-Bag-Tree-Trim (WB-Bag-Tree-Node-Left tree2) lo val2 cmp-fn) + lo val2 cmp-fn) + (WB-Bag-Tree-Sum-Rng (WB-Bag-Tree-Trim tree1 val2 hi cmp-fn) + (WB-Bag-Tree-Trim (WB-Bag-Tree-Node-Right tree2) val2 hi cmp-fn) + val2 hi cmp-fn) + cmp-fn))) (t (let ((val1 (WB-Bag-Tree-Node-Value tree1)) (count1 (WB-Bag-Tree-Node-Count tree1)) @@ -2431,7 +2470,22 @@ (defstruct (WB-Bag-Tree-Node ((and (consp tree1) (consp tree2)) (Vector-Pair-Bag-Intersect tree1 tree2 lo hi cmp-fn)) ((consp tree1) - (WB-Bag-Tree-Intersect-Rng (WB-Bag-Tree-Trim tree2 lo hi cmp-fn) tree1 lo hi cmp-fn)) + (let ((val2 (WB-Bag-Tree-Node-Value tree2)) + (count2 (WB-Bag-Tree-Node-Count tree2)) + ((new-left + (WB-Bag-Tree-Intersect-Rng (WB-Bag-Tree-Trim tree1 lo val2 cmp-fn) + (WB-Bag-Tree-Node-Left tree2) + lo val2 cmp-fn)) + (new-right + (WB-Bag-Tree-Intersect-Rng (WB-Bag-Tree-Trim tree1 val2 hi cmp-fn) + (WB-Bag-Tree-Node-Right tree2) + val2 hi cmp-fn))) + ((eqvv1? eqvv1 eqvc1 (WB-Bag-Tree-Find-Equivalent tree1 val2 cmp-fn)) + ((nonnull? value count + (and eqvv1? (Equivalent-Bag-Intersect eqvv1 eqvc1 val2 count2 cmp-fn)))))) + (if nonnull? + (WB-Bag-Tree-Concat value count new-left new-right cmp-fn) + (WB-Bag-Tree-Join new-left new-right cmp-fn)))) (t (let ((val1 (WB-Bag-Tree-Node-Value tree1)) (count1 (WB-Bag-Tree-Node-Count tree1)) @@ -2466,7 +2520,22 @@ (defstruct (WB-Bag-Tree-Node ((and (consp tree1) (consp tree2)) (Vector-Pair-Bag-Product tree1 tree2 lo hi cmp-fn)) ((consp tree1) - (WB-Bag-Tree-Product-Rng (WB-Bag-Tree-Trim tree2 lo hi cmp-fn) tree1 lo hi cmp-fn)) + (let ((val2 (WB-Bag-Tree-Node-Value tree2)) + (count2 (WB-Bag-Tree-Node-Count tree2)) + ((new-left + (WB-Bag-Tree-Product-Rng (WB-Bag-Tree-Trim tree1 lo val2 cmp-fn) + (WB-Bag-Tree-Node-Left tree2) + lo val2 cmp-fn)) + (new-right + (WB-Bag-Tree-Product-Rng (WB-Bag-Tree-Trim tree1 val2 hi cmp-fn) + (WB-Bag-Tree-Node-Right tree2) + val2 hi cmp-fn))) + ((eqvv1? eqvv1 eqvc1 (WB-Bag-Tree-Find-Equivalent tree1 val2 cmp-fn)) + ((nonnull? value count + (and eqvv1? (Equivalent-Bag-Product eqvv1 eqvc1 val2 count2 cmp-fn)))))) + (if nonnull? + (WB-Bag-Tree-Concat value count new-left new-right cmp-fn) + (WB-Bag-Tree-Join new-left new-right cmp-fn)))) (t (let ((val1 (WB-Bag-Tree-Node-Value tree1)) (count1 (WB-Bag-Tree-Node-Count tree1)) @@ -3212,7 +3281,7 @@ (defstruct (WB-Bag-Tree-Node ((comp (funcall cmp-fn val1 val2)))) (ecase comp (:equal - (push val1 vals) + (push val1 vals) ; prefer `val1' (push (gen max (svref counts1 i1) (svref counts2 i2)) counts) (incf i1) @@ -3775,7 +3844,7 @@ (defstruct (WB-Bag-Tree-Node (rlabels (copies 0) (copies (j) (declare (fixnum j)) - (if (< j (WB-Bag-Tree-Node-Count node)) + (if (gen < j (WB-Bag-Tree-Node-Count node)) (lambda (op) (ecase op (:first (values value t)) @@ -3803,7 +3872,7 @@ (defstruct (WB-Bag-Tree-Node cont)) (copies (i j) (declare (fixnum i j)) - (if (< j (the fixnum (svref (cdr node) i))) + (if (gen < j (svref (cdr node) i)) (lambda (op) (ecase op (:first (values (svref (car node) i) t)) @@ -3833,7 +3902,7 @@ (defstruct (WB-Bag-Tree-Node (rlabels (copies 0) (copies (j) (declare (fixnum j)) - (if (< j (WB-Bag-Tree-Node-Count node)) + (if (gen < j (WB-Bag-Tree-Node-Count node)) (lambda (op) (ecase op (:first (values value t)) @@ -3953,11 +4022,16 @@ (defstruct (WB-Bag-Tree-Node (Make-Equivalent-Bag result)) (let ((pr1 (assoc val2 alist1 :test (equal?-fn cmp-fn)))) (if pr1 - (Make-Equivalent-Bag (cons (cons val2 (gen + (cdr pr1) count2)) + (Make-Equivalent-Bag (cons (cons (car pr1) (gen + (cdr pr1) count2)) (cl:remove pr1 alist1))) (Make-Equivalent-Bag (cons (cons val2 count2) alist1)))))) (if (Equivalent-Node? val2) - (Equivalent-Bag-Sum val2 count2 val1 count1 cmp-fn) + (let ((alist2 (Equivalent-Node-List val2)) + ((pr2 (assoc val1 alist2 :test (equal?-fn cmp-fn))))) + (if pr2 + (Make-Equivalent-Bag (cons (cons val1 (gen + count1 (cdr pr2))) + (cl:remove pr2 alist2))) + (Make-Equivalent-Bag (cons (cons val1 count1) alist2)))) (if (equal?-cmp val1 val2 cmp-fn) (values val1 (gen + count1 count2)) (Make-Equivalent-Bag (list (cons val1 count1) (cons val2 count2))))))) @@ -3982,11 +4056,16 @@ (defstruct (WB-Bag-Tree-Node (Make-Equivalent-Bag result)) (let ((pr1 (assoc val2 alist1 :test (equal?-fn cmp-fn)))) (if pr1 - (Make-Equivalent-Bag (cons (cons val2 (gen max (cdr pr1) count2)) + (Make-Equivalent-Bag (cons (cons (car pr1) (gen max (cdr pr1) count2)) (cl:remove pr1 alist1))) (Make-Equivalent-Bag (cons (cons val2 count2) alist1)))))) (if (Equivalent-Node? val2) - (Equivalent-Bag-Union val2 count2 val1 count1 cmp-fn) + (let ((alist2 (Equivalent-Node-List val2)) + ((pr2 (assoc val1 alist2 :test (equal?-fn cmp-fn))))) + (if pr2 + (Make-Equivalent-Bag (cons (cons val1 (gen max count1 (cdr pr2))) + (cl:remove pr2 alist2))) + (Make-Equivalent-Bag (cons (cons val1 count1) alist2)))) (if (equal?-cmp val1 val2 cmp-fn) (values val1 (gen max count1 count2)) (Make-Equivalent-Bag (list (cons val1 count1) (cons val2 count2))))))) @@ -4010,7 +4089,7 @@ (defstruct (WB-Bag-Tree-Node (t (values t (Make-Equivalent-Bag result))))) (let ((pr1 (assoc val2 alist1 :test (equal?-fn cmp-fn)))) (and pr1 - (values t val2 (gen min (cdr pr1) count2)))))) + (values t (car pr1) (gen min (cdr pr1) count2)))))) (if (Equivalent-Node? val2) (let ((pr2 (assoc val1 (Equivalent-Node-List val2) :test (equal?-fn cmp-fn)))) (and pr2 (values t val1 (gen min count1 (cdr pr2))))) @@ -4036,7 +4115,7 @@ (defstruct (WB-Bag-Tree-Node (t (values t (Make-Equivalent-Bag result))))) (let ((pr1 (assoc val2 alist1 :test (equal?-fn cmp-fn)))) (and pr1 - (values t val2 (gen * (cdr pr1) count2)))))) + (values t (car pr1) (gen * (cdr pr1) count2)))))) (if (Equivalent-Node? val2) (let ((pr2 (assoc val1 (Equivalent-Node-List val2) :test (equal?-fn cmp-fn)))) (and pr2 (values t val1 (gen * count1 (cdr pr2))))) @@ -4306,8 +4385,8 @@ (defstruct (WB-Map-Tree-Node ;;; Lookup (defun WB-Map-Tree-Lookup (tree key key-cmp-fn) - "If `tree' contains a pair whose key is `key', returns two values, true and -the associated value; otherwise `nil'." + "If `tree' contains a pair whose key is equal to `key', returns three values: +true, the associated value, and the key found; otherwise `nil'." (declare (optimize (speed 3) (safety 0)) (type WB-Map-Tree tree) (type function key-cmp-fn)) @@ -4315,18 +4394,19 @@ (defstruct (WB-Map-Tree-Node ((consp tree) (let ((found? idx (Vector-Set-Binary-Search (car tree) key key-cmp-fn))) (and (eq found? ':equal) - (values t (svref (cdr tree) idx))))) + (values t (svref (cdr tree) idx) (svref (car tree) idx))))) (t (let ((node-key (WB-Map-Tree-Node-Key tree)) ((comp (funcall key-cmp-fn key node-key)))) (ecase comp - (:equal (values t (if (Equivalent-Node? node-key) - (cdar (Equivalent-Node-List node-key)) - (WB-Map-Tree-Node-Value tree)))) + (:equal (if (Equivalent-Node? node-key) + (let ((alist (Equivalent-Node-List node-key))) + (values t (cdar alist) (caar alist))) + (values t (WB-Map-Tree-Node-Value tree) node-key))) (:unequal (and (Equivalent-Node? node-key) (let ((pr (assoc key (Equivalent-Node-List node-key) :test (equal?-fn key-cmp-fn)))) - (and pr (values t (cdr pr)))))) + (and pr (values t (cdr pr) (car pr)))))) (:less (WB-Map-Tree-Lookup (WB-Map-Tree-Node-Left tree) key key-cmp-fn)) (:greater @@ -4388,7 +4468,7 @@ (defstruct (WB-Map-Tree-Node (Vector-Insert (cdr tree) idx value)) (Make-WB-Map-Tree-Node (if found? (Equivalent-Map-With (svref (car tree) idx) (svref (cdr tree) idx) - key value key-cmp-fn) + key value key-cmp-fn val-cmp-fn) key) value (and (> idx 0) @@ -4408,7 +4488,7 @@ (defstruct (WB-Map-Tree-Node (if (and (eq key-comp ':equal) (not (Equivalent-Node? key)) (not (Equivalent-Node? node-key)) (equal?-cmp value node-val val-cmp-fn)) tree - (Make-WB-Map-Tree-Node (Equivalent-Map-With node-key node-val key value key-cmp-fn) + (Make-WB-Map-Tree-Node (Equivalent-Map-With node-key node-val key value key-cmp-fn val-cmp-fn) value node-left node-right))) ((:less) (let ((new-left (WB-Map-Tree-With node-left key value key-cmp-fn val-cmp-fn))) @@ -4602,10 +4682,10 @@ (defstruct (WB-Map-Tree-Node ;;; ================================================================================ ;;; Union, intersection, and map difference -(defun WB-Map-Tree-Union (tree1 tree2 val-fn key-cmp-fn) - (WB-Map-Tree-Union-Rng tree1 tree2 val-fn Hedge-Negative-Infinity Hedge-Positive-Infinity key-cmp-fn)) +(defun WB-Map-Tree-Union (tree1 tree2 val-fn key-cmp-fn val-cmp-fn) + (WB-Map-Tree-Union-Rng tree1 tree2 val-fn Hedge-Negative-Infinity Hedge-Positive-Infinity key-cmp-fn val-cmp-fn)) -(defun WB-Map-Tree-Union-Rng (tree1 tree2 val-fn lo hi key-cmp-fn) +(defun WB-Map-Tree-Union-Rng (tree1 tree2 val-fn lo hi key-cmp-fn val-cmp-fn) (declare (optimize (speed 3) (safety 0)) (type function val-fn key-cmp-fn) (type WB-Map-Tree tree1 tree2)) @@ -4616,82 +4696,79 @@ (defstruct (WB-Map-Tree-Node ((null tree1) (WB-Map-Tree-Split tree2 lo hi key-cmp-fn)) ((and (consp tree1) (consp tree2)) - (WB-Map-Tree-Vector-Pair-Union tree1 tree2 val-fn lo hi key-cmp-fn)) + (WB-Map-Tree-Vector-Pair-Union tree1 tree2 val-fn lo hi key-cmp-fn val-cmp-fn)) ((consp tree1) - ;; Can't use the swap-trees trick here, as the operation is noncommutative if 'val-fn' is. (let ((key2 (WB-Map-Tree-Node-Key tree2)) (val2 (WB-Map-Tree-Node-Value tree2)) ((eqvk1? eqvk1 eqvv1 (WB-Map-Tree-Find-Equivalent tree1 key2 key-cmp-fn)) - ((nonnull? key val (if eqvk1? (Equivalent-Map-Union eqvk1 eqvv1 key2 val2 val-fn key-cmp-fn) + ((nonnull? key val (if eqvk1? (Equivalent-Map-Union eqvk1 eqvv1 key2 val2 val-fn key-cmp-fn val-cmp-fn) (values t key2 val2)))))) (WB-Map-Tree-Concat-Maybe nonnull? key val (WB-Map-Tree-Union-Rng (WB-Map-Tree-Trim tree1 lo key2 key-cmp-fn) (WB-Map-Tree-Trim (WB-Map-Tree-Node-Left tree2) lo key2 key-cmp-fn) - val-fn lo key2 key-cmp-fn) + val-fn lo key2 key-cmp-fn val-cmp-fn) (WB-Map-Tree-Union-Rng (WB-Map-Tree-Trim tree1 key2 hi key-cmp-fn) (WB-Map-Tree-Trim (WB-Map-Tree-Node-Right tree2) key2 hi key-cmp-fn) - val-fn key2 hi key-cmp-fn) + val-fn key2 hi key-cmp-fn val-cmp-fn) key-cmp-fn))) (t (let ((key1 (WB-Map-Tree-Node-Key tree1)) (val1 (WB-Map-Tree-Node-Value tree1)) ((eqvk2? eqvk2 eqvv2 (WB-Map-Tree-Find-Equivalent tree2 key1 key-cmp-fn)) - ((nonnull? key val (if eqvk2? (Equivalent-Map-Union key1 val1 eqvk2 eqvv2 val-fn key-cmp-fn) + ((nonnull? key val (if eqvk2? (Equivalent-Map-Union key1 val1 eqvk2 eqvv2 val-fn key-cmp-fn val-cmp-fn) (values t key1 val1)))))) (WB-Map-Tree-Concat-Maybe nonnull? key val (WB-Map-Tree-Union-Rng (WB-Map-Tree-Node-Left tree1) (WB-Map-Tree-Trim tree2 lo key1 key-cmp-fn) - val-fn lo key1 key-cmp-fn) + val-fn lo key1 key-cmp-fn val-cmp-fn) (WB-Map-Tree-Union-Rng (WB-Map-Tree-Node-Right tree1) (WB-Map-Tree-Trim tree2 key1 hi key-cmp-fn) - val-fn key1 hi key-cmp-fn) + val-fn key1 hi key-cmp-fn val-cmp-fn) key-cmp-fn))))) -(defun WB-Map-Tree-Intersect (tree1 tree2 val-fn key-cmp-fn) - (WB-Map-Tree-Intersect-Rng tree1 tree2 val-fn Hedge-Negative-Infinity Hedge-Positive-Infinity key-cmp-fn)) +(defun WB-Map-Tree-Intersect (tree1 tree2 val-fn key-cmp-fn val-cmp-fn) + (WB-Map-Tree-Intersect-Rng tree1 tree2 val-fn Hedge-Negative-Infinity Hedge-Positive-Infinity key-cmp-fn val-cmp-fn)) -(defun WB-Map-Tree-Intersect-Rng (tree1 tree2 val-fn lo hi key-cmp-fn) +(defun WB-Map-Tree-Intersect-Rng (tree1 tree2 val-fn lo hi key-cmp-fn val-cmp-fn) (declare (optimize (speed 3) (safety 0)) - (type function val-fn key-cmp-fn) + (type function val-fn key-cmp-fn val-cmp-fn) (type WB-Map-Tree tree1 tree2)) (cond ((eq tree1 tree2) ; historically-related-map optimization (WB-Map-Tree-Split tree1 lo hi key-cmp-fn)) ((or (null tree1) (null tree2)) nil) ((and (consp tree1) (consp tree2)) - (Vector-Pair-Intersect tree1 tree2 val-fn lo hi key-cmp-fn)) + (Vector-Pair-Intersect tree1 tree2 val-fn lo hi key-cmp-fn val-cmp-fn)) ((consp tree1) - ;; Can't use the swap-trees trick here, as `val-fn' might be noncommutative. (let ((key2 (WB-Map-Tree-Node-Key tree2)) (val2 (WB-Map-Tree-Node-Value tree2)) ((eqvk1? eqvk1 eqvv1 (WB-Map-Tree-Find-Equivalent tree1 key2 key-cmp-fn)) ((nonnull? key val - (and eqvk1? (Equivalent-Map-Intersect eqvk1 eqvv1 key2 val2 val-fn key-cmp-fn)))))) + (and eqvk1? (Equivalent-Map-Intersect eqvk1 eqvv1 key2 val2 val-fn key-cmp-fn val-cmp-fn)))))) (WB-Map-Tree-Concat-Maybe nonnull? key val (WB-Map-Tree-Intersect-Rng (WB-Map-Tree-Trim tree1 lo key2 key-cmp-fn) - ;; I think this `trim' call is redundant. (WB-Map-Tree-Trim (WB-Map-Tree-Node-Left tree2) lo key2 key-cmp-fn) - val-fn lo key2 key-cmp-fn) + val-fn lo key2 key-cmp-fn val-cmp-fn) (WB-Map-Tree-Intersect-Rng (WB-Map-Tree-Trim tree1 key2 hi key-cmp-fn) (WB-Map-Tree-Trim (WB-Map-Tree-Node-Right tree2) key2 hi key-cmp-fn) - val-fn key2 hi key-cmp-fn) + val-fn key2 hi key-cmp-fn val-cmp-fn) key-cmp-fn))) (t (let ((key1 (WB-Map-Tree-Node-Key tree1)) (val1 (WB-Map-Tree-Node-Value tree1)) ((eqvk2? eqvk2 eqvv2 (WB-Map-Tree-Find-Equivalent tree2 key1 key-cmp-fn)) ((nonnull? key val - (and eqvk2? (Equivalent-Map-Intersect key1 val1 eqvk2 eqvv2 val-fn key-cmp-fn)))))) + (and eqvk2? (Equivalent-Map-Intersect key1 val1 eqvk2 eqvv2 val-fn key-cmp-fn val-cmp-fn)))))) (WB-Map-Tree-Concat-Maybe nonnull? key val (WB-Map-Tree-Intersect-Rng (WB-Map-Tree-Node-Left tree1) (WB-Map-Tree-Trim tree2 lo key1 key-cmp-fn) - val-fn lo key1 key-cmp-fn) + val-fn lo key1 key-cmp-fn val-cmp-fn) (WB-Map-Tree-Intersect-Rng (WB-Map-Tree-Node-Right tree1) (WB-Map-Tree-Trim tree2 key1 hi key-cmp-fn) - val-fn key1 hi key-cmp-fn) + val-fn key1 hi key-cmp-fn val-cmp-fn) key-cmp-fn))))) @@ -5076,7 +5153,7 @@ (defstruct (WB-Map-Tree-Node ;; Fall back to the general case, being careful to keep the rightmost value for ;; a duplicated key. (values (WB-Map-Tree-Union (WB-Map-Tree-With left k v key-cmp-fn val-cmp-fn) - right (fn (_a b) b) key-cmp-fn) + right (fn (_a b) b) key-cmp-fn val-cmp-fn) (if (less-than?-cmp left-first right-first key-cmp-fn) left-first right-first) (if (less-than?-cmp left-last right-last key-cmp-fn) right-last left-last)))))))) (recur len))) @@ -5299,8 +5376,8 @@ (defstruct (WB-Map-Tree-Node (WB-Map-Tree-Verify-Rng (WB-Map-Tree-Node-Right tree) key hi key-cmp-fn)))))) -(defun WB-Map-Tree-Vector-Pair-Union (pr1 pr2 val-fn lo hi key-cmp-fn) - (let ((new-pr any-equivalent? (Vector-Pair-Union pr1 pr2 val-fn lo hi key-cmp-fn))) +(defun WB-Map-Tree-Vector-Pair-Union (pr1 pr2 val-fn lo hi key-cmp-fn val-cmp-fn) + (let ((new-pr any-equivalent? (Vector-Pair-Union pr1 pr2 val-fn lo hi key-cmp-fn val-cmp-fn))) (if any-equivalent? (let ((tree nil)) ;; Let's just do it the stupid way -- it's not supposed to happen often. @@ -5319,10 +5396,10 @@ (defstruct (WB-Map-Tree-Node (Vector-Subseq (cdr new-pr) (1+ split-point))))) new-pr)))) -(defun Vector-Pair-Union (pr1 pr2 val-fn lo hi key-cmp-fn) +(defun Vector-Pair-Union (pr1 pr2 val-fn lo hi key-cmp-fn val-cmp-fn) (declare (optimize (speed 3) (safety 0)) (type cons pr1 pr2) - (type function val-fn key-cmp-fn)) + (type function val-fn key-cmp-fn val-cmp-fn)) (let ((keys1 (the simple-vector (car pr1))) (keys2 (the simple-vector (car pr2))) (vals1 (the simple-vector (cdr pr1))) @@ -5366,7 +5443,10 @@ (defstruct (WB-Map-Tree-Node ((comp (funcall key-cmp-fn key1 key2)))) (ecase comp ((:equal) - (let ((new-val second-val (funcall val-fn (svref vals1 i1) (svref vals2 i2)))) + (let ((val1 (svref vals1 i1)) + (val2 (svref vals2 i2)) + ((new-val second-val (if (equal?-cmp val1 val2 val-cmp-fn) val1 + (funcall val-fn val1 val2))))) (unless (eq second-val ':no-value) (push key1 keys) (push new-val vals))) @@ -5383,7 +5463,7 @@ (defstruct (WB-Map-Tree-Node ((:unequal) (let ((nonnull? key val (Equivalent-Map-Union key1 (svref vals1 i1) - key2 (svref vals2 i2) val-fn key-cmp-fn))) + key2 (svref vals2 i2) val-fn key-cmp-fn val-cmp-fn))) (when nonnull? (push key keys) (push val vals) @@ -5392,10 +5472,10 @@ (defstruct (WB-Map-Tree-Node (incf i1) (incf i2))))))))) -(defun Vector-Pair-Intersect (pr1 pr2 val-fn lo hi key-cmp-fn) +(defun Vector-Pair-Intersect (pr1 pr2 val-fn lo hi key-cmp-fn val-cmp-fn) (declare (optimize (speed 3) (safety 0)) (type cons pr1 pr2) - (type function val-fn key-cmp-fn)) + (type function val-fn key-cmp-fn val-cmp-fn)) (let ((keys1 (the simple-vector (car pr1))) (vals1 (the simple-vector (cdr pr1))) (keys2 (the simple-vector (car pr2))) @@ -5421,7 +5501,10 @@ (defstruct (WB-Map-Tree-Node ((comp (funcall key-cmp-fn key1 key2)))) (ecase comp ((:equal) - (let ((new-val second-val (funcall val-fn (svref vals1 i1) (svref vals2 i2)))) + (let ((val1 (svref vals1 i1)) + (val2 (svref vals2 i2)) + ((new-val second-val (if (equal?-cmp val1 val2 val-cmp-fn) val1 + (funcall val-fn val1 val2))))) (unless (eq second-val ':no-value) (push key1 keys) (push new-val vals))) @@ -5819,13 +5902,13 @@ (defstruct (WB-Map-Tree-Node ;;; ================================================================================ ;;; Equivalent-Map routines -(defun Equivalent-Map-With (key1 val1 key2 val2 key-cmp-fn) - (let ((nonnull? key val (Equivalent-Map-Union key1 val1 key2 val2 (fn (_a b) b) key-cmp-fn))) +(defun Equivalent-Map-With (key1 val1 key2 val2 key-cmp-fn val-cmp-fn) + (let ((nonnull? key val (Equivalent-Map-Union key1 val1 key2 val2 (fn (_a b) b) key-cmp-fn val-cmp-fn))) (declare (ignore nonnull?)) ;; `nonnull?' must be true given `val-fn'. (values key val))) -(defun Equivalent-Map-Union (key1 val1 key2 val2 val-fn key-cmp-fn) +(defun Equivalent-Map-Union (key1 val1 key2 val2 val-fn key-cmp-fn val-cmp-fn) "Both `key1' and `key2' may be single values (representing a single key/value pair) or `Equivalent-Map's of key/value pairs. That is, if `key1' is a `Equivalent-Map', `val1' is ignored, and similarly for `key2' and `val2'. @@ -5833,62 +5916,64 @@ (defstruct (WB-Map-Tree-Node the \"1\" pairs. If the result is a single pair, it's returned as two values; otherwise one value is returned, which is an `Equivalent-Map'." (declare (optimize (speed 3) (safety 0)) - (type function key-cmp-fn val-fn) + (type function key-cmp-fn val-cmp-fn val-fn) (dynamic-extent val-fn)) - (if (Equivalent-Node? key1) - (if (Equivalent-Node? key2) + (flet ((compute-new-val (val1 val2) + (if (equal?-cmp val1 val2 val-cmp-fn) + (values val1 nil) + (n-values 2 (funcall val-fn val1 val2))))) + (if (Equivalent-Node? key1) + (if (Equivalent-Node? key2) + (let ((alist1 (Equivalent-Node-List key1)) + (alist2 (copy-list (Equivalent-Node-List key2))) + ((result nil))) + (declare (type list alist1 alist2)) + (dolist (pr1 alist1) + (let ((pr2 (find (car pr1) alist2 :test (equal?-fn key-cmp-fn) :key #'car))) + (if pr2 + (let ((new-val second-val (compute-new-val (cdr pr1) (cdr pr2)))) + (unless (eq second-val ':no-value) + (push (cons (car pr1) new-val) result)) + (setq alist2 (delete pr2 alist2))) + (push pr1 result)))) + (setq result (nconc result alist2)) + (cond ((null result) nil) + ((null (cdr result)) + (values t (caar result) (cdar result))) + (t + (values t (Make-Equivalent-Map result))))) (let ((alist1 (Equivalent-Node-List key1)) - (alist2 (Equivalent-Node-List key2)) - ((result nil))) - (declare (type list alist1 alist2)) - (dolist (pr1 alist1) - (let ((pr2 (find (car pr1) alist2 :test (equal?-fn key-cmp-fn) :key #'car))) - (if pr2 - (let ((new-val second-val (funcall val-fn (cdr pr1) (cdr pr2)))) - (unless (eq second-val ':no-value) - (push (cons (car pr1) new-val) result))) - (push pr1 result)))) - (dolist (pr2 alist2) - (let ((pr1 (find (car pr2) alist1 :test (equal?-fn key-cmp-fn) :key #'car))) - (when (null pr1) - (push pr2 result)))) - (cond ((null result) nil) - ((cdr result) - (values t (Make-Equivalent-Map result))) - (t - (values t (caar result) (cdar result))))) - (let ((alist1 (Equivalent-Node-List key1)) - ((pr1 (find key2 alist1 :test (equal?-fn key-cmp-fn) :key #'car)))) - (declare (type list alist1)) - (if pr1 - (progn - (setq alist1 (remove pr1 alist1)) - (let ((new-val second-val (funcall val-fn (cdr pr1) val2))) - (if (eq second-val ':no-value) - (if (null (cdr alist1)) - (values t (caar alist1) (cdar alist1)) - (values t (Make-Equivalent-Map alist1))) - (values t (Make-Equivalent-Map (cons (cons key2 new-val) alist1)))))) - (values t (Make-Equivalent-Map (cons (cons key2 val2) alist1)))))) - (if (Equivalent-Node? key2) - (let ((alist2 (Equivalent-Node-List key2)) - ((pr2 (find key1 alist2 :test (equal?-fn key-cmp-fn) :key #'car)))) - (declare (type list alist2)) - (if pr2 - (progn - (setq alist2 (remove pr2 alist2)) - (let ((new-val second-val (funcall val-fn val1 (cdr pr2)))) - (if (eq second-val ':no-value) - (if (null (cdr alist2)) - (values t (caar alist2) (cdar alist2)) - (values t (Make-Equivalent-Map alist2))) - (values t (Make-Equivalent-Map (cons (cons key1 new-val) alist2)))))) - (values t (Make-Equivalent-Map (cons (cons key1 val1) alist2))))) - (if (equal?-cmp key1 key2 key-cmp-fn) - (let ((new-val second-val (funcall val-fn val1 val2))) - (and (not (eq second-val ':no-value)) - (values t key1 new-val))) - (values t (Make-Equivalent-Map (list (cons key1 val1) (cons key2 val2)))))))) + ((pr1 (find key2 alist1 :test (equal?-fn key-cmp-fn) :key #'car)))) + (declare (type list alist1)) + (if pr1 + (progn + (setq alist1 (remove pr1 alist1)) + (let ((new-val second-val (compute-new-val (cdr pr1) val2))) + (if (eq second-val ':no-value) + (if (null (cdr alist1)) + (values t (caar alist1) (cdar alist1)) + (values t (Make-Equivalent-Map alist1))) + (values t (Make-Equivalent-Map (cons (cons (car pr1) new-val) alist1)))))) + (values t (Make-Equivalent-Map (cons (cons key2 val2) alist1)))))) + (if (Equivalent-Node? key2) + (let ((alist2 (Equivalent-Node-List key2)) + ((pr2 (find key1 alist2 :test (equal?-fn key-cmp-fn) :key #'car)))) + (declare (type list alist2)) + (if pr2 + (progn + (setq alist2 (remove pr2 alist2)) + (let ((new-val second-val (compute-new-val val1 (cdr pr2)))) + (if (eq second-val ':no-value) + (if (null (cdr alist2)) + (values t (caar alist2) (cdar alist2)) + (values t (Make-Equivalent-Map alist2))) + (values t (Make-Equivalent-Map (cons (cons key1 new-val) alist2)))))) + (values t (Make-Equivalent-Map (cons (cons key1 val1) alist2))))) + (if (equal?-cmp key1 key2 key-cmp-fn) + (let ((new-val second-val (compute-new-val val1 val2))) + (and (not (eq second-val ':no-value)) + (values t key1 new-val))) + (values t (Make-Equivalent-Map (list (cons key1 val1) (cons key2 val2))))))))) (defun Equivalent-Map-Update (key1 val1 key2 value-fn default second-arg key-cmp-fn) "`key1' may be either a single value (representing a single key/value pair) @@ -5913,7 +5998,7 @@ (defstruct (WB-Map-Tree-Node (Make-Equivalent-Map (list (cons key1 val1) (cons key2 (funcall value-fn default second-arg))))))) -(defun Equivalent-Map-Intersect (key1 val1 key2 val2 val-fn key-cmp-fn) +(defun Equivalent-Map-Intersect (key1 val1 key2 val2 val-fn key-cmp-fn val-cmp-fn) "Both `key1' and `key2' may be single values (representing a single key/value pair) or `Equivalent-Map's of key/value pairs. That is, if `key1' is a `Equivalent-Map', `val1' is ignored, and similarly for `key2' and `val2'. @@ -5922,39 +6007,43 @@ (defstruct (WB-Map-Tree-Node pair, returns true and an `Equivalent-Map' of the pairs. If the intersection is null, returns false." (declare (optimize (speed 3) (safety 0)) - (type function val-fn key-cmp-fn)) - (if (Equivalent-Node? key1) - (if (Equivalent-Node? key2) + (type function val-fn key-cmp-fn val-cmp-fn)) + (flet ((compute-new-val (val1 val2) + (if (equal?-cmp val1 val2 val-cmp-fn) + (values val1 nil) + (n-values 2 (funcall val-fn val1 val2))))) + (if (Equivalent-Node? key1) + (if (Equivalent-Node? key2) + (let ((alist1 (Equivalent-Node-List key1)) + (alist2 (Equivalent-Node-List key2)) + (result nil)) + (declare (type list alist1 alist2)) + (dolist (pr1 alist1) + (let ((pr2 (cl:find (car pr1) alist2 :test (equal?-fn key-cmp-fn) :key #'car))) + (when pr2 + (let ((new-val second-val (compute-new-val (cdr pr1) (cdr pr2)))) + (unless (eq second-val ':no-value) + (push (cons (car pr1) new-val) result)))))) + (and result + (if (cdr result) + (values t (Make-Equivalent-Map result)) + (values t (caar result) (cdar result))))) (let ((alist1 (Equivalent-Node-List key1)) - (alist2 (Equivalent-Node-List key2)) - (result nil)) - (declare (type list alist1 alist2)) - (dolist (pr1 alist1) - (let ((pr2 (cl:find (car pr1) alist2 :test (equal?-fn key-cmp-fn) :key #'car))) - (when pr2 - (let ((new-val second-val (funcall val-fn (cdr pr1) (cdr pr2)))) - (unless (eq second-val ':no-value) - (push (cons (car pr1) new-val) result)))))) - (and result - (if (cdr result) - (values t (Make-Equivalent-Map result)) - (values t (caar result) (cdar result))))) - (let ((alist1 (Equivalent-Node-List key1)) - ((pr1 (cl:find key2 alist1 :test (equal?-fn key-cmp-fn) :key #'car)))) - (declare (type list alist1)) - (and pr1 - (let ((new-val second-val (funcall val-fn (cdr pr1) val2))) - (and (not (eq second-val ':no-value)) (values t key2 new-val)))))) - (if (Equivalent-Node? key2) - (let ((alist2 (Equivalent-Node-List key2)) - ((pr2 (cl:find key1 alist2 :test (equal?-fn key-cmp-fn) :key #'car)))) - (declare (type list alist2)) - (and pr2 - (let ((new-val second-val (funcall val-fn val1 (cdr pr2)))) - (and (not (eq second-val ':no-value)) (values t key1 new-val))))) - (and (equal?-cmp key1 key2 key-cmp-fn) - (let ((new-val second-val (funcall val-fn val1 val2))) - (and (not (eq second-val ':no-value)) (values t key1 new-val))))))) + ((pr1 (cl:find key2 alist1 :test (equal?-fn key-cmp-fn) :key #'car)))) + (declare (type list alist1)) + (and pr1 + (let ((new-val second-val (compute-new-val (cdr pr1) val2))) + (and (not (eq second-val ':no-value)) (values t (car pr1) new-val)))))) + (if (Equivalent-Node? key2) + (let ((alist2 (Equivalent-Node-List key2)) + ((pr2 (cl:find key1 alist2 :test (equal?-fn key-cmp-fn) :key #'car)))) + (declare (type list alist2)) + (and pr2 + (let ((new-val second-val (compute-new-val val1 (cdr pr2)))) + (and (not (eq second-val ':no-value)) (values t key1 new-val))))) + (and (equal?-cmp key1 key2 key-cmp-fn) + (let ((new-val second-val (compute-new-val val1 val2))) + (and (not (eq second-val ':no-value)) (values t key1 new-val)))))))) (defun Equivalent-Map-Difference (key1 val1 key2 val2 key-cmp-fn val-cmp-fn) "Both `key1' and `key2' may be single values (representing a single key/value @@ -6139,6 +6228,37 @@ (defstruct (WB-Seq-Tree-Node (list nil sub))))) (format stream "#seq-node<...>"))) +(declaim (inline character-type)) +(defun character-type (ch) + (declare (ignorable ch)) + ;; In some 32-bit implementations with two character types, we only want to use `base-char', + ;; because `character' takes 32 bits — might as well use simple-vectors for those. + #-FSet-Ext-Strings 'base-char + #+FSet-Ext-Strings (if (typep ch 'base-char) 'base-char 'character)) + +(declaim (inline string-char-type)) +(defun string-char-type (str) + "The element-type of a string." + (declare (ignorable str)) + #-FSet-Ext-Strings 'base-char + #+FSet-Ext-Strings (if (typep str 'base-string) 'base-char 'character)) + +(declaim (inline string-plus-char-type)) +(defun string-plus-char-type (str ch) + "The element-type of a new string with `ch' being added to the contents of `str'." + (declare (ignorable str ch)) + #-FSet-Ext-Strings 'base-char + #+FSet-Ext-Strings (if (and (typep str 'base-string) (typep ch 'base-char)) + 'base-char + 'character)) + +(declaim (inline string-plus-string-type)) +(defun string-plus-string-type (str1 str2) + (declare (ignorable str1 str2)) + #-FSet-Ext-Strings 'base-string + #+FSet-Ext-Strings (if (and (typep str1 'base-string) (typep str2 'base-string)) + 'base-string + 'string)) (defun WB-Seq-Tree-Subscript (tree idx) @@ -6146,6 +6266,7 @@ (defstruct (WB-Seq-Tree-Node (type WB-Seq-Tree tree) (type fixnum idx)) (cond ((null tree) nil) + ;; &&& Might be faster to check for a node first. ((stringp tree) (and (>= idx 0) (< idx (length tree)) (values t (schar tree idx)))) @@ -6169,7 +6290,10 @@ (defstruct (WB-Seq-Tree-Node (type WB-Seq-Tree tree) (type fixnum idx)) (cond ((null tree) - (if (characterp value) (string value) + (if (characterp value) + (let ((str (make-string 1 :element-type (character-type value)))) + (setf (schar str 0) value) + str) (vector value))) ((stringp tree) (if (characterp value) @@ -6221,12 +6345,7 @@ (defstruct (WB-Seq-Tree-Node (type simple-string str) (type fixnum idx)) (let ((len (length str)) - ((new-str (make-string (1+ len) - :element-type #-FSet-Ext-Strings 'base-char - #+FSet-Ext-Strings (if (and (typep str 'base-string) - (typep ch 'base-char)) - 'base-char - 'character))))) + ((new-str (make-string (1+ len) :element-type (string-plus-char-type str ch))))) (dotimes (i idx) (setf (schar new-str i) (schar str i))) (setf (schar new-str idx) ch) @@ -6260,11 +6379,7 @@ (defstruct (WB-Seq-Tree-Node (type simple-string str) (type fixnum start end)) (let ((len (- end start)) - ((new-str (make-string len - :element-type #-FSet-Ext-Strings 'base-char - #+FSet-Ext-Strings (if (typep str 'base-string) - 'base-char - 'character))))) + ((new-str (make-string len :element-type (string-char-type str))))) (declare (fixnum len)) (dotimes (i len) (setf (schar new-str i) (schar str (+ i start)))) @@ -6277,12 +6392,7 @@ (defstruct (WB-Seq-Tree-Node (type simple-string str) (type fixnum start end idx)) (let ((len (- end start)) - ((new-str (make-string (1+ len) - :element-type #-FSet-Ext-Strings 'base-char - #+FSet-Ext-Strings (if (and (typep str 'base-string) - (typep ch 'base-char)) - 'base-char - 'character))))) + ((new-str (make-string (1+ len) :element-type (string-plus-char-type str ch))))) (declare (type fixnum len)) (dotimes (i idx) (setf (schar new-str i) (schar str (+ i start)))) @@ -6335,11 +6445,7 @@ (defstruct (WB-Seq-Tree-Node (type (unsigned-byte 24) idx)) (let ((len (length str))) (and (> len 1) - (let ((new-str (make-string (1- len) - :element-type #-FSet-Ext-Strings 'base-char - #+FSet-Ext-Strings (if (typep str 'base-string) - 'base-char - 'character)))) + (let ((new-str (make-string (1- len) :element-type (string-char-type str)))) (declare (fixnum len)) (dotimes (i idx) (setf (schar new-str i) (schar str i))) @@ -6386,12 +6492,7 @@ (defstruct (WB-Seq-Tree-Node (type simple-string str) (type fixnum idx)) (let ((len (length str)) - ((new-str (make-string len - :element-type #-FSet-Ext-Strings 'base-char - #+FSet-Ext-Strings (if (and (typep str 'base-string) - (typep ch 'base-char)) - 'base-char - 'character))))) + ((new-str (make-string len :element-type (string-plus-char-type str ch))))) (declare (fixnum len)) (dotimes (i len) (setf (schar new-str i) (schar str i))) @@ -6622,19 +6723,72 @@ (defstruct (WB-Seq-Tree-Node (left (pop stack))) (push (Make-WB-Seq-Tree-Node left right) stack)))))))) +(defun WB-Seq-Tree-From-List-Reverse (lst) + (declare (optimize (speed 3) (safety 0)) + (type list lst)) + (and lst + (let ((len (length lst)) + ((npieces (ceiling len *WB-Tree-Max-Vector-Length*)) + ((piece-len remainder (floor len npieces))))) + (declare (type fixnum npieces piece-len remainder)) + (do ((ipiece 0 (1+ ipiece)) + (stack nil)) + ((= ipiece npieces) + (do () ((null (cdr stack))) + (let ((left (pop stack)) + (right (pop stack))) + (push (Make-WB-Seq-Tree-Node left right) stack))) + (car stack)) + (declare (type fixnum ipiece)) + (let ((piece-len (if (< ipiece remainder) (1+ piece-len) piece-len)) + ((piece (cond ((gmap (:result and) (fn (x _y) (typep x 'base-char)) + (:arg list lst) + (:arg index 0 piece-len)) + (let ((str (make-string piece-len + :element-type 'base-char))) + (dotimes (i piece-len) + (setf (schar str (- piece-len i 1)) (pop lst))) + str)) + #+FSet-Ext-Strings + ((gmap (:result and) (fn (x _y) (typep x 'character)) + (:arg list lst) + (:arg index 0 piece-len)) + (let ((str (make-string piece-len + :element-type 'character))) + (dotimes (i piece-len) + (setf (char str (- piece-len i 1)) (pop lst))) + str)) + (t + (let ((vec (make-array piece-len))) + (dotimes (i piece-len) + (setf (svref vec (- piece-len i 1)) (pop lst))) + vec)))))) + (push piece stack) + (do ((i ipiece (ash i -1))) + ((evenp i)) + (declare (type fixnum i)) + (let ((left (pop stack)) + (right (pop stack))) + (push (Make-WB-Seq-Tree-Node left right) stack)))))))) + (defun WB-Seq-Tree-To-List (tree) - (declare (optimize (speed 3) (safety 0))) - (if (or (null tree) (vectorp tree)) - (coerce tree 'list) - ;; We carefully build the list from the right so this runs in linear time. - (labels ((build (tree result) - (cond ((null tree) result) - ((vectorp tree) - (nconc (coerce tree 'list) result)) - (t - (build (WB-Seq-Tree-Node-Left tree) - (build (WB-Seq-Tree-Node-Right tree) result)))))) - (build tree nil)))) + (declare (optimize (speed 3) (safety 0)) + #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) + (rlabels (build tree nil) + (build (tree result) + (cond ((null tree) result) + ;; SBCL wants the type breakdown to optimize the `coerce'. + ((simple-vector-p tree) + (nconc (coerce tree 'list) result)) + #+FSet-Ext-Strings + ((typep tree 'base-string) + (nconc (coerce tree 'list) result)) + ((typep tree 'string) + (nconc (coerce tree 'list) result)) + (t + ;; We build the list from the right so we don't need an `nreverse'. + (build (WB-Seq-Tree-Node-Left tree) + (build (WB-Seq-Tree-Node-Right tree) result))))))) (defun WB-Seq-Tree-From-Iterable (it len) ;; (declare (optimize (speed 3) (safety 0))) @@ -6808,12 +6962,7 @@ (defstruct (WB-Seq-Tree-Node ((null right) left) ((and (stringp left) (stringp right) (<= (+ (length-nv left) (length-nv right)) *WB-Tree-Max-String-Length*)) - (concatenate #-FSet-Ext-Strings 'base-string - #+FSet-Ext-Strings (if (and (typep left 'base-string) - (typep right 'base-string)) - 'base-string - 'string) - (the string left) (the string right))) + (concatenate (string-plus-string-type left right) left right)) ((and (or (stringp left) (simple-vector-p left)) (or (stringp right) (simple-vector-p right))) (if (<= (+ (length-nv left) (length-nv right)) *WB-Tree-Max-Vector-Length*) @@ -6987,7 +7136,7 @@ (defstruct (WB-Seq-Tree-Node (:more? (not (WB-Seq-Tree-Iterator-Done? iter))))))) (defun Make-WB-Seq-Tree-Iterator-Internal (tree &optional start end) - (declare (optimize (speed 3) (safety 1)) + (declare (optimize (speed 3) (safety 0)) (type (or null fixnum) start end)) (let ((tree-size (WB-Seq-Tree-Size tree)) ((iter (Make-WB-Tree-Iterator tree tree-size 2 nil)))) @@ -7076,7 +7225,7 @@ (defstruct (WB-Seq-Tree-Node (:more? (not (WB-Seq-Tree-Rev-Iterator-Done? iter))))))) (defun Make-WB-Seq-Tree-Rev-Iterator-Internal (tree &optional start end) - (declare (optimize (speed 3) (safety 1)) + (declare (optimize (speed 3) (safety 0)) (type (or null fixnum) start end)) (let ((tree-size (WB-Seq-Tree-Size tree)) ((iter (Make-WB-Tree-Iterator tree tree-size 2 nil)))) @@ -7110,7 +7259,7 @@ (defstruct (WB-Seq-Tree-Node (cons iter (- start end)))) (defun WB-Seq-Tree-Rev-Iterator-Canonicalize (iter) - (declare (optimize (debug 3) (safety 0))) + (declare (optimize (speed 3) (safety 0))) (unless (zerop (the fixnum (cdr iter))) (let ((stack (car iter))) (loop @@ -7146,7 +7295,7 @@ (defstruct (WB-Seq-Tree-Node (zerop (the fixnum (cdr iter)))) (defun WB-Seq-Tree-Rev-Iterator-Get (iter) - (declare (optimize (debug 3) (safety 0))) + (declare (optimize (speed 3) (safety 0))) (if (zerop (the fixnum (cdr iter))) (values nil nil) (let ((stack (car iter)) diff --git a/fset.asd b/fset.asd index da96bc74ce15223fab1f5d52b42d6b19b82e8c02..fd124403b78516f60382609a93f235c929f062f5 100644 --- a/fset.asd +++ b/fset.asd @@ -13,11 +13,11 @@ See: https://gitlab.common-lisp.net/fset/fset/-/wikis/home " :author "Scott L. Burson " - :version "1.6.0" + :version "2.0.0" :homepage "https://gitlab.common-lisp.net/fset/fset/-/wikis/home" :source-control "https://github.com/slburson/fset" :license "BSD-2-Clause" - :depends-on (:misc-extensions :mt19937 :named-readtables) + :depends-on ((:version :misc-extensions "4.2.0") :mt19937 :named-readtables) :in-order-to ((test-op (test-op "fset/test"))) :serial t :components