--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs ;
+IN: persistent.assocs
+
+GENERIC: new-at ( value key phash -- phash' )
+
+M: assoc new-at clone [ set-at ] keep ;
+
+GENERIC: pluck-at ( key phash -- phash' )
+
+M: assoc pluck-at clone [ delete-at ] keep ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Persistent associative mapping protocol
--- /dev/null
+collections
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: layouts kernel parser math ;
+IN: persistent.hashtables.config
+
+: radix-bits ( -- n ) << cell 4 = 4 5 ? parsed >> ; foldable
+: radix-mask ( -- n ) radix-bits 2^ 1- ; foldable
+: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1- ; inline
--- /dev/null
+IN: persistent.hashtables.tests
+USING: persistent.hashtables persistent.assocs hashtables assocs
+tools.test kernel namespaces random math.ranges sequences fry ;
+
+[ t ] [ PH{ } assoc-empty? ] unit-test
+
+[ PH{ { "A" "B" } } ] [ PH{ } "B" "A" rot new-at ] unit-test
+
+[ "B" ] [ "A" PH{ { "A" "B" } } at ] unit-test
+
+[ f ] [ "X" PH{ { "A" "B" } } at ] unit-test
+
+TUPLE: hash-0-a ;
+
+M: hash-0-a hashcode* 2drop 0 ;
+
+TUPLE: hash-0-b ;
+
+M: hash-0-b hashcode* 2drop 0 ;
+
+[ ] [
+ PH{ }
+ "a" T{ hash-0-a } rot new-at
+ "b" T{ hash-0-b } rot new-at
+ "ph" set
+] unit-test
+
+[
+ H{
+ { T{ hash-0-a } "a" }
+ { T{ hash-0-b } "b" }
+ }
+] [ "ph" get >hashtable ] unit-test
+
+[
+ H{
+ { T{ hash-0-b } "b" }
+ }
+] [ "ph" get T{ hash-0-a } swap pluck-at >hashtable ] unit-test
+
+[
+ H{
+ { T{ hash-0-a } "a" }
+ }
+] [ "ph" get T{ hash-0-b } swap pluck-at >hashtable ] unit-test
+
+[
+ H{
+ { T{ hash-0-a } "a" }
+ { T{ hash-0-b } "b" }
+ }
+] [ "ph" get "X" swap pluck-at >hashtable ] unit-test
+
+[ ] [
+ PH{ }
+ "B" "A" rot new-at
+ "D" "C" rot new-at
+ "ph" set
+] unit-test
+
+[ H{ { "A" "B" } { "C" "D" } } ] [
+ "ph" get >hashtable
+] unit-test
+
+[ H{ { "C" "D" } } ] [
+ "ph" get "A" swap pluck-at >hashtable
+] unit-test
+
+[ H{ { "A" "B" } { "C" "D" } { "E" "F" } } ] [
+ "ph" get "F" "E" rot new-at >hashtable
+] unit-test
+
+[ H{ { "C" "D" } { "E" "F" } } ] [
+ "ph" get "F" "E" rot new-at "A" swap pluck-at >hashtable
+] unit-test
+
+: random-string ( -- str )
+ 1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
+
+: random-assocs ( -- hash phash )
+ [ random-string ] replicate
+ [ H{ } clone [ '[ swap , set-at ] each-index ] keep ]
+ [ PH{ } clone swap [ spin new-at ] each-index ]
+ bi ;
+
+: ok? ( assoc1 assoc2 -- ? )
+ [ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ;
+
+: test-persistent-hashtables-1 ( n -- )
+ random-assocs ok? ;
+
+[ t ] [ 10 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 20 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 30 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 50 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 100 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 500 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 1000 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 5000 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 10000 test-persistent-hashtables-1 ] unit-test
+[ t ] [ 50000 test-persistent-hashtables-1 ] unit-test
+
+: test-persistent-hashtables-2 ( n -- )
+ random-assocs
+ dup keys [
+ [ nip over delete-at ] [ swap pluck-at nip ] 3bi
+ 2dup ok?
+ ] all? 2nip ;
+
+[ t ] [ 6000 test-persistent-hashtables-2 ] unit-test
--- /dev/null
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: kernel math accessors assocs fry combinators parser
+prettyprint.backend namespaces
+persistent.assocs
+persistent.hashtables.nodes
+persistent.hashtables.nodes.empty
+persistent.hashtables.nodes.leaf
+persistent.hashtables.nodes.full
+persistent.hashtables.nodes.bitmap
+persistent.hashtables.nodes.collision ;
+IN: persistent.hashtables
+
+TUPLE: persistent-hash
+{ root read-only initial: empty-node }
+{ count fixnum read-only } ;
+
+M: persistent-hash assoc-size count>> ;
+
+M: persistent-hash at*
+ [ dup hashcode >fixnum ] [ root>> ] bi* (entry-at)
+ dup [ value>> t ] [ f ] if ;
+
+M: persistent-hash new-at ( value key assoc -- assoc' )
+ [
+ { [ 0 ] [ ] [ dup hashcode >fixnum ] [ root>> ] } spread
+ (new-at) 1 0 ?
+ ] [ count>> ] bi +
+ persistent-hash boa ;
+
+M: persistent-hash pluck-at
+ [ [ dup hashcode >fixnum ] [ root>> ] bi* (pluck-at) ] keep
+ {
+ { [ 2dup root>> eq? ] [ nip ] }
+ { [ over not ] [ 2drop T{ persistent-hash } ] }
+ [ count>> 1- persistent-hash boa ]
+ } cond ;
+
+M: persistent-hash >alist [ root>> >alist% ] { } make ;
+
+: >persistent-hash ( assoc -- phash )
+ T{ persistent-hash } swap [ spin new-at ] assoc-each ;
+
+: PH{ \ } [ >persistent-hash ] parse-literal ; parsing
+
+M: persistent-hash pprint-delims drop \ PH{ \ } ;
+
+M: persistent-hash >pprint-sequence >alist ;
--- /dev/null
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: math math.bit-count arrays kernel accessors locals sequences
+sequences.private sequences.lib
+persistent.sequences
+persistent.hashtables.config
+persistent.hashtables.nodes ;
+IN: persistent.hashtables.nodes.bitmap
+
+: index ( bit bitmap -- n ) [ 1- ] dip bitand bit-count ; inline
+
+M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry )
+ [let* | shift [ bitmap-node shift>> ]
+ bit [ hashcode shift bitpos ]
+ bitmap [ bitmap-node bitmap>> ]
+ nodes [ bitmap-node nodes>> ] |
+ bitmap bit bitand 0 eq? [ f ] [
+ key hashcode
+ bit bitmap index nodes nth-unsafe
+ (entry-at)
+ ] if
+ ] ;
+
+M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-leaf )
+ [let* | shift [ bitmap-node shift>> ]
+ bit [ hashcode shift bitpos ]
+ bitmap [ bitmap-node bitmap>> ]
+ idx [ bit bitmap index ]
+ nodes [ bitmap-node nodes>> ] |
+ bitmap bit bitand 0 eq? [
+ [let | new-leaf [ value key hashcode <leaf-node> ] |
+ bitmap bit bitor
+ new-leaf idx nodes insert-nth
+ shift
+ <bitmap-node>
+ new-leaf
+ ]
+ ] [
+ [let | n [ idx nodes nth ] |
+ shift radix-bits + value key hashcode n (new-at)
+ [let | new-leaf [ ] n' [ ] |
+ n n' eq? [
+ bitmap-node
+ ] [
+ bitmap
+ n' idx nodes new-nth
+ shift
+ <bitmap-node>
+ ] if
+ new-leaf
+ ]
+ ]
+ ] if
+ ] ;
+
+M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' )
+ [let | bit [ hashcode bitmap-node shift>> bitpos ]
+ bitmap [ bitmap-node bitmap>> ]
+ nodes [ bitmap-node nodes>> ]
+ shift [ bitmap-node shift>> ] |
+ bit bitmap bitand 0 eq? [ bitmap-node ] [
+ [let* | idx [ bit bitmap index ]
+ n [ idx nodes nth-unsafe ]
+ n' [ key hashcode n (pluck-at) ] |
+ n n' eq? [
+ bitmap-node
+ ] [
+ n' [
+ bitmap
+ n' idx nodes new-nth
+ shift
+ <bitmap-node>
+ ] [
+ bitmap bit eq? [ f ] [
+ bitmap bit bitnot bitand
+ idx nodes remove-nth
+ shift
+ <bitmap-node>
+ ] if
+ ] if
+ ] if
+ ]
+ ] if
+ ] ;
+
+M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ;
--- /dev/null
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: kernel accessors math arrays fry sequences sequences.lib
+locals persistent.sequences
+persistent.hashtables.config
+persistent.hashtables.nodes
+persistent.hashtables.nodes.leaf ;
+IN: persistent.hashtables.nodes.collision
+
+: find-index ( key hashcode collision-node -- n leaf-node )
+ leaves>> -rot '[ , , _ matching-key? ] find ; inline
+
+M:: collision-node (entry-at) ( key hashcode collision-node -- leaf-node )
+ key hashcode collision-node find-index nip ;
+
+M:: collision-node (pluck-at) ( key hashcode collision-node -- leaf-node )
+ hashcode collision-node hashcode>> eq? [
+ [let | idx [ key hashcode collision-node find-index drop ] |
+ idx [
+ idx collision-node leaves>> smash [
+ collision-node hashcode>>
+ <collision-node>
+ ] when
+ ] [ collision-node ] if
+ ]
+ ] [ collision-node ] if ;
+
+M:: collision-node (new-at) ( shift value key hashcode collision-node -- node' added-leaf )
+ hashcode collision-node hashcode>> eq? [
+ key hashcode collision-node find-index
+ [let | leaf-node [ ] idx [ ] |
+ idx [
+ value leaf-node value>> = [
+ collision-node f
+ ] [
+ hashcode
+ value key hashcode <leaf-node>
+ idx
+ collision-node leaves>>
+ new-nth
+ <collision-node>
+ f
+ ] if
+ ] [
+ [let | new-leaf-node [ value key hashcode <leaf-node> ] |
+ hashcode
+ collision-node leaves>>
+ new-leaf-node
+ suffix
+ <collision-node>
+ new-leaf-node
+ ]
+ ] if
+ ]
+ ] [
+ shift collision-node value key hashcode make-bitmap-node
+ ] if ;
+
+M: collision-node >alist% leaves>> >alist-each% ;
--- /dev/null
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: accessors kernel locals persistent.hashtables.nodes ;
+IN: persistent.hashtables.nodes.empty
+
+M: empty-node (entry-at) 3drop f ;
+
+M: empty-node (pluck-at) 2nip ;
+
+M:: empty-node (new-at) ( shift value key hashcode node -- node' added-leaf )
+ value key hashcode <leaf-node> dup ;
+
+M: empty-node >alist% drop ;
+
+M: empty-node hashcode>> drop 0 ;
--- /dev/null
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: math accessors kernel arrays sequences sequences.private
+locals sequences.lib
+persistent.sequences
+persistent.hashtables.config
+persistent.hashtables.nodes ;
+IN: persistent.hashtables.nodes.full
+
+M:: full-node (new-at) ( shift value key hashcode full-node -- node' added-leaf )
+ [let* | nodes [ full-node nodes>> ]
+ idx [ hashcode full-node shift>> mask ]
+ n [ idx nodes nth-unsafe ] |
+ shift radix-bits + value key hashcode n (new-at)
+ [let | new-leaf [ ] n' [ ] |
+ n n' eq? [
+ full-node
+ ] [
+ n' idx nodes new-nth shift <full-node>
+ ] if
+ new-leaf
+ ]
+ ] ;
+
+M:: full-node (pluck-at) ( key hashcode full-node -- node' )
+ [let* | idx [ hashcode full-node shift>> mask ]
+ n [ idx full-node nodes>> nth ]
+ n' [ key hashcode n (pluck-at) ] |
+ n n' eq? [
+ full-node
+ ] [
+ n' [
+ n' idx full-node nodes>> new-nth
+ full-node shift>>
+ <full-node>
+ ] [
+ hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand
+ idx full-node nodes>> remove-nth
+ full-node shift>>
+ <bitmap-node>
+ ] if
+ ] if
+ ] ;
+
+M:: full-node (entry-at) ( key hashcode full-node -- node' )
+ key hashcode
+ hashcode full-node shift>> mask
+ full-node nodes>> nth-unsafe
+ (entry-at) ;
+
+M: full-node >alist% nodes>> >alist-each% ;
--- /dev/null
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: kernel accessors locals math arrays namespaces
+persistent.hashtables.config
+persistent.hashtables.nodes ;
+IN: persistent.hashtables.nodes.leaf
+
+: matching-key? ( key hashcode leaf-node -- ? )
+ tuck hashcode>> eq? [ key>> = ] [ 2drop f ] if ; inline
+
+M: leaf-node (entry-at) [ matching-key? ] keep and ;
+
+M: leaf-node (pluck-at) [ matching-key? not ] keep and ;
+
+M:: leaf-node (new-at) ( shift value key hashcode leaf-node -- node' added-leaf )
+ hashcode leaf-node hashcode>> eq? [
+ key leaf-node key>> = [
+ value leaf-node value>> =
+ [ leaf-node f ] [ value key hashcode <leaf-node> f ] if
+ ] [
+ [let | new-leaf [ value key hashcode <leaf-node> ] |
+ hashcode leaf-node new-leaf 2array <collision-node>
+ new-leaf
+ ]
+ ] if
+ ] [ shift leaf-node value key hashcode make-bitmap-node ] if ;
+
+M: leaf-node >alist% [ key>> ] [ value>> ] bi 2array , ;
--- /dev/null
+! Based on Clojure's PersistentHashMap by Rich Hickey.
+
+USING: math arrays kernel sequences sequences.lib
+accessors locals persistent.hashtables.config ;
+IN: persistent.hashtables.nodes
+
+SINGLETON: empty-node
+
+TUPLE: leaf-node
+{ value read-only }
+{ key read-only }
+{ hashcode fixnum read-only } ;
+
+C: <leaf-node> leaf-node
+
+TUPLE: collision-node
+{ hashcode fixnum read-only }
+{ leaves array read-only } ;
+
+C: <collision-node> collision-node
+
+TUPLE: full-node
+{ nodes array read-only }
+{ shift fixnum read-only }
+{ hashcode fixnum read-only } ;
+
+: <full-node> ( nodes shift -- node )
+ over first hashcode>> full-node boa ;
+
+TUPLE: bitmap-node
+{ bitmap fixnum read-only }
+{ nodes array read-only }
+{ shift fixnum read-only }
+{ hashcode fixnum read-only } ;
+
+: <bitmap-node> ( bitmap nodes shift -- node )
+ pick full-bitmap-mask =
+ [ <full-node> nip ]
+ [ over first hashcode>> bitmap-node boa ] if ;
+
+GENERIC: (entry-at) ( key hashcode node -- entry )
+
+GENERIC: (new-at) ( shift value key hashcode node -- node' added-leaf )
+
+GENERIC: (pluck-at) ( key hashcode node -- node' )
+
+GENERIC: >alist% ( node -- )
+
+: >alist-each% ( nodes -- ) [ >alist% ] each ;
+
+: mask ( hash shift -- n ) neg shift radix-mask bitand ; inline
+
+: bitpos ( hash shift -- n ) mask 2^ ; inline
+
+: smash ( idx seq -- seq/elt ? )
+ dup length 2 = [ [ 1 = ] dip first2 ? f ] [ remove-nth t ] if ; inline
+
+:: make-bitmap-node ( shift branch value key hashcode -- node' added-leaf )
+ shift value key hashcode
+ branch hashcode>> shift bitpos
+ branch 1array
+ shift
+ <bitmap-node>
+ (new-at) ; inline
--- /dev/null
+Persistent hashtables with O(1) insertion, removal and lookup
--- /dev/null
+collections
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+USING: help.syntax help.markup kernel arrays assocs ;
+IN: persistent.heaps
+
+HELP: <persistent-heap>
+{ $values { "heap" "a persistent heap" } }
+{ $description "Creates a new persistent heap" } ;
+
+HELP: <singleton-heap>
+{ $values { "value" object } { "prio" "a priority" } { "heap" "a persistent heap" } }
+{ $description "Creates a new persistent heap consisting of one object with the given priority." } ;
+
+HELP: pheap-empty?
+{ $values { "heap" "a persistent heap" } { "?" "a boolean" } }
+{ $description "Returns true if this is an empty persistent heap." } ;
+
+HELP: pheap-peek
+{ $values { "heap" "a persistent heap" } { "value" "an object in the heap" } { "prio" "the minimum priority" } }
+{ $description "Gets the object in the heap with minumum priority." } ;
+
+HELP: pheap-push
+{ $values { "heap" "a persistent heap" } { "value" object } { "prio" "a priority" } { "newheap" "a new persistent heap" } }
+{ $description "Creates a new persistent heap also containing the given object of the given priority." } ;
+
+HELP: pheap-pop*
+{ $values { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } }
+{ $description "Creates a new persistent heap with the minimum element removed." } ;
+
+HELP: pheap-pop
+{ $values { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } { "value" object } { "prio" "a priority" } }
+{ $description "Creates a new persistent heap with the minimum element removed, returning that element and its priority." } ;
+
+HELP: assoc>pheap
+{ $values { "assoc" assoc } { "heap" "a persistent heap" } }
+{ $description "Creates a new persistent heap from an associative mapping whose keys are the entries in the heap and whose values are the associated priorities." } ;
+
+HELP: pheap>alist
+{ $values { "heap" "a persistent heap" } { "alist" "an association list" } }
+{ $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ;
+
+HELP: pheap>values
+{ $values { "heap" "a persistent heap" } { "values" array } }
+{ $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ;
+
+ARTICLE: "persistent-heaps" "Persistent heaps"
+"This vocabulary implements persistent minheaps, aka priority queues. They are purely functional and support efficient O(log n) operations of pushing and popping, with O(1) time access to the minimum element. To create heaps, use the following words:"
+{ $subsection <persistent-heap> }
+{ $subsection <singleton-heap> }
+"To manipulate them:"
+{ $subsection pheap-peek }
+{ $subsection pheap-push }
+{ $subsection pheap-pop }
+{ $subsection pheap-pop* }
+{ $subsection pheap-empty? }
+{ $subsection assoc>pheap }
+{ $subsection pheap>alist }
+{ $subsection pheap>values } ;
+
+ABOUT: "persistent-heaps"
--- /dev/null
+USING: persistent.heaps tools.test ;
+IN: persistent.heaps.tests
+
+: test-input
+ { { "hello" 3 } { "goodbye" 2 } { "whatever" 5 }
+ { "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } } ;
+
+[
+ { { "baz" -7 } { "bar" -1 } { "bing" 0 } { "foo" 1 }
+ { "goodbye" 2 } { "hello" 3 } { "whatever" 5 } }
+] [ test-input assoc>pheap pheap>alist ] unit-test
--- /dev/null
+USING: kernel accessors multi-methods locals combinators math arrays
+assocs namespaces sequences ;
+IN: persistent.heaps
+! These are minheaps
+
+<PRIVATE
+TUPLE: branch value prio left right ;
+TUPLE: empty-heap ;
+
+PREDICATE: singleton-heap < branch
+ [ left>> ] [ right>> ] bi [ empty-heap? ] both? ;
+
+C: <branch> branch
+: >branch< ( branch -- value prio left right )
+ { [ value>> ] [ prio>> ] [ left>> ] [ right>> ] } cleave ;
+PRIVATE>
+
+: <persistent-heap> ( -- heap ) T{ empty-heap } ;
+
+: <singleton-heap> ( value prio -- heap )
+ <persistent-heap> <persistent-heap> <branch> ;
+
+: pheap-empty? ( heap -- ? ) empty-heap? ;
+
+: empty-pheap ( -- * )
+ "Attempt to delete from an empty heap" throw ;
+
+<PRIVATE
+: remove-left ( heap -- value prio newheap )
+ dup [ left>> ] [ right>> ] bi [ pheap-empty? ] both?
+ [ [ value>> ] [ prio>> ] bi <persistent-heap> ]
+ [ >branch< swap remove-left -rot [ <branch> ] 2dip rot ] if ;
+
+: both-with? ( obj a b quot -- ? )
+ swap >r with r> swap both? ; inline
+
+GENERIC: sift-down ( value prio left right -- heap )
+
+METHOD: sift-down { empty-heap empty-heap } <branch> ;
+
+METHOD: sift-down { singleton-heap empty-heap }
+ 3dup drop prio>> <= [ <branch> ] [
+ drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip
+ <singleton-heap> <persistent-heap> <branch>
+ ] if ;
+
+:: reroot-left ( value prio left right -- heap )
+ left value>> left prio>>
+ value prio left left>> left right>> sift-down
+ right <branch> ;
+
+:: reroot-right ( value prio left right -- heap )
+ right value>> right prio>> left
+ value prio right left>> right right>> sift-down
+ <branch> ;
+
+METHOD: sift-down { branch branch }
+ 3dup [ prio>> <= ] both-with? [ <branch> ] [
+ 2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if
+ ] if ;
+PRIVATE>
+
+GENERIC: pheap-peek ( heap -- value prio )
+M: empty-heap pheap-peek empty-pheap ;
+M: branch pheap-peek [ value>> ] [ prio>> ] bi ;
+
+GENERIC: pheap-push ( value prio heap -- newheap )
+
+M: empty-heap pheap-push
+ drop <singleton-heap> ;
+
+<PRIVATE
+: push-top ( value prio heap -- newheap )
+ [ [ value>> ] [ prio>> ] [ right>> ] tri pheap-push ]
+ [ left>> ] bi <branch> ;
+
+: push-in ( value prio heap -- newheap )
+ [ 2nip [ value>> ] [ prio>> ] bi ]
+ [ right>> pheap-push ]
+ [ 2nip left>> ] 3tri <branch> ;
+PRIVATE>
+
+M: branch pheap-push
+ 2dup prio>> <= [ push-top ] [ push-in ] if ;
+
+: pheap-pop* ( heap -- newheap )
+ dup pheap-empty? [ empty-pheap ] [
+ dup left>> pheap-empty?
+ [ drop <persistent-heap> ]
+ [ [ left>> remove-left ] keep right>> swap sift-down ] if
+ ] if ;
+
+: pheap-pop ( heap -- newheap value prio )
+ [ pheap-pop* ] [ pheap-peek ] bi ;
+
+: assoc>pheap ( assoc -- heap ) ! Assoc is value => prio
+ <persistent-heap> swap [ rot pheap-push ] assoc-each ;
+
+: pheap>alist ( heap -- alist )
+ [ dup pheap-empty? not ] [ pheap-pop 2array ] [ ] produce nip ;
+
+: pheap>values ( heap -- seq ) pheap>alist keys ;
--- /dev/null
+Datastructure for functional peristent heaps, from ML for the Working Programmer
--- /dev/null
+collections
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: persistent.sequences
+USING: help.markup help.syntax math sequences kernel ;
+
+HELP: new-nth
+{ $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." }
+{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: ppush
+{ $values { "val" object } { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." }
+{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: ppop
+{ $values { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." }
+{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel ;
+IN: persistent.sequences
+
+GENERIC: ppush ( val seq -- seq' )
+
+M: sequence ppush swap suffix ;
+
+GENERIC: ppop ( seq -- seq' )
+
+M: sequence ppop 1 head* ;
+
+GENERIC: new-nth ( val i seq -- seq' )
+
+M: sequence new-nth clone [ set-nth ] keep ;
--- /dev/null
+Persistent sequence protocol
--- /dev/null
+collections
--- /dev/null
+Slava Pestov
--- /dev/null
+Immutable vectors with O(log_32 n) random access, push, and pop
--- /dev/null
+collections
--- /dev/null
+USING: help.markup help.syntax kernel math sequences ;
+IN: persistent-vectors
+
+HELP: PV{
+{ $syntax "elements... }" }
+{ $description "Parses a literal " { $link persistent-vector } "." } ;
+
+HELP: >persistent-vector
+{ $values { "seq" sequence } { "pvec" persistent-vector } }
+{ $description "Creates a " { $link persistent-vector } " with the same elements as " { $snippet "seq" } "." } ;
+
+HELP: persistent-vector
+{ $class-description "The class of persistent vectors." } ;
+
+ARTICLE: "persistent-vectors" "Persistent vectors"
+"A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time."
+$nl
+"The class of persistent vectors:"
+{ $subsection persistent-vector }
+"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")."
+$nl
+"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:"
+{ $subsection new-nth }
+{ $subsection ppush }
+{ $subsection ppop }
+"Converting a sequence into a persistent vector:"
+{ $subsection >persistent-vector }
+"Persistent vectors have a literal syntax:"
+{ $subsection POSTPONE: PV{ }
+"The empty persistent vector, written " { $snippet "PV{ }" } ", is used for building up all other persistent vectors."
+$nl
+"This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ;
+
+ABOUT: "persistent-vectors"
--- /dev/null
+IN: persistent-vectors.tests
+USING: accessors tools.test persistent.vectors
+persistent.sequences sequences kernel arrays random namespaces
+vectors math math.order ;
+
+\ new-nth must-infer
+\ ppush must-infer
+\ ppop must-infer
+
+[ 0 ] [ PV{ } length ] unit-test
+
+[ 1 ] [ 3 PV{ } ppush length ] unit-test
+
+[ 3 ] [ 3 PV{ } ppush first ] unit-test
+
+[ PV{ 3 1 3 3 7 } ] [
+ PV{ } { 3 1 3 3 7 } [ swap ppush ] each
+] unit-test
+
+[ { 3 1 3 3 7 } ] [
+ PV{ } { 3 1 3 3 7 } [ swap ppush ] each >array
+] unit-test
+
+{ 100 1060 2000 10000 100000 1000000 } [
+ [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test
+] each
+
+[ ] [ 10000 [ 16 random-bits ] PV{ } replicate-as "1" set ] unit-test
+[ ] [ "1" get >vector "2" set ] unit-test
+
+[ t ] [
+ 3000 [
+ drop
+ 16 random-bits 10000 random
+ [ "1" [ new-nth ] change ]
+ [ "2" [ new-nth ] change ] 2bi
+ "1" get "2" get sequence=
+ ] all?
+] unit-test
+
+[ PV{ } ppop ] [ empty-error? ] must-fail-with
+
+[ t ] [ PV{ 3 } ppop empty? ] unit-test
+
+[ PV{ 3 7 } ] [ PV{ 3 7 6 } ppop ] unit-test
+
+[ PV{ 3 7 6 5 } ] [ 5 PV{ 3 7 6 } ppush ] unit-test
+
+[ ] [ PV{ } "1" set ] unit-test
+[ ] [ V{ } clone "2" set ] unit-test
+
+: push/pop-test ( vec -- vec' ) 3 swap ppush 3 swap ppush ppop ;
+
+[ ] [ PV{ } 10000 [ push/pop-test ] times drop ] unit-test
+
+[ PV{ } ] [
+ PV{ }
+ 10000 [ 1 swap ppush ] times
+ 10000 [ ppop ] times
+] unit-test
+
+[ t ] [
+ 10000 >persistent-vector 752 [ ppop ] times dup length sequence=
+] unit-test
+
+[ t ] [
+ 100 [
+ drop
+ 100 random [
+ 16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi
+ ] times
+ 100 random "1" get length min [
+ "1" [ ppop ] change
+ "2" get pop*
+ ] times
+ "1" get "2" get sequence=
+ ] all?
+] unit-test
--- /dev/null
+! Based on Clojure's PersistentVector by Rich Hickey.
+
+USING: math accessors kernel sequences.private sequences arrays
+combinators combinators.short-circuit parser prettyprint.backend
+persistent.sequences ;
+IN: persistent.vectors
+
+<PRIVATE
+
+TUPLE: node { children array } { level fixnum } ;
+
+PRIVATE>
+
+ERROR: empty-error pvec ;
+
+TUPLE: persistent-vector
+{ count fixnum }
+{ root node initial: T{ node f { } 1 } }
+{ tail node initial: T{ node f { } 0 } } ;
+
+M: persistent-vector length count>> ;
+
+: node-size 32 ; inline
+
+: node-mask node-size mod ; inline
+
+: node-shift -5 * shift ; inline
+
+: node-nth ( i node -- obj )
+ [ node-mask ] [ children>> ] bi* nth ;
+
+: body-nth ( i node -- i node' )
+ dup level>> [
+ dupd [ level>> node-shift ] keep node-nth
+ ] times ;
+
+: tail-offset ( pvec -- n )
+ [ count>> ] [ tail>> children>> length ] bi - ;
+
+M: persistent-vector nth-unsafe
+ 2dup tail-offset >=
+ [ tail>> ] [ root>> body-nth ] if
+ node-nth ;
+
+: node-add ( val node -- node' )
+ clone [ ppush ] change-children ;
+
+: ppush-tail ( val pvec -- pvec' )
+ [ node-add ] change-tail ;
+
+: full? ( node -- ? )
+ children>> length node-size = ;
+
+: 1node ( val level -- node )
+ [ 1array ] dip node boa ;
+
+: 2node ( first second -- node )
+ [ 2array ] [ drop level>> 1+ ] 2bi node boa ;
+
+: new-child ( new-child node -- node' expansion/f )
+ dup full? [ tuck level>> 1node ] [ node-add f ] if ;
+
+: new-last ( val seq -- seq' )
+ [ length 1- ] keep new-nth ;
+
+: node-set-last ( child node -- node' )
+ clone [ new-last ] change-children ;
+
+: (ppush-new-tail) ( tail node -- node' expansion/f )
+ dup level>> 1 = [
+ new-child
+ ] [
+ tuck children>> peek (ppush-new-tail)
+ [ swap new-child ] [ swap node-set-last f ] ?if
+ ] if ;
+
+: do-expansion ( pvec root expansion/f -- pvec )
+ [ 2node ] when* >>root ;
+
+: ppush-new-tail ( val pvec -- pvec' )
+ [ ] [ tail>> ] [ root>> ] tri
+ (ppush-new-tail) do-expansion
+ swap 0 1node >>tail ;
+
+M: persistent-vector ppush ( val pvec -- pvec' )
+ clone
+ dup tail>> full?
+ [ ppush-new-tail ] [ ppush-tail ] if
+ [ 1+ ] change-count ;
+
+: node-set-nth ( val i node -- node' )
+ clone [ new-nth ] change-children ;
+
+: node-change-nth ( i node quot -- node' )
+ [ clone ] dip [
+ [ clone ] dip [ change-nth ] 2keep drop
+ ] curry change-children ; inline
+
+: (new-nth) ( val i node -- node' )
+ dup level>> 0 = [
+ [ node-mask ] dip node-set-nth
+ ] [
+ [ dupd level>> node-shift node-mask ] keep
+ [ (new-nth) ] node-change-nth
+ ] if ;
+
+M: persistent-vector new-nth ( obj i pvec -- pvec' )
+ 2dup count>> = [ nip ppush ] [
+ clone
+ 2dup tail-offset >= [
+ [ node-mask ] dip
+ [ node-set-nth ] change-tail
+ ] [
+ [ (new-nth) ] change-root
+ ] if
+ ] if ;
+
+! The pop code is really convoluted. I don't understand Rich Hickey's
+! original code. It uses a 'Box' out parameter which is passed around
+! inside a recursive function, and gets mutated along the way to boot.
+! Super-confusing.
+: ppop-tail ( pvec -- pvec' )
+ [ clone [ ppop ] change-children ] change-tail ;
+
+: (ppop-contraction) ( node -- node' tail' )
+ clone [ unclip-last swap ] change-children swap ;
+
+: ppop-contraction ( node -- node' tail' )
+ dup children>> length 1 =
+ [ children>> peek f swap ]
+ [ (ppop-contraction) ]
+ if ;
+
+: (ppop-new-tail) ( root -- root' tail' )
+ dup level>> 1 > [
+ dup children>> peek (ppop-new-tail) [
+ dup
+ [ swap node-set-last ]
+ [ drop ppop-contraction drop ]
+ if
+ ] dip
+ ] [
+ ppop-contraction
+ ] if ;
+
+: trivial? ( node -- ? )
+ { [ level>> 1 > ] [ children>> length 1 = ] } 1&& ;
+
+: ppop-new-tail ( pvec -- pvec' )
+ dup root>> (ppop-new-tail) [
+ {
+ { [ dup not ] [ drop T{ node f { } 1 } ] }
+ { [ dup trivial? ] [ children>> first ] }
+ [ ]
+ } cond
+ ] dip [ >>root ] [ >>tail ] bi* ;
+
+PRIVATE>
+
+M: persistent-vector ppop ( pvec -- pvec' )
+ dup count>> {
+ { 0 [ empty-error ] }
+ { 1 [ drop T{ persistent-vector } ] }
+ [
+ [
+ clone
+ dup tail>> children>> length 1 >
+ [ ppop-tail ] [ ppop-new-tail ] if
+ ] dip 1- >>count
+ ]
+ } case ;
+
+M: persistent-vector like
+ drop T{ persistent-vector } [ swap ppush ] reduce ;
+
+M: persistent-vector equal?
+ over persistent-vector? [ sequence= ] [ 2drop f ] if ;
+
+: >persistent-vector ( seq -- pvec )
+ T{ persistent-vector } like ;
+
+: PV{ \ } [ >persistent-vector ] parse-literal ; parsing
+
+M: persistent-vector pprint-delims drop \ PV{ \ } ;
+
+M: persistent-vector >pprint-sequence ;
+
+INSTANCE: persistent-vector immutable-sequence
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs ;
-IN: persistent.assocs
-
-GENERIC: new-at ( value key phash -- phash' )
-
-M: assoc new-at clone [ set-at ] keep ;
-
-GENERIC: pluck-at ( key phash -- phash' )
-
-M: assoc pluck-at clone [ delete-at ] keep ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Persistent associative mapping protocol
+++ /dev/null
-collections
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: layouts kernel parser math ;
-IN: persistent.hashtables.config
-
-: radix-bits ( -- n ) << cell 4 = 4 5 ? parsed >> ; foldable
-: radix-mask ( -- n ) radix-bits 2^ 1- ; foldable
-: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1- ; inline
+++ /dev/null
-IN: persistent.hashtables.tests
-USING: persistent.hashtables persistent.assocs hashtables assocs
-tools.test kernel namespaces random math.ranges sequences fry ;
-
-[ t ] [ PH{ } assoc-empty? ] unit-test
-
-[ PH{ { "A" "B" } } ] [ PH{ } "B" "A" rot new-at ] unit-test
-
-[ "B" ] [ "A" PH{ { "A" "B" } } at ] unit-test
-
-[ f ] [ "X" PH{ { "A" "B" } } at ] unit-test
-
-TUPLE: hash-0-a ;
-
-M: hash-0-a hashcode* 2drop 0 ;
-
-TUPLE: hash-0-b ;
-
-M: hash-0-b hashcode* 2drop 0 ;
-
-[ ] [
- PH{ }
- "a" T{ hash-0-a } rot new-at
- "b" T{ hash-0-b } rot new-at
- "ph" set
-] unit-test
-
-[
- H{
- { T{ hash-0-a } "a" }
- { T{ hash-0-b } "b" }
- }
-] [ "ph" get >hashtable ] unit-test
-
-[
- H{
- { T{ hash-0-b } "b" }
- }
-] [ "ph" get T{ hash-0-a } swap pluck-at >hashtable ] unit-test
-
-[
- H{
- { T{ hash-0-a } "a" }
- }
-] [ "ph" get T{ hash-0-b } swap pluck-at >hashtable ] unit-test
-
-[
- H{
- { T{ hash-0-a } "a" }
- { T{ hash-0-b } "b" }
- }
-] [ "ph" get "X" swap pluck-at >hashtable ] unit-test
-
-[ ] [
- PH{ }
- "B" "A" rot new-at
- "D" "C" rot new-at
- "ph" set
-] unit-test
-
-[ H{ { "A" "B" } { "C" "D" } } ] [
- "ph" get >hashtable
-] unit-test
-
-[ H{ { "C" "D" } } ] [
- "ph" get "A" swap pluck-at >hashtable
-] unit-test
-
-[ H{ { "A" "B" } { "C" "D" } { "E" "F" } } ] [
- "ph" get "F" "E" rot new-at >hashtable
-] unit-test
-
-[ H{ { "C" "D" } { "E" "F" } } ] [
- "ph" get "F" "E" rot new-at "A" swap pluck-at >hashtable
-] unit-test
-
-: random-string ( -- str )
- 1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
-
-: random-assocs ( -- hash phash )
- [ random-string ] replicate
- [ H{ } clone [ '[ swap , set-at ] each-index ] keep ]
- [ PH{ } clone swap [ spin new-at ] each-index ]
- bi ;
-
-: ok? ( assoc1 assoc2 -- ? )
- [ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ;
-
-: test-persistent-hashtables-1 ( n -- )
- random-assocs ok? ;
-
-[ t ] [ 10 test-persistent-hashtables-1 ] unit-test
-[ t ] [ 20 test-persistent-hashtables-1 ] unit-test
-[ t ] [ 30 test-persistent-hashtables-1 ] unit-test
-[ t ] [ 50 test-persistent-hashtables-1 ] unit-test
-[ t ] [ 100 test-persistent-hashtables-1 ] unit-test
-[ t ] [ 500 test-persistent-hashtables-1 ] unit-test
-[ t ] [ 1000 test-persistent-hashtables-1 ] unit-test
-[ t ] [ 5000 test-persistent-hashtables-1 ] unit-test
-[ t ] [ 10000 test-persistent-hashtables-1 ] unit-test
-[ t ] [ 50000 test-persistent-hashtables-1 ] unit-test
-
-: test-persistent-hashtables-2 ( n -- )
- random-assocs
- dup keys [
- [ nip over delete-at ] [ swap pluck-at nip ] 3bi
- 2dup ok?
- ] all? 2nip ;
-
-[ t ] [ 6000 test-persistent-hashtables-2 ] unit-test
+++ /dev/null
-! Based on Clojure's PersistentHashMap by Rich Hickey.
-
-USING: kernel math accessors assocs fry combinators parser
-prettyprint.backend namespaces
-persistent.assocs
-persistent.hashtables.nodes
-persistent.hashtables.nodes.empty
-persistent.hashtables.nodes.leaf
-persistent.hashtables.nodes.full
-persistent.hashtables.nodes.bitmap
-persistent.hashtables.nodes.collision ;
-IN: persistent.hashtables
-
-TUPLE: persistent-hash
-{ root read-only initial: empty-node }
-{ count fixnum read-only } ;
-
-M: persistent-hash assoc-size count>> ;
-
-M: persistent-hash at*
- [ dup hashcode >fixnum ] [ root>> ] bi* (entry-at)
- dup [ value>> t ] [ f ] if ;
-
-M: persistent-hash new-at ( value key assoc -- assoc' )
- [
- { [ 0 ] [ ] [ dup hashcode >fixnum ] [ root>> ] } spread
- (new-at) 1 0 ?
- ] [ count>> ] bi +
- persistent-hash boa ;
-
-M: persistent-hash pluck-at
- [ [ dup hashcode >fixnum ] [ root>> ] bi* (pluck-at) ] keep
- {
- { [ 2dup root>> eq? ] [ nip ] }
- { [ over not ] [ 2drop T{ persistent-hash } ] }
- [ count>> 1- persistent-hash boa ]
- } cond ;
-
-M: persistent-hash >alist [ root>> >alist% ] { } make ;
-
-: >persistent-hash ( assoc -- phash )
- T{ persistent-hash } swap [ spin new-at ] assoc-each ;
-
-: PH{ \ } [ >persistent-hash ] parse-literal ; parsing
-
-M: persistent-hash pprint-delims drop \ PH{ \ } ;
-
-M: persistent-hash >pprint-sequence >alist ;
+++ /dev/null
-! Based on Clojure's PersistentHashMap by Rich Hickey.
-
-USING: math math.bit-count arrays kernel accessors locals sequences
-sequences.private sequences.lib
-persistent.sequences
-persistent.hashtables.config
-persistent.hashtables.nodes ;
-IN: persistent.hashtables.nodes.bitmap
-
-: index ( bit bitmap -- n ) [ 1- ] dip bitand bit-count ; inline
-
-M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry )
- [let* | shift [ bitmap-node shift>> ]
- bit [ hashcode shift bitpos ]
- bitmap [ bitmap-node bitmap>> ]
- nodes [ bitmap-node nodes>> ] |
- bitmap bit bitand 0 eq? [ f ] [
- key hashcode
- bit bitmap index nodes nth-unsafe
- (entry-at)
- ] if
- ] ;
-
-M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-leaf )
- [let* | shift [ bitmap-node shift>> ]
- bit [ hashcode shift bitpos ]
- bitmap [ bitmap-node bitmap>> ]
- idx [ bit bitmap index ]
- nodes [ bitmap-node nodes>> ] |
- bitmap bit bitand 0 eq? [
- [let | new-leaf [ value key hashcode <leaf-node> ] |
- bitmap bit bitor
- new-leaf idx nodes insert-nth
- shift
- <bitmap-node>
- new-leaf
- ]
- ] [
- [let | n [ idx nodes nth ] |
- shift radix-bits + value key hashcode n (new-at)
- [let | new-leaf [ ] n' [ ] |
- n n' eq? [
- bitmap-node
- ] [
- bitmap
- n' idx nodes new-nth
- shift
- <bitmap-node>
- ] if
- new-leaf
- ]
- ]
- ] if
- ] ;
-
-M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' )
- [let | bit [ hashcode bitmap-node shift>> bitpos ]
- bitmap [ bitmap-node bitmap>> ]
- nodes [ bitmap-node nodes>> ]
- shift [ bitmap-node shift>> ] |
- bit bitmap bitand 0 eq? [ bitmap-node ] [
- [let* | idx [ bit bitmap index ]
- n [ idx nodes nth-unsafe ]
- n' [ key hashcode n (pluck-at) ] |
- n n' eq? [
- bitmap-node
- ] [
- n' [
- bitmap
- n' idx nodes new-nth
- shift
- <bitmap-node>
- ] [
- bitmap bit eq? [ f ] [
- bitmap bit bitnot bitand
- idx nodes remove-nth
- shift
- <bitmap-node>
- ] if
- ] if
- ] if
- ]
- ] if
- ] ;
-
-M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ;
+++ /dev/null
-! Based on Clojure's PersistentHashMap by Rich Hickey.
-
-USING: kernel accessors math arrays fry sequences sequences.lib
-locals persistent.sequences
-persistent.hashtables.config
-persistent.hashtables.nodes
-persistent.hashtables.nodes.leaf ;
-IN: persistent.hashtables.nodes.collision
-
-: find-index ( key hashcode collision-node -- n leaf-node )
- leaves>> -rot '[ , , _ matching-key? ] find ; inline
-
-M:: collision-node (entry-at) ( key hashcode collision-node -- leaf-node )
- key hashcode collision-node find-index nip ;
-
-M:: collision-node (pluck-at) ( key hashcode collision-node -- leaf-node )
- hashcode collision-node hashcode>> eq? [
- [let | idx [ key hashcode collision-node find-index drop ] |
- idx [
- idx collision-node leaves>> smash [
- collision-node hashcode>>
- <collision-node>
- ] when
- ] [ collision-node ] if
- ]
- ] [ collision-node ] if ;
-
-M:: collision-node (new-at) ( shift value key hashcode collision-node -- node' added-leaf )
- hashcode collision-node hashcode>> eq? [
- key hashcode collision-node find-index
- [let | leaf-node [ ] idx [ ] |
- idx [
- value leaf-node value>> = [
- collision-node f
- ] [
- hashcode
- value key hashcode <leaf-node>
- idx
- collision-node leaves>>
- new-nth
- <collision-node>
- f
- ] if
- ] [
- [let | new-leaf-node [ value key hashcode <leaf-node> ] |
- hashcode
- collision-node leaves>>
- new-leaf-node
- suffix
- <collision-node>
- new-leaf-node
- ]
- ] if
- ]
- ] [
- shift collision-node value key hashcode make-bitmap-node
- ] if ;
-
-M: collision-node >alist% leaves>> >alist-each% ;
+++ /dev/null
-! Based on Clojure's PersistentHashMap by Rich Hickey.
-
-USING: accessors kernel locals persistent.hashtables.nodes ;
-IN: persistent.hashtables.nodes.empty
-
-M: empty-node (entry-at) 3drop f ;
-
-M: empty-node (pluck-at) 2nip ;
-
-M:: empty-node (new-at) ( shift value key hashcode node -- node' added-leaf )
- value key hashcode <leaf-node> dup ;
-
-M: empty-node >alist% drop ;
-
-M: empty-node hashcode>> drop 0 ;
+++ /dev/null
-! Based on Clojure's PersistentHashMap by Rich Hickey.
-
-USING: math accessors kernel arrays sequences sequences.private
-locals sequences.lib
-persistent.sequences
-persistent.hashtables.config
-persistent.hashtables.nodes ;
-IN: persistent.hashtables.nodes.full
-
-M:: full-node (new-at) ( shift value key hashcode full-node -- node' added-leaf )
- [let* | nodes [ full-node nodes>> ]
- idx [ hashcode full-node shift>> mask ]
- n [ idx nodes nth-unsafe ] |
- shift radix-bits + value key hashcode n (new-at)
- [let | new-leaf [ ] n' [ ] |
- n n' eq? [
- full-node
- ] [
- n' idx nodes new-nth shift <full-node>
- ] if
- new-leaf
- ]
- ] ;
-
-M:: full-node (pluck-at) ( key hashcode full-node -- node' )
- [let* | idx [ hashcode full-node shift>> mask ]
- n [ idx full-node nodes>> nth ]
- n' [ key hashcode n (pluck-at) ] |
- n n' eq? [
- full-node
- ] [
- n' [
- n' idx full-node nodes>> new-nth
- full-node shift>>
- <full-node>
- ] [
- hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand
- idx full-node nodes>> remove-nth
- full-node shift>>
- <bitmap-node>
- ] if
- ] if
- ] ;
-
-M:: full-node (entry-at) ( key hashcode full-node -- node' )
- key hashcode
- hashcode full-node shift>> mask
- full-node nodes>> nth-unsafe
- (entry-at) ;
-
-M: full-node >alist% nodes>> >alist-each% ;
+++ /dev/null
-! Based on Clojure's PersistentHashMap by Rich Hickey.
-
-USING: kernel accessors locals math arrays namespaces
-persistent.hashtables.config
-persistent.hashtables.nodes ;
-IN: persistent.hashtables.nodes.leaf
-
-: matching-key? ( key hashcode leaf-node -- ? )
- tuck hashcode>> eq? [ key>> = ] [ 2drop f ] if ; inline
-
-M: leaf-node (entry-at) [ matching-key? ] keep and ;
-
-M: leaf-node (pluck-at) [ matching-key? not ] keep and ;
-
-M:: leaf-node (new-at) ( shift value key hashcode leaf-node -- node' added-leaf )
- hashcode leaf-node hashcode>> eq? [
- key leaf-node key>> = [
- value leaf-node value>> =
- [ leaf-node f ] [ value key hashcode <leaf-node> f ] if
- ] [
- [let | new-leaf [ value key hashcode <leaf-node> ] |
- hashcode leaf-node new-leaf 2array <collision-node>
- new-leaf
- ]
- ] if
- ] [ shift leaf-node value key hashcode make-bitmap-node ] if ;
-
-M: leaf-node >alist% [ key>> ] [ value>> ] bi 2array , ;
+++ /dev/null
-! Based on Clojure's PersistentHashMap by Rich Hickey.
-
-USING: math arrays kernel sequences sequences.lib
-accessors locals persistent.hashtables.config ;
-IN: persistent.hashtables.nodes
-
-SINGLETON: empty-node
-
-TUPLE: leaf-node
-{ value read-only }
-{ key read-only }
-{ hashcode fixnum read-only } ;
-
-C: <leaf-node> leaf-node
-
-TUPLE: collision-node
-{ hashcode fixnum read-only }
-{ leaves array read-only } ;
-
-C: <collision-node> collision-node
-
-TUPLE: full-node
-{ nodes array read-only }
-{ shift fixnum read-only }
-{ hashcode fixnum read-only } ;
-
-: <full-node> ( nodes shift -- node )
- over first hashcode>> full-node boa ;
-
-TUPLE: bitmap-node
-{ bitmap fixnum read-only }
-{ nodes array read-only }
-{ shift fixnum read-only }
-{ hashcode fixnum read-only } ;
-
-: <bitmap-node> ( bitmap nodes shift -- node )
- pick full-bitmap-mask =
- [ <full-node> nip ]
- [ over first hashcode>> bitmap-node boa ] if ;
-
-GENERIC: (entry-at) ( key hashcode node -- entry )
-
-GENERIC: (new-at) ( shift value key hashcode node -- node' added-leaf )
-
-GENERIC: (pluck-at) ( key hashcode node -- node' )
-
-GENERIC: >alist% ( node -- )
-
-: >alist-each% ( nodes -- ) [ >alist% ] each ;
-
-: mask ( hash shift -- n ) neg shift radix-mask bitand ; inline
-
-: bitpos ( hash shift -- n ) mask 2^ ; inline
-
-: smash ( idx seq -- seq/elt ? )
- dup length 2 = [ [ 1 = ] dip first2 ? f ] [ remove-nth t ] if ; inline
-
-:: make-bitmap-node ( shift branch value key hashcode -- node' added-leaf )
- shift value key hashcode
- branch hashcode>> shift bitpos
- branch 1array
- shift
- <bitmap-node>
- (new-at) ; inline
+++ /dev/null
-Persistent hashtables with O(1) insertion, removal and lookup
+++ /dev/null
-collections
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-USING: help.syntax help.markup kernel arrays assocs ;
-IN: persistent.heaps
-
-HELP: <persistent-heap>
-{ $values { "heap" "a persistent heap" } }
-{ $description "Creates a new persistent heap" } ;
-
-HELP: <singleton-heap>
-{ $values { "value" object } { "prio" "a priority" } { "heap" "a persistent heap" } }
-{ $description "Creates a new persistent heap consisting of one object with the given priority." } ;
-
-HELP: pheap-empty?
-{ $values { "heap" "a persistent heap" } { "?" "a boolean" } }
-{ $description "Returns true if this is an empty persistent heap." } ;
-
-HELP: pheap-peek
-{ $values { "heap" "a persistent heap" } { "value" "an object in the heap" } { "prio" "the minimum priority" } }
-{ $description "Gets the object in the heap with minumum priority." } ;
-
-HELP: pheap-push
-{ $values { "heap" "a persistent heap" } { "value" object } { "prio" "a priority" } { "newheap" "a new persistent heap" } }
-{ $description "Creates a new persistent heap also containing the given object of the given priority." } ;
-
-HELP: pheap-pop*
-{ $values { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } }
-{ $description "Creates a new persistent heap with the minimum element removed." } ;
-
-HELP: pheap-pop
-{ $values { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } { "value" object } { "prio" "a priority" } }
-{ $description "Creates a new persistent heap with the minimum element removed, returning that element and its priority." } ;
-
-HELP: assoc>pheap
-{ $values { "assoc" assoc } { "heap" "a persistent heap" } }
-{ $description "Creates a new persistent heap from an associative mapping whose keys are the entries in the heap and whose values are the associated priorities." } ;
-
-HELP: pheap>alist
-{ $values { "heap" "a persistent heap" } { "alist" "an association list" } }
-{ $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ;
-
-HELP: pheap>values
-{ $values { "heap" "a persistent heap" } { "values" array } }
-{ $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ;
-
-ARTICLE: "persistent-heaps" "Persistent heaps"
-"This vocabulary implements persistent minheaps, aka priority queues. They are purely functional and support efficient O(log n) operations of pushing and popping, with O(1) time access to the minimum element. To create heaps, use the following words:"
-{ $subsection <persistent-heap> }
-{ $subsection <singleton-heap> }
-"To manipulate them:"
-{ $subsection pheap-peek }
-{ $subsection pheap-push }
-{ $subsection pheap-pop }
-{ $subsection pheap-pop* }
-{ $subsection pheap-empty? }
-{ $subsection assoc>pheap }
-{ $subsection pheap>alist }
-{ $subsection pheap>values } ;
-
-ABOUT: "persistent-heaps"
+++ /dev/null
-USING: persistent.heaps tools.test ;
-IN: persistent.heaps.tests
-
-: test-input
- { { "hello" 3 } { "goodbye" 2 } { "whatever" 5 }
- { "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } } ;
-
-[
- { { "baz" -7 } { "bar" -1 } { "bing" 0 } { "foo" 1 }
- { "goodbye" 2 } { "hello" 3 } { "whatever" 5 } }
-] [ test-input assoc>pheap pheap>alist ] unit-test
+++ /dev/null
-USING: kernel accessors multi-methods locals combinators math arrays
-assocs namespaces sequences ;
-IN: persistent.heaps
-! These are minheaps
-
-<PRIVATE
-TUPLE: branch value prio left right ;
-TUPLE: empty-heap ;
-
-PREDICATE: singleton-heap < branch
- [ left>> ] [ right>> ] bi [ empty-heap? ] both? ;
-
-C: <branch> branch
-: >branch< ( branch -- value prio left right )
- { [ value>> ] [ prio>> ] [ left>> ] [ right>> ] } cleave ;
-PRIVATE>
-
-: <persistent-heap> ( -- heap ) T{ empty-heap } ;
-
-: <singleton-heap> ( value prio -- heap )
- <persistent-heap> <persistent-heap> <branch> ;
-
-: pheap-empty? ( heap -- ? ) empty-heap? ;
-
-: empty-pheap ( -- * )
- "Attempt to delete from an empty heap" throw ;
-
-<PRIVATE
-: remove-left ( heap -- value prio newheap )
- dup [ left>> ] [ right>> ] bi [ pheap-empty? ] both?
- [ [ value>> ] [ prio>> ] bi <persistent-heap> ]
- [ >branch< swap remove-left -rot [ <branch> ] 2dip rot ] if ;
-
-: both-with? ( obj a b quot -- ? )
- swap >r with r> swap both? ; inline
-
-GENERIC: sift-down ( value prio left right -- heap )
-
-METHOD: sift-down { empty-heap empty-heap } <branch> ;
-
-METHOD: sift-down { singleton-heap empty-heap }
- 3dup drop prio>> <= [ <branch> ] [
- drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip
- <singleton-heap> <persistent-heap> <branch>
- ] if ;
-
-:: reroot-left ( value prio left right -- heap )
- left value>> left prio>>
- value prio left left>> left right>> sift-down
- right <branch> ;
-
-:: reroot-right ( value prio left right -- heap )
- right value>> right prio>> left
- value prio right left>> right right>> sift-down
- <branch> ;
-
-METHOD: sift-down { branch branch }
- 3dup [ prio>> <= ] both-with? [ <branch> ] [
- 2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if
- ] if ;
-PRIVATE>
-
-GENERIC: pheap-peek ( heap -- value prio )
-M: empty-heap pheap-peek empty-pheap ;
-M: branch pheap-peek [ value>> ] [ prio>> ] bi ;
-
-GENERIC: pheap-push ( value prio heap -- newheap )
-
-M: empty-heap pheap-push
- drop <singleton-heap> ;
-
-<PRIVATE
-: push-top ( value prio heap -- newheap )
- [ [ value>> ] [ prio>> ] [ right>> ] tri pheap-push ]
- [ left>> ] bi <branch> ;
-
-: push-in ( value prio heap -- newheap )
- [ 2nip [ value>> ] [ prio>> ] bi ]
- [ right>> pheap-push ]
- [ 2nip left>> ] 3tri <branch> ;
-PRIVATE>
-
-M: branch pheap-push
- 2dup prio>> <= [ push-top ] [ push-in ] if ;
-
-: pheap-pop* ( heap -- newheap )
- dup pheap-empty? [ empty-pheap ] [
- dup left>> pheap-empty?
- [ drop <persistent-heap> ]
- [ [ left>> remove-left ] keep right>> swap sift-down ] if
- ] if ;
-
-: pheap-pop ( heap -- newheap value prio )
- [ pheap-pop* ] [ pheap-peek ] bi ;
-
-: assoc>pheap ( assoc -- heap ) ! Assoc is value => prio
- <persistent-heap> swap [ rot pheap-push ] assoc-each ;
-
-: pheap>alist ( heap -- alist )
- [ dup pheap-empty? not ] [ pheap-pop 2array ] [ ] produce nip ;
-
-: pheap>values ( heap -- seq ) pheap>alist keys ;
+++ /dev/null
-Datastructure for functional peristent heaps, from ML for the Working Programmer
+++ /dev/null
-collections
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: persistent.sequences
-USING: help.markup help.syntax math sequences kernel ;
-
-HELP: new-nth
-{ $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } }
-{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." }
-{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
-
-HELP: ppush
-{ $values { "val" object } { "seq" sequence } { "seq'" sequence } }
-{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." }
-{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
-
-HELP: ppop
-{ $values { "seq" sequence } { "seq'" sequence } }
-{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." }
-{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel ;
-IN: persistent.sequences
-
-GENERIC: ppush ( val seq -- seq' )
-
-M: sequence ppush swap suffix ;
-
-GENERIC: ppop ( seq -- seq' )
-
-M: sequence ppop 1 head* ;
-
-GENERIC: new-nth ( val i seq -- seq' )
-
-M: sequence new-nth clone [ set-nth ] keep ;
+++ /dev/null
-Persistent sequence protocol
+++ /dev/null
-collections
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Immutable vectors with O(log_32 n) random access, push, and pop
+++ /dev/null
-collections
+++ /dev/null
-USING: help.markup help.syntax kernel math sequences ;
-IN: persistent-vectors
-
-HELP: PV{
-{ $syntax "elements... }" }
-{ $description "Parses a literal " { $link persistent-vector } "." } ;
-
-HELP: >persistent-vector
-{ $values { "seq" sequence } { "pvec" persistent-vector } }
-{ $description "Creates a " { $link persistent-vector } " with the same elements as " { $snippet "seq" } "." } ;
-
-HELP: persistent-vector
-{ $class-description "The class of persistent vectors." } ;
-
-ARTICLE: "persistent-vectors" "Persistent vectors"
-"A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time."
-$nl
-"The class of persistent vectors:"
-{ $subsection persistent-vector }
-"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")."
-$nl
-"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:"
-{ $subsection new-nth }
-{ $subsection ppush }
-{ $subsection ppop }
-"Converting a sequence into a persistent vector:"
-{ $subsection >persistent-vector }
-"Persistent vectors have a literal syntax:"
-{ $subsection POSTPONE: PV{ }
-"The empty persistent vector, written " { $snippet "PV{ }" } ", is used for building up all other persistent vectors."
-$nl
-"This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ;
-
-ABOUT: "persistent-vectors"
+++ /dev/null
-IN: persistent-vectors.tests
-USING: accessors tools.test persistent.vectors
-persistent.sequences sequences kernel arrays random namespaces
-vectors math math.order ;
-
-\ new-nth must-infer
-\ ppush must-infer
-\ ppop must-infer
-
-[ 0 ] [ PV{ } length ] unit-test
-
-[ 1 ] [ 3 PV{ } ppush length ] unit-test
-
-[ 3 ] [ 3 PV{ } ppush first ] unit-test
-
-[ PV{ 3 1 3 3 7 } ] [
- PV{ } { 3 1 3 3 7 } [ swap ppush ] each
-] unit-test
-
-[ { 3 1 3 3 7 } ] [
- PV{ } { 3 1 3 3 7 } [ swap ppush ] each >array
-] unit-test
-
-{ 100 1060 2000 10000 100000 1000000 } [
- [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test
-] each
-
-[ ] [ 10000 [ 16 random-bits ] PV{ } replicate-as "1" set ] unit-test
-[ ] [ "1" get >vector "2" set ] unit-test
-
-[ t ] [
- 3000 [
- drop
- 16 random-bits 10000 random
- [ "1" [ new-nth ] change ]
- [ "2" [ new-nth ] change ] 2bi
- "1" get "2" get sequence=
- ] all?
-] unit-test
-
-[ PV{ } ppop ] [ empty-error? ] must-fail-with
-
-[ t ] [ PV{ 3 } ppop empty? ] unit-test
-
-[ PV{ 3 7 } ] [ PV{ 3 7 6 } ppop ] unit-test
-
-[ PV{ 3 7 6 5 } ] [ 5 PV{ 3 7 6 } ppush ] unit-test
-
-[ ] [ PV{ } "1" set ] unit-test
-[ ] [ V{ } clone "2" set ] unit-test
-
-: push/pop-test ( vec -- vec' ) 3 swap ppush 3 swap ppush ppop ;
-
-[ ] [ PV{ } 10000 [ push/pop-test ] times drop ] unit-test
-
-[ PV{ } ] [
- PV{ }
- 10000 [ 1 swap ppush ] times
- 10000 [ ppop ] times
-] unit-test
-
-[ t ] [
- 10000 >persistent-vector 752 [ ppop ] times dup length sequence=
-] unit-test
-
-[ t ] [
- 100 [
- drop
- 100 random [
- 16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi
- ] times
- 100 random "1" get length min [
- "1" [ ppop ] change
- "2" get pop*
- ] times
- "1" get "2" get sequence=
- ] all?
-] unit-test
+++ /dev/null
-! Based on Clojure's PersistentVector by Rich Hickey.
-
-USING: math accessors kernel sequences.private sequences arrays
-combinators combinators.short-circuit parser prettyprint.backend
-persistent.sequences ;
-IN: persistent.vectors
-
-<PRIVATE
-
-TUPLE: node { children array } { level fixnum } ;
-
-PRIVATE>
-
-ERROR: empty-error pvec ;
-
-TUPLE: persistent-vector
-{ count fixnum }
-{ root node initial: T{ node f { } 1 } }
-{ tail node initial: T{ node f { } 0 } } ;
-
-M: persistent-vector length count>> ;
-
-: node-size 32 ; inline
-
-: node-mask node-size mod ; inline
-
-: node-shift -5 * shift ; inline
-
-: node-nth ( i node -- obj )
- [ node-mask ] [ children>> ] bi* nth ;
-
-: body-nth ( i node -- i node' )
- dup level>> [
- dupd [ level>> node-shift ] keep node-nth
- ] times ;
-
-: tail-offset ( pvec -- n )
- [ count>> ] [ tail>> children>> length ] bi - ;
-
-M: persistent-vector nth-unsafe
- 2dup tail-offset >=
- [ tail>> ] [ root>> body-nth ] if
- node-nth ;
-
-: node-add ( val node -- node' )
- clone [ ppush ] change-children ;
-
-: ppush-tail ( val pvec -- pvec' )
- [ node-add ] change-tail ;
-
-: full? ( node -- ? )
- children>> length node-size = ;
-
-: 1node ( val level -- node )
- [ 1array ] dip node boa ;
-
-: 2node ( first second -- node )
- [ 2array ] [ drop level>> 1+ ] 2bi node boa ;
-
-: new-child ( new-child node -- node' expansion/f )
- dup full? [ tuck level>> 1node ] [ node-add f ] if ;
-
-: new-last ( val seq -- seq' )
- [ length 1- ] keep new-nth ;
-
-: node-set-last ( child node -- node' )
- clone [ new-last ] change-children ;
-
-: (ppush-new-tail) ( tail node -- node' expansion/f )
- dup level>> 1 = [
- new-child
- ] [
- tuck children>> peek (ppush-new-tail)
- [ swap new-child ] [ swap node-set-last f ] ?if
- ] if ;
-
-: do-expansion ( pvec root expansion/f -- pvec )
- [ 2node ] when* >>root ;
-
-: ppush-new-tail ( val pvec -- pvec' )
- [ ] [ tail>> ] [ root>> ] tri
- (ppush-new-tail) do-expansion
- swap 0 1node >>tail ;
-
-M: persistent-vector ppush ( val pvec -- pvec' )
- clone
- dup tail>> full?
- [ ppush-new-tail ] [ ppush-tail ] if
- [ 1+ ] change-count ;
-
-: node-set-nth ( val i node -- node' )
- clone [ new-nth ] change-children ;
-
-: node-change-nth ( i node quot -- node' )
- [ clone ] dip [
- [ clone ] dip [ change-nth ] 2keep drop
- ] curry change-children ; inline
-
-: (new-nth) ( val i node -- node' )
- dup level>> 0 = [
- [ node-mask ] dip node-set-nth
- ] [
- [ dupd level>> node-shift node-mask ] keep
- [ (new-nth) ] node-change-nth
- ] if ;
-
-M: persistent-vector new-nth ( obj i pvec -- pvec' )
- 2dup count>> = [ nip ppush ] [
- clone
- 2dup tail-offset >= [
- [ node-mask ] dip
- [ node-set-nth ] change-tail
- ] [
- [ (new-nth) ] change-root
- ] if
- ] if ;
-
-! The pop code is really convoluted. I don't understand Rich Hickey's
-! original code. It uses a 'Box' out parameter which is passed around
-! inside a recursive function, and gets mutated along the way to boot.
-! Super-confusing.
-: ppop-tail ( pvec -- pvec' )
- [ clone [ ppop ] change-children ] change-tail ;
-
-: (ppop-contraction) ( node -- node' tail' )
- clone [ unclip-last swap ] change-children swap ;
-
-: ppop-contraction ( node -- node' tail' )
- dup children>> length 1 =
- [ children>> peek f swap ]
- [ (ppop-contraction) ]
- if ;
-
-: (ppop-new-tail) ( root -- root' tail' )
- dup level>> 1 > [
- dup children>> peek (ppop-new-tail) [
- dup
- [ swap node-set-last ]
- [ drop ppop-contraction drop ]
- if
- ] dip
- ] [
- ppop-contraction
- ] if ;
-
-: trivial? ( node -- ? )
- { [ level>> 1 > ] [ children>> length 1 = ] } 1&& ;
-
-: ppop-new-tail ( pvec -- pvec' )
- dup root>> (ppop-new-tail) [
- {
- { [ dup not ] [ drop T{ node f { } 1 } ] }
- { [ dup trivial? ] [ children>> first ] }
- [ ]
- } cond
- ] dip [ >>root ] [ >>tail ] bi* ;
-
-PRIVATE>
-
-M: persistent-vector ppop ( pvec -- pvec' )
- dup count>> {
- { 0 [ empty-error ] }
- { 1 [ drop T{ persistent-vector } ] }
- [
- [
- clone
- dup tail>> children>> length 1 >
- [ ppop-tail ] [ ppop-new-tail ] if
- ] dip 1- >>count
- ]
- } case ;
-
-M: persistent-vector like
- drop T{ persistent-vector } [ swap ppush ] reduce ;
-
-M: persistent-vector equal?
- over persistent-vector? [ sequence= ] [ 2drop f ] if ;
-
-: >persistent-vector ( seq -- pvec )
- T{ persistent-vector } like ;
-
-: PV{ \ } [ >persistent-vector ] parse-literal ; parsing
-
-M: persistent-vector pprint-delims drop \ PV{ \ } ;
-
-M: persistent-vector >pprint-sequence ;
-
-INSTANCE: persistent-vector immutable-sequence
projects / factor.git / commitdiff