dlists: make a dlist-link tuple so you can "be the node" by subclassing it. this...

diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor
index 59efcda93e27e43dff7d3be2a5272d62a38a73df..bd8329860953fc19747bdf2710f769b6319e024d 100644 (file)
--- a/basis/dlists/dlists-tests.factor
+++ b/basis/dlists/dlists-tests.factor
@@ -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
+
+

diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor
index 21b5f40af885840e0749a1b369f40f738b1113b1..bbac957aa2900909b149cd3bdf63bb7d87a94297 100644 (file)
--- a/basis/dlists/dlists.factor
+++ b/basis/dlists/dlists.factor
@@ -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
-