From eee87f05f8289d4606ce69a54eae9c918588ef6a Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sun, 28 Sep 2025 21:56:35 -0700 Subject: [PATCH 01/37] Add lexicographic compare-fns; remove `less-than?', `greater-than?'. --- Code/defs.lisp | 16 ++++--------- Code/fset.lisp | 20 ++++++++++++++++ Code/macros.lisp | 12 ++++++++++ Code/order.lisp | 12 +++++----- Code/testing.lisp | 60 ++++++++++++++++++++++++---------------------- Code/wb-trees.lisp | 13 ---------- 6 files changed, 74 insertions(+), 59 deletions(-) diff --git a/Code/defs.lisp b/Code/defs.lisp index e3f0796..1f5ad13 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -40,17 +40,14 @@ #: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 #: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 @@ -160,17 +157,14 @@ #: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 #: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 diff --git a/Code/fset.lisp b/Code/fset.lisp index 8e7526d..03bfb45 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -4671,6 +4671,26 @@ (defmethod compare ((s1 wb-seq) (s2 wb-seq)) ':unequal ':equal)))))) +(defun compare-seqs-lexicographically (a b &optional (val-compare-fn #'compare)) + (declare (type function val-compare-fn)) + (if (eq a b) ':equal + (let ((a-size (size a)) + (b-size (size b)) + (default ':equal)) + (or (gmap :or (fn (ea eb) + (let ((comp (funcall val-compare-fn ea eb))) + (ecase comp + ((:less :greater) comp) + (:equal nil) + (:unequal + (setq default ':unequal) + nil)))) + (:arg seq a) + (:arg seq b)) + (cond ((< a-size b-size) ':less) + ((> a-size b-size) ':greater)) + default)))) + (defmethod hash-value ((s wb-seq)) ;; Currently doing bounded hashing, but &&& am considering changing it to do caching ;; with incremental update. diff --git a/Code/macros.lisp b/Code/macros.lisp index 0bf20e0..5969fb2 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -1310,6 +1310,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)) diff --git a/Code/order.lisp b/Code/order.lisp index ca557a2..f45cf30 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))) @@ -420,6 +414,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 +443,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 diff --git a/Code/testing.lisp b/Code/testing.lisp index 63b9475..fe625c2 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -105,8 +105,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))) @@ -2627,16 +2630,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)) @@ -2649,16 +2652,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)) @@ -2779,16 +2783,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)) @@ -2807,12 +2811,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)) @@ -2971,16 +2977,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)) @@ -3014,7 +3020,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)) @@ -3024,7 +3031,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)) @@ -3227,8 +3235,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 @@ -3285,12 +3293,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. diff --git a/Code/wb-trees.lisp b/Code/wb-trees.lisp index a7cb975..23febc0 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 -- GitLab From 42bb26c4027b0b7f08b3cd75d75f95dfa7d1fdbb Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Fri, 3 Oct 2025 21:14:11 -0700 Subject: [PATCH 02/37] Initial commit of FSet2! --- Code/champ.lisp | 1 + Code/defs.lisp | 76 +++- Code/fset.lisp | 961 +++++++++++++++++++++++++++++++++----------- Code/macros.lisp | 103 ++++- Code/reader.lisp | 205 +++++++--- Code/relations.lisp | 131 +++--- Code/replay.lisp | 107 +++-- Code/testing.lisp | 341 +++++++++++----- Code/tuples.lisp | 24 +- 9 files changed, 1440 insertions(+), 509 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index d208524..4106ed5 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -328,6 +328,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)) diff --git a/Code/defs.lisp b/Code/defs.lisp index 1f5ad13..8c63159 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -61,9 +61,10 @@ #:set-difference #:set-difference-2 #:bag-difference #: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 @@ -131,23 +132,33 @@ (: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- + ;; 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) + ;; 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 + #:empty-set #:empty-map #:empty-wb-map #:empty-ch-map #:empty-seq #:empty-wb-seq + ;; 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 @@ -178,9 +189,13 @@ #:set-difference #:set-difference-2 #:bag-difference #: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 + #:map-domain-error #:map-domain-error-map #:map-domain-error-key + #:seq-bounds-error #:seq-bounds-error-seq #:seq-bounds-error-index + #: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 @@ -214,7 +229,7 @@ #: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 + #: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 @@ -256,8 +271,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 6676883..b00ceb3 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 two values: if it contains a mapping +for `key', the corresponding value and true; otherwise, the map's default and +false. + +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 two values: if it contains a mapping +for `key', the corresponding value and true; otherwise, the map's default and +false. 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 @@ -285,7 +309,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 +318,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) @@ -315,7 +339,7 @@ (defmethod filter (fn (s sequence)) (defmethod filter-pairs (fn (collection t)) (filter fn collection)) -(defgeneric image (fn collection &key) +(define-generics (image 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, @@ -357,6 +381,12 @@ (defmethod reduce (fn (s sequence) &rest keyword-args "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.")) +(defgeneric fset2:default (collection) + (:documentation + "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 @@ -382,6 +412,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 +449,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 +515,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 @@ -1287,19 +1369,19 @@ (defmethod concat ((a list) &rest seqs) (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 +1395,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 +1436,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 +1448,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 +1505,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 +1518,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 +1532,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) @@ -1550,15 +1644,19 @@ (defstruct (wb-custom-set (defun empty-set () "Returns an empty set of the default implementation." *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-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* @@ -1586,9 +1684,6 @@ (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 @@ -1632,7 +1727,7 @@ (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) @@ -1853,14 +1948,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 +1969,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 +2002,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?)) @@ -1957,6 +2060,8 @@ (defmethod stable-sort ((s set) pred &key key) (defmethod convert ((to-type (eql 'set)) (s set) &key) s) +(defmethod convert ((to-type (eql 'fset2:set)) (s set) &key) + s) (defmethod convert ((to-type (eql 'wb-set)) (s set) &key compare-fn-name) (convert-to-wb-set s nil @@ -1989,6 +2094,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 +2108,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 +2117,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 @@ -2026,11 +2137,11 @@ (defmethod find (item (s set) &key key test) (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 (not (eq test #'equal?)) + (do-set (x s) + (when (funcall test item x) + (return x))) + (nth-value 1 (lookup s item)))))) (defmethod find-if (pred (s set) &key key) (declare (optimize (speed 3) (safety 0))) @@ -2060,7 +2171,7 @@ (defmethod count (item (s set) &key key test) (when (funcall test item (funcall key x)) (incf total)))) (if default? - (if (lookup s item) 1 0) + (if (contains? s item) 1 0) (let ((total 0)) (declare (fixnum total)) (do-set (x s total) @@ -2141,11 +2252,24 @@ (defstruct (ch-set (defparameter *empty-ch-set* (make-ch-set nil (make-hash-set-org 'compare #'compare #'hash-value))) -(declaim (inline empty-ch-set)) +(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 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-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* @@ -2172,9 +2296,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 +2326,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)))) @@ -2297,12 +2418,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 +2432,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 +2450,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 +2472,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))) @@ -2479,16 +2609,19 @@ (defstruct (wb-bag "Returns an empty bag of the default implementation and type." *empty-wb-bag*) -(defmethod empty-instance-function ((class-name (eql 'bag))) - 'empty-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-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)) @@ -2505,9 +2638,6 @@ (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)))) @@ -2548,6 +2678,9 @@ (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'." @@ -2995,27 +3128,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 +3166,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?)) @@ -3303,18 +3442,28 @@ (defstruct (wb-map "Returns an empty map of the default implementation." (if default (make-wb-map nil +fset-default-tree-map-org+ default) *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* (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." + (if (and default? no-default?) + (error "Both a default and `no-default?' specified") + (let ((default (if default? default (and no-default? 'no-default)))) + (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*) + (t (make-wb-map nil +fset-default-tree-map-org+ default)))))) (deflex +empty-wb-custom-map-cache+ (make-hash-table :test 'equal)) @@ -3338,17 +3487,16 @@ (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) - (defmethod empty-map-like ((m wb-map)) (let ((tmorg (wb-map-org m))) (empty-wb-custom-map (map-default m) (tree-map-org-key-compare-fn-name tmorg) @@ -3367,11 +3515,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,11 +3558,29 @@ (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))))) +(define-condition fset2:map-domain-error (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)))))) + (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))))) ;; Our internal convention is the reverse of the external one. (values (if val? val (map-default m)) val?))) +(defmethod fset2: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))))) + (values (if val? val + (let ((default (map-default m))) + (if (eq default 'no-default) + (error 'fset2:map-domain-error :map m :key key) + default))) + val?))) (defmethod rank ((m wb-map) x) (let ((found? rank (WB-Map-Tree-Rank (wb-map-contents m) x @@ -3554,29 +3725,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,30 +3810,62 @@ (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))) + (let ((v1 v1? (lookup m1 k))) ; no error (if (not v1?) (setf (lookup result k) 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) + (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) + (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)) - tmorg (let ((def1 (map-default map1)) - (def2 (map-default map2))) - (and (or def1 def2) (funcall val-fn def1 def2)))) + 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)) + 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))) (do-map (k v1 m1) @@ -3665,20 +3874,47 @@ (defmethod map-intersection ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2 (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) + (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) + (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)) - tmorg (let ((def1 (map-default map1)) - (def2 (map-default map2))) - (and (or def1 def2) (funcall val-fn def1 def2)))) + 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)) + 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)) @@ -3693,13 +3929,36 @@ (defmethod map-difference-2 ((m1 map) (m2 map)) (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 +3999,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 @@ -3765,24 +4024,40 @@ (defmethod compose ((map1 wb-map) (map2 map) &key val-compare-fn-name) (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'." + (make-wb-map (WB-Map-Tree-Compose (wb-map-contents map1) + (fn (x) + (let ((val2 val2? (fset2: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 ((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))))))) -(defmethod compose ((m wb-map) (fn function) &key val-compare-fn-name) +(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) m) +(defmethod convert ((to-type (eql 'fset2:map)) (m map) &key) + m) (defmethod convert ((to-type (eql 'wb-map)) (m wb-map) &key (default nil default?) key-compare-fn-name val-compare-fn-name) @@ -3795,6 +4070,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,36 +4108,60 @@ (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-wb-set result))) ;;; &&& 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 'fset2:map)) (l list) &key (key-fn #'car) (value-fn #'cdr)) + (convert 'ch-map l :key-fn key-fn :value-fn value-fn)) (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) (wb-map-from-sequence l key-fn value-fn input-sorted? key-compare-fn-name val-compare-fn-name)) +(defmethod convert ((to-type (eql '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) &key (key-fn #'car) (value-fn #'cdr) input-sorted?) (with-default (wb-map-from-sequence s key-fn value-fn input-sorted?) (seq-default s))) +(defmethod convert ((to-type (eql 'fset2:map)) (s seq) &key (key-fn #'car) (value-fn #'cdr)) + (convert 'ch-map s :key-fn key-fn :value-fn value-fn)) (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) + (with-default (wb-map-from-sequence s key-fn value-fn input-sorted? key-compare-fn-name val-compare-fn-name) + (seq-default s))) +(defmethod convert ((to-type (eql '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))) (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 'fset2:map)) (s sequence) &key (key-fn #'car) (value-fn #'cdr)) + (convert 'ch-map s :key-fn key-fn :value-fn value-fn)) (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) (wb-map-from-sequence s key-fn value-fn input-sorted? key-compare-fn-name val-compare-fn-name)) +(defmethod convert ((to-type (eql '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) (convert-to-wb-map s nil nil @@ -3866,6 +4178,8 @@ (defmethod convert ((to-type (eql 'wb-map)) (s sequence) (defmethod convert ((to-type (eql 'map)) (b bag) &key) (convert 'wb-map b)) +(defmethod convert ((to-type (eql 'fset2:map)) (b bag) &key) + (convert 'ch-map b)) (defmethod convert ((to-type (eql '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 @@ -3874,9 +4188,16 @@ (defmethod convert ((to-type (eql 'wb-map)) (b bag) &key key-compare-fn-name val (let ((tree nil)) (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 'fset2:wb-map)) (b bag) &key key-compare-fn-name val-compare-fn-name) + (convert-to-wb-map b nil nil + (let ((tree nil)) + (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) (convert 'wb-map ht)) +(defmethod convert ((to-type (eql 'fset2:map)) (ht hash-table) &key) + (convert 'ch-map ht)) (defmethod convert ((to-type (eql 'wb-map)) (ht hash-table) &key key-compare-fn-name val-compare-fn-name) (convert-to-wb-map ht nil nil @@ -3885,6 +4206,13 @@ (defmethod convert ((to-type (eql 'wb-map)) (ht hash-table) &key key-compare-fn- (setq tree (WB-Map-Tree-With tree k v key-compare-fn val-compare-fn))) ht) tree))) +(defmethod convert ((to-type (eql '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) + (setq tree (WB-Map-Tree-With tree k v key-compare-fn val-compare-fn))) + ht) + tree))) (defmethod convert ((to-type (eql 'hash-table)) (m map) &rest make-hash-table-args &key &allow-other-keys) @@ -3974,11 +4302,13 @@ (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*~]~@[/~A~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (map-default map)))) + (if (eq dflt 'no-default) "[no default]" + (format nil "~S" dflt))))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) @@ -3989,8 +4319,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))) ;;; ================================================================================ @@ -4023,13 +4355,36 @@ (defstruct (ch-map (make-ch-map nil (make-hash-map-org 'compare #'compare #'hash-value 'compare #'compare #'hash-value) nil)) -(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." + (if (and default? no-default?) + (error "Both a default and `no-default?' specified") + (let ((default (if default? default (and no-default? 'no-default)))) + (if (null default) + *empty-ch-map* + (make-ch-map nil (ch-map-org *empty-ch-map*) default))))) + +(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-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." + (if (and default? no-default?) + (error "Both a default and `no-default?' specified") + (let ((default (if default? default (and no-default? 'no-default)))) + (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*) + (t (make-ch-map nil (ch-map-org *empty-ch-map*) default)))))) (deflex +empty-ch-custom-map-cache+ (make-hash-table :test 'equal)) @@ -4043,7 +4398,6 @@ (defstruct (ch-map (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'. (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 +4415,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 +4451,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))) @@ -4147,6 +4503,16 @@ (defmethod lookup ((m ch-map) 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?))) +(defmethod 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))))) + (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 index ((m ch-map) key) (declare (optimize (debug 3))) @@ -4222,9 +4588,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 +4611,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)) @@ -4277,14 +4668,25 @@ (defmethod compose ((map1 ch-map) (map2 map) &key 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 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))) ; no error + (if val2? val2 (map-default map2))))) + (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)))))))) -(defmethod compose ((m ch-map) (fn function) &key val-compare-fn-name) +(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 +4694,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 +4704,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 +4726,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)) @@ -4354,6 +4762,11 @@ (defmethod convert ((to-type (eql 'wb-map)) (m ch-map) &key key-compare-fn-name (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 '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)) @@ -4416,6 +4829,12 @@ (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)) (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)))))) + (defmethod convert ((to-type (eql 'ch-map)) (ht hash-table) &key key-compare-fn-name val-compare-fn-name) (convert-to-ch-map ht nil nil (let ((tree nil)) @@ -4431,11 +4850,13 @@ (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*~]~@[/~A~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (map-default map)))) + (if (eq dflt 'no-default) "[no default]" + (format nil "~S" dflt))))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) @@ -4469,50 +4890,99 @@ (defstruct (wb-seq (defparameter *empty-wb-seq* (make-wb-seq nil)) -(declaim (inline empty-seq)) +(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 () +(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." + (if (and default? no-default?) + (error "Both a default and `no-default?' specified") + (cond (default? (make-wb-seq nil default)) + (no-default? (make-wb-seq nil 'no-default)) + (t *empty-wb-seq*)))) + +(declaim (inline empty-wb-seq fset2:empty-wb-seq)) +(defun empty-wb-seq (&optional default) "Returns an empty wb-seq." - *empty-wb-seq*) - -(defmethod empty-instance-function ((class-name (eql 'wb-seq))) - '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." + (if (and default? no-default?) + (error "Both a default and `no-default?' specified") + (cond (default? (make-wb-seq nil default)) + (no-default? (make-wb-seq nil 'no-default)) + (t *empty-wb-seq*)))) (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))) +(define-condition fset2:seq-bounds-error (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)))))) + (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))) + (let ((val? val (if (typep key 'fixnum) (WB-Seq-Tree-Subscript (wb-seq-contents s) key) + (values nil nil)))) + (values (if val? val (seq-default s)) val?))) +(defmethod 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 (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 +5008,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 +5033,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 +5055,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))) @@ -4766,7 +5246,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)) @@ -4797,20 +5276,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)) @@ -4822,20 +5303,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)) @@ -4869,21 +5352,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) + (seq-image fn s '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) + (seq-image (coerce-to-function fn) s '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) + (seq-image #'(lambda (x) (fset2:lookup fn x)) s '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) + (seq-image #'(lambda (x) (fset2:lookup fn x)) s '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) + (seq-image #'(lambda (x) (fset2:lookup fn x)) s '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 @@ -4891,8 +5384,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?) @@ -5162,11 +5654,14 @@ (defmethod substitute-if-not (newitem pred (s seq) &key key start end from-end c (write-char #\Space stream) (pprint-newline :linear stream) (write x :stream stream)) - (format stream " ]~:[~;/~:*~S~]" (seq-default seq)))) + (format stream " ]~:[~;/~:*~A~]" + (let ((dflt (seq-default seq))) + (if (eq dflt 'no-default) "[no default]" + (format nil "~S" dflt)))))) (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))) ;;; ================================================================================ @@ -5183,13 +5678,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) @@ -5214,16 +5709,16 @@ (defmethod convert ((to-type (eql 'vector)) (s sequence) &key) (defun compose-with-key-fn (fn collection) (lambda (key) (lookup collection (funcall fn key)))) -(defmethod compose ((fn function) (m map) &key) +(define-methods (compose fset2: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 symbol) (m map) &key) (compose-with-key-fn fn m)) -(defmethod compose ((fn function) (s seq) &key) +(define-methods (compose fset2:compose) ((fn function) (s seq) &key) (compose-with-key-fn fn s)) -(defmethod compose ((fn symbol) (s seq) &key) +(define-methods (compose fset2:compose) ((fn symbol) (s seq) &key) (compose-with-key-fn fn s)) diff --git a/Code/macros.lisp b/Code/macros.lisp index 5969fb2..0d19124 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -168,6 +168,16 @@ (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))) + ;;; 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 @@ -509,20 +519,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 +558,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 +594,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)) ;;; -------------------------------- @@ -767,10 +803,14 @@ (define-setf-expander @ (collection key &environment env) #'(lambda (it) (funcall it ':done?)) #'(lambda (it) (funcall it ':get)))) +(gmap:def-arg-type-synonym fset2:set set) + (gmap:def-gmap-res-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)) +(gmap:def-result-type-synonym fset2:set set) + ;;; A bit faster than `set', if you know it's a `wb-set'. (gmap:def-gmap-arg-type wb-set (set) @@ -916,12 +956,16 @@ (define-setf-expander @ (collection key &environment env) #'(lambda (it) (funcall it ':done?)) (:values 2 #'(lambda (it) (funcall it ':get))))) +(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))) +(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?) #'(lambda (it) (funcall it ':empty?)) @@ -933,7 +977,9 @@ (define-setf-expander @ (collection key &environment env) 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)) + ,filterp)) + +(gmap:def-result-type-synonym fset2:map map) (gmap:def-gmap-res-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. @@ -948,6 +994,8 @@ (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-synonym fset2:wb-map wb-map) + (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' @@ -962,6 +1010,8 @@ (define-setf-expander @ (collection key &environment env) ,filterp ((,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) "Returns the map-intersection of the values, optionally filtered by `filterp'. @@ -977,6 +1027,8 @@ (define-setf-expander @ (collection key &environment env) ,filterp ((,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) "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. @@ -992,6 +1044,8 @@ (define-setf-expander @ (collection key &environment env) #'ch-map-tree-iterator-done? (:values 2 #'ch-map-tree-iterator-get))) +(gmap:def-arg-type-synonym fset2:ch-map ch-map) + (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." @@ -1009,6 +1063,8 @@ (define-setf-expander @ (collection key &environment env) (,vhf-var (hash-map-org-val-hash-fn ,org-var)) (,vcf-var (hash-map-org-val-compare-fn ,org-var))))))) +(gmap:def-result-type-synonym fset2:ch-map ch-map) + ;;; ---------------- ;;; Seqs @@ -1085,7 +1141,7 @@ (define-setf-expander @ (collection key &environment env) ;;; 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) "Consumes two values from the mapped function; returns a wb-2-relation of the pairs. @@ -1379,6 +1435,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/reader.lisp b/Code/reader.lisp index be1af08..7cade7d 100644 --- a/Code/reader.lisp +++ b/Code/reader.lisp @@ -176,7 +176,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 +191,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 +200,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 +208,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 +218,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 +242,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 +250,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 +259,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 +267,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 +276,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 +303,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 +315,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 +329,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-set-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 +341,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 +375,20 @@ 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', in which case the next argument subform is a form whose value will +become the map's default. 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 +402,20 @@ 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', in which case the +next argument subform is a form whose value will become the map's default. 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 +433,24 @@ 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', in which case the +next argument subform is a form whose value will become the map's default. 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 +464,20 @@ 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', in which case the +next argument subform is a form whose value will become the map's default. 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 +495,45 @@ 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', in which case the +next argument subform is a form whose value will become the map's default. 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 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 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~@ @@ -468,7 +560,7 @@ 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)) + (expand-replay-map-constructor-form '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 @@ -480,7 +572,7 @@ 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)) + (expand-replay-map-constructor-form '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 @@ -492,7 +584,8 @@ 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)) + (expand-replay-map-constructor-form '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 @@ -504,7 +597,7 @@ 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)) + (expand-replay-map-constructor-form '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 @@ -516,17 +609,25 @@ 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)) + (expand-replay-map-constructor-form '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 args &optional 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)) + ((result `(,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 +645,7 @@ 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 wb-seq (&rest args) "Constructs a wb-seq according to the supplied argument subforms. Each @@ -552,14 +653,14 @@ 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)) -(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 +736,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 +752,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 +768,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 +785,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 +801,12 @@ (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 key-compare-fn-name `(,key-compare-fn-name ,val-compare-fn-name))))) (labels ((recur (subforms result) (if (null subforms) result (let ((subform (car subforms))) diff --git a/Code/relations.lisp b/Code/relations.lisp index e4f2801..0d0edd7 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -40,11 +40,9 @@ (defmethod arity ((rel 2-relation)) (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) + ;; Now CHAMP! + (declare (special *empty-ch-2-relation*)) + *empty-ch-2-relation*) (defgeneric lookup-inv (2-relation y) (:documentation "Does an inverse lookup on a binary relation.")) @@ -121,13 +119,19 @@ (defstruct (wb-2-relation (defparameter *empty-wb-2-relation* (make-wb-2-relation 0 nil nil (wb-map-org *empty-wb-map*))) -(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-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)) @@ -153,9 +157,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)))) @@ -185,7 +186,7 @@ (defmethod contains? ((rel wb-2-relation) x &optional (y nil y?)) ;;; 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) +(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))))) @@ -448,20 +449,20 @@ (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) @@ -478,8 +479,8 @@ (defmethod compose ((rel1 wb-2-relation) (rel2 wb-2-relation) &key) (:arg wb-map (make-wb-map (wb-2-relation-map0 rel) +fset-default-tree-map-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) @@ -576,34 +577,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)))) @@ -777,13 +763,19 @@ (defstruct (ch-2-relation (defparameter *empty-ch-2-relation* (make-ch-2-relation 0 nil nil (ch-map-org *empty-ch-map*))) -(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-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)) @@ -819,9 +811,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 +835,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 @@ -1108,20 +1091,20 @@ (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) @@ -1139,8 +1122,8 @@ (defmethod compose ((rel1 ch-2-relation) (rel2 ch-2-relation) &key) (:arg ch-map (make-ch-map (ch-2-relation-map0 rel) (ch-map-org *empty-ch-map*) 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) @@ -1235,6 +1218,14 @@ (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)) + (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 '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 +1234,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)) @@ -1509,6 +1507,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-wb-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 +1523,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)) @@ -1926,6 +1939,15 @@ (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)) @@ -2342,6 +2364,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 +2403,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 6defe2a..91d4790 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -14,15 +14,13 @@ ;;; We have some implementation-generic methods. +(declaim (inline empty-replay-set)) (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) - (defmethod convert ((to-type (eql 'replay-set)) (s replay-set) &key) s) @@ -73,11 +71,15 @@ (defstruct (wb-replay-set (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-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)) @@ -93,9 +95,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))) @@ -155,7 +154,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)))) @@ -316,11 +315,15 @@ (defstruct (ch-replay-set (defparameter *empty-ch-replay-set* (make-ch-replay-set nil nil (ch-set-org *empty-ch-set*))) -(declaim (inline 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-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)) @@ -343,9 +346,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))) @@ -398,7 +398,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)))) @@ -540,13 +540,19 @@ (defmethod less ((s ch-replay-set) value &optional (arg2 nil arg2?)) ;;; We have some implementation-generic methods. +(declaim (inline empty-replay-map fset2:empty-replay-map)) (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) +(defun fset2:empty-replay-map (&key (default nil default?) no-default?) + (declare (special *empty-ch-replay-map*)) + (if (and default? no-default?) + (error "Both a default and `no-default?' specified") + (let ((default (if default? default (and no-default? 'no-default)))) + (if (null default) + *empty-ch-replay-map* + (make-ch-replay-map nil nil (ch-map-org *empty-ch-map*) default))))) (defmethod convert ((to-type (eql 'replay-map)) (m replay-map) &key) m) @@ -628,12 +634,25 @@ (defstruct (wb-replay-map (defparameter *empty-wb-replay-map* (make-wb-replay-map nil nil +fset-default-tree-map-org+)) +(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* (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." + (if (and default? no-default?) + (error "Both a default and `no-default?' specified") + (let ((default (if default? default (and no-default? 'no-default)))) + (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*) + (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)) @@ -662,9 +681,6 @@ (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)) @@ -808,6 +824,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)))) @@ -886,11 +911,13 @@ (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*~]~@[/~A~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (map-default map)))) + (if (eq dflt 'no-default) "[no default]" + (format nil "~S" dflt))))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) @@ -914,18 +941,31 @@ (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*))) +(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-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." + (if (and default? no-default?) + (error "Both a default and `no-default?' specified") + (let ((default (if default? default (and no-default? 'no-default)))) + (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*) + (t (make-ch-replay-map nil nil (ch-map-org *empty-ch-map*) default)))))) (deflex +empty-ch-custom-replay-map-cache+ (make-hash-table :test 'equal)) @@ -964,9 +1004,6 @@ (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)) @@ -1094,6 +1131,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))) @@ -1183,11 +1230,13 @@ (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*~]~@[/~A~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (map-default map)))) + (if (eq dflt 'no-default) "[no default]" + (format nil "~S" dflt))))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) diff --git a/Code/testing.lisp b/Code/testing.lisp index 669ab50..73b6120 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -83,6 +83,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)) @@ -3752,85 +3753,85 @@ (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)))) + + (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))))) + + (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)))) + + (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)))) + (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")))) + (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")))) @@ -3841,25 +3842,25 @@ (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)) + (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))) - (2-relation ('a 7) ('a 11) ('b 7) ('c 6) ('c 15)))) + (wb-2-relation ('a 7) ('a 11) ('b 7) ('c 6) ('c 15)))) - (test (equal? (image (2-relation ('a 3) ('a 5) ('b 3) ('c 4) ('c 8)) + (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)))) @@ -3874,31 +3875,31 @@ (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 '2-relation (map ('a (set 3 5)) ('b (set 2)) ('c (set 4 7))) + (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 'wb-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 '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 (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 (2-relation ('a 3) ('a 5) ('b 6) ('b 8)) - (2-relation ('a 3) ('a 5) ('b 7) ('b 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))) @@ -4047,8 +4048,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))) @@ -4414,3 +4415,161 @@ (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) + +(defun fset::test-fset2 () + (macrolet ((test (form) + `(unless ,form + (error "Test failed: ~S" ',form))) + (test-error (form) + `(handler-case (progn + ,form + (error "Test failed to signal an error: ~S" ',form)) + (error ())))) + #+sbcl + ;; Check that each shadowed GF has the same methods in `fset:' and `fset2:'. + (flet ((methods (gf) + (gmap (:result set) + (fn (method) (cddr (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)) + (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))))) + ;; 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))) + + ;; 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? (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 wbm (map ('a 4)))) + (list (wb-map ('c 7) :no-default) (map ('a 4) :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 7)) (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)))))) diff --git a/Code/tuples.lisp b/Code/tuples.lisp index 074943f..87d53b4 100644 --- a/Code/tuples.lisp +++ b/Code/tuples.lisp @@ -641,7 +641,7 @@ (defmethod with ((tuple tuple) (key tuple-key) &optional (value nil value?)) (check-three-arguments value? 'with 'tuple) (Tuple-With tuple key value)) -(defmethod lookup ((tuple tuple) (key tuple-key)) +(define-methods (lookup fset2: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))) @@ -687,16 +687,18 @@ (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) - (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)) + +(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) @@ -730,12 +732,14 @@ (defmethod make-load-form ((key tuple-key) &optional environment) ;;; ================================================================================ -(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))) -- GitLab From 798cb36cc97087325448019fd81769921a1a447a Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sat, 4 Oct 2025 14:52:35 -0700 Subject: [PATCH 03/37] Fix 'rank' semantics. --- Code/defs.lisp | 1 + Code/fset.lisp | 25 +++++++++++++++++++++++++ Code/testing.lisp | 7 +++++-- 3 files changed, 31 insertions(+), 2 deletions(-) diff --git a/Code/defs.lisp b/Code/defs.lisp index 8c63159..8b4bb2e 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -150,6 +150,7 @@ (:shadow ;; Names shadowed from `fset:' to implement FSet2 semantics #:set #:map #:wb-map #:wb-custom-map #:ch-map #:ch-custom-map #:empty-set #:empty-map #:empty-wb-map #:empty-ch-map #:empty-seq #:empty-wb-seq + #:rank ;; 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 diff --git a/Code/fset.lisp b/Code/fset.lisp index b00ceb3..418ad93 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -164,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 @@ -1733,6 +1747,9 @@ (define-wb-set-methods (lookup fset2:lookup) ((s wb-set) key) (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)) @@ -2686,6 +2703,10 @@ (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'." @@ -3586,6 +3607,10 @@ (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)) diff --git a/Code/testing.lisp b/Code/testing.lisp index 73b6120..3148e18 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -4439,7 +4439,8 @@ (defmethod verify ((m ch-map)) (gmap (:result set) (fn (method) (cddr (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)) + (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))))) @@ -4572,4 +4573,6 @@ (defmethod verify ((m ch-map)) (ch-map ('a 12) :no-default))) (test-error (compose (ch-map ('a 7)) (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)))))) + (ch-map ('a 12) :no-default))) + + (test (= (rank (wb-set 1 3 5) 2) 1))))) -- GitLab From 44fe78538baf4335a83739cf8597504ff63a7176 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sat, 4 Oct 2025 16:04:10 -0700 Subject: [PATCH 04/37] Fix tuple key defaulting. --- Code/defs.lisp | 5 ++-- Code/testing.lisp | 16 ++++++++--- Code/tuples.lisp | 67 +++++++++++++++++++++++++++++++++++++++++------ 3 files changed, 75 insertions(+), 13 deletions(-) diff --git a/Code/defs.lisp b/Code/defs.lisp index 8b4bb2e..a829a2e 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -150,7 +150,7 @@ (:shadow ;; Names shadowed from `fset:' to implement FSet2 semantics #:set #:map #:wb-map #:wb-custom-map #:ch-map #:ch-custom-map #:empty-set #:empty-map #:empty-wb-map #:empty-ch-map #:empty-seq #:empty-wb-seq - #:rank + #:rank #:define-tuple-key #:get-tuple-key ;; 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 @@ -194,6 +194,7 @@ #:with-default #:without-default #:default #: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 @@ -212,7 +213,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* diff --git a/Code/testing.lisp b/Code/testing.lisp index 3148e18..2ad56da 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+) @@ -263,11 +263,12 @@ (define-hash-function erapmoc hash-value-negated) ($ (tuple (+K1+ 2) (+K2+ 3))) (+K0+ 2) ($ (tuple (+K4+ 7) (+K2+ 8)))))) - #'< :key (fn (x) (tuple-key-number (car x)))) + #'string< :key (fn (x) (tuple-key-name (car x)))) `((,+K0+ . 2) (,+K1+ . 2) (,+K2+ . 8) (,+K4+ . 7)))) (test (less-than? (tuple (+K0+ 1)) (tuple (+K0+ 2)))) (test (unequal? (tuple (+K0+ 1.0) (+K1+ 'c)) (tuple (+K0+ 1) (+K1+ 'c)))) (test (less-than? (tuple (+K0+ 1.0) (+K1+ 'c)) (tuple (+K0+ 1) (+K1+ 'd)))) + (test (equal? (@ (tuple (+K0+ 'foo) (+K2+ 'zot)) +K1+) 'foo)) (test (not (equal? (map (3 7) :default 0) (map (3 7) :default 1)))) (test (not (equal? (with-default (seq 42 17) 6) (with-default (seq 42 17) 9)))) @@ -4424,6 +4425,8 @@ (defmethod verify ((m ch-map)) (in-package :fset2) +(define-tuple-key +k5+ :default 'plugh) + (defun fset::test-fset2 () (macrolet ((test (form) `(unless ,form @@ -4575,4 +4578,11 @@ (defmethod verify ((m ch-map)) (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 (= (rank (wb-set 1 3 5) 2) 1)) + (test (equal? (@ (tuple) +k5+) 'plugh)) + (let ((k (get-tuple-key 'fubar :default 11))) + (test (equal? (@ (tuple) k) 11)) + (setq k (get-tuple-key 'fubar :no-default? t)) + (test-error (@ (tuple) k)) + (setq k (get-tuple-key 'fubar :default 0)) + (test (equal? (@ (tuple) k) 0)))))) diff --git a/Code/tuples.lisp b/Code/tuples.lisp index 87d53b4..de5ba27 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 nil) ; default 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, `lookup' +in this case will signal an error. If neither is specified, then if the key is +being freshly created, its default will be `nil'; otherwise, its default is +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'." @@ -174,6 +199,17 @@ (defstruct (tuple-key (when doc-string (setf (get name 'tuple-key-doc-string) doc-string)) `(deflex ,name (get-tuple-key ',name ,default))) +(defmacro fset2:define-tuple-key (name &key (default nil default?) (no-default? nil 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' when +the tuple has no explicit pair with this key; if `no-default?' is true, +that case will cause an error; if neither is supplied, the key's default +is `nil'." + (assert (symbolp name)) + (when documentation + (setf (get name 'tuple-key-documentation) documentation)) + `(deflex-reinit ,name (fset2:get-tuple-key ',name ,@(and default? `(:default ,default)) + . ,(and no-default?? `(:no-default? ,no-default?))))) (defun print-tuple-key (key stream level) (declare (ignore level)) @@ -641,11 +677,26 @@ (defmethod with ((tuple tuple) (key tuple-key) &optional (value nil value?)) (check-three-arguments value? 'with 'tuple) (Tuple-With tuple key value)) -(define-methods (lookup fset2:lookup) ((tuple tuple) (key tuple-key)) +(define-condition fset2:tuple-key-unbound-error (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))) + (let ((default-fn (tuple-key-default 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)))) @@ -727,7 +778,7 @@ (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))) ;;; ================================================================================ -- GitLab From 4f123265093dc74bb5b9674b28bc0dd45279f417 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sun, 5 Oct 2025 14:12:21 -0700 Subject: [PATCH 05/37] Print defaults iff they exist. (Instead of suppressing "/NIL" and printing "/[no default]" when there was none.) --- Code/fset.lisp | 21 +++++++++------------ Code/replay.lisp | 10 ++++------ 2 files changed, 13 insertions(+), 18 deletions(-) diff --git a/Code/fset.lisp b/Code/fset.lisp index 418ad93..4c1cc0c 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -4329,11 +4329,10 @@ (defmethod count-if-not (pred (m map) &key key) ((key-default? (eq key-cf-name 'compare)) (val-default? (eq val-cf-name 'compare)))) (dflt (map-default map))) - (format nil " |}~:[[~:[~S~;~*~];~:[~S~;~*~]]~;~4*~]~@[/~A~]" + (format nil " |}~:[[~:[~S~;~*~];~:[~S~;~*~]]~;~4*~]~:[/~S~;~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (if (eq dflt 'no-default) "[no default]" - (format nil "~S" dflt))))) + (eq dflt 'no-default) dflt))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) @@ -4877,11 +4876,10 @@ (defmethod convert ((to-type (eql 'ch-map)) (ht hash-table) &key key-compare-fn- ((key-default? (eq key-cf-name 'compare)) (val-default? (eq val-cf-name 'compare)))) (dflt (map-default map))) - (format nil " |}~:[[~:[~S~;~*~];~:[~S~;~*~]]~;~4*~]~@[/~A~]" + (format nil " |}~:[[~:[~S~;~*~];~:[~S~;~*~]]~;~4*~]~:[/~S~;~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (if (eq dflt 'no-default) "[no default]" - (format nil "~S" dflt))))) + (eq dflt 'no-default) dflt))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) @@ -5673,16 +5671,15 @@ (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 " ]~:[~;/~:*~A~]" - (let ((dflt (seq-default seq))) - (if (eq dflt 'no-default) "[no default]" - (format nil "~S" dflt)))))) + (write x :stream stream)))) (defmethod make-load-form ((s wb-seq) &optional environment) (declare (ignore environment)) diff --git a/Code/replay.lisp b/Code/replay.lisp index 91d4790..b54759c 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -913,11 +913,10 @@ (defmethod domain ((m wb-replay-map)) ((key-default? (eq key-cf-name 'compare)) (val-default? (eq val-cf-name 'compare)))) (dflt (map-default map))) - (format nil " |}~:[[~:[~S~;~*~]:~:[~S~;~*~]]~;~4*~]~@[/~A~]" + (format nil " |}~:[[~:[~S~;~*~]:~:[~S~;~*~]]~;~4*~]~:[/~S~;~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (if (eq dflt 'no-default) "[no default]" - (format nil "~S" dflt))))) + (eq dflt 'no-default) dflt))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) @@ -1232,11 +1231,10 @@ (defmethod domain ((m ch-replay-map)) ((key-default? (eq key-cf-name 'compare)) (val-default? (eq val-cf-name 'compare)))) (dflt (map-default map))) - (format nil " |}~:[[~:[~S~;~*~]:~:[~S~;~*~]]~;~4*~]~@[/~A~]" + (format nil " |}~:[[~:[~S~;~*~]:~:[~S~;~*~]]~;~4*~]~:[/~S~;~]" (and key-default? val-default?) key-default? key-cf-name val-default? val-cf-name - (if (eq dflt 'no-default) "[no default]" - (format nil "~S" dflt))))) + (eq dflt 'no-default) dflt))) (do-map (x y map) (pprint-pop) (write-char #\Space stream) -- GitLab From 81371e7a00680aacaafa2cdb0776ed28529feb68 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sun, 5 Oct 2025 14:15:23 -0700 Subject: [PATCH 06/37] Doc string improvements, and missing 'without-default' methods. --- Code/fset.lisp | 6 ++ Code/reader.lisp | 146 +++++++++++++++++++++++++++++------------------ Code/replay.lisp | 6 ++ 3 files changed, 102 insertions(+), 56 deletions(-) diff --git a/Code/fset.lisp b/Code/fset.lisp index 4c1cc0c..236f5f8 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -406,6 +406,12 @@ (defmethod reduce (fn (s sequence) &rest keyword-args "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 diff --git a/Code/reader.lisp b/Code/reader.lisp index 7cade7d..600a014 100644 --- a/Code/reader.lisp +++ b/Code/reader.lisp @@ -382,12 +382,16 @@ `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. 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." +`: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) @@ -408,13 +412,16 @@ 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. 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." +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) @@ -443,13 +450,16 @@ 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', in which case the -next argument subform is a form whose value will become the map's default. 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." +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) @@ -470,13 +480,16 @@ 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. 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." +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) @@ -505,13 +518,16 @@ 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', in which case the -next argument subform is a form whose value will become the map's default. 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." +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 @@ -556,10 +572,14 @@ `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." +`: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 'fset2:empty-replay-map args)) (defmacro wb-replay-map (&rest args) @@ -567,11 +587,14 @@ 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." +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 'fset2:empty-wb-replay-map args)) (defmacro wb-custom-replay-map (key-compare-fn-name val-compare-fn-name &rest args) @@ -580,10 +603,14 @@ `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." +`: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 'fset2:empty-wb-replay-map args key-compare-fn-name val-compare-fn-name)) @@ -592,11 +619,14 @@ 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." +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 'fset2::empty-ch-replay-map args)) (defmacro ch-custom-replay-map (key-compare-fn-name val-compare-fn-name &rest args) @@ -605,10 +635,14 @@ `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." +`: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 'fset2::empty-ch-replay-map args key-compare-fn-name val-compare-fn-name)) diff --git a/Code/replay.lisp b/Code/replay.lisp index b54759c..3b83c97 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -684,6 +684,9 @@ (defstruct (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))) @@ -1006,6 +1009,9 @@ (defstruct (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))) -- GitLab From 728c7e9f9710b9a5a60f45ad9e87ea9f2976ff27 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Wed, 8 Oct 2025 18:09:56 -0700 Subject: [PATCH 07/37] GMap expander tests & fixes; missing 'convert' methods; other misc. --- Code/defs.lisp | 15 ++- Code/fset.lisp | 80 ++++++++++-- Code/macros.lisp | 293 ++++++++++++++++++++++++++------------------ Code/reader.lisp | 2 +- Code/relations.lisp | 201 +++++++++++++++++++++++------- Code/replay.lisp | 22 ++++ Code/testing.lisp | 275 +++++++++++++++++++++++++++++++++++++++-- Code/tuples.lisp | 4 + 8 files changed, 712 insertions(+), 180 deletions(-) diff --git a/Code/defs.lisp b/Code/defs.lisp index a829a2e..dc26c4c 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -58,7 +58,7 @@ #: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 #:update @@ -114,6 +114,9 @@ ;;; 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, @@ -145,10 +148,14 @@ #:position #:position-if #:position-if-not #:remove #:remove-if #:remove-if-not #:substitute #:substitute-if #:substitute-if-not - #:some #:every #:notany #:notevery) + #: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 + #:set #:map #:wb-map #:wb-custom-map #:ch-map #:ch-custom-map #:map-to-sets #:empty-set #:empty-map #:empty-wb-map #:empty-ch-map #:empty-seq #:empty-wb-seq #:rank #:define-tuple-key #:get-tuple-key ;; These just changed from `&optional' to `&key' @@ -187,7 +194,7 @@ #: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 #:update diff --git a/Code/fset.lisp b/Code/fset.lisp index 236f5f8..6430681 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -3257,6 +3257,8 @@ (defmethod convert ((to-type (eql 'wb-bag)) (b wb-bag) &key compare-fn-name) (defmethod convert ((to-type (eql '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 '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) (convert-to-wb-set b nil @@ -4799,16 +4801,17 @@ (defmethod convert ((to-type (eql 'fset2:wb-map)) (m ch-map) &key key-compare-fn (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)))) + (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 '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) @@ -4824,6 +4827,20 @@ (defmethod convert ((to-type (eql 'ch-map)) (m ch-map) (do-ch-map-tree-pairs (k v (ch-map-contents 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 '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))) + (or (eq m-hmorg hmorg) + (and (eq key-hash-fn (hash-map-org-key-hash-fn m-hmorg)) + (eq key-compare-fn (hash-map-org-key-compare-fn m-hmorg)) + (eq val-hash-fn (hash-map-org-val-hash-fn m-hmorg)) + (eq val-compare-fn (hash-map-org-val-compare-fn m-hmorg))))) + (let ((tree nil)) + (do-ch-map-tree-pairs (k v (ch-map-contents 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)) (l list) &key (key-fn #'car) (value-fn #'cdr) @@ -4835,6 +4852,16 @@ (defmethod convert ((to-type (eql 'ch-map)) (l list) (setq tree (ch-map-tree-with tree (funcall key-fn x) (funcall value-fn x) key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) tree))) +(defmethod convert ((to-type (eql '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)) + (dolist (x l) + (setq tree (ch-map-tree-with tree (funcall key-fn x) (funcall value-fn x) + 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) @@ -4846,6 +4873,16 @@ (defmethod convert ((to-type (eql 'ch-map)) (s seq) (setq tree (ch-map-tree-with tree (funcall key-fn x) (funcall value-fn x) key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) tree))) +(defmethod convert ((to-type (eql '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)) + (do-seq (x s) + (setq tree (ch-map-tree-with tree (funcall key-fn x) (funcall value-fn x) + 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) @@ -4858,12 +4895,28 @@ (defmethod convert ((to-type (eql 'ch-map)) (s sequence) (setq tree (ch-map-tree-with tree (funcall key-fn x) (funcall value-fn x) key-hash-fn key-compare-fn val-hash-fn val-compare-fn)))) tree))) +(defmethod convert ((to-type (eql '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)) + (dotimes (i (length s)) + (let ((x (elt s i))) + (setq tree (ch-map-tree-with tree (funcall key-fn x) (funcall value-fn x) + key-hash-fn key-compare-fn val-hash-fn val-compare-fn)))) + tree))) (defmethod convert ((to-type (eql '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)))))) +(defmethod convert ((to-type (eql '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)))))) (defmethod convert ((to-type (eql 'ch-map)) (ht hash-table) &key key-compare-fn-name val-compare-fn-name) (convert-to-ch-map ht nil nil @@ -4872,6 +4925,13 @@ (defmethod convert ((to-type (eql 'ch-map)) (ht hash-table) &key key-compare-fn- (setq tree (ch-map-tree-with tree k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) ht) tree))) +(defmethod convert ((to-type (eql '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) + (setq tree (ch-map-tree-with tree k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) + ht) + tree))) (defun print-ch-map (map stream level) (declare (ignore level)) diff --git a/Code/macros.lisp b/Code/macros.lisp index 0d19124..93bd4a5 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -797,27 +797,38 @@ (define-setf-expander fset2:@ (collection key &environment env) ;;; ---------------- ;;; Sets -(gmap:def-gmap-arg-type set (set) +(gmap:def-arg-type set (set) "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) - "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)) +(gmap:def-arg-type-synonym fun-set fun-sequence) -(gmap:def-result-type-synonym fset2:set set) +;;; 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 @@ -833,27 +844,20 @@ (define-setf-expander fset2:@ (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 (ch-set-org *empty-ch-set*))) + ,filterp)) (gmap:def-gmap-res-type ch-set (&key filterp compare-fn-name) "Returns a set of the values, optionally filtered by `filterp'. If @@ -868,6 +872,21 @@ (define-setf-expander fset2:@ (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 @@ -875,25 +894,33 @@ (define-setf-expander fset2:@ (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?) @@ -954,7 +981,9 @@ (define-setf-expander fset2:@ (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) @@ -962,7 +991,9 @@ (define-setf-expander fset2:@ (collection key &environment env) "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) @@ -996,6 +1027,35 @@ (define-setf-expander fset2:@ (collection key &environment env) (gmap:def-result-type-synonym fset2:wb-map wb-map) +(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-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))))))) + +(gmap:def-result-type-synonym fset2:ch-map ch-map) + (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' @@ -1005,10 +1065,10 @@ (define-setf-expander fset2:@ (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) @@ -1022,48 +1082,34 @@ (define-setf-expander fset2:@ (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)) - -(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-arg-type-synonym fset2:ch-map ch-map) - -(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. + (let ((vcfn-var (gensymx #:vcfn-))) + `((empty-wb-map (empty-wb-set ,vcfn-var) + ,key-compare-fn-name (make-wb-set-compare-fn (or ,vcfn-var '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 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))))))) + (let ((vcfn-var (gensymx #:vcfn-))) + `((empty-ch-map (empty-ch-set ,vcfn-var) + ,key-compare-fn-name (make-ch-set-compare-fn (or ,vcfn-var '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-synonym fset2:ch-map ch-map) ;;; ---------------- ;;; Seqs @@ -1082,24 +1128,28 @@ (define-setf-expander fset2:@ (collection key &environment env) 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) - "Returns a seq of the values, optionally filtered by `filterp'." - `(nil - #'(lambda (a b) (cons b a)) - #'(lambda (s) (convert 'seq (nreverse s))) - ,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-result-type-synonym seq wb-seq) (gmap:def-gmap-res-type wb-seq (&key filterp) "Returns a seq of the values, optionally filtered by `filterp'." @@ -1128,22 +1178,23 @@ (define-setf-expander fset2:@ (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 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-)) @@ -1165,7 +1216,7 @@ (define-setf-expander fset2:@ (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-)) @@ -1192,28 +1243,37 @@ (define-setf-expander fset2:@ (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) @@ -1233,21 +1293,12 @@ (define-setf-expander fset2:@ (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 @@ -1269,6 +1320,16 @@ (define-setf-expander fset2:@ (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 @@ -1292,7 +1353,7 @@ (define-setf-expander fset2:@ (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)) @@ -1312,7 +1373,7 @@ (define-setf-expander fset2:@ (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)) @@ -1337,7 +1398,7 @@ (define-setf-expander fset2:@ (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)) diff --git a/Code/reader.lisp b/Code/reader.lisp index 600a014..ec68c35 100644 --- a/Code/reader.lisp +++ b/Code/reader.lisp @@ -329,7 +329,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-set-constructor-form 'wb-bag 'empty-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 empty-fn args &optional compare-fn-name) (let ((normal-args (remove-if #'(lambda (arg) (and (listp arg) diff --git a/Code/relations.lisp b/Code/relations.lisp index 0d0edd7..15919bb 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -180,12 +180,7 @@ (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. +;;; 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)) @@ -467,16 +462,17 @@ (define-methods (compose fset2:compose) ((rel1 wb-2-relation) (rel2 wb-2-relatio (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-methods (image fset2:image) ((fn 2-relation) (s wb-set) &key compare-fn-name) @@ -514,6 +510,8 @@ (defmethod convert ((to-type (eql 'list)) (rel 2-relation) &key (pair-fn #'cons) (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))) @@ -598,16 +596,28 @@ (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 'no-default)) (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 'no-default)) -(defun wb-2-relation-to-wb-map (rel key-compare-fn-name val-compare-fn-name) +(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 @@ -620,14 +630,59 @@ (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))) + (wb-2-relation-to-map-to-sets rel nil)) +(defmethod convert ((to-type (eql 'fset2:map-to-sets)) (rel wb-2-relation) &key) + "This conversion returns a map mapping each domain value to the set of +corresponding range values." + (wb-2-relation-to-map-to-sets rel 'no-default)) + +;;; This is remarkably difficult to do correctly in the presence of custom compare-fns. +;;; The problem is that the val-compare-fn will expect to compare elements of the range +;;; sets, not the sets themselves. We have to synthesize one that will work. +(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 (make-wb-set-compare-fn vcfn-nm)) + ((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))) + +(defvar *make-wb-set-compare-fn-lock* (make-lock "*make-wb-set-compare-fn-lock*")) + +(defun make-wb-set-compare-fn (elt-compare-fn-name) + (if (eq elt-compare-fn-name 'compare) 'compare + ;; Have to intern it somewhere, and `fset-user:' is very unlikely to be locked. (The reason + ;; we have to intern it comes down to the `compare' method on maps; if compare-fn names are + ;; not `eq', it wants to order them, and uninterned symbols with the same print-name can't be + ;; ordered. Besides, we'd like the compare-fns themselves to be `eq' when possible.) + (let ((nm (intern (let ((*package* (find-package ':cl))) ; force prefix + (format nil "~A-~S" '%wb-set-by elt-compare-fn-name)) + (find-package ':fset-user)))) + ;; I believe the barriers are necessary and sufficient to let us do double-checked locking. + (if (fboundp nm) + (read-memory-barrier) + (with-lock (*make-wb-set-compare-fn-lock*) + (unless (fboundp nm) + (setf (symbol-function nm) + (fn (s1 s2) + (WB-Set-Tree-Compare (wb-set-contents s1) (wb-set-contents s2) + (symbol-function elt-compare-fn-name)))) + (write-memory-barrier)))) + nm))) (defmethod conflicts ((rel wb-2-relation)) (let ((m0 nil) @@ -1109,17 +1164,18 @@ (define-methods (compose fset2:compose) ((rel1 ch-2-relation) (rel2 ch-2-relatio (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))) (define-methods (image fset2:image) ((fn 2-relation) (s ch-set) &key compare-fn-name) @@ -1160,6 +1216,8 @@ (defmethod convert ((to-type (eql 'list)) (rel 2-relation) &key (pair-fn #'cons) (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))) @@ -1254,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 'no-default)) (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 'no-default)) -(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 @@ -1278,14 +1348,59 @@ (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))) + (ch-2-relation-to-map-to-sets rel nil)) +(defmethod convert ((to-type (eql 'fset2:map-to-sets)) (rel ch-2-relation) &key) + "This conversion returns a map mapping each domain value to the set of +corresponding range values." + (ch-2-relation-to-map-to-sets rel '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 (make-wb-set-compare-fn vcfn-nm)) + ((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))) + +(defvar *make-ch-set-compare-fn-lock* (make-lock "*make-ch-set-compare-fn-lock*")) + +;;; See comments at `make-wb-set-compare-fn'. +(defun make-ch-set-compare-fn (elt-compare-fn-name &optional elt-compare-fn) + (if (eq elt-compare-fn-name 'compare) 'compare + (let ((nm (intern (let ((*package* (find-package ':cl))) + (format nil "~A-~S" '%ch-set-by elt-compare-fn-name)) + (find-package ':fset-user)))) + (unless (fboundp nm) + (with-lock (*make-ch-set-compare-fn-lock*) + (setf (symbol-function nm) + (fn (s1 s2) + (ch-set-tree-compare (ch-set-contents s1) (ch-set-contents s2) + (or elt-compare-fn (symbol-function elt-compare-fn-name))))) + (let ((hashfn-nm (intern (let ((*package* (find-package ':cl))) + (format nil "~A-~S-~A" '%ch-set-by elt-compare-fn-name 'hash)) + (find-package ':fset-user)))) + (setf (get nm 'hash-function) hashfn-nm) + (setf (symbol-function hashfn-nm) + (fn (s) (ch-set-tree-hash-value (ch-set-contents s))))))) + nm))) (defmethod conflicts ((rel ch-2-relation)) (let ((m0 nil) @@ -1558,6 +1673,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) @@ -1965,6 +2082,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) diff --git a/Code/replay.lisp b/Code/replay.lisp index 3b83c97..39e6c9b 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -198,6 +198,9 @@ (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)) @@ -438,6 +441,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)) @@ -789,11 +795,19 @@ (defmethod convert ((to-type (eql 'wb-replay-map)) (m wb-replay-map) (defmethod convert ((to-type (eql '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 '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) (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)) +(defmethod convert ((to-type (eql '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)) (defmethod convert ((to-type (eql 'wb-replay-map)) (list list) &key (key-fn #'car) (value-fn #'cdr) default key-compare-fn-name val-compare-fn-name) @@ -1090,11 +1104,19 @@ (defmethod convert ((to-type (eql 'ch-replay-map)) (m ch-replay-map) (defmethod convert ((to-type (eql '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 '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) (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)) +(defmethod convert ((to-type (eql '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)) (defmethod convert ((to-type (eql 'list)) (m ch-replay-map) &key (pair-fn #'cons)) (let ((hmorg (ch-replay-map-org m)) diff --git a/Code/testing.lisp b/Code/testing.lisp index 2ad56da..6799648 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -69,6 +69,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) @@ -97,6 +98,163 @@ (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 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) @@ -263,12 +421,11 @@ (define-hash-function erapmoc hash-value-negated) ($ (tuple (+K1+ 2) (+K2+ 3))) (+K0+ 2) ($ (tuple (+K4+ 7) (+K2+ 8)))))) - #'string< :key (fn (x) (tuple-key-name (car x)))) + #'< :key (fn (x) (tuple-key-number (car x)))) `((,+K0+ . 2) (,+K1+ . 2) (,+K2+ . 8) (,+K4+ . 7)))) (test (less-than? (tuple (+K0+ 1)) (tuple (+K0+ 2)))) (test (unequal? (tuple (+K0+ 1.0) (+K1+ 'c)) (tuple (+K0+ 1) (+K1+ 'c)))) (test (less-than? (tuple (+K0+ 1.0) (+K1+ 'c)) (tuple (+K0+ 1) (+K1+ 'd)))) - (test (equal? (@ (tuple (+K0+ 'foo) (+K2+ 'zot)) +K1+) 'foo)) (test (not (equal? (map (3 7) :default 0) (map (3 7) :default 1)))) (test (not (equal? (with-default (seq 42 17) 6) (with-default (seq 42 17) 9)))) @@ -857,8 +1014,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)) @@ -4084,7 +4241,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)) @@ -4120,7 +4279,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))))))) ;;; ---------------- @@ -4428,6 +4590,8 @@ (defmethod verify ((m ch-map)) (define-tuple-key +k5+ :default 'plugh) (defun fset::test-fset2 () + (declare (optimize (debug 3))) + (test-fset2-gmap) (macrolet ((test (form) `(unless ,form (error "Test failed: ~S" ',form))) @@ -4440,7 +4604,7 @@ (define-tuple-key +k5+ :default 'plugh) ;; Check that each shadowed GF has the same methods in `fset:' and `fset2:'. (flet ((methods (gf) (gmap (:result set) - (fn (method) (cddr (getf (slot-value method 'sb-pcl::plist) ':name))) + (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)) @@ -4448,7 +4612,31 @@ (define-tuple-key +k5+ :default 'plugh) (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))))) + (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)) + (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)) @@ -4586,3 +4774,74 @@ (define-tuple-key +k5+ :default 'plugh) (test-error (@ (tuple) k)) (setq k (get-tuple-key 'fubar :default 0)) (test (equal? (@ (tuple) k) 0)))))) +(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))) + (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))))) + (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)))))) diff --git a/Code/tuples.lisp b/Code/tuples.lisp index de5ba27..c70d8b2 100644 --- a/Code/tuples.lisp +++ b/Code/tuples.lisp @@ -740,9 +740,13 @@ (defmethod convert ((to-type (eql 'dyn-tuple)) (tup dyn-tuple) &key) (defmethod convert ((to-type (eql 'map)) (tup tuple) &key) (wb-map-from-tuple tup)) +(defmethod convert ((to-type (eql 'fset2:map)) (tup tuple) &key) + (wb-map-from-tuple tup)) (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) -- GitLab From 7211478464b0e2171a9f95973a7eea7f38efd1c3 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Wed, 8 Oct 2025 18:14:42 -0700 Subject: [PATCH 08/37] Addendum to previous. --- Code/testing.lisp | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Code/testing.lisp b/Code/testing.lisp index 6799648..bfcdaeb 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -2073,7 +2073,7 @@ (define-hash-function erapmoc hash-value-negated) (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 (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))))) @@ -2098,7 +2098,7 @@ (define-hash-function erapmoc hash-value-negated) (test (equal? rs (convert 'replay-set (convert 'vector rs)))) (test (equal? rs (convert 'ch-replay-set (convert 'wb-replay-set rs)))) (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))))) @@ -4774,6 +4774,7 @@ (define-tuple-key +k5+ :default 'plugh) (test-error (@ (tuple) k)) (setq k (get-tuple-key 'fubar :default 0)) (test (equal? (@ (tuple) k) 0)))))) + (defun test-fset2-gmap () (macrolet ((test (form) `(unless ,form -- GitLab From dc74ba6470040fd14cdec71414c0f86bfa2febfd Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 9 Oct 2025 18:56:38 -0700 Subject: [PATCH 09/37] FSet 2 now has no default default. Also, updated reader macros. And, some cleanup. --- Code/defs.lisp | 5 +- Code/fset.lisp | 342 +++++++++++++++++++--------------------------- Code/macros.lisp | 78 +++++++++-- Code/order.lisp | 2 +- Code/reader.lisp | 318 +++++++++++++++++++++++++++++------------- Code/replay.lisp | 148 ++++++++++---------- Code/testing.lisp | 110 +++++++++------ fset.asd | 4 +- 8 files changed, 587 insertions(+), 420 deletions(-) diff --git a/Code/defs.lisp b/Code/defs.lisp index dc26c4c..0f6eafa 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -155,9 +155,10 @@ #: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 #:map-to-sets + #: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 + #: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 diff --git a/Code/fset.lisp b/Code/fset.lisp index 6430681..fc437f9 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -604,7 +604,9 @@ (defmethod last ((s sequence)) (defgeneric concat (seq1 &rest seqs) (:documentation "Returns the concatenation of `seq1' with each of `seqs'.")) - +(defgeneric fset2:concat (seq1 &rest seqs) + (:documentation + "Returns the concatenation of `seq1' with each of `seqs'.")) ;;; 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 @@ -1383,7 +1385,7 @@ (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) @@ -2081,9 +2083,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) - s) -(defmethod convert ((to-type (eql 'fset2: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) @@ -3255,9 +3255,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) - (make-wb-set (WB-Bag-Tree-To-Set-Tree (wb-bag-contents b)) (wb-bag-org b))) -(defmethod convert ((to-type (eql 'fset2: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) @@ -3464,13 +3462,21 @@ (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+ 'no-default)) + +(defparameter *empty-wb-map/nil* (make-wb-map nil +fset-default-tree-map-org+ nil)) + +;;; I've parameterized this on the thought that some people might want to set it to `nil', +;;; for backward compatibility with FSet 1. The longer I think about it, though, the less +;;; likely it seems, considering they can still use the FSet 1 API if they want. +(defparameter *fset2-default-default* 'no-default + "The value used for map and seq defaults if no other value is specified.") (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/nil*)) ;;; `fset2:empty-map' is below (declaim (inline empty-wb-map fset2:empty-wb-map)) @@ -3478,20 +3484,32 @@ (defstruct (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/nil* (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." + (empty-wb-map-internal default? default no-default? key-compare-fn-name val-compare-fn-name)) + +(declaim (inline fset2-default)) +(defun fset2-default (default? default no-default?) + (cond (default? default) + (no-default? 'no-default) + (t *fset2-default-default*))) + +(defun empty-wb-map-internal (default? default no-default? key-compare-fn-name val-compare-fn-name) + ;; This has gotten too big to inline. (if (and default? no-default?) (error "Both a default and `no-default?' specified") - (let ((default (if default? default (and no-default? 'no-default)))) + (let ((default (fset2-default default? default no-default?))) (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) + ((eq default 'no-default) *empty-wb-map*) + ((null default) + *empty-wb-map/nil*) (t (make-wb-map nil +fset-default-tree-map-org+ default)))))) (deflex +empty-wb-custom-map-cache+ (make-hash-table :test 'equal)) @@ -3504,7 +3522,7 @@ (defstruct (wb-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/nil* (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 (!). @@ -3859,7 +3877,8 @@ (defmethod fset2:map-union ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2) (setf (lookup result k) v2) (unless (equal?-cmp v1 v2 vcf1) (let ((new-v second-val (funcall val-fn v1 v2))) - (unless (eq second-val ':no-value) + (if (eq second-val ':no-value) + (excludef result k) (setf (lookup result k) new-v))))))) (with-default result default))) @@ -4087,9 +4106,7 @@ (define-methods (compose fset2:compose) ((m wb-map) (s seq) &key val-compare-fn- (if (eq dflt1 'no-default) 'no-default (funcall fn dflt1))))) -(defmethod convert ((to-type (eql 'map)) (m map) &key) - m) -(defmethod convert ((to-type (eql 'fset2:map)) (m map) &key) +(define-convert-methods (map fset2:map) ((m map) &key) m) (defmethod convert ((to-type (eql 'wb-map)) (m wb-map) @@ -4154,13 +4171,9 @@ (defmethod convert ((to-type (eql 'map)) (l list) (defmethod convert ((to-type (eql 'fset2:map)) (l list) &key (key-fn #'car) (value-fn #'cdr)) (convert 'ch-map l :key-fn key-fn :value-fn value-fn)) -(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) - (wb-map-from-sequence l key-fn value-fn input-sorted? key-compare-fn-name val-compare-fn-name)) -(defmethod convert ((to-type (eql 'fset2: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) @@ -4170,16 +4183,11 @@ (defmethod convert ((to-type (eql 'map)) (s seq) (defmethod convert ((to-type (eql 'fset2:map)) (s seq) &key (key-fn #'car) (value-fn #'cdr)) (convert 'ch-map s :key-fn key-fn :value-fn value-fn)) -(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))) -(defmethod convert ((to-type (eql '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))) (defmethod convert ((to-type (eql 'map)) (s sequence) &key (key-fn #'car) (value-fn #'cdr) input-sorted?) @@ -4187,13 +4195,9 @@ (defmethod convert ((to-type (eql 'map)) (s sequence) (defmethod convert ((to-type (eql 'fset2:map)) (s sequence) &key (key-fn #'car) (value-fn #'cdr)) (convert 'ch-map s :key-fn key-fn :value-fn value-fn)) -(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) - (wb-map-from-sequence s key-fn value-fn input-sorted? key-compare-fn-name val-compare-fn-name)) -(defmethod convert ((to-type (eql 'fset2: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) @@ -4209,37 +4213,21 @@ (defmethod convert ((to-type (eql 'fset2: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 'fset2:map)) (b bag) &key) - (convert 'ch-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 (let ((tree nil)) (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 'fset2:wb-map)) (b bag) &key key-compare-fn-name val-compare-fn-name) - (convert-to-wb-map b nil nil - (let ((tree nil)) - (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 'fset2:map)) (ht hash-table) &key) - (convert 'ch-map ht)) -(defmethod convert ((to-type (eql '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) - (setq tree (WB-Map-Tree-With tree k v key-compare-fn val-compare-fn))) - ht) - tree))) -(defmethod convert ((to-type (eql 'fset2: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) @@ -4384,6 +4372,10 @@ (defstruct (ch-map (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) + 'no-default)) + +(defparameter *empty-ch-map/nil* (make-ch-map nil (make-hash-map-org 'compare #'compare #'hash-value 'compare #'compare #'hash-value) nil)) @@ -4391,31 +4383,31 @@ (defstruct (ch-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." - (if (and default? no-default?) - (error "Both a default and `no-default?' specified") - (let ((default (if default? default (and no-default? 'no-default)))) - (if (null default) - *empty-ch-map* - (make-ch-map nil (ch-map-org *empty-ch-map*) default))))) + (empty-ch-map-internal 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* + *empty-ch-map/nil* (make-ch-map nil (ch-map-org *empty-ch-map*) 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 default? default no-default? key-compare-fn-name val-compare-fn-name)) + +(defun empty-ch-map-internal (default? default no-default? key-compare-fn-name val-compare-fn-name) (if (and default? no-default?) (error "Both a default and `no-default?' specified") - (let ((default (if default? default (and no-default? 'no-default)))) + (let ((default (fset2-default default? default no-default?))) (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) + ((eq default 'no-default) *empty-ch-map*) + ((null default) + *empty-ch-map/nil*) (t (make-ch-map nil (ch-map-org *empty-ch-map*) default)))))) (deflex +empty-ch-custom-map-cache+ (make-hash-table :test 'equal)) @@ -4428,7 +4420,7 @@ (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* + (if (null default) *empty-ch-map/nil* (make-ch-map nil (ch-map-org *empty-ch-map*) default)) (let ((cache-key (list key-compare-fn-name val-compare-fn-name)) ((prev-instance (gethash cache-key +empty-ch-custom-map-cache+))) @@ -4789,46 +4781,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) - (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 'fset2: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) - (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 'fset2:ch-map)) (m map) &key key-compare-fn-name val-compare-fn-name) +(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) - "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))) - (or (eq m-hmorg hmorg) - (and (eq key-hash-fn (hash-map-org-key-hash-fn m-hmorg)) - (eq key-compare-fn (hash-map-org-key-compare-fn m-hmorg)) - (eq val-hash-fn (hash-map-org-val-hash-fn m-hmorg)) - (eq val-compare-fn (hash-map-org-val-compare-fn m-hmorg))))) - (let ((tree nil)) - (do-ch-map-tree-pairs (k v (ch-map-contents 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 'fset2: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))) @@ -4842,19 +4809,8 @@ (defmethod convert ((to-type (eql 'fset2: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) - (declare (type function key-fn value-fn)) - (convert-to-ch-map l nil nil - (let ((tree nil)) - (dolist (x l) - (setq tree (ch-map-tree-with tree (funcall key-fn x) (funcall value-fn x) - key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) - tree))) -(defmethod convert ((to-type (eql 'fset2: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: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)) @@ -4863,19 +4819,8 @@ (defmethod convert ((to-type (eql 'fset2: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) - (declare (type function key-fn value-fn)) - (convert-to-ch-map l nil nil - (let ((tree nil)) - (do-seq (x s) - (setq tree (ch-map-tree-with tree (funcall key-fn x) (funcall value-fn x) - key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) - tree))) -(defmethod convert ((to-type (eql 'fset2: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: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)) @@ -4884,20 +4829,8 @@ (defmethod convert ((to-type (eql 'fset2: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) - (declare (type function key-fn value-fn)) - (convert-to-ch-map l nil nil - (let ((tree nil)) - (dotimes (i (length s)) - (let ((x (elt s i))) - (setq tree (ch-map-tree-with tree (funcall key-fn x) (funcall value-fn x) - key-hash-fn key-compare-fn val-hash-fn val-compare-fn)))) - tree))) -(defmethod convert ((to-type (eql 'fset2: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: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)) @@ -4907,25 +4840,13 @@ (defmethod convert ((to-type (eql 'fset2:ch-map)) (s sequence) key-hash-fn key-compare-fn val-hash-fn val-compare-fn)))) tree))) -(defmethod convert ((to-type (eql '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)))))) -(defmethod convert ((to-type (eql 'fset2:ch-map)) (b bag) &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)))))) -(defmethod convert ((to-type (eql '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) - (setq tree (ch-map-tree-with tree k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) - ht) - tree))) -(defmethod convert ((to-type (eql 'fset2:ch-map)) (ht hash-table) &key key-compare-fn-name val-compare-fn-name) +(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) @@ -4967,7 +4888,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)) @@ -4977,21 +4898,19 @@ (defstruct (wb-seq (contents nil :read-only t)) -(defparameter *empty-wb-seq* (make-wb-seq nil)) +(defparameter *empty-wb-seq* (make-wb-seq nil 'no-default)) + +(defparameter *empty-wb-seq/nil* (make-wb-seq nil nil)) (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*)) + *empty-wb-seq/nil*)) (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." - (if (and default? no-default?) - (error "Both a default and `no-default?' specified") - (cond (default? (make-wb-seq nil default)) - (no-default? (make-wb-seq nil 'no-default)) - (t *empty-wb-seq*)))) + (empty-wb-seq-internal default? default no-default?)) (declaim (inline empty-wb-seq fset2:empty-wb-seq)) (defun empty-wb-seq (&optional default) @@ -5000,11 +4919,17 @@ (defstruct (wb-seq *empty-wb-seq*)) (defun fset2:empty-wb-seq (&key (default nil default?) no-default?) "Returns an empty wb-seq." + (empty-wb-seq-internal default? default no-default?)) + +(defun empty-wb-seq-internal (default? default no-default?) (if (and default? no-default?) (error "Both a default and `no-default?' specified") - (cond (default? (make-wb-seq nil default)) - (no-default? (make-wb-seq nil 'no-default)) - (t *empty-wb-seq*)))) + (let ((default (fset2-default default? default no-default?))) + (cond ((eq default 'no-default) + *empty-wb-seq*) + ((null default) + *empty-wb-seq/nil*) + (t (make-wb-seq nil default)))))) (defmethod empty? ((s wb-seq)) (null (wb-seq-contents s))) @@ -5171,7 +5096,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))))) @@ -5208,17 +5133,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))) @@ -5226,25 +5142,38 @@ (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) + (make-wb-seq (WB-Seq-Tree-From-List l) 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) ((l list) &key (default nil default?) no-default?) + (make-wb-seq (WB-Seq-Tree-From-List l) (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) ((s set) &key) + (make-wb-seq (wb-seq-tree-from-iterable (iterator s) (size s)) 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) ((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)) (b bag) &key pairs? (pair-fn #'cons)) +(define-convert-methods (seq wb-seq) ((b bag) &key pairs? (pair-fn #'cons)) + (bag-to-seq b pairs? pair-fn nil)) + +(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?))) + +(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) @@ -5253,19 +5182,24 @@ (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)) + +(define-convert-methods (seq wb-seq) ( (m map) &key (pair-fn #'cons)) + (map-to-seq m pair-fn nil)) -(defmethod convert ((to-type (eql 'seq)) (m map) &key (pair-fn #'cons)) - (convert 'wb-seq m :pair-fn pair-fn)) +(define-convert-methods (fset2:seq fset2:wb-seq) + ((m map) &key (pair-fn #'cons) (default nil default?) no-default?) + (map-to-seq m pair-fn (fset2-default default? default no-default?))) -(defmethod convert ((to-type (eql 'wb-seq)) (m map) &key (pair-fn #'cons)) +(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, @@ -5442,28 +5376,28 @@ (defmethod sort-and-group ((s seq) pred &key key) (defmethod image ((fn function) (s seq) &key) (seq-image fn s (seq-default s))) -(defmethod fset2:image ((fn function) (s seq) &key) - (seq-image fn s 'no-default)) +(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-default s))) -(defmethod fset2:image ((fn symbol) (s seq) &key) - (seq-image (coerce-to-function fn) s 'no-default)) +(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-default s))) -(defmethod fset2:image ((fn map) (s seq) &key) - (seq-image #'(lambda (x) (fset2:lookup fn x)) s 'no-default)) +(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-default s))) -(defmethod fset2:image ((fn set) (s seq) &key) - (seq-image #'(lambda (x) (fset2:lookup fn x)) s 'no-default)) +(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-default s))) -(defmethod fset2:image ((fn bag) (s seq) &key) - (seq-image #'(lambda (x) (fset2:lookup fn x)) s 'no-default)) +(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 default) (declare (optimize (speed 3) (safety 0)) diff --git a/Code/macros.lisp b/Code/macros.lisp index 93bd4a5..79b96fb 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -178,6 +178,13 @@ (defmethod compare ((f1 frob) (f2 frob)) `(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 @@ -1003,16 +1010,23 @@ (define-setf-expander fset2:@ (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)) -(gmap:def-result-type-synonym fset2:map map) +(gmap:def-result-type fset2:map (&key filterp (default nil 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*) + ,(if default? default + '*fset2-default-default*))) + ,filterp)) -(gmap:def-gmap-res-type wb-map (&key filterp default key-compare-fn-name val-compare-fn-name) +(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-)) @@ -1025,7 +1039,20 @@ (define-setf-expander fset2:@ (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-synonym fset2:wb-map wb-map) +(gmap:def-result-type fset2:wb-map (&key filterp (default nil 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) + ,(if default? default + '*fset2-default-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." @@ -1037,7 +1064,7 @@ (define-setf-expander fset2:@ (collection key &environment env) (gmap:def-arg-type-synonym fset2:ch-map ch-map) -(gmap:def-gmap-res-type ch-map (&key filterp default key-compare-fn-name val-compare-fn-name) +(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-)) @@ -1054,7 +1081,23 @@ (define-setf-expander fset2:@ (collection key &environment env) (,vhf-var (hash-map-org-val-hash-fn ,org-var)) (,vcf-var (hash-map-org-val-compare-fn ,org-var))))))) -(gmap:def-result-type-synonym fset2:ch-map ch-map) +(gmap:def-result-type fset2:ch-map (&key filterp (default nil 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 ,(if default? default + '*fset2-default-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) @@ -1123,6 +1166,8 @@ (define-setf-expander fset2:@ (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 @@ -1149,19 +1194,36 @@ (define-setf-expander fset2:@ (collection key &environment env) #'(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-gmap-res-type wb-seq (&key filterp) +(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 concat (&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 'fset2:seq (nreverse s) + ,@(and default `(:default ,default)) + ,@(and no-default? `(:no-default? ,no-default?)))) + ,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 diff --git a/Code/order.lisp b/Code/order.lisp index f45cf30..1d2fac6 100644 --- a/Code/order.lisp +++ b/Code/order.lisp @@ -71,7 +71,7 @@ (defstruct (map (:predicate map?) (:copier nil)) "The abstract class for FSet functional maps. It is a structure class." - (default nil :read-only t)) + (default 'no-default :read-only t)) (defstruct (replay-map (:constructor nil) diff --git a/Code/reader.lisp b/Code/reader.lisp index ec68c35..ef464b6 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. @@ -580,7 +546,22 @@ 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 'fset2:empty-replay-map args)) + (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 @@ -595,7 +576,21 @@ 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 'fset2:empty-wb-replay-map args)) + (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 @@ -611,7 +606,23 @@ 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 'fset2:empty-wb-replay-map args + (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) @@ -627,7 +638,21 @@ 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 'fset2::empty-ch-replay-map args)) + (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 @@ -643,7 +668,23 @@ 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 'fset2::empty-ch-replay-map args + (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) @@ -651,10 +692,14 @@ ;; We MUST maintain ORDER!!! Yow!!! (let ((default? (member ':default args)) (no-default? (member ':no-default args)) - ((result `(,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)))))) + (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))) @@ -680,6 +725,14 @@ the result sequence. The order of the result sequence reflects the order of the argument subforms." (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 @@ -688,6 +741,13 @@ 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 '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 empty-fn args) (labels ((recur (args nonsplice-args) @@ -897,28 +957,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)) @@ -941,6 +1001,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'." @@ -951,6 +1046,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)) @@ -965,48 +1061,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)) @@ -1015,7 +1134,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)) @@ -1038,6 +1157,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 @@ -1048,6 +1176,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)) @@ -1062,4 +1191,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/replay.lisp b/Code/replay.lisp index 39e6c9b..5f7d52e 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -30,9 +30,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) *fset2-default-default*)) (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) *fset2-default-default*)) (defmethod convert ((to-type (eql 'replay-set)) (l list) &key) (gmap (:result replay-set) nil (:arg list l))) @@ -280,7 +284,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))))) @@ -523,7 +527,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)))) @@ -552,32 +556,34 @@ (defmethod less ((s ch-replay-set) value &optional (arg2 nil arg2?)) (if default (make-ch-replay-map nil nil (ch-map-org *empty-ch-map*) default) *empty-ch-replay-map*)) (defun fset2:empty-replay-map (&key (default nil default?) no-default?) - (declare (special *empty-ch-replay-map*)) - (if (and default? no-default?) - (error "Both a default and `no-default?' specified") - (let ((default (if default? default (and no-default? 'no-default)))) - (if (null default) - *empty-ch-replay-map* - (make-ch-replay-map nil nil (ch-map-org *empty-ch-map*) default))))) + (empty-ch-replay-map-internal default? default no-default? nil nil)) (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) @@ -595,9 +601,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) @@ -625,7 +628,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)) @@ -638,7 +641,9 @@ (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+ 'no-default)) + +(defparameter *empty-wb-replay-map/nil* (make-wb-replay-map nil nil +fset-default-tree-map-org+ nil)) (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) @@ -651,13 +656,20 @@ (defstruct (wb-replay-map "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 default? default no-default? key-compare-fn-name val-compare-fn-name)) + +(defun empty-wb-replay-map-internal (default? default no-default? key-compare-fn-name val-compare-fn-name) (if (and default? no-default?) (error "Both a default and `no-default?' specified") - (let ((default (if default? default (and no-default? 'no-default)))) + (let ((default (cond (default? default) + (no-default? 'no-default) + (t *fset2-default-default*)))) (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) + ((eq default 'no-default) *empty-wb-replay-map*) + ((null default) + *empty-wb-replay-map/nil*) (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)) @@ -760,12 +772,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) +(define-convert-methods (replay-map 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)) @@ -776,8 +787,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)) @@ -793,18 +804,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?)) - (make-wb-map (wb-replay-map-contents m) (wb-replay-map-org m) (if default? default (map-default m)))) -(defmethod convert ((to-type (eql 'fset2: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) - (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)) -(defmethod convert ((to-type (eql 'fset2: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)) @@ -910,7 +914,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))))) @@ -948,7 +952,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)) @@ -961,26 +965,35 @@ (defstruct (ch-replay-map (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 (ch-map-org *empty-ch-map*) 'no-default)) + +(defparameter *empty-ch-replay-map/nil* (make-ch-replay-map nil nil (ch-map-org *empty-ch-map*) 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* + *empty-ch-replay-map/nil* (make-ch-replay-map nil nil (ch-replay-map-org *empty-ch-replay-map*) 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 default? default no-default? key-compare-fn-name val-compare-fn-name)) + +(defun empty-ch-replay-map-internal (default? default no-default? key-compare-fn-name val-compare-fn-name) (if (and default? no-default?) (error "Both a default and `no-default?' specified") - (let ((default (if default? default (and no-default? 'no-default)))) + (let ((default (cond (default? default) + (no-default? 'no-default) + (t *fset2-default-default*)))) (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) + ((eq default 'no-default) *empty-ch-replay-map*) + ((null default) + *empty-ch-replay-map/nil*) (t (make-ch-replay-map nil nil (ch-map-org *empty-ch-map*) default)))))) (deflex +empty-ch-custom-replay-map-cache+ (make-hash-table :test 'equal)) @@ -1083,8 +1096,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) @@ -1092,8 +1105,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 @@ -1102,18 +1115,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?)) - (make-ch-map (ch-replay-map-contents m) (ch-replay-map-org m) (if default? default (map-default m)))) -(defmethod convert ((to-type (eql 'fset2: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) - (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)) -(defmethod convert ((to-type (eql 'fset2: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)) @@ -1131,6 +1137,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) @@ -1239,7 +1247,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))))) diff --git a/Code/testing.lisp b/Code/testing.lisp index bfcdaeb..fdf9cf0 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -976,7 +976,7 @@ (define-hash-function erapmoc hash-value-negated) (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)) @@ -2455,15 +2455,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))) @@ -2475,14 +2475,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)) @@ -2495,14 +2495,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 @@ -2510,14 +2508,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))) @@ -4475,8 +4481,9 @@ (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)))) (setq *champ-map-test-pairs* (seq)) (dotimes (j 256) (let ((mi (make-my-integer (random 1024))) @@ -4520,8 +4527,9 @@ (defmethod verify ((m ch-map)) ;; `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))) + (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))) @@ -4553,7 +4561,7 @@ (defmethod verify ((m ch-map)) ((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))))) + (error "ch-map union failed: ~A, ~A" ch-only wb-only))))) (let ((chm-intersection (map-intersection chm saved-chm #'filter-mod-20))) (test (verify chm-intersection)) (let ((wbm-intersection (map-intersection wbm saved-wbm #'filter-mod-20)) @@ -4617,7 +4625,7 @@ (define-tuple-key +k5+ :default 'plugh) (let ((convert-methods (methods #'convert)) (all-missing (map)) (all-extra (map))) - (dolist (to-type '(set map wb-map ch-map map-to-sets)) + (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)))) @@ -4686,7 +4694,6 @@ (define-tuple-key +k5+ :default 'plugh) (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)) @@ -4701,27 +4708,27 @@ (define-tuple-key +k5+ :default 'plugh) (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 chm-d (map ('b 4) :default 33)) + (map ('a 3) ('b 4) :default 33))) ; 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))) + (test (equal? (map-union (map ('b 4) :default 21) 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 wbm-d (wb-map ('b 4) :default 13)) + (wb-map ('b 4) ('c 7) :default 13))) ; 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))) + (test (equal? (map-union (wb-map ('b 4) :default 47) 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)))) @@ -4730,19 +4737,19 @@ (define-tuple-key +k5+ :default 'plugh) (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-d) chm)) (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-d) wbm)) (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 chm-d (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) @@ -4758,7 +4765,7 @@ (define-tuple-key +k5+ :default 'plugh) (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? (compose (ch-map ('a 7)) (map (7 12) :default 3)) + (test (equal? (compose (ch-map ('a 7) :default 9) (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))) @@ -4845,4 +4852,29 @@ (define-tuple-key +k5+ :default 'plugh) (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)))))) + (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/fset.asd b/fset.asd index da96bc7..fd12440 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 -- GitLab From 460bc5d8ac7e03906ccdd997298c8aa664f43827 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 9 Oct 2025 19:28:22 -0700 Subject: [PATCH 10/37] Add 'fset2:lookup-error' as error superclass. --- Code/defs.lisp | 2 +- Code/fset.lisp | 9 ++++++--- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/Code/defs.lisp b/Code/defs.lisp index 0f6eafa..7e30adf 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -200,7 +200,7 @@ #:filter #:filter-pairs #:partition #:image #:reduce #:domain #:range #:update #:with-default #:without-default #:default - #:map-domain-error #:map-domain-error-map #:map-domain-error-key + #: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 diff --git a/Code/fset.lisp b/Code/fset.lisp index fc437f9..81d0760 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -3605,7 +3605,10 @@ (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))))) -(define-condition fset2:map-domain-error (error) +(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) @@ -4948,7 +4951,7 @@ (defmethod fset2:without-default ((s wb-seq)) (defmethod size ((s wb-seq)) (WB-Seq-Tree-Size (wb-seq-contents s))) -(define-condition fset2:seq-bounds-error (error) +(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) @@ -4971,7 +4974,7 @@ (defmethod fset2:lookup ((s wb-seq) index) dflt))) val?))) -(define-condition fset2:empty-seq-error (error) +(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) -- GitLab From 69a6638eb3bf42187f5f2e34d51b6091cbfbdee9 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 9 Oct 2025 21:12:02 -0700 Subject: [PATCH 11/37] Oops -- forgot to remove default default from tuple keys. --- Code/tuples.lisp | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/Code/tuples.lisp b/Code/tuples.lisp index c70d8b2..0afb20b 100644 --- a/Code/tuples.lisp +++ b/Code/tuples.lisp @@ -121,7 +121,7 @@ (defstruct (tuple-key (: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 nil) ; default for tuples with no explicit entry for this key + (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 @@ -157,10 +157,10 @@ (defstruct (tuple-key (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, `lookup' -in this case will signal an error. If neither is specified, then if the key is -being freshly created, its default will be `nil'; otherwise, its default is -unchanged." +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 no default; +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+) @@ -173,8 +173,7 @@ (defstruct (tuple-key (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))) + (let ((key (make-tuple-key name (if default? default 'no-default) key-idx))) (setf (lookup +Tuple-Key-Name-Map+ name) key) (push-last +Tuple-Key-Seq+ key) key)) @@ -199,17 +198,16 @@ (defstruct (tuple-key (when doc-string (setf (get name 'tuple-key-doc-string) doc-string)) `(deflex ,name (get-tuple-key ',name ,default))) -(defmacro fset2:define-tuple-key (name &key (default nil default?) (no-default? nil no-default??) documentation) +(defmacro fset2:define-tuple-key (name &key (default nil 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' when -the tuple has no explicit pair with this key; if `no-default?' is true, -that case will cause an error; if neither is supplied, the key's default -is `nil'." +the tuple has no explicit pair with this key; otherwise, `lookup` will signal +an error in that case." (assert (symbolp name)) (when documentation (setf (get name 'tuple-key-documentation) documentation)) - `(deflex-reinit ,name (fset2:get-tuple-key ',name ,@(and default? `(:default ,default)) - . ,(and no-default?? `(:no-default? ,no-default?))))) + `(deflex-reinit ,name (fset2:get-tuple-key ',name ,@(if default? `(:default ,default) + '(:no-default? t))))) (defun print-tuple-key (key stream level) (declare (ignore level)) @@ -677,7 +675,7 @@ (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 (error) +(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) -- GitLab From 560ed55dbb69ee55671926a88e9ec933583c0d97 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Fri, 10 Oct 2025 09:15:22 -0700 Subject: [PATCH 12/37] Minor fixes. --- Code/macros.lisp | 2 +- Code/relations.lisp | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Code/macros.lisp b/Code/macros.lisp index 79b96fb..afd02fe 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -804,7 +804,7 @@ (define-setf-expander fset2:@ (collection key &environment env) ;;; ---------------- ;;; Sets -(gmap:def-arg-type set (set) +(gmap:def-gmap-arg-type set (set) "Yields the elements of `set'." `((the function (iterator ,set)) #'(lambda (it) (funcall it ':done?)) diff --git a/Code/relations.lisp b/Code/relations.lisp index 15919bb..4bbb549 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -1627,7 +1627,7 @@ (defstruct (wb-list-relation the first tuple added." (unless (or (null arity) (and (integerp arity) (>= arity 1))) (error "Invalid arity")) - (empty-wb-list-relation 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 -- GitLab From 7376e177513096ff1ed49b2098904f8088d82d1e Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Fri, 10 Oct 2025 21:52:40 -0700 Subject: [PATCH 13/37] Make 'fset:lookup' also error on missing default. (In case someone has a mixed codebase, hopefully because they're in the middle of migrating it.) --- Code/fset.lisp | 65 ++++++++++++++++++----------------------------- Code/testing.lisp | 12 +++++---- Code/tuples.lisp | 5 +++- 3 files changed, 36 insertions(+), 46 deletions(-) diff --git a/Code/fset.lisp b/Code/fset.lisp index 81d0760..65e9c69 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -3617,19 +3617,17 @@ (define-condition fset2:map-domain-error (fset2:lookup-error) (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)))))) -(defmethod lookup ((m wb-map) key) +;;; 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 (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?))) -(defmethod fset2: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))))) (values (if val? val - (let ((default (map-default m))) - (if (eq default 'no-default) + (let ((dflt (map-default m))) + (if (eq dflt 'no-default) (error 'fset2:map-domain-error :map m :key key) - default))) + dflt))) val?))) (defmethod rank ((m wb-map) x) @@ -3873,9 +3871,10 @@ (defmethod fset2:map-union ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2) (defun generic-map-union (m1 m2 val-fn default) (let ((result m1) - (vcf1 (val-compare-fn m1))) + (vcf1 (val-compare-fn m1)) + (m1d (with-default m1 nil))) ; so `lookup' doesn't error (do-map (k v2 m2) - (let ((v1 v1? (lookup m1 k))) ; no error + (let ((v1 v1? (lookup m1d k))) (if (not v1?) (setf (lookup result k) v2) (unless (equal?-cmp v1 v2 vcf1) @@ -3922,9 +3921,10 @@ (defmethod fset2:map-intersection ((m1 map) (m2 map) &optional (val-fn (fn (_v1 (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))) + (let ((v2 v2? (lookup m2d 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) @@ -3973,13 +3973,15 @@ (defmethod fset2:map-difference-2 ((m1 map) (m2 map)) (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))) @@ -4073,19 +4075,15 @@ (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))))) + ;; 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'." - (make-wb-map (WB-Map-Tree-Compose (wb-map-contents map1) - (fn (x) - (let ((val2 val2? (fset2:lookup map2 x))) - (if val2? val2 (map-default map2))))) + (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 @@ -4524,16 +4522,11 @@ (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))))) ;; Our internal convention is the reverse of the external one. - (values (if val? val (map-default m)) val?))) -(defmethod 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))))) (values (if val? val (let ((dflt (map-default m))) (if (eq dflt 'no-default) @@ -4688,19 +4681,15 @@ (defmethod restrict-not ((m ch-map) (s ch-set)) (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))))) + ;; 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) (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))) ; no error - (if val2? val2 (map-default map2))))) + (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 @@ -4960,11 +4949,7 @@ (define-condition fset2:seq-bounds-error (fset2:lookup-error) (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)))))) -(defmethod lookup ((s wb-seq) key) - (let ((val? val (if (typep key 'fixnum) (WB-Seq-Tree-Subscript (wb-seq-contents s) key) - (values nil nil)))) - (values (if val? val (seq-default s)) val?))) -(defmethod fset2:lookup ((s wb-seq) index) +(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 diff --git a/Code/testing.lisp b/Code/testing.lisp index fdf9cf0..209c893 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -4604,10 +4604,9 @@ (define-tuple-key +k5+ :default 'plugh) `(unless ,form (error "Test failed: ~S" ',form))) (test-error (form) - `(handler-case (progn - ,form - (error "Test failed to signal an error: ~S" ',form)) - (error ())))) + `(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) @@ -4769,7 +4768,10 @@ (define-tuple-key +k5+ :default 'plugh) (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 7)) (map (7 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))) diff --git a/Code/tuples.lisp b/Code/tuples.lisp index 0afb20b..ec845ab 100644 --- a/Code/tuples.lisp +++ b/Code/tuples.lisp @@ -687,7 +687,10 @@ (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 key))) - (values (and default-fn (funcall default-fn tuple)) nil))))) + ;; 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) -- GitLab From 69fcb5ca359218c4fa52cf9375fd93691186d277 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sat, 11 Oct 2025 14:16:58 -0700 Subject: [PATCH 14/37] Fix tuple key doc string (GitHub #60). --- Code/tuples.lisp | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/Code/tuples.lisp b/Code/tuples.lisp index ec845ab..605dcaa 100644 --- a/Code/tuples.lisp +++ b/Code/tuples.lisp @@ -195,19 +195,17 @@ (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?) documentation) "Defines a tuple key named `name' as a global lexical variable (see `deflex'). If `default' is supplied, it will be returned from `lookup' when the tuple has no explicit pair with this key; otherwise, `lookup` will signal an error in that case." (assert (symbolp name)) - (when documentation - (setf (get name 'tuple-key-documentation) documentation)) `(deflex-reinit ,name (fset2:get-tuple-key ',name ,@(if default? `(:default ,default) - '(:no-default? t))))) + '(:no-default? t))) + . ,(and documentation `(,documentation)))) (defun print-tuple-key (key stream level) (declare (ignore level)) -- GitLab From c36de66d7ff48763dd051e456fc0f91815d264a2 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Fri, 17 Oct 2025 16:23:18 -0700 Subject: [PATCH 15/37] Add 'splicef'; minor internal improvements. --- Code/defs.lisp | 4 +-- Code/fset.lisp | 62 ++++++++++++++++++++++----------------- Code/macros.lisp | 12 ++++++-- Code/wb-trees.lisp | 72 ++++++++++++++++++++++++---------------------- 4 files changed, 84 insertions(+), 66 deletions(-) diff --git a/Code/defs.lisp b/Code/defs.lisp index 7e30adf..f4ec0e2 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -68,7 +68,7 @@ #: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 @@ -209,7 +209,7 @@ #: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 diff --git a/Code/fset.lisp b/Code/fset.lisp index 65e9c69..e7d5403 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -4074,21 +4074,25 @@ (define-methods (compose fset2: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) - ;; 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))))) + (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'." - (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))))))) + (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)) @@ -4679,22 +4683,26 @@ (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) - ;; 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)))))) + (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) - (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)))))))) + (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)) diff --git a/Code/macros.lisp b/Code/macros.lisp index afd02fe..b62dcb4 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -351,7 +351,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 @@ -408,7 +410,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 @@ -512,6 +517,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)) diff --git a/Code/wb-trees.lisp b/Code/wb-trees.lisp index 23febc0..55a3455 100644 --- a/Code/wb-trees.lisp +++ b/Code/wb-trees.lisp @@ -6126,6 +6126,32 @@ (defstruct (WB-Seq-Tree-Node (list nil sub))))) (format stream "#seq-node<...>"))) +(declaim (inline character-type)) +(defun character-type (ch) + ;; &&& Why `base-char' and not `character' in the first case? + #-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." + #-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'." + #-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) + #-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) @@ -6133,6 +6159,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)))) @@ -6156,7 +6183,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) @@ -6208,12 +6238,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) @@ -6247,11 +6272,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)))) @@ -6264,12 +6285,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)))) @@ -6322,11 +6338,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))) @@ -6373,12 +6385,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))) @@ -6795,12 +6802,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*) -- GitLab From 0eecef3e8743cd4264bee2b6416c3a9091573502 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Fri, 17 Oct 2025 20:55:30 -0700 Subject: [PATCH 16/37] The `nil' default default is back! Reverts much of dc74ba6. --- Code/fset.lisp | 141 +++++++++++++++++++++----------------------- Code/macros.lisp | 23 ++++---- Code/order.lisp | 2 +- Code/relations.lisp | 4 +- Code/replay.lisp | 70 ++++++++++------------ Code/testing.lisp | 27 +++++---- 6 files changed, 124 insertions(+), 143 deletions(-) diff --git a/Code/fset.lisp b/Code/fset.lisp index e7d5403..a8b2e79 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -589,24 +589,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'.")) + "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 @@ -617,7 +617,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. @@ -2262,6 +2262,8 @@ (defstruct (hash-set-org (compare-fn nil :type function :read-only t) (hash-fn nil :type function :read-only t)) +(deflex +fset-default-hash-set-org+ (make-hash-set-org 'compare #'compare #'hash-value)) + (declaim (inline make-ch-set)) (defstruct (ch-set @@ -2273,7 +2275,7 @@ (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 () @@ -3462,21 +3464,23 @@ (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+ 'no-default)) +(defparameter *empty-wb-map* (make-wb-map nil +fset-default-tree-map-org+ nil)) -(defparameter *empty-wb-map/nil* (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)) -;;; I've parameterized this on the thought that some people might want to set it to `nil', -;;; for backward compatibility with FSet 1. The longer I think about it, though, the less -;;; likely it seems, considering they can still use the FSet 1 API if they want. -(defparameter *fset2-default-default* 'no-default - "The value used for map and seq defaults if no other value is specified.") +(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/nil*)) + *empty-wb-map*)) ;;; `fset2:empty-map' is below (declaim (inline empty-wb-map fset2:empty-wb-map)) @@ -3484,33 +3488,26 @@ (defstruct (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/nil* + *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." - (empty-wb-map-internal default? default no-default? key-compare-fn-name val-compare-fn-name)) - -(declaim (inline fset2-default)) -(defun fset2-default (default? default no-default?) - (cond (default? default) - (no-default? 'no-default) - (t *fset2-default-default*))) + ;; 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? 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. - (if (and default? no-default?) - (error "Both a default and `no-default?' specified") - (let ((default (fset2-default default? default no-default?))) - (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))) - ((eq default 'no-default) - *empty-wb-map*) - ((null default) - *empty-wb-map/nil*) - (t (make-wb-map nil +fset-default-tree-map-org+ default)))))) + (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)) @@ -3522,7 +3519,7 @@ (defstruct (wb-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/nil* + (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 (!). @@ -4365,6 +4362,9 @@ (defstruct (hash-map-org (val-compare-fn nil :type function :read-only t) (val-hash-fn nil :type function :read-only t)) +(deflex +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 @@ -4376,44 +4376,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) - 'no-default)) +(defparameter *empty-ch-map* (make-ch-map nil +fset-default-hash-map-org+ nil)) -(defparameter *empty-ch-map/nil* - (make-ch-map nil (make-hash-map-org 'compare #'compare #'hash-value 'compare #'compare #'hash-value) - nil)) +(defparameter *empty-ch-map/no-default* (make-ch-map nil +fset-default-hash-map-org+ 'no-default)) (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 default? default no-default? nil nil)) + (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/nil* - (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 default? default no-default? key-compare-fn-name val-compare-fn-name)) + (empty-ch-map-internal (fset2-default default? default no-default?) key-compare-fn-name val-compare-fn-name)) -(defun empty-ch-map-internal (default? default no-default? key-compare-fn-name val-compare-fn-name) - (if (and default? no-default?) - (error "Both a default and `no-default?' specified") - (let ((default (fset2-default default? default no-default?))) - (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))) - ((eq default 'no-default) - *empty-ch-map*) - ((null default) - *empty-ch-map/nil*) - (t (make-ch-map nil (ch-map-org *empty-ch-map*) default)))))) +(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)) @@ -4425,8 +4418,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/nil* - (make-ch-map nil (ch-map-org *empty-ch-map*) default)) + (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) @@ -4898,19 +4891,19 @@ (defstruct (wb-seq (contents nil :read-only t)) -(defparameter *empty-wb-seq* (make-wb-seq nil 'no-default)) +(defparameter *empty-wb-seq* (make-wb-seq nil nil)) -(defparameter *empty-wb-seq/nil* (make-wb-seq nil nil)) +(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/nil*)) + *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 default? default no-default?)) + (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) @@ -4919,17 +4912,14 @@ (defstruct (wb-seq *empty-wb-seq*)) (defun fset2:empty-wb-seq (&key (default nil default?) no-default?) "Returns an empty wb-seq." - (empty-wb-seq-internal default? default no-default?)) + (empty-wb-seq-internal (fset2-default default? default no-default?))) -(defun empty-wb-seq-internal (default? default no-default?) - (if (and default? no-default?) - (error "Both a default and `no-default?' specified") - (let ((default (fset2-default default? default no-default?))) - (cond ((eq default 'no-default) - *empty-wb-seq*) - ((null default) - *empty-wb-seq/nil*) - (t (make-wb-seq nil default)))))) +(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))) @@ -5748,3 +5738,4 @@ (define-methods (compose fset2:compose) ((fn symbol) (s seq) &key) (define-condition simple-program-error (simple-condition program-error) ()) +eri diff --git a/Code/macros.lisp b/Code/macros.lisp index b62dcb4..3cfc618 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -1025,13 +1025,12 @@ (define-setf-expander fset2:@ (collection key &environment env) #'(lambda (tree) (make-wb-map tree (wb-map-org *empty-wb-map*) ,default)) ,filterp)) -(gmap:def-result-type fset2:map (&key filterp (default nil default?)) +(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) (WB-Map-Tree-With m x y #'compare #'compare))) - #'(lambda (tree) (make-wb-map tree (wb-map-org *empty-wb-map*) - ,(if default? default - '*fset2-default-default*))) + `(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) @@ -1047,7 +1046,8 @@ (define-setf-expander fset2:@ (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?) key-compare-fn-name val-compare-fn-name) +(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-)) @@ -1055,8 +1055,7 @@ (define-setf-expander fset2:@ (collection key &environment env) (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) - ,(if default? default - '*fset2-default-default*))) + (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))) @@ -1089,7 +1088,8 @@ (define-setf-expander fset2:@ (collection key &environment env) (,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?) key-compare-fn-name val-compare-fn-name) +(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-)) @@ -1098,8 +1098,7 @@ (define-setf-expander fset2:@ (collection key &environment env) (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 ,(if default? default - '*fset2-default-default*))) + #'(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)) @@ -1427,7 +1426,7 @@ (define-setf-expander fset2:@ (collection key &environment env) (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))))) diff --git a/Code/order.lisp b/Code/order.lisp index 1d2fac6..f45cf30 100644 --- a/Code/order.lisp +++ b/Code/order.lisp @@ -71,7 +71,7 @@ (defstruct (map (:predicate map?) (:copier nil)) "The abstract class for FSet functional maps. It is a structure class." - (default 'no-default :read-only t)) + (default nil :read-only t)) (defstruct (replay-map (:constructor nil) diff --git a/Code/relations.lisp b/Code/relations.lisp index 4bbb549..7cc31f7 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -816,7 +816,7 @@ (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+)) (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) @@ -2092,7 +2092,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?)) diff --git a/Code/replay.lisp b/Code/replay.lisp index 5f7d52e..2705ab7 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -32,11 +32,11 @@ (defmethod convert ((to-type (eql 'vector)) (s replay-set) &key) (defmethod convert ((to-type (eql 'seq)) (s replay-set) &key) (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) *fset2-default-default*)) + (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) nil)) (defmethod convert ((to-type (eql 'fset2:wb-seq)) (s replay-set) &key) - (make-wb-seq (replay-set-ordering s) *fset2-default-default*)) + (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))) @@ -553,10 +553,10 @@ (defmethod less ((s ch-replay-set) value &optional (arg2 nil arg2?)) (declaim (inline empty-replay-map fset2:empty-replay-map)) (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) + (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 default? default no-default? nil nil)) + (empty-ch-replay-map-internal (fset2-default default? default no-default?) nil nil)) (defmethod convert ((to-type (eql 'replay-map)) (m replay-map) &key) m) @@ -641,9 +641,9 @@ (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+ 'no-default)) +(defparameter *empty-wb-replay-map* (make-wb-replay-map nil nil +fset-default-tree-map-org+ nil)) -(defparameter *empty-wb-replay-map/nil* (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) @@ -656,21 +656,16 @@ (defstruct (wb-replay-map "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 default? default no-default? key-compare-fn-name val-compare-fn-name)) - -(defun empty-wb-replay-map-internal (default? default no-default? key-compare-fn-name val-compare-fn-name) - (if (and default? no-default?) - (error "Both a default and `no-default?' specified") - (let ((default (cond (default? default) - (no-default? 'no-default) - (t *fset2-default-default*)))) - (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))) - ((eq default 'no-default) - *empty-wb-replay-map*) - ((null default) - *empty-wb-replay-map/nil*) - (t (make-wb-replay-map nil nil +fset-default-tree-map-org+ default)))))) + (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)) @@ -965,36 +960,31 @@ (defstruct (ch-replay-map (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*) 'no-default)) +(defparameter *empty-ch-replay-map* (make-ch-replay-map nil nil +fset-default-hash-map-org+ nil)) -(defparameter *empty-ch-replay-map/nil* (make-ch-replay-map nil nil (ch-map-org *empty-ch-map*) nil)) +(defparameter *empty-ch-replay-map/no-default* (make-ch-replay-map nil nil +fset-default-hash-map-org+ 'no-default)) (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/nil* - (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 default? default no-default? key-compare-fn-name val-compare-fn-name)) - -(defun empty-ch-replay-map-internal (default? default no-default? key-compare-fn-name val-compare-fn-name) - (if (and default? no-default?) - (error "Both a default and `no-default?' specified") - (let ((default (cond (default? default) - (no-default? 'no-default) - (t *fset2-default-default*)))) - (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))) - ((eq default 'no-default) - *empty-ch-replay-map*) - ((null default) - *empty-ch-replay-map/nil*) - (t (make-ch-replay-map nil nil (ch-map-org *empty-ch-map*) default)))))) + (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)) diff --git a/Code/testing.lisp b/Code/testing.lisp index 209c893..c6ffc79 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -4693,6 +4693,7 @@ (define-tuple-key +k5+ :default 'plugh) (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)) @@ -4707,27 +4708,27 @@ (define-tuple-key +k5+ :default 'plugh) (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) :default 33)) - (map ('a 3) ('b 4) :default 33))) ; val-fn discards left default + (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) :default 21) chm-d (fn (_x y) (if (= y 42) (values nil ':no-value) - y))) + (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) :default 13)) - (wb-map ('b 4) ('c 7) :default 13))) ; val-fn discards left 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) :default 47) wbm-d (fn (_x y) (if (= y 21) (values nil ':no-value) - y))) + (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)))) @@ -4736,19 +4737,19 @@ (define-tuple-key +k5+ :default 'plugh) (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)) + (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)) + (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-d (wb-map ('a 4) :default 17)) (ch-map ('a 4) :default 17))) + (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) @@ -4764,7 +4765,7 @@ (define-tuple-key +k5+ :default 'plugh) (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? (compose (ch-map ('a 7) :default 9) (map (7 12) :default 3)) + (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))) @@ -4842,7 +4843,7 @@ (define-tuple-key +k5+ :default 'plugh) #'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)))) + (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))) -- GitLab From 7ea6b4e42d03bbb898fd607e848c6194e7edfe87 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sat, 18 Oct 2025 01:00:09 -0700 Subject: [PATCH 17/37] Tuple keys also have a 'nil' default default again. --- Code/fset.lisp | 1 - Code/testing.lisp | 12 ++++++------ Code/tuples.lisp | 20 ++++++++++++-------- 3 files changed, 18 insertions(+), 15 deletions(-) diff --git a/Code/fset.lisp b/Code/fset.lisp index a8b2e79..0624811 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -5738,4 +5738,3 @@ (define-methods (compose fset2:compose) ((fn symbol) (s seq) &key) (define-condition simple-program-error (simple-condition program-error) ()) -eri diff --git a/Code/testing.lisp b/Code/testing.lisp index c6ffc79..b55cdcf 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -4596,6 +4596,7 @@ (defmethod verify ((m ch-map)) (in-package :fset2) (define-tuple-key +k5+ :default 'plugh) +(define-tuple-key +k6+) (defun fset::test-fset2 () (declare (optimize (debug 3))) @@ -4778,12 +4779,11 @@ (define-tuple-key +k5+ :default 'plugh) (test (= (rank (wb-set 1 3 5) 2) 1)) (test (equal? (@ (tuple) +k5+) 'plugh)) - (let ((k (get-tuple-key 'fubar :default 11))) - (test (equal? (@ (tuple) k) 11)) - (setq k (get-tuple-key 'fubar :no-default? t)) - (test-error (@ (tuple) k)) - (setq k (get-tuple-key 'fubar :default 0)) - (test (equal? (@ (tuple) k) 0)))))) + (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))))) (defun test-fset2-gmap () (macrolet ((test (form) diff --git a/Code/tuples.lisp b/Code/tuples.lisp index 605dcaa..aeb4055 100644 --- a/Code/tuples.lisp +++ b/Code/tuples.lisp @@ -159,8 +159,8 @@ (defstruct (tuple-key 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 no default; -if it already existed, its default will be unchanged." +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+) @@ -173,7 +173,8 @@ (defstruct (tuple-key (setf (tuple-key-default key) 'no-default))) key) ((<= key-idx Tuple-Key-Number-Mask) - (let ((key (make-tuple-key name (if default? default 'no-default) key-idx))) + (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)) @@ -197,14 +198,17 @@ (defstruct (tuple-key (assert (symbolp name)) `(deflex ,name (get-tuple-key ',name ,default) . ,(and doc-string `(,doc-string)))) -(defmacro fset2:define-tuple-key (name &key (default nil default?) documentation) +(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' when -the tuple has no explicit pair with this key; otherwise, `lookup` will signal -an error in that case." +`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) - '(:no-default? t))) + (and no-default? '(:no-default? t)))) . ,(and documentation `(,documentation)))) (defun print-tuple-key (key stream level) -- GitLab From 944421615488fe421fca3343124d270adaf370bc Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Mon, 20 Oct 2025 14:52:52 -0700 Subject: [PATCH 18/37] Improve CHAMP tests. --- Code/testing.lisp | 76 +++++++++++++++++++++++++++-------------------- 1 file changed, 44 insertions(+), 32 deletions(-) diff --git a/Code/testing.lisp b/Code/testing.lisp index b55cdcf..8c28242 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -4364,6 +4364,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) @@ -4377,7 +4383,9 @@ (defmethod verify ((s ch-set)) (let ((wbs (wb-set)) (chs (ch-set))) (dotimes (j 256) - (let ((mi (make-my-integer (random 1024))) + (let ((mi (if (logbitp 0 i) + (@ *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))) @@ -4404,23 +4412,24 @@ (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 (logbitp 0 i) + (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))))) (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))) @@ -4486,7 +4495,9 @@ (defmethod verify ((m ch-map)) ((chm (ch-custom-map cfn nil)))) (setq *champ-map-test-pairs* (seq)) (dotimes (j 256) - (let ((mi (make-my-integer (random 1024))) + (let ((mi (if (logbitp 0 i) + (@ *seq-of-symbols* (random (size *seq-of-symbols*))) + (make-my-integer (random 1024)))) (val (random 65536)) (prev-wbm wbm) (prev-chm chm)) @@ -4514,22 +4525,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. - (when (eq (key-compare-fn-name chm) 'compare) - (test (eq (compare chm tmp-chm) ':less)) - (test (eq (compare tmp-chm chm) ':greater)))) + (unless (logbitp 0 i) + (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))) -- GitLab From 800a476fdf3f4be10783624bd5968e86beebfce1 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Mon, 20 Oct 2025 14:57:44 -0700 Subject: [PATCH 19/37] Re-introduce package locking, with disable feature (GitHub #78). --- Code/port.lisp | 19 +++++++++++-------- Code/post.lisp | 4 +++- 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/Code/port.lisp b/Code/port.lisp index 5595b66..0c2ac5d 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))))) ;;; ---------------- diff --git a/Code/post.lisp b/Code/post.lisp index bd31b9a..3bec619 100644 --- a/Code/post.lisp +++ b/Code/post.lisp @@ -16,5 +16,7 @@ (declaim (ftype (function (t &key (:from-end? t) &allow-other-keys) function) fun-iterator)) +;;; Must be last! #+FSet-Use-Package-Locks -(lock-fset-package) +(lock-fset-packages) + -- GitLab From e6d71e3e04fd95688b88f8a59be9dc2024825fa5 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Mon, 20 Oct 2025 14:59:43 -0700 Subject: [PATCH 20/37] Copy class definitions from shadowed 'fset:' symbols to `fset2:'. --- Code/post.lisp | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/Code/post.lisp b/Code/post.lisp index 3bec619..0b15638 100644 --- a/Code/post.lisp +++ b/Code/post.lisp @@ -16,6 +16,12 @@ (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)) + (setf (find-class (intern (string sym) :fset2)) (find-class sym))) + + ;;; Must be last! #+FSet-Use-Package-Locks (lock-fset-packages) -- GitLab From 8db859a09992dd70f403d7bbc5a2000a857caab5 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Mon, 20 Oct 2025 17:38:00 -0700 Subject: [PATCH 21/37] Minor tweaks. --- Code/relations.lisp | 4 ---- Code/wb-trees.lisp | 7 ++++++- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/Code/relations.lisp b/Code/relations.lisp index 7cc31f7..b39da7e 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -2067,10 +2067,6 @@ (defstruct (ch-list-relation (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))) diff --git a/Code/wb-trees.lisp b/Code/wb-trees.lisp index 55a3455..17d371d 100644 --- a/Code/wb-trees.lisp +++ b/Code/wb-trees.lisp @@ -6128,19 +6128,23 @@ (defstruct (WB-Seq-Tree-Node (declaim (inline character-type)) (defun character-type (ch) - ;; &&& Why `base-char' and not `character' in the first case? + (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 @@ -6148,6 +6152,7 @@ (defstruct (WB-Seq-Tree-Node (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 -- GitLab From 0a8cd0bce6291e55edf8bc70789cb147fc2bba8d Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Mon, 20 Oct 2025 18:02:19 -0700 Subject: [PATCH 22/37] CCL fix for e6d71e3. --- Code/post.lisp | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Code/post.lisp b/Code/post.lisp index 0b15638..a1908f0 100644 --- a/Code/post.lisp +++ b/Code/post.lisp @@ -19,7 +19,10 @@ ;;; 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)) - (setf (find-class (intern (string sym) :fset2)) (find-class sym))) + (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))) ;;; Must be last! -- GitLab From 81315ff7ec4b00e0ca3e17724e37f4b5f179d18b Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sat, 25 Oct 2025 19:32:05 -0700 Subject: [PATCH 23/37] Export 'hash-slots'. --- Code/defs.lisp | 4 ++-- Code/macros.lisp | 21 +++++++++++++++++++++ 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/Code/defs.lisp b/Code/defs.lisp index f4ec0e2..b905f2d 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -40,7 +40,7 @@ #: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? #: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 @@ -177,7 +177,7 @@ #: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? #: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 diff --git a/Code/macros.lisp b/Code/macros.lisp index 3cfc618..507b44e 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -85,6 +85,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))) @@ -280,6 +282,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-))) @@ -298,6 +317,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))) -- GitLab From 6783ae00694d259edfced4457ab1737d9ed32bc0 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sat, 25 Oct 2025 19:32:29 -0700 Subject: [PATCH 24/37] Work around SBCL package lock bug. --- Code/relations.lisp | 6 ++++-- Code/replay.lisp | 12 ++++++++---- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/Code/relations.lisp b/Code/relations.lisp index b39da7e..ac80e35 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -38,10 +38,12 @@ (defstruct (2-relation (defmethod arity ((rel 2-relation)) 2) +;;; Had to move this up because of https://bugs.launchpad.net/sbcl/+bug/2129827 . +(defparameter *empty-ch-2-relation* (make-ch-2-relation 0 nil nil +fset-default-hash-map-org+)) + (declaim (inline empty-2-relation)) (defun empty-2-relation () ;; Now CHAMP! - (declare (special *empty-ch-2-relation*)) *empty-ch-2-relation*) (defgeneric lookup-inv (2-relation y) @@ -816,7 +818,7 @@ (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 +fset-default-hash-map-org+)) +;;; See above for `*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) diff --git a/Code/replay.lisp b/Code/replay.lisp index 2705ab7..156b6cf 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -14,11 +14,13 @@ ;;; We have some implementation-generic methods. +;;; Had to move this up because of https://bugs.launchpad.net/sbcl/+bug/2129827 . +(defparameter *empty-ch-replay-set* (make-ch-replay-set nil nil (ch-set-org *empty-ch-set*))) + (declaim (inline empty-replay-set)) (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 convert ((to-type (eql 'replay-set)) (s replay-set) &key) @@ -320,7 +322,7 @@ (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*))) +;;; See above for `*empty-ch-replay-set*'. (declaim (inline empty-ch-replay-set fset2:empty-ch-replay-set)) (defun empty-ch-replay-set (&optional compare-fn-name) @@ -550,9 +552,11 @@ (defmethod less ((s ch-replay-set) value &optional (arg2 nil arg2?)) ;;; We have some implementation-generic methods. +;;; Had to move this up because of https://bugs.launchpad.net/sbcl/+bug/2129827 . +(defparameter *empty-ch-replay-map* (make-ch-replay-map nil nil +fset-default-hash-map-org+ nil)) + (declaim (inline empty-replay-map fset2:empty-replay-map)) (defun empty-replay-map (&optional default) - (declare (special *empty-ch-replay-map*)) (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?) @@ -960,7 +964,7 @@ (defstruct (ch-replay-map (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 +fset-default-hash-map-org+ nil)) +;;; See above for `*empty-ch-replay-map*'. (defparameter *empty-ch-replay-map/no-default* (make-ch-replay-map nil nil +fset-default-hash-map-org+ 'no-default)) -- GitLab From 48d38a89f1002703b95cfdf21155a26a692f0399 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sat, 25 Oct 2025 19:53:30 -0700 Subject: [PATCH 25/37] Oops -- second try. --- Code/relations.lisp | 6 +++--- Code/replay.lisp | 12 ++++++------ 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/Code/relations.lisp b/Code/relations.lisp index ac80e35..4939394 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -38,8 +38,8 @@ (defstruct (2-relation (defmethod arity ((rel 2-relation)) 2) -;;; Had to move this up because of https://bugs.launchpad.net/sbcl/+bug/2129827 . -(defparameter *empty-ch-2-relation* (make-ch-2-relation 0 nil nil +fset-default-hash-map-org+)) +;;; Had to pre-declare this because of https://bugs.launchpad.net/sbcl/+bug/2129827 . +(defparameter *empty-ch-2-relation* nil) (declaim (inline empty-2-relation)) (defun empty-2-relation () @@ -818,7 +818,7 @@ (defstruct (ch-2-relation (map1 nil) ; a cache, so we leave it mutable (org nil :type hash-map-org :read-only t)) -;;; See above for `*empty-ch-2-relation*'. +(defparameter *empty-ch-2-relation* (make-ch-2-relation 0 nil nil +fset-default-hash-map-org+)) (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) diff --git a/Code/replay.lisp b/Code/replay.lisp index 156b6cf..334ae8f 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -14,8 +14,8 @@ ;;; We have some implementation-generic methods. -;;; Had to move this up because of https://bugs.launchpad.net/sbcl/+bug/2129827 . -(defparameter *empty-ch-replay-set* (make-ch-replay-set nil nil (ch-set-org *empty-ch-set*))) +;;; Had to pre-declare this because of https://bugs.launchpad.net/sbcl/+bug/2129827 . +(defparameter *empty-ch-replay-set* nil) (declaim (inline empty-replay-set)) (defun empty-replay-set () @@ -322,7 +322,7 @@ (defstruct (ch-replay-set (contents nil :read-only t) (org nil :type hash-set-org :read-only t)) -;;; See above for `*empty-ch-replay-set*'. +(defparameter *empty-ch-replay-set* (make-ch-replay-set nil nil (ch-set-org *empty-ch-set*))) (declaim (inline empty-ch-replay-set fset2:empty-ch-replay-set)) (defun empty-ch-replay-set (&optional compare-fn-name) @@ -552,8 +552,8 @@ (defmethod less ((s ch-replay-set) value &optional (arg2 nil arg2?)) ;;; We have some implementation-generic methods. -;;; Had to move this up because of https://bugs.launchpad.net/sbcl/+bug/2129827 . -(defparameter *empty-ch-replay-map* (make-ch-replay-map nil nil +fset-default-hash-map-org+ nil)) +;;; Had to pre-declare this because of https://bugs.launchpad.net/sbcl/+bug/2129827 . +(defparameter *empty-ch-replay-map* nil) (declaim (inline empty-replay-map fset2:empty-replay-map)) (defun empty-replay-map (&optional default) @@ -964,7 +964,7 @@ (defstruct (ch-replay-map (contents nil :read-only t) (org nil :type hash-map-org :read-only t)) -;;; See above for `*empty-ch-replay-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)) -- GitLab From 540b8c222ff298a50fb1405df862f75226a906cf Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Mon, 27 Oct 2025 19:37:02 -0700 Subject: [PATCH 26/37] Added 'instance-class-name'; other minor fixes. --- Code/defs.lisp | 11 +++++++++-- Code/fset.lisp | 5 ----- Code/order.lisp | 11 +++++++++++ Code/relations.lisp | 3 --- Code/replay.lisp | 2 +- Code/testing.lisp | 6 ++++++ Code/wb-trees.lisp | 29 +++++++++++++++++------------ 7 files changed, 44 insertions(+), 23 deletions(-) diff --git a/Code/defs.lisp b/Code/defs.lisp index b905f2d..7bb1c39 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 @@ -41,7 +42,7 @@ #:ch-custom-set #:ch-custom-map #:wb-custom-replay-set #:wb-custom-replay-map #:ch-custom-replay-set #:ch-custom-replay-map #:equal? #:compare #:compare-slots #:compare-slots-no-unequal #:hash-slots #:eql-compare - #:define-equality-slots #:define-comparison-slots #:define-hash-function + #:define-equality-slots #:define-comparison-slots #:define-hash-function #:instance-class-name #: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 @@ -135,6 +136,7 @@ (: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*) + #+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. (:shadowing-import-from :fset @@ -178,7 +180,7 @@ #:ch-custom-set #:ch-custom-map #:wb-custom-replay-set #:wb-custom-replay-map #:ch-custom-replay-set #:ch-custom-replay-map #:equal? #:compare #:compare-slots #:compare-slots-no-unequal #:hash-slots #:eql-compare - #:define-equality-slots #:define-comparison-slots #:define-hash-function + #:define-equality-slots #:define-comparison-slots #:define-hash-function #:instance-class-name #: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 @@ -255,6 +257,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, diff --git a/Code/fset.lisp b/Code/fset.lisp index 0624811..b4cc555 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -391,11 +391,6 @@ (defmethod reduce (fn (s sequence) &rest keyword-args are mapped by the map.")) (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.")) - -(defgeneric fset2:default (collection) (:documentation "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 diff --git a/Code/order.lisp b/Code/order.lisp index f45cf30..df32bc4 100644 --- a/Code/order.lisp +++ b/Code/order.lisp @@ -471,3 +471,14 @@ (defmethod compare-lexicographically ((a vector) (b vector) &key (val-compare-fn (return res)) (when (eq res ':unequal) (setq default ':unequal)))))))) + + +;;; ================================================================================ +;;; Miscellany + +(defun instance-class-name (x) + "In a `define-equality-slots' form for a class with subclasses, or for one +of its subclasses, supply `#'instance-class-name' as the first accessor to +discriminate instances by class." + (class-name (class-of x))) + diff --git a/Code/relations.lisp b/Code/relations.lisp index 4939394..bb9ce9f 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -1213,9 +1213,6 @@ (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 '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)) diff --git a/Code/replay.lisp b/Code/replay.lisp index 334ae8f..ce71aa8 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -771,7 +771,7 @@ (defmethod at-index ((m wb-replay-map) index) (defmethod size ((m wb-replay-map)) (WB-Map-Tree-Size (wb-replay-map-contents m))) -(define-convert-methods (replay-map fset2:replay-map) ((m replay-map) &key) +(defmethod convert ((to-type (eql 'fset2:replay-map)) (m replay-map) &key) m) (define-convert-methods (wb-replay-map fset2:wb-replay-map) diff --git a/Code/testing.lisp b/Code/testing.lisp index 8c28242..7e2cae4 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -4716,6 +4716,12 @@ (define-tuple-key +k6+) (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)))) diff --git a/Code/wb-trees.lisp b/Code/wb-trees.lisp index 17d371d..e754c35 100644 --- a/Code/wb-trees.lisp +++ b/Code/wb-trees.lisp @@ -6622,18 +6622,23 @@ (defstruct (WB-Seq-Tree-Node (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))) -- GitLab From e1845f33fe89fe49099f9c94e7e2919dcf3147a1 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Tue, 28 Oct 2025 01:11:38 -0700 Subject: [PATCH 27/37] Change some `deflex' to `defparameter'; adjust earmuffs. This works around an ABCL bug with symbol macros (used by `deflex'). (I wanted to use `defconstant', but it requires an initial value evaluable at compile time.) --- Code/fset.lisp | 78 +++++++++++++++++++++++---------------------- Code/macros.lisp | 6 ++-- Code/relations.lisp | 45 ++++++++++++-------------- Code/replay.lisp | 78 ++++++++++++++++++++++----------------------- 4 files changed, 103 insertions(+), 104 deletions(-) diff --git a/Code/fset.lisp b/Code/fset.lisp index b4cc555..07743d6 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -1590,7 +1590,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)) @@ -1655,12 +1657,12 @@ (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 (declaim (inline empty-wb-set fset2:empty-wb-set)) @@ -1669,14 +1671,14 @@ (defstruct (wb-custom-set 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-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 @@ -1692,7 +1694,7 @@ (defstruct (wb-custom-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 @@ -2257,7 +2259,7 @@ (defstruct (hash-set-org (compare-fn nil :type function :read-only t) (hash-fn nil :type function :read-only t)) -(deflex +fset-default-hash-set-org+ (make-hash-set-org 'compare #'compare #'hash-value)) +(defparameter +fset-default-hash-set-org+ (make-hash-set-org 'compare #'compare #'hash-value)) (declaim (inline make-ch-set)) @@ -2270,12 +2272,12 @@ (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 +fset-default-hash-set-org+)) +(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*) + +empty-ch-set+) (declaim (inline empty-ch-set fset2:empty-ch-set)) (defun empty-ch-set (&optional compare-fn-name) @@ -2284,7 +2286,7 @@ (defstruct (ch-set 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 @@ -2292,7 +2294,7 @@ (defstruct (ch-set 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))) (deflex +empty-ch-custom-set-cache+ (make-hash-table :test 'eq)) @@ -2301,7 +2303,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) @@ -2622,25 +2624,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*) + +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-bag+ (empty-wb-custom-bag compare-fn-name))) (deflex +empty-wb-custom-bag-cache+ (make-hash-table :test 'eq)) @@ -2649,7 +2651,7 @@ (defstruct (wb-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 @@ -3444,7 +3446,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)) @@ -3459,9 +3461,9 @@ (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)) +(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?) @@ -3475,7 +3477,7 @@ (defstruct (wb-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 (declaim (inline empty-wb-map fset2:empty-wb-map)) @@ -3483,7 +3485,7 @@ (defstruct (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) @@ -3499,9 +3501,9 @@ (defstruct (wb-map (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*) + +empty-wb-map+) ((eq default 'no-default) - *empty-wb-map/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)) @@ -3514,7 +3516,7 @@ (defstruct (wb-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 (!). @@ -4357,7 +4359,7 @@ (defstruct (hash-map-org (val-compare-fn nil :type function :read-only t) (val-hash-fn nil :type function :read-only t)) -(deflex +fset-default-hash-map-org+ +(defparameter +fset-default-hash-map-org+ (make-hash-map-org 'compare #'compare #'hash-value 'compare #'compare #'hash-value)) (declaim (inline make-ch-map)) @@ -4371,9 +4373,9 @@ (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 +fset-default-hash-map-org+ 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)) +(defparameter +empty-ch-map/no-default+ (make-ch-map nil +fset-default-hash-map-org+ 'no-default)) (declaim (inline fset2:empty-map)) (defun fset2:empty-map (&key (default nil default?) no-default?) @@ -4385,7 +4387,7 @@ (defstruct (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* + +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) @@ -4398,9 +4400,9 @@ (defstruct (ch-map (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*) + +empty-ch-map+) ((eq default 'no-default) - *empty-ch-map/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)) @@ -4413,7 +4415,7 @@ (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* + (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+))) @@ -4886,15 +4888,15 @@ (defstruct (wb-seq (contents nil :read-only t)) -(defparameter *empty-wb-seq* (make-wb-seq nil nil)) +(defparameter +empty-wb-seq+ (make-wb-seq nil nil)) -(defparameter *empty-wb-seq/no-default* (make-wb-seq nil 'no-default)) +(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*)) + +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." @@ -4904,16 +4906,16 @@ (defstruct (wb-seq (defun empty-wb-seq (&optional default) "Returns an empty wb-seq." (if default (make-wb-seq nil default) - *empty-wb-seq*)) + +empty-wb-seq+)) (defun fset2:empty-wb-seq (&key (default nil default?) no-default?) "Returns an empty wb-seq." (empty-wb-seq-internal (fset2-default default? default no-default?))) (defun empty-wb-seq-internal (default) (cond ((null default) - *empty-wb-seq*) + +empty-wb-seq+) ((eq default 'no-default) - *empty-wb-seq/no-default*) + +empty-wb-seq/no-default+) (t (make-wb-seq nil default)))) (defmethod empty? ((s wb-seq)) diff --git a/Code/macros.lisp b/Code/macros.lisp index 507b44e..66c1228 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -892,7 +892,7 @@ (define-setf-expander fset2:@ (collection key &environment env) "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 (ch-set-org *empty-ch-set*))) + #'(lambda (s) (make-ch-set s +fset-default-hash-set-org+)) ,filterp)) (gmap:def-gmap-res-type ch-set (&key filterp compare-fn-name) @@ -1043,7 +1043,7 @@ (define-setf-expander fset2:@ (collection key &environment env) "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)) + #'(lambda (tree) (make-wb-map tree +fset-default-tree-map-org+ ,default)) ,filterp)) (gmap:def-result-type fset2:map (&key filterp (default nil default?) no-default?) @@ -1375,7 +1375,7 @@ (define-setf-expander fset2:@ (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))))) diff --git a/Code/relations.lisp b/Code/relations.lisp index bb9ce9f..23aabd8 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -38,13 +38,7 @@ (defstruct (2-relation (defmethod arity ((rel 2-relation)) 2) -;;; Had to pre-declare this because of https://bugs.launchpad.net/sbcl/+bug/2129827 . -(defparameter *empty-ch-2-relation* nil) - -(declaim (inline empty-2-relation)) -(defun empty-2-relation () - ;; Now CHAMP! - *empty-ch-2-relation*) +;;; `empty-2-relation' is below. (defgeneric lookup-inv (2-relation y) (:documentation "Does an inverse lookup on a binary relation.")) @@ -119,20 +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 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-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)) @@ -145,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)) @@ -190,15 +184,13 @@ (define-methods (lookup fset2:lookup) ((rel wb-2-relation) x) ;; 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)) @@ -818,20 +810,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 +fset-default-hash-map-org+)) +(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 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-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)) @@ -844,7 +843,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) @@ -900,16 +899,14 @@ (define-methods (lookup fset2: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))) @@ -1682,7 +1679,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?)) diff --git a/Code/replay.lisp b/Code/replay.lisp index ce71aa8..83bd15e 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -13,15 +13,7 @@ ;;; Replay sets ;;; We have some implementation-generic methods. - -;;; Had to pre-declare this because of https://bugs.launchpad.net/sbcl/+bug/2129827 . -(defparameter *empty-ch-replay-set* nil) - -(declaim (inline empty-replay-set)) -(defun empty-replay-set () - "Returns an empty replay set of the default implementation." - ;; Now CHAMP! - *empty-ch-replay-set*) +;;; `empty-replay-set' is below. (defmethod convert ((to-type (eql 'replay-set)) (s replay-set) &key) s) @@ -75,16 +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 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-replay-set+ (empty-wb-custom-replay-set compare-fn-name))) (deflex +empty-wb-custom-replay-set-cache+ (make-hash-table :test 'eq)) @@ -92,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 @@ -322,16 +314,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+)) + +;;; 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-replay-set+ (empty-ch-custom-replay-set compare-fn-name))) (deflex +empty-ch-custom-replay-set-cache+ (make-hash-table :test 'eq)) @@ -340,7 +340,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) @@ -551,16 +551,7 @@ (defmethod less ((s ch-replay-set) value &optional (arg2 nil arg2?)) ;;; Replay maps ;;; We have some implementation-generic methods. - -;;; Had to pre-declare this because of https://bugs.launchpad.net/sbcl/+bug/2129827 . -(defparameter *empty-ch-replay-map* nil) - -(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)) +;;; `empty-replay-map' is below. (defmethod convert ((to-type (eql 'replay-map)) (m replay-map) &key) m) @@ -645,15 +636,15 @@ (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+ nil)) +(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)) +(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) @@ -666,9 +657,9 @@ (defstruct (wb-replay-map (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*) + +empty-wb-replay-map+) ((eq default 'no-default) - *empty-wb-replay-map/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)) @@ -681,7 +672,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+))) @@ -964,15 +955,24 @@ (defstruct (ch-replay-map (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 +fset-default-hash-map-org+ nil)) +(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)) +(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* + +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) @@ -985,9 +985,9 @@ (defstruct (ch-replay-map (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*) + +empty-ch-replay-map+) ((eq default 'no-default) - *empty-ch-replay-map/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)) @@ -1000,7 +1000,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+))) -- GitLab From 2018fb9b92ce5a441848b79971b29331d72daa81 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Fri, 31 Oct 2025 15:24:28 -0700 Subject: [PATCH 28/37] Add reversal feature to list-to-seq converter. --- Code/fset.lisp | 14 +++++++++----- Code/testing.lisp | 2 ++ Code/wb-trees.lisp | 48 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 59 insertions(+), 5 deletions(-) diff --git a/Code/fset.lisp b/Code/fset.lisp index 07743d6..6ba8d39 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -5137,11 +5137,15 @@ (define-convert-methods (seq wb-seq) ((vec vector) &key) (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) - (make-wb-seq (WB-Seq-Tree-From-List l) nil)) - -(define-convert-methods (fset2:seq fset2:wb-seq) ((l list) &key (default nil default?) no-default?) - (make-wb-seq (WB-Seq-Tree-From-List l) (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)) diff --git a/Code/testing.lisp b/Code/testing.lisp index 7e2cae4..91c02ca 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -3351,6 +3351,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)) diff --git a/Code/wb-trees.lisp b/Code/wb-trees.lisp index e754c35..5174d16 100644 --- a/Code/wb-trees.lisp +++ b/Code/wb-trees.lisp @@ -6621,6 +6621,54 @@ (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)) #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) -- GitLab From c7a2e2f5f95d4f45628186e7e399b89e0a19f117 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sun, 2 Nov 2025 00:57:52 -0700 Subject: [PATCH 29/37] Bug fix for custom compare-fns. --- Code/fset.lisp | 88 ++++++++++++++++++++++---------------------------- 1 file changed, 39 insertions(+), 49 deletions(-) diff --git a/Code/fset.lisp b/Code/fset.lisp index bdf8e4f..f658a6c 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -2020,17 +2020,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,7 +2059,7 @@ (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 (and default? (eq (compare-fn s) #'compare)) (if (lookup s item) 1 0) (let ((total 0)) (declare (fixnum total)) @@ -3175,19 +3175,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 +3217,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))) @@ -3895,19 +3895,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 +3937,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))) @@ -4989,7 +4989,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 +4999,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)) -- GitLab From 34c6cd235a8c5bec5cc1b17e84c98d1747b85392 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Tue, 4 Nov 2025 17:57:09 -0800 Subject: [PATCH 30/37] OST, remove 'instance-class-name'; just use 'class-of'. --- Code/defs.lisp | 17 ++++------------- Code/fset.lisp | 7 ------- Code/order.lisp | 18 ++++++++---------- Code/relations.lisp | 21 +++++++++++++++++++++ 4 files changed, 33 insertions(+), 30 deletions(-) diff --git a/Code/defs.lisp b/Code/defs.lisp index 7bb1c39..3a7d917 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -42,7 +42,7 @@ #:ch-custom-set #:ch-custom-map #:wb-custom-replay-set #:wb-custom-replay-map #:ch-custom-replay-set #:ch-custom-replay-map #:equal? #:compare #:compare-slots #:compare-slots-no-unequal #:hash-slots #:eql-compare - #:define-equality-slots #:define-comparison-slots #:define-hash-function #:instance-class-name + #: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 @@ -119,17 +119,8 @@ (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) @@ -180,7 +171,7 @@ #:ch-custom-set #:ch-custom-map #:wb-custom-replay-set #:wb-custom-replay-map #:ch-custom-replay-set #:ch-custom-replay-map #:equal? #:compare #:compare-slots #:compare-slots-no-unequal #:hash-slots #:eql-compare - #:define-equality-slots #:define-comparison-slots #:define-hash-function #:instance-class-name + #: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 diff --git a/Code/fset.lisp b/Code/fset.lisp index 91c4e98..a7b87f7 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -805,13 +805,6 @@ (defmethod last ((s sequence)) 17. The default of the result is the same as that of the argument. 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 diff --git a/Code/order.lisp b/Code/order.lisp index df32bc4..4284836 100644 --- a/Code/order.lisp +++ b/Code/order.lisp @@ -168,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) @@ -403,6 +404,13 @@ (defmethod compare ((a sequence) (b sequence)) (setq unequal? t))))))))))) +;;; Classes + +;;; Might as well do this the easy way. +(define-equality-slots class + #'class-name) + + ;;; ================================================================================ ;;; Lexicographic comparison of sequences @@ -472,13 +480,3 @@ (defmethod compare-lexicographically ((a vector) (b vector) &key (val-compare-fn (when (eq res ':unequal) (setq default ':unequal)))))))) - -;;; ================================================================================ -;;; Miscellany - -(defun instance-class-name (x) - "In a `define-equality-slots' form for a class with subclasses, or for one -of its subclasses, supply `#'instance-class-name' as the first accessor to -discriminate instances by class." - (class-name (class-of x))) - diff --git a/Code/relations.lisp b/Code/relations.lisp index 23aabd8..626cf90 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -499,6 +499,14 @@ (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))) @@ -1210,6 +1218,19 @@ (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 '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)) -- GitLab From 0a8e1aa818808c34f3046e2379baa793d35bfded Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 6 Nov 2025 14:54:31 -0800 Subject: [PATCH 31/37] Oops, fix build. --- Code/macros.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Code/macros.lisp b/Code/macros.lisp index 66c1228..5584ccc 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -273,7 +273,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) -- GitLab From 931f35949dbf8ec0952e52e76ef0fb3d419725e2 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Wed, 12 Nov 2025 18:40:02 -0800 Subject: [PATCH 32/37] Left preference in 'union' etc. GitLab #3. Woof! This was much more involved than I expected, but doing it did turn up a few other bugs along the way. --- Code/champ.lisp | 536 ++++++++++++++++++++++++++++++++------------ Code/fset.lisp | 120 +++++----- Code/macros.lisp | 9 + Code/port.lisp | 1 + Code/relations.lisp | 23 +- Code/swank.lisp | 13 +- Code/testing.lisp | 250 ++++++++++++++------- Code/wb-trees.lisp | 480 +++++++++++++++++++++++---------------- 8 files changed, 965 insertions(+), 467 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index 4106ed5..8c5f544 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)) @@ -665,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)) @@ -675,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)) @@ -685,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)) @@ -701,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) @@ -724,12 +730,31 @@ (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 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)) @@ -748,11 +773,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))) @@ -764,7 +789,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)))) @@ -802,7 +828,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)) @@ -813,9 +856,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) @@ -828,13 +871,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)) @@ -874,9 +919,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) @@ -945,9 +990,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) @@ -995,6 +1040,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)) @@ -1103,6 +1195,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) @@ -1217,29 +1310,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) @@ -1260,7 +1353,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. @@ -1274,9 +1367,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)))) @@ -1320,8 +1416,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) @@ -1372,6 +1468,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))) @@ -1459,7 +1563,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) @@ -1471,12 +1575,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))) @@ -1485,16 +1589,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))) @@ -1508,7 +1610,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)) @@ -1560,7 +1662,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)) @@ -1894,8 +1996,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)) @@ -1906,8 +2008,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)) @@ -1916,7 +2018,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)) @@ -1933,10 +2035,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) @@ -1944,7 +2046,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)) @@ -1952,22 +2054,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 + 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 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 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)) @@ -1987,15 +2113,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) @@ -2003,7 +2129,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))))) @@ -2013,61 +2139,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)) @@ -2080,9 +2234,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) @@ -2090,7 +2244,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)) @@ -2098,22 +2252,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)) @@ -2164,9 +2322,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) @@ -2250,9 +2408,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) @@ -2314,9 +2472,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) @@ -2353,6 +2511,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)) @@ -2390,6 +2651,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) @@ -2398,11 +2660,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)))) @@ -2429,7 +2689,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)))) @@ -2458,7 +2718,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/fset.lisp b/Code/fset.lisp index a7b87f7..0601664 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -1826,8 +1826,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)) @@ -2791,10 +2791,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) @@ -2815,16 +2817,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) @@ -2839,8 +2845,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)) @@ -2853,15 +2862,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)))) @@ -2869,7 +2879,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)) @@ -2884,8 +2896,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) @@ -2916,9 +2928,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)) @@ -2926,16 +2937,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)) @@ -2957,17 +2970,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)) @@ -3607,15 +3621,15 @@ (define-condition fset2:map-domain-error (fset2:lookup-error) ;;; 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 (WB-Map-Tree-Lookup (wb-map-contents m) key - (tree-map-org-key-compare-fn (wb-map-org m))))) + (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 (let ((dflt (map-default m))) (if (eq dflt 'no-default) (error 'fset2:map-domain-error :map m :key key) dflt))) - val?))) + val? mkey))) (defmethod rank ((m wb-map) x) (let ((found? rank (WB-Map-Tree-Rank (wb-map-contents m) x @@ -3860,15 +3874,15 @@ (defmethod fset2:map-union ((m1 map) (m2 map) &optional (val-fn (fn (_v1 v2) v2) (let ((result m1) (vcf1 (val-compare-fn m1)) (m1d (with-default m1 nil))) ; so `lookup' doesn't error - (do-map (k v2 m2) - (let ((v1 v1? (lookup m1d k))) + (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))) (if (eq second-val ':no-value) - (excludef result k) - (setf (lookup result k) new-v))))))) + (excludef result k1) + (setf (lookup result k1) new-v))))))) (with-default result default))) (defun map-union-default (m1 m2 val-fn) @@ -3884,7 +3898,8 @@ (defmethod 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)) + (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)))) @@ -3893,7 +3908,8 @@ (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)) + (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))) @@ -3912,10 +3928,12 @@ (defmethod fset2:map-intersection ((m1 map) (m2 map) &optional (val-fn (fn (_v1 (m2d (with-default m2 nil))) ; prevent `lookup' errors (do-map (k v1 m1) (let ((v2 v2? (lookup m2d 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)))))) + (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) @@ -3931,7 +3949,8 @@ (defmethod 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)) + (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)))) @@ -3940,7 +3959,8 @@ (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)) + (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))) @@ -4511,15 +4531,15 @@ (defmethod less ((m ch-map) key &optional (arg2 nil arg2?)) (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 (let ((dflt (map-default m))) (if (eq dflt 'no-default) (error 'fset2:map-domain-error :map m :key key) dflt))) - val?))) + val? mkey))) (defmethod index ((m ch-map) key) (declare (optimize (debug 3))) diff --git a/Code/macros.lisp b/Code/macros.lisp index 5584ccc..ce21ff2 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 diff --git a/Code/port.lisp b/Code/port.lisp index 0c2ac5d..f138650 100644 --- a/Code/port.lisp +++ b/Code/port.lisp @@ -495,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/relations.lisp b/Code/relations.lisp index 626cf90..1c44c7d 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -351,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))) @@ -372,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) @@ -381,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))) @@ -1057,14 +1060,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))) @@ -1081,7 +1087,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) @@ -1091,7 +1097,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))) diff --git a/Code/swank.lisp b/Code/swank.lisp index badf506..dea1c28 100644 --- a/Code/swank.lisp +++ b/Code/swank.lisp @@ -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 91c02ca..5afce5e 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -2254,8 +2254,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") @@ -2622,6 +2622,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)))) @@ -2854,25 +2855,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)))) @@ -2936,8 +2948,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))) @@ -3026,7 +3041,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) @@ -3034,10 +3057,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) @@ -3046,7 +3073,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) @@ -3231,26 +3259,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)))) @@ -4383,9 +4454,10 @@ (defmethod verify ((s ch-set)) (when (zerop (mod i 10)) (format t ".")) (let ((wbs (wb-set)) - (chs (ch-set))) + (chs (ch-set)) + (use-seq-of-symbols? (= 7 (ldb (byte 3 1) i)))) (dotimes (j 256) - (let ((mi (if (logbitp 0 i) + (let ((mi (if use-seq-of-symbols? (@ *seq-of-symbols* (random (size *seq-of-symbols*))) (make-my-integer (random 1024)))) (prev-wbs wbs) @@ -4414,7 +4486,7 @@ (defmethod verify ((s ch-set)) (includef elts (at-index chs k))) (unless (equal? elts wbs) (error "ch-set at-index failed"))) - (unless (logbitp 0 i) + (unless use-seq-of-symbols? (let ((idx (random (size chs))) ((elt (at-index chs idx)) ((tmp-chs (with (less chs elt) @@ -4451,20 +4523,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.) @@ -4494,13 +4578,14 @@ (defmethod verify ((m ch-map)) (format t ".")) (let ((cfn (if (zerop (mod i 4)) 'erapmoc 'compare)) (wbm (wb-map)) - ((chm (ch-custom-map cfn nil)))) + ((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 (if (logbitp 0 i) + (let ((mi (if use-seq-of-symbols? (@ *seq-of-symbols* (random (size *seq-of-symbols*))) (make-my-integer (random 1024)))) - (val (random 65536)) + (val (random 128)) (prev-wbm wbm) (prev-chm chm)) (test (eql (lookup chm mi) (lookup wbm mi))) @@ -4527,7 +4612,7 @@ (defmethod verify ((m ch-map)) (let ((ch-dom (domain chm))) (test (verify ch-dom)) (test (equal? (convert 'wb-set ch-dom) (domain wbm)))) - (unless (logbitp 0 i) + (unless use-seq-of-symbols? (let ((idx (random (size chm))) ((elt (at-index chm idx)) ((chm-less-elt tval (less chm elt)) @@ -4563,24 +4648,35 @@ (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 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)) diff --git a/Code/wb-trees.lisp b/Code/wb-trees.lisp index 5174d16..40f162b 100644 --- a/Code/wb-trees.lisp +++ b/Code/wb-trees.lisp @@ -520,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 @@ -561,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 @@ -602,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) @@ -1320,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) @@ -1373,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) @@ -1806,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)))))) @@ -1833,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)) @@ -2349,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)) @@ -2381,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)) @@ -2418,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)) @@ -2453,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)) @@ -3199,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) @@ -3762,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)) @@ -3790,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)) @@ -3820,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)) @@ -3940,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))))))) @@ -3969,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))))))) @@ -3997,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))))) @@ -4023,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))))) @@ -4293,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)) @@ -4302,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 @@ -4375,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) @@ -4395,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))) @@ -4589,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)) @@ -4603,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))))) @@ -5063,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))) @@ -5286,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. @@ -5306,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))) @@ -5353,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))) @@ -5370,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) @@ -5379,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))) @@ -5408,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))) @@ -5806,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'. @@ -5820,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) @@ -5900,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'. @@ -5909,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 @@ -7034,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)))) @@ -7123,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)))) @@ -7157,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 @@ -7193,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)) -- GitLab From 1f8fa9f5b5236933d9087169a7e9c345cbcd5e21 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 13 Nov 2025 12:20:12 -0800 Subject: [PATCH 33/37] Tweak to previous. --- Code/testing.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Code/testing.lisp b/Code/testing.lisp index 5afce5e..93daca9 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -4585,7 +4585,7 @@ (defmethod verify ((m ch-map)) (let ((mi (if use-seq-of-symbols? (@ *seq-of-symbols* (random (size *seq-of-symbols*))) (make-my-integer (random 1024)))) - (val (random 128)) + (val (make-my-integer (random 128))) (prev-wbm wbm) (prev-chm chm)) (test (eql (lookup chm mi) (lookup wbm mi))) @@ -4650,7 +4650,7 @@ (defmethod verify ((m ch-map)) (gmap (:result seq) #'cons (:arg fun-map chm :from-end? t))))))) (flet ((filter-mod-8 (x y) (declare (ignore x)) - (if (zerop (mod y 8)) + (if (zerop (mod (my-integer-value y) 8)) (values nil ':no-value) y)) (check-pref (result source label &optional right?) -- GitLab From cc3c5d046cc6abf94bea631a0747d81d9ed1d68a Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 13 Nov 2025 12:38:48 -0800 Subject: [PATCH 34/37] Minor test improvement. --- Code/testing.lisp | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/Code/testing.lisp b/Code/testing.lisp index 93daca9..35ae553 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -4027,6 +4027,10 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (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 ((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))) @@ -4168,6 +4172,10 @@ (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 ((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))) -- GitLab From 7dfa2923902bfe53c75dd405adeb2e9b97e45827 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 13 Nov 2025 19:47:14 -0800 Subject: [PATCH 35/37] The last bug :-) --- Code/champ.lisp | 9 +++++---- Code/order.lisp | 5 +---- Code/post.lisp | 5 +++++ Code/testing.lisp | 10 +++++++--- 4 files changed, 18 insertions(+), 11 deletions(-) diff --git a/Code/champ.lisp b/Code/champ.lisp index 8c5f544..9049973 100644 --- a/Code/champ.lisp +++ b/Code/champ.lisp @@ -744,7 +744,8 @@ (defstruct (ch-set-node (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 depth (not tree1-collision?)))))) + (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)) @@ -2078,12 +2079,12 @@ (defstruct (ch-map-node (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 - depth) + (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 depth (not tree1-collision?)))) + 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 depth (not tree1-collision?)))))))) + 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)) diff --git a/Code/order.lisp b/Code/order.lisp index 4284836..290b9ae 100644 --- a/Code/order.lisp +++ b/Code/order.lisp @@ -405,10 +405,7 @@ (defmethod compare ((a sequence) (b sequence)) ;;; Classes - -;;; Might as well do this the easy way. -(define-equality-slots class - #'class-name) +;;; [Moved to `post.lisp'] ;;; ================================================================================ diff --git a/Code/post.lisp b/Code/post.lisp index a1908f0..a9f8064 100644 --- a/Code/post.lisp +++ b/Code/post.lisp @@ -25,6 +25,11 @@ #+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-packages) diff --git a/Code/testing.lisp b/Code/testing.lisp index 35ae553..8d2986a 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -4464,7 +4464,9 @@ (defmethod verify ((s ch-set)) (let ((wbs (wb-set)) (chs (ch-set)) (use-seq-of-symbols? (= 7 (ldb (byte 3 1) i)))) - (dotimes (j 256) + ;; 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)))) @@ -4589,7 +4591,7 @@ (defmethod verify ((m ch-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) + (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)))) @@ -4690,7 +4692,9 @@ (defmethod verify ((m ch-map)) (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)) -- GitLab From 8424a950093600282d0acdac7336f78ad5250047 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Fri, 14 Nov 2025 18:33:44 -0800 Subject: [PATCH 36/37] Update 'lookup' doc string. --- Code/fset.lisp | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/Code/fset.lisp b/Code/fset.lisp index 0601664..47a6914 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -119,9 +119,9 @@ (defgeneric lookup (collection key) (:documentation - "If `collection' is a map, returns two values: if it contains a mapping -for `key', the corresponding value and true; otherwise, the map's default and -false. + "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 @@ -132,10 +132,10 @@ canonicalization.")) (defgeneric fset2:lookup (collection key) (:documentation - "If `collection' is a map, returns two values: if it contains a mapping -for `key', the corresponding value and true; otherwise, the map's default and -false. 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 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 -- GitLab From f5200d4ce607c0fd9c5a231bf77fe41b9629d3d5 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Fri, 21 Nov 2025 00:11:40 -0800 Subject: [PATCH 37/37] Slogged through test coverage output. Fixed many bugs, mostly minor. --- .gitignore | 1 + Code/defs.lisp | 8 +- Code/fset.lisp | 184 ++++++++-------- Code/macros.lisp | 16 +- Code/reader.lisp | 8 +- Code/relations.lisp | 96 +++------ Code/replay.lisp | 31 +-- Code/swank.lisp | 2 +- Code/testing.lisp | 498 ++++++++++++++++++++++++++++++++++++++------ 9 files changed, 596 insertions(+), 248 deletions(-) diff --git a/.gitignore b/.gitignore index af1167f..fb3c469 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ _darcs Java-Code *.64xfasl .DS_Store +Coverage-Reports diff --git a/Code/defs.lisp b/Code/defs.lisp index 3a7d917..ec0326a 100644 --- a/Code/defs.lisp +++ b/Code/defs.lisp @@ -51,7 +51,8 @@ #: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 @@ -99,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? @@ -180,7 +182,8 @@ #: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 @@ -232,6 +235,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? diff --git a/Code/fset.lisp b/Code/fset.lisp index 47a6914..28433b4 100644 --- a/Code/fset.lisp +++ b/Code/fset.lisp @@ -353,7 +353,7 @@ (define-methods (filter fset2:filter) (fn (s sequence)) (defmethod filter-pairs (fn (collection t)) (filter fn collection)) -(define-generics (image fset2:image) (fn collection &key) +(defgeneric 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, @@ -364,6 +364,24 @@ (define-generics (image fset2:image) (fn collection &key) 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).")) @@ -714,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 @@ -802,7 +820,8 @@ (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.).")) @@ -1699,7 +1718,7 @@ (defstruct (wb-custom-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)) @@ -1719,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))) @@ -1910,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 @@ -2407,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) @@ -2657,6 +2694,11 @@ (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)))) @@ -2766,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)))) @@ -2778,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)))) @@ -3047,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))) @@ -3090,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. @@ -3545,6 +3594,11 @@ (defstruct (wb-map val-compare-fn-name val-compare-fn) default)))))) +(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))) (empty-wb-custom-map (map-default m) (tree-map-org-key-compare-fn-name tmorg) @@ -4174,14 +4228,12 @@ (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-wb-set result))) + (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 'fset2:map)) (l list) &key (key-fn #'car) (value-fn #'cdr)) - (convert 'ch-map l :key-fn key-fn :value-fn value-fn)) (define-convert-methods (wb-map fset2:wb-map) ((l list) &key (key-fn #'car) (value-fn #'cdr) input-sorted? @@ -4192,8 +4244,6 @@ (defmethod convert ((to-type (eql 'map)) (s seq) &key (key-fn #'car) (value-fn #'cdr) input-sorted?) (with-default (wb-map-from-sequence s key-fn value-fn input-sorted?) (seq-default s))) -(defmethod convert ((to-type (eql 'fset2:map)) (s seq) &key (key-fn #'car) (value-fn #'cdr)) - (convert 'ch-map s :key-fn key-fn :value-fn value-fn)) (define-convert-methods (wb-map fset2:wb-map) ((s seq) &key (key-fn #'car) (value-fn #'cdr) input-sorted? @@ -4204,8 +4254,6 @@ (define-convert-methods (wb-map fset2:wb-map) (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 'fset2:map)) (s sequence) &key (key-fn #'car) (value-fn #'cdr)) - (convert 'ch-map s :key-fn key-fn :value-fn value-fn)) (define-convert-methods (wb-map fset2:wb-map) ((s sequence) &key (key-fn #'car) (value-fn #'cdr) input-sorted? @@ -4542,7 +4590,6 @@ (define-methods (lookup fset2:lookup) ((m ch-map) key) 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)))) @@ -4812,7 +4859,7 @@ (define-convert-methods (ch-map fset2:ch-map) (setq tree (ch-map-tree-with tree k v key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) tree))) -(define-convert-methods (ch-map fset2:ch-map) +(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 @@ -4822,7 +4869,7 @@ (define-convert-methods (ch-map fset2:ch-map) key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) tree))) -(define-convert-methods (ch-map fset2:ch-map) +(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 @@ -4832,7 +4879,7 @@ (define-convert-methods (ch-map fset2:ch-map) key-hash-fn key-compare-fn val-hash-fn val-compare-fn))) tree))) -(define-convert-methods (ch-map fset2:ch-map) +(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 @@ -5185,12 +5232,11 @@ (define-convert-methods (fset2:seq fset2:wb-seq) (if pairs? (set-size b) (size b))) default)) -(define-convert-methods (seq wb-seq) ( (m map) &key (pair-fn #'cons)) +(define-convert-methods (seq wb-seq) ((m map) &key (pair-fn #'cons)) (map-to-seq m pair-fn nil)) -(define-convert-methods (fset2:seq fset2:wb-seq) - ((m map) &key (pair-fn #'cons) (default nil default?) no-default?) - (map-to-seq m pair-fn (fset2-default default? default no-default?))) +(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))) @@ -5216,24 +5262,7 @@ (defmethod compare ((s1 wb-seq) (s2 wb-seq)) ':equal)))))) (defun compare-seqs-lexicographically (a b &optional (val-compare-fn #'compare)) - (declare (type function val-compare-fn)) - (if (eq a b) ':equal - (let ((a-size (size a)) - (b-size (size b)) - (default ':equal)) - (or (gmap :or (fn (ea eb) - (let ((comp (funcall val-compare-fn ea eb))) - (ecase comp - ((:less :greater) comp) - (:equal nil) - (:unequal - (setq default ':unequal) - nil)))) - (:arg seq a) - (:arg seq b)) - (cond ((< a-size b-size) ':less) - ((> a-size b-size) ':greater)) - default)))) + (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 @@ -5430,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) @@ -5706,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)))) (define-methods (compose fset2:compose) ((fn function) (m map) &key) (compose-with-key-fn fn m)) (define-methods (compose fset2:compose) ((fn symbol) (m map) &key) - (compose-with-key-fn fn m)) + (compose-with-key-fn (coerce fn 'function) m)) (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 fn s)) - + (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 ce21ff2..becfaba 100644 --- a/Code/macros.lisp +++ b/Code/macros.lisp @@ -1172,20 +1172,22 @@ (define-setf-expander fset2:@ (collection key &environment env) (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." +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 (make-wb-set-compare-fn (or ,vcfn-var 'compare))) + `((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 that `filterp', if supplied, must take two arguments." +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 (make-ch-set-compare-fn (or ,vcfn-var 'compare))) + `((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))))) @@ -1586,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 diff --git a/Code/reader.lisp b/Code/reader.lisp index ef464b6..2274b71 100644 --- a/Code/reader.lisp +++ b/Code/reader.lisp @@ -503,7 +503,8 @@ (fset1? (eq (symbol-package empty-fn) (symbol-package 'map))) ((empty-form (if fset1? `(,empty-fn ,(cadr default?) - . ,(and key-compare-fn-name `(,key-compare-fn-name ,val-compare-fn-name))) + . ,(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)) @@ -695,7 +696,7 @@ (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))) + . ,(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)) @@ -900,7 +901,8 @@ (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 key-compare-fn-name `(,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))) diff --git a/Code/relations.lisp b/Code/relations.lisp index 1c44c7d..ed4716e 100644 --- a/Code/relations.lisp +++ b/Code/relations.lisp @@ -538,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))) @@ -550,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))) @@ -572,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))))))) @@ -607,7 +606,7 @@ (defmethod convert ((to-type (eql 'fset2: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 'no-default)) + (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 @@ -620,8 +619,9 @@ (defmethod convert ((to-type (eql 'fset2:wb-map)) (rel wb-2-relation) &key key-c 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 'no-default)) + (wb-2-relation-to-wb-map rel key-compare-fn-name val-compare-fn-name nil)) +;;; `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)) @@ -639,21 +639,22 @@ (defmethod convert ((to-type (eql 'fset2:wb-map)) (rel wb-2-relation) &key key-c (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." +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) + +(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." - (wb-2-relation-to-map-to-sets rel 'no-default)) +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?))) -;;; This is remarkably difficult to do correctly in the presence of custom compare-fns. -;;; The problem is that the val-compare-fn will expect to compare elements of the range -;;; sets, not the sets themselves. We have to synthesize one that will work. (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 (make-wb-set-compare-fn vcfn-nm)) + ((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. @@ -666,29 +667,6 @@ (defmethod convert ((to-type (eql 'fset2:map-to-sets)) (rel wb-2-relation) &key) map-val-cfn-nm (symbol-function map-val-cfn-nm)) default))) -(defvar *make-wb-set-compare-fn-lock* (make-lock "*make-wb-set-compare-fn-lock*")) - -(defun make-wb-set-compare-fn (elt-compare-fn-name) - (if (eq elt-compare-fn-name 'compare) 'compare - ;; Have to intern it somewhere, and `fset-user:' is very unlikely to be locked. (The reason - ;; we have to intern it comes down to the `compare' method on maps; if compare-fn names are - ;; not `eq', it wants to order them, and uninterned symbols with the same print-name can't be - ;; ordered. Besides, we'd like the compare-fns themselves to be `eq' when possible.) - (let ((nm (intern (let ((*package* (find-package ':cl))) ; force prefix - (format nil "~A-~S" '%wb-set-by elt-compare-fn-name)) - (find-package ':fset-user)))) - ;; I believe the barriers are necessary and sufficient to let us do double-checked locking. - (if (fboundp nm) - (read-memory-barrier) - (with-lock (*make-wb-set-compare-fn-lock*) - (unless (fboundp nm) - (setf (symbol-function nm) - (fn (s1 s2) - (WB-Set-Tree-Compare (wb-set-contents s1) (wb-set-contents s2) - (symbol-function elt-compare-fn-name)))) - (write-memory-barrier)))) - nm))) - (defmethod conflicts ((rel wb-2-relation)) (let ((m0 nil) (key-compare-fn (tree-map-org-key-compare-fn (wb-2-relation-org rel))) @@ -1257,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))) @@ -1269,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))) @@ -1291,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) @@ -1302,7 +1279,6 @@ (defmethod convert ((to-type (eql 'ch-2-relation)) (m ch-map) &key from-type key (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))) @@ -1342,7 +1318,7 @@ (defmethod convert ((to-type (eql 'fset2: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 'no-default)) + (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 @@ -1355,7 +1331,7 @@ (defmethod convert ((to-type (eql 'fset2:ch-map)) (rel ch-2-relation) &key key-c 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 'no-default)) + (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 default) (let ((m nil) @@ -1376,18 +1352,22 @@ (defmethod convert ((to-type (eql 'fset2:ch-map)) (rel ch-2-relation) &key key-c (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." +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) + +(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." - (ch-2-relation-to-map-to-sets rel 'no-default)) +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 (make-wb-set-compare-fn vcfn-nm)) + ((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. @@ -1404,28 +1384,6 @@ (defmethod convert ((to-type (eql 'fset2:map-to-sets)) (rel ch-2-relation) &key) (symbol-function (get map-val-cfn-nm 'hash-function))) default))) -(defvar *make-ch-set-compare-fn-lock* (make-lock "*make-ch-set-compare-fn-lock*")) - -;;; See comments at `make-wb-set-compare-fn'. -(defun make-ch-set-compare-fn (elt-compare-fn-name &optional elt-compare-fn) - (if (eq elt-compare-fn-name 'compare) 'compare - (let ((nm (intern (let ((*package* (find-package ':cl))) - (format nil "~A-~S" '%ch-set-by elt-compare-fn-name)) - (find-package ':fset-user)))) - (unless (fboundp nm) - (with-lock (*make-ch-set-compare-fn-lock*) - (setf (symbol-function nm) - (fn (s1 s2) - (ch-set-tree-compare (ch-set-contents s1) (ch-set-contents s2) - (or elt-compare-fn (symbol-function elt-compare-fn-name))))) - (let ((hashfn-nm (intern (let ((*package* (find-package ':cl))) - (format nil "~A-~S-~A" '%ch-set-by elt-compare-fn-name 'hash)) - (find-package ':fset-user)))) - (setf (get nm 'hash-function) hashfn-nm) - (setf (symbol-function hashfn-nm) - (fn (s) (ch-set-tree-hash-value (ch-set-contents s))))))) - nm))) - (defmethod conflicts ((rel ch-2-relation)) (let ((m0 nil) (org (ch-2-relation-org rel)) diff --git a/Code/replay.lisp b/Code/replay.lisp index 83bd15e..b9fa636 100644 --- a/Code/replay.lisp +++ b/Code/replay.lisp @@ -132,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)) @@ -200,7 +201,8 @@ (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'. @@ -385,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)) @@ -741,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)) @@ -893,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)) @@ -1015,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)) @@ -1065,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)) @@ -1228,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)) diff --git a/Code/swank.lisp b/Code/swank.lisp index dea1c28..f006939 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)) diff --git a/Code/testing.lisp b/Code/testing.lisp index 8d2986a..760a999 100644 --- a/Code/testing.lisp +++ b/Code/testing.lisp @@ -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) @@ -102,6 +110,19 @@ (define-hash-function erapmoc hash-value-negated) (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))) #'<) @@ -315,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) @@ -366,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")) @@ -394,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) @@ -410,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"))) @@ -499,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))) @@ -511,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)) @@ -710,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))) @@ -768,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)))) @@ -789,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)) @@ -847,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." @@ -934,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))) @@ -944,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)))) @@ -971,6 +1057,13 @@ (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)) @@ -1121,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)) @@ -1588,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))) @@ -1728,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))) @@ -2061,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) @@ -2072,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 (: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))))) @@ -2086,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) @@ -2096,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 (: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)) @@ -2127,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) @@ -2141,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)) @@ -2161,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))))) @@ -2225,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)) @@ -2735,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))) @@ -2759,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))) @@ -2898,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))) @@ -2909,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)) @@ -2934,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)) @@ -3085,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))))) @@ -3100,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) @@ -3126,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))) @@ -3335,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))))) @@ -3350,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)) @@ -3396,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)))) @@ -3588,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) @@ -3938,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)))) @@ -4008,6 +4205,11 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (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))) @@ -4027,6 +4229,16 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (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)))) @@ -4040,6 +4252,16 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (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)) @@ -4054,6 +4276,11 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (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)))) + (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))) @@ -4069,6 +4296,11 @@ (defmethod compare ((x My-Integer) (y My-Integer)) ('a 7) ('b 12) ('c 17)) (wb-2-relation ('b 12) ('c 22))) (wb-custom-2-relation 'erapmoc 'erapmoc ('b 12)))) + (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) @@ -4083,11 +4315,20 @@ (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? (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? (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)) @@ -4116,9 +4357,11 @@ (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 '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 'wb-2-relation (map ('a (set 3 5)) ('b (set 2)) ('c (set 4 7))) + (test (equal? (convert '2-relation (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 (handler-case (progn @@ -4127,8 +4370,16 @@ (defmethod compare ((x My-Integer) (y My-Integer)) (error () t))) (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 (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))))) + (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)))) @@ -4172,6 +4423,12 @@ (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)))) @@ -4185,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)) @@ -4199,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))) @@ -4214,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) @@ -4389,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) @@ -4510,6 +4779,10 @@ (defmethod verify ((s ch-set)) (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)))) @@ -4612,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))) @@ -4809,6 +5085,19 @@ (define-tuple-key +k6+) (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)) @@ -4891,9 +5180,34 @@ (define-tuple-key +k6+) (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)) @@ -4911,7 +5225,59 @@ (define-tuple-key +k6+) (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? (@ (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) -- GitLab