PersistentVectors from Clojure
parent
3b26266dc4
commit
58dd889379
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -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"
|
|
@ -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
|
|
@ -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>> ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: node children level ;
|
||||
|
||||
: node-mask HEX: 1f bitand ; inline
|
||||
|
||||
: node-size 32 ; inline
|
||||
|
||||
: tail-offset [ 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
|
|
@ -0,0 +1 @@
|
|||
Immutable vectors with O(log_32 n) random access and amortized O(1) push/pop
|
|
@ -0,0 +1 @@
|
|||
collections
|
Loading…
Reference in New Issue