diff --git a/extra/persistent-vectors/authors.txt b/extra/persistent-vectors/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/persistent-vectors/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/persistent-vectors/persistent-vectors-docs.factor b/extra/persistent-vectors/persistent-vectors-docs.factor new file mode 100644 index 0000000000..b0cb512d43 --- /dev/null +++ b/extra/persistent-vectors/persistent-vectors-docs.factor @@ -0,0 +1,53 @@ +USING: help.markup help.syntax kernel math sequences ; +IN: persistent-vectors + +HELP: new-nth +{ $values { "val" object } { "i" integer } { "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-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; + +HELP: ppush +{ $values { "val" object } { "i" integer } { "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-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; + +HELP: ppop +{ $values { "val" object } { "i" integer } { "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-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; + +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." } ; + +HELP: pempty +{ $values { "pvec" persistent-vector } } +{ $description "Outputs an empty " { $link persistent-vector } "." } ; + +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 } +"The empty persistent vector, used for building up all other persistent vectors:" +{ $subsection pempty } +"Converting a sequence into a persistent vector:" +{ $subsection >persistent-vector } +"Persistent vectors have a literal syntax:" +{ $subsection POSTPONE: PV{ } +"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" diff --git a/extra/persistent-vectors/persistent-vectors-tests.factor b/extra/persistent-vectors/persistent-vectors-tests.factor new file mode 100644 index 0000000000..f871c95e16 --- /dev/null +++ b/extra/persistent-vectors/persistent-vectors-tests.factor @@ -0,0 +1,63 @@ +IN: persistent-vectors.tests +USING: tools.test persistent-vectors sequences kernel arrays +random namespaces vectors math math.order ; + +\ new-nth must-infer +\ ppush must-infer +\ ppop must-infer + +[ 0 ] [ pempty length ] unit-test + +[ 1 ] [ 3 pempty ppush length ] unit-test + +[ 3 ] [ 3 pempty ppush first ] unit-test + +[ PV{ 3 1 3 3 7 } ] [ + pempty { 3 1 3 3 7 } [ swap ppush ] each +] unit-test + +[ { 3 1 3 3 7 } ] [ + pempty { 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 [ drop 16 random-bits ] PV{ } map-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 + +[ 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 diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor new file mode 100644 index 0000000000..6ed43ca0af --- /dev/null +++ b/extra/persistent-vectors/persistent-vectors.factor @@ -0,0 +1,185 @@ +! Based on Clojure's PersistentVector by Rich Hickey. + +USING: math accessors kernel sequences.private sequences arrays +combinators parser prettyprint.backend fry debugger ; +IN: persistent-vectors + +ERROR: empty-error pvec ; + +GENERIC: ppush ( obj seq -- seq' ) + +M: sequence ppush swap suffix ; + +GENERIC: ppop ( seq -- seq' ) + +M: sequence ppop 1 head* ; + +GENERIC: new-nth ( obj i seq -- seq' ) + +M: sequence new-nth clone [ set-nth ] keep ; + +TUPLE: persistent-vector count root tail ; + +M: persistent-vector length count>> ; + +> ] [ tail>> children>> length ] bi - ; + +: node-shift -5 * shift ; inline + +: node-nth ( i node -- obj ) + children>> [ node-mask ] dip nth ; inline + +: body-nth ( i node -- obj ) + dup level>> 0 > [ + [ drop ] [ [ level>> node-shift ] keep node-nth ] 2bi + body-nth + ] [ + node-nth + ] if ; inline + +M: persistent-vector nth-unsafe + 2dup tail-offset >= + [ tail>> node-nth ] [ root>> body-nth ] if ; + +: node-add ( obj node -- node' ) + clone [ ppush ] change-children ; + +: ppush-tail ( obj pvec -- pvec' ) + [ node-add ] change-tail ; + +: full? ( node -- ? ) + children>> length node-size = ; + +: 1node ( obj level -- node ) + node new + swap >>level + swap 1array >>children ; + +: 2node ( first second -- node ) + 2dup [ level>> ] bi@ assert= + [ 2array ] [ drop level>> 1+ ] 2bi node boa ; + +: new-child ( new-child node -- node' expansion/f ) + dup full? [ tuck level>> 1node ] [ node-add f ] if ; + +: pset-last ( val seq -- seq' ) + [ length 1- ] keep new-nth ; + +: node-set-last ( child node -- node' ) + clone [ pset-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 ( obj pvec -- pvec' ) + [ ] [ tail>> ] [ root>> ] tri + (ppush-new-tail) do-expansion + swap 0 1node >>tail ; + +M: persistent-vector ppush ( obj 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 [ , change-nth ] keep + ] 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 ; + +: (ppop-contraction) ( node -- node' tail' ) + clone [ unclip-last swap ] change-children swap ; + +: ppop-contraction ( node -- node' tail' ) + [ (ppop-contraction) ] [ level>> 1 = ] bi swap and ; + +: (ppop-new-tail) ( root -- root' tail' ) + dup level>> 1 > [ + dup children>> peek (ppop-new-tail) over children>> empty? + [ 2drop ppop-contraction ] [ [ swap node-set-last ] dip ] if + ] [ + ppop-contraction + ] if ; + +: ppop-tail ( pvec -- pvec' ) + [ clone [ ppop ] change-children ] change-tail ; + +: ppop-new-tail ( pvec -- pvec' ) + dup root>> (ppop-new-tail) + [ + dup [ level>> 1 > ] [ children>> length 1 = ] bi and + [ children>> first ] when + ] dip + [ >>root ] [ >>tail ] bi* ; + +PRIVATE> + +: pempty ( -- pvec ) + T{ persistent-vector f 0 T{ node f { } 1 } T{ node f { } 0 } } ; inline + +M: persistent-vector ppop ( pvec -- pvec' ) + dup count>> { + { 0 [ empty-error ] } + { 1 [ drop pempty ] } + [ + [ + clone + dup tail>> children>> length 1 > + [ ppop-tail ] [ ppop-new-tail ] if + ] dip 1- >>count + ] + } case ; + +M: persistent-vector like + drop pempty [ swap ppush ] reduce ; + +M: persistent-vector equal? + over persistent-vector? [ sequence= ] [ 2drop f ] if ; + +: >persistent-vector ( seq -- pvec ) pempty clone-like ; inline + +: PV{ \ } [ >persistent-vector ] parse-literal ; parsing + +M: persistent-vector pprint-delims drop \ PV{ \ } ; + +M: persistent-vector >pprint-sequence ; + +INSTANCE: persistent-vector immutable-sequence diff --git a/extra/persistent-vectors/summary.txt b/extra/persistent-vectors/summary.txt new file mode 100644 index 0000000000..19f3f66ca3 --- /dev/null +++ b/extra/persistent-vectors/summary.txt @@ -0,0 +1 @@ +Immutable vectors with O(log_32 n) random access and amortized O(1) push/pop diff --git a/extra/persistent-vectors/tags.txt b/extra/persistent-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/persistent-vectors/tags.txt @@ -0,0 +1 @@ +collections