steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Debugging persistent vectors

db4
Slava Pestov 2008-06-18 19:46:37 -05:00
parent 42f421d988
commit 3e11a7f204
2 changed files with 25 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/persistent-vectors/persistent-vectors-tests.factor
View File

@ -48,6 +48,10 @@ random namespaces vectors math math.order ;
[ ] [ PV{ } "1" set ] unit-test [ ] [ PV{ } "1" set ] unit-test
[ ] [ V{ } clone "2" 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
[ t ] [ [ t ] [
100 [ 100 [
drop drop

33
extra/persistent-vectors/persistent-vectors.factor
View File

@ -1,7 +1,7 @@
! Based on Clojure's PersistentVector by Rich Hickey. ! Based on Clojure's PersistentVector by Rich Hickey.
USING: math accessors kernel sequences.private sequences arrays USING: math accessors kernel sequences.private sequences arrays
combinators parser prettyprint.backend ; combinators combinators.lib parser prettyprint.backend ;
IN: persistent-vectors IN: persistent-vectors
ERROR: empty-error pvec ; ERROR: empty-error pvec ;
@ -123,30 +123,39 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' )
] if ] if
] if ; ] if ;
: ppop-tail ( pvec -- pvec' )
[ clone [ ppop ] change-children ] change-tail ;
: (ppop-contraction) ( node -- node' tail' ) : (ppop-contraction) ( node -- node' tail' )
clone [ unclip-last swap ] change-children swap ; clone [ unclip-last swap ] change-children swap ;
: ppop-contraction ( node -- node' tail' ) : ppop-contraction ( node -- node' tail' )
[ (ppop-contraction) ] [ level>> 1 = ] bi swap and ; dup children>> length 1 =
[ children>> peek f swap ]
[ (ppop-contraction) ]
if ;
: (ppop-new-tail) ( root -- root' tail' ) : (ppop-new-tail) ( root -- root' tail' )
dup level>> 1 > [ dup level>> 1 > [
dup children>> peek (ppop-new-tail) over children>> empty? dup children>> peek (ppop-new-tail) over
[ 2drop ppop-contraction ] [ [ swap node-set-last ] dip ] if [ [ swap node-set-last ] dip ]
[ 2drop ppop-contraction ]
if
] [ ] [
ppop-contraction ppop-contraction
] if ; ] if ;
: ppop-tail ( pvec -- pvec' ) : trivial? ( node -- ? )
[ clone [ ppop ] change-children ] change-tail ; { [ level>> 1 > ] [ children>> length 1 = ] } 1&& ;
: ppop-new-tail ( pvec -- pvec' ) : ppop-new-tail ( pvec -- pvec' )
dup root>> (ppop-new-tail) dup root>> (ppop-new-tail) [
[ {
dup [ level>> 1 > ] [ children>> length 1 = ] bi and { [ dup not ] [ drop T{ node f { } 1 } ] }
[ children>> first ] when { [ dup trivial? ] [ children>> first ] }
] dip [ ]
[ >>root ] [ >>tail ] bi* ; } cond
] dip [ >>root ] [ >>tail ] bi* ;
PRIVATE> PRIVATE>