1 ! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: combinators kernel math sequences accessors deques
8 TUPLE: dlist front back length ;
14 M: dlist deque-length length>> ;
18 TUPLE: dlist-node obj prev next ;
20 C: <dlist-node> dlist-node
22 M: dlist-node node-value obj>> ;
24 : inc-length ( dlist -- )
25 [ 1+ ] change-length drop ; inline
27 : dec-length ( dlist -- )
28 [ 1- ] change-length drop ; inline
30 : set-prev-when ( dlist-node dlist-node/f -- )
31 [ (>>prev) ] [ drop ] if* ;
33 : set-next-when ( dlist-node dlist-node/f -- )
34 [ (>>next) ] [ drop ] if* ;
36 : set-next-prev ( dlist-node -- )
37 dup next>> set-prev-when ;
39 : normalize-front ( dlist -- )
40 dup back>> [ f >>front ] unless drop ;
42 : normalize-back ( dlist -- )
43 dup front>> [ f >>back ] unless drop ;
45 : set-back-to-front ( dlist -- )
46 dup back>> [ dup front>> >>back ] unless drop ;
48 : set-front-to-back ( dlist -- )
49 dup front>> [ dup back>> >>front ] unless drop ;
51 : (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
54 [ drop t ] [ >r next>> r> (dlist-find-node) ] if
55 ] [ 2drop f f ] if ; inline recursive
57 : dlist-find-node ( dlist quot -- node/f ? )
58 >r front>> r> (dlist-find-node) ; inline
60 : dlist-each-node ( dlist quot -- )
61 [ f ] compose dlist-find-node 2drop ; inline
63 : unlink-node ( dlist-node -- )
64 dup prev>> over next>> set-prev-when
65 dup next>> swap prev>> set-next-when ;
69 M: dlist push-front* ( obj dlist -- dlist-node )
70 [ front>> f swap <dlist-node> dup dup set-next-prev ] keep
72 [ set-back-to-front ] keep
75 M: dlist push-back* ( obj dlist -- dlist-node )
76 [ back>> f <dlist-node> ] keep
77 [ back>> set-next-when ] 2keep
79 [ set-front-to-back ] keep
84 M: empty-dlist summary ( dlist -- )
87 M: dlist peek-front ( dlist -- obj )
88 front>> [ obj>> ] [ empty-dlist ] if* ;
90 M: dlist pop-front* ( dlist -- )
91 dup front>> [ empty-dlist ] unless
99 [ normalize-back ] keep
102 M: dlist peek-back ( dlist -- obj )
103 back>> [ obj>> ] [ empty-dlist ] if* ;
105 M: dlist pop-back* ( dlist -- )
106 dup back>> [ empty-dlist ] unless
114 [ normalize-front ] keep
117 : dlist-find ( dlist quot -- obj/f ? )
119 dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
121 : dlist-contains? ( dlist quot -- ? )
122 dlist-find nip ; inline
124 M: dlist deque-member? ( value dlist -- ? )
125 [ = ] with dlist-contains? ;
127 M: dlist delete-node ( dlist-node dlist -- )
129 { [ 2dup front>> eq? ] [ nip pop-front* ] }
130 { [ 2dup back>> eq? ] [ nip pop-back* ] }
131 [ dec-length unlink-node ]
134 : delete-node-if* ( dlist quot -- obj/f ? )
135 dupd dlist-find-node [
137 [ swap delete-node ] keep obj>> t
145 : delete-node-if ( dlist quot -- obj/f )
146 [ obj>> ] prepose delete-node-if* drop ; inline
148 M: dlist clear-deque ( dlist -- )
154 : dlist-each ( dlist quot -- )
155 [ obj>> ] prepose dlist-each-node ; inline
157 : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
159 INSTANCE: dlist deque