multisets: Basic multiset vocabulary based on avl trees and hashes.

There's probably a way to do this much much better, but it's a start.

diff --git a/extra/multisets/authors.txt b/extra/multisets/authors.txt
new file mode 100644 (file)
index 0000000..7c1b2f2
--- /dev/null
+++ b/extra/multisets/authors.txt
@@ -0,0 +1 @@
+Doug Coleman

diff --git a/extra/multisets/multisets-tests.factor b/extra/multisets/multisets-tests.factor
new file mode 100644 (file)
index 0000000..a727228
--- /dev/null
+++ b/extra/multisets/multisets-tests.factor
@@ -0,0 +1,32 @@
+! Copyright (C) 2022 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel multisets prettyprint tools.test ;
+IN: multisets.tests
+
+{ multiset{ } } [
+    <multiset>
+        100 over multiset-emplace
+        100 over multiset-emplace
+        100 over multiset-erase
+] unit-test
+
+{ t } [
+    <multiset>
+        100 over multiset-emplace
+        100 over multiset-emplace
+    multiset{ 100 100 } =
+] unit-test
+
+{ t } [ multiset{ } multiset-empty? ] unit-test
+{ f } [ multiset{ 100 100 } multiset-empty? ] unit-test
+
+{ t } [ multiset{ 100 100 } 100 multiset-in? ] unit-test
+{ f } [ multiset{ 100 100 } 200 multiset-in? ] unit-test
+
+{ 2 } [ multiset{ 100 100 } 100 multiset-count ] unit-test
+{ 0 } [ multiset{ 100 100 } 200 multiset-count ] unit-test
+
+{ { 100 100 } } [ multiset{ 100 100 } multiset-members ] unit-test
+
+
+{ } [ multiset{ 100 100 } [ . ] multiset-each ] unit-test

diff --git a/extra/multisets/multisets.factor b/extra/multisets/multisets.factor
new file mode 100644 (file)
index 0000000..0c06eaf
--- /dev/null
+++ b/extra/multisets/multisets.factor
@@ -0,0 +1,59 @@
+! Copyright (C) 2022 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel math parser prettyprint.custom
+sequences trees.avl ;
+IN: multisets
+
+TUPLE: multiset size avl hash ;
+
+: <multiset> ( -- multiset )
+    multiset new
+        0 >>size
+        <avl> >>avl
+        H{ } clone >>hash ; inline
+
+: multiset-emplace ( obj multiset -- )
+    [ dup 1 + ] change-size
+    [ avl>> set-at ]
+    [ hash>> swapd push-at ] 3bi ; inline
+
+: multiset-erase ( obj multiset -- )
+    [
+        hash>> delete-at* drop
+    ] [
+        nip
+        [ avl>> '[ _ delete-at ] each ]
+        [ [ length ] dip [ swap - ] change-size drop ] 2bi
+    ] 2bi ;
+
+: multiset-clear ( multiset -- )
+    [ hash>> clear-assoc ]
+    [ avl>> f >>root 0 >>count drop ] bi ;
+
+: multiset-empty? ( multiset -- ? ) avl>> assoc-size 0 eq? ; inline
+
+: multiset-in? ( multiset obj -- ? ) swap hash>> key? ; inline
+
+: multiset-count ( multiset obj -- n )
+    swap hash>> at* [ length ] [ drop 0 ] if ; inline
+
+: multiset-members ( multiset -- seq )
+    avl>> >alist values ; inline
+
+: multiset-each ( multiset quot -- )
+    [ multiset-members ] dip each ; inline
+
+: >multiset ( seq -- multiset )
+    <multiset>
+    [ '[ _ multiset-emplace ] each ] keep ;
+
+SYNTAX: multiset{
+    \ } [ >multiset ] parse-literal ;
+
+M: multiset pprint-delims drop \ multiset{ \ } ;
+
+M: multiset >pprint-sequence avl>> >alist values ;
+
+M: multiset pprint-narrow? drop t ;
+
+M: multiset pprint* pprint-object ;