vlists: immutable sequences with mostly-O(1) push and pop, O(n) behavior when sharing...

diff --git a/basis/vlists/vlists-tests.factor b/basis/vlists/vlists-tests.factor
new file mode 100644 (file)
index 0000000..3546051
--- /dev/null
+++ b/basis/vlists/vlists-tests.factor
@@ -0,0 +1,41 @@
+USING: vlists kernel persistent.sequences arrays tools.test
+namespaces accessors sequences assocs ;
+IN: vlists.tests
+
+[ { "hi" "there" } ]
+[ VL{ } "hi" swap ppush "there" swap ppush >array ] unit-test
+
+[ VL{ "hi" "there" "foo" } VL{ "hi" "there" "bar" } t ]
+[
+    VL{ } "hi" swap ppush "there" swap ppush "v" set
+    "foo" "v" get ppush
+    "bar" "v" get ppush
+    dup "baz" over ppush [ vector>> ] bi@ eq?
+] unit-test
+
+[ "foo" VL{ "hi" "there" } t ]
+[
+    VL{ "hi" "there" "foo" } dup "v" set
+    [ peek ] [ ppop ] bi
+    dup "v" get [ vector>> ] bi@ eq?
+] unit-test
+
+[ VL{ } 3 over push ] must-fail
+
+[ 4 VL{ "hi" } set-first ] must-fail
+
+[ 5 t ] [
+    "rice" VA{ { "rice" 5 } { "beans" 10 } } at*
+] unit-test
+
+[ 6 t ] [
+    "rice" VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } at*
+] unit-test
+
+[ 3 ] [
+    VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } assoc-size
+] unit-test
+
+[ f f ] [
+    "meat" VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } at*
+] unit-test

diff --git a/basis/vlists/vlists.factor b/basis/vlists/vlists.factor
new file mode 100644 (file)
index 0000000..e0f7e55
--- /dev/null
+++ b/basis/vlists/vlists.factor
@@ -0,0 +1,93 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors sequences sequences.private
+persistent.sequences assocs persistent.assocs kernel math
+vectors parser prettyprint.backend ;
+IN: vlists
+
+TUPLE: vlist
+{ length array-capacity read-only }
+{ vector vector read-only } ;
+
+: <vlist> ( -- vlist ) 0 V{ } clone vlist boa ; inline
+
+M: vlist length length>> ;
+
+M: vlist nth-unsafe vector>> nth-unsafe ;
+
+<PRIVATE
+
+: >vlist< [ length>> ] [ vector>> ] bi ; inline
+
+: unshare ( len vec -- len vec' )
+    clone [ set-length ] 2keep ; inline
+
+PRIVATE>
+
+M: vlist ppush
+    >vlist<
+    2dup length = [ unshare ] unless
+    [ [ 1+ swap ] dip push ] keep vlist boa ;
+
+ERROR: empty-vlist-error ;
+
+M: vlist ppop
+    [ empty-vlist-error ]
+    [ [ length>> 1- ] [ vector>> ] bi vlist boa ] if-empty ;
+
+M: vlist clone
+    [ length>> ] [ vector>> >vector ] bi vlist boa ;
+
+M: vlist equal?
+    over vlist? [ sequence= ] [ 2drop f ] if ;
+
+: >vlist ( seq -- vlist )
+    [ length ] [ >vector ] bi vlist boa ; inline
+
+M: vlist like
+    drop dup vlist? [ >vlist ] unless ;
+
+INSTANCE: vlist immutable-sequence
+
+: VL{ \ } [ >vlist ] parse-literal ; parsing
+
+M: vlist pprint-delims drop \ VL{ \ } ;
+M: vlist >pprint-sequence ;
+M: vlist pprint* pprint-object ;
+
+TUPLE: valist { vlist vlist read-only } ;
+
+: <valist> ( -- valist ) <vlist> valist boa ; inline
+
+M: valist assoc-size vlist>> length 2/ ;
+
+: valist-at ( key i array -- value ? )
+    over 0 >= [
+        3dup nth-unsafe = [
+            [ 1+ ] dip nth-unsafe nip t
+        ] [
+            [ 2 - ] dip valist-at
+        ] if
+    ] [ 3drop f f ] if ; inline recursive
+
+M: valist at*
+    vlist>> >vlist< [ 2 - ] [ underlying>> ] bi* valist-at ;
+
+M: valist new-at
+    vlist>> ppush ppush valist boa ;
+
+M: valist >alist vlist>> ;
+
+: >valist ( assoc -- valist )
+    >alist concat >vlist valist boa ; inline
+
+M: valist assoc-like
+    drop dup valist? [ >valist ] unless ;
+
+INSTANCE: valist assoc
+
+: VA{ \ } [ >valist ] parse-literal ; parsing
+
+M: valist pprint-delims drop \ VA{ \ } ;
+M: valist >pprint-sequence >alist ;
+M: valist pprint* pprint-object ;