dlists: make a dlist-link tuple so you can "be the node" by subclassing it. this allows you go put a type on the obj>> slot. ensure that dlist nodes are returned with prev/next pointers set to f so they can be reused. dlist-filter used to work destructively on the dlist, make a new dlist instead because the combinator relied on using prev/next of deleted nodes.

db4
Doug Coleman 2011-11-15 16:30:20 -08:00
parent 5a2243d481
commit 9ae3b50a53
2 changed files with 88 additions and 17 deletions

View File

@ -1,11 +1,11 @@
USING: deques dlists dlists.private kernel tools.test random
assocs sets sequences namespaces sorting debugger io prettyprint
math accessors classes ;
math accessors classes locals arrays ;
IN: dlists.tests
[ t ] [ <dlist> deque-empty? ] unit-test
[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } } ]
[ T{ dlist f T{ dlist-node f f f 1 } T{ dlist-node f f f 1 } } ]
[ <dlist> 1 over push-front ] unit-test
! Make sure empty lists are empty
@ -100,3 +100,52 @@ IN: dlists.tests
[ f ] [ DL{ f } DL{ 1 } = ] unit-test
[ f ] [ f DL{ } = ] unit-test
[ f ] [ DL{ } f = ] unit-test
TUPLE: my-node < dlist-link { obj fixnum } ;
: <my-node> ( obj -- node )
my-node new
swap >>obj ; inline
[ V{ 1 } ] [ <dlist> 1 <my-node> over push-node-front dlist>seq ] unit-test
[ V{ 2 1 } ] [ <dlist> 1 <my-node> over push-node-front 2 <my-node> over push-node-front dlist>seq ] unit-test
[ V{ 1 } ] [ <dlist> 1 <my-node> over push-node-back dlist>seq ] unit-test
[ V{ 1 2 } ] [ <dlist> 1 <my-node> over push-node-back 2 <my-node> over push-node-back dlist>seq ] unit-test
[ V{ 1 2 3 } ] [ <dlist> 1 <my-node> over push-node-back 2 <my-node> over push-node-back 3 <my-node> over push-node-back dlist>seq ] unit-test
: assert-links ( dlist-node -- )
[ prev>> ] [ next>> ] bi 2array { f f } assert= ;
[ V{ } ] [ <dlist> 1 <my-node> over push-node-back [ [ back>> ] [ ] bi delete-node ] [ ] bi dlist>seq ] unit-test
[ V{ 1 2 } ] [| |
<dlist> :> dl
1 <my-node> :> n1 n1 dl push-node-back
2 <my-node> :> n2 n2 dl push-node-back
3 <my-node> :> n3 n3 dl push-node-back
n3 dl delete-node n3 assert-links
dl dlist>seq
] unit-test
[ V{ 1 3 } ] [| |
<dlist> :> dl
1 <my-node> :> n1 n1 dl push-node-back
2 <my-node> :> n2 n2 dl push-node-back
3 <my-node> :> n3 n3 dl push-node-back
n2 dl delete-node n2 assert-links
dl dlist>seq
] unit-test
[ V{ 2 3 } ] [| |
<dlist> :> dl
1 <my-node> :> n1 n1 dl push-node-back
2 <my-node> :> n2 n2 dl push-node-back
3 <my-node> :> n3 n3 dl push-node-back
n1 dl delete-node n1 assert-links
dl dlist>seq
] unit-test

View File

@ -6,19 +6,26 @@ deques fry hashtables kernel parser search-deques sequences
summary vocabs.loader ;
IN: dlists
<PRIVATE
MIXIN: ?dlist-node
INSTANCE: f ?dlist-node
TUPLE: dlist-node obj { prev ?dlist-node } { next ?dlist-node } ;
TUPLE: dlist-link { prev ?dlist-node } { next ?dlist-node } ;
INSTANCE: dlist-node ?dlist-node
INSTANCE: dlist-link ?dlist-node
C: <dlist-node> dlist-node
TUPLE: dlist-node < dlist-link obj ;
PRIVATE>
M: dlist-link obj>> ;
: new-dlist-link ( obj prev next class -- node )
new
swap >>next
swap >>prev
swap >>obj ; inline
: <dlist-node> ( obj prev next -- node )
\ dlist-node new-dlist-link ; inline
TUPLE: dlist
{ front ?dlist-node }
@ -63,6 +70,9 @@ M: dlist equal?
: set-next-prev ( dlist-node -- )
dup next>> set-prev-when ; inline
: set-prev-next ( dlist-node -- )
dup prev>> set-next-when ;
: normalize-front ( dlist -- )
dup back>> [ f >>front ] unless drop ; inline
@ -90,17 +100,27 @@ M: dlist equal?
: dlist-each-node ( ... dlist quot: ( ... node -- ... ) -- ... )
'[ @ f ] dlist-find-node drop ; inline
PRIVATE>
: unlink-node ( dlist-node -- )
dup prev>> over next>> set-prev-when
dup next>> swap prev>> set-next-when ; inline
PRIVATE>
M: dlist push-front* ( obj dlist -- dlist-node )
[ front>> f swap <dlist-node> dup dup set-next-prev ] keep
[ front<< ] keep
set-back-to-front ;
: push-node-front ( node dlist -- )
[ front>> >>next drop ]
[ front<< ]
[ [ set-next-prev ] [ set-back-to-front ] bi* ] 2tri ;
: push-node-back ( node dlist -- )
[ back>> >>prev drop ]
[ back<< ]
[ [ set-prev-next ] [ set-front-to-back ] bi* ] 2tri ;
M: dlist push-back* ( obj dlist -- dlist-node )
[ back>> f <dlist-node> ] keep
[ back>> set-next-when ] 2keep
@ -143,11 +163,13 @@ M: dlist deque-member? ( value dlist -- ? )
[ = ] with dlist-any? ;
M: dlist delete-node ( dlist-node dlist -- )
{
{ [ 2dup front>> eq? ] [ nip pop-front* ] }
{ [ 2dup back>> eq? ] [ nip pop-back* ] }
[ drop unlink-node ]
} cond ;
[
{
{ [ 2dup front>> eq? ] [ nip pop-front* ] }
{ [ 2dup back>> eq? ] [ nip pop-back* ] }
[ drop unlink-node ]
} cond
] [ drop f >>prev f >>next drop ] 2bi ;
: delete-node-if* ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
dupd dlist-find-node [
@ -180,7 +202,8 @@ M: dlist clear-deque ( dlist -- )
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
: dlist-filter ( ... dlist quot: ( ... value -- ... ? ) -- ... dlist' )
over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
[ not ] compose
<dlist> [ '[ dup obj>> @ [ drop ] [ obj>> _ push-back ] if ] dlist-each-node ] keep ; inline
M: dlist clone
<dlist> [ '[ _ push-back ] dlist-each ] keep ;
@ -190,4 +213,3 @@ INSTANCE: dlist deque
SYNTAX: DL{ \ } [ seq>dlist ] parse-literal ;
{ "dlists" "prettyprint" } "dlists.prettyprint" require-when