1 ! Copyright (C) 2007, 2009 Mackenzie Straight, Doug Coleman,
2 ! Slava Pestov, John Benediktsson.
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors arrays combinators combinators.short-circuit
5 deques fry hashtables kernel math.order parser search-deques
6 sequences summary vocabs.loader ;
9 TUPLE: dlist-link { prev maybe{ dlist-link } } { next maybe{ dlist-link } } ;
11 TUPLE: dlist-node < dlist-link obj ;
15 M: dlist-link node-value obj>> ;
17 : new-dlist-link ( obj prev next class -- node )
23 : <dlist-node> ( obj prev next -- dlist-node )
24 \ dlist-node new-dlist-link ; inline
27 { front maybe{ dlist-link } }
28 { back maybe{ dlist-link } } ;
33 : <hashed-dlist> ( -- search-deque )
34 20 <hashtable> <dlist> <search-deque> ;
36 M: dlist deque-empty? front>> not ; inline
41 [ 2dup { [ and ] [ [ obj>> ] same? ] } 2&& ]
42 [ [ next>> ] bi@ ] while
48 : set-prev-when ( dlist-node dlist-node/f -- )
49 [ prev<< ] [ drop ] if* ; inline
51 : set-next-when ( dlist-node dlist-node/f -- )
52 [ next<< ] [ drop ] if* ; inline
54 : set-next-prev ( dlist-node -- )
55 dup next>> set-prev-when ; inline
57 : set-prev-next ( dlist-node -- )
58 dup prev>> set-next-when ;
60 : normalize-front ( dlist -- )
61 dup back>> [ f >>front ] unless drop ; inline
63 : normalize-back ( dlist -- )
64 dup front>> [ f >>back ] unless drop ; inline
66 : set-back-to-front ( dlist -- )
67 dup back>> [ dup front>> >>back ] unless drop ; inline
69 : set-front-to-back ( dlist -- )
70 dup front>> [ dup back>> >>front ] unless drop ; inline
72 : (dlist-find-node) ( ... dlist-node quot: ( ... node -- ... ? ) -- ... node/f )
75 [ drop ] [ [ next>> ] dip (dlist-find-node) ] if
76 ] [ 2drop f ] if ; inline recursive
78 : dlist-find-node ( ... dlist quot: ( ... node -- ... ? ) -- ... node/f )
79 [ front>> ] dip (dlist-find-node) ; inline
81 : dlist-find-node-prev ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
82 dlist-find-node [ prev>> ] [ f ] if* ; inline
84 : dlist-each-node ( ... dlist quot: ( ... node -- ... ) -- ... )
85 '[ @ f ] dlist-find-node drop ; inline
89 : unlink-node ( dlist-node -- )
90 dup prev>> over next>> set-prev-when
91 dup next>> swap prev>> set-next-when ; inline
93 M: dlist push-front* ( obj dlist -- dlist-node )
94 [ front>> f swap <dlist-node> dup dup set-next-prev ] keep
98 : push-node-front ( dlist-node dlist -- )
99 [ front>> >>next drop ]
101 [ [ set-next-prev ] [ set-back-to-front ] bi* ] 2tri ;
103 : push-node-back ( dlist-node dlist -- )
104 [ back>> >>prev drop ]
106 [ [ set-prev-next ] [ set-front-to-back ] bi* ] 2tri ;
108 M: dlist push-back* ( obj dlist -- dlist-node )
109 [ back>> f <dlist-node> ] keep
110 [ back>> set-next-when ] 2keep
114 M: dlist peek-front* ( dlist -- obj/f ? )
115 front>> [ obj>> t ] [ f f ] if* ;
117 M: dlist peek-back* ( dlist -- obj/f ? )
118 back>> [ obj>> t ] [ f f ] if* ;
120 M: dlist pop-front* ( dlist -- )
123 [ empty-deque ] unless*
130 M: dlist pop-back* ( dlist -- )
133 [ empty-deque ] unless*
140 : dlist-find ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
141 '[ obj>> @ ] dlist-find-node [ obj>> t ] [ f f ] if* ; inline
143 : dlist-any? ( ... dlist quot: ( ... value -- ... ? ) -- ... ? )
144 dlist-find nip ; inline
146 M: dlist deque-member? ( value dlist -- ? )
147 [ = ] with dlist-any? ;
149 M: dlist delete-node ( dlist-node dlist -- )
152 { [ 2dup front>> eq? ] [ nip pop-front* ] }
153 { [ 2dup back>> eq? ] [ nip pop-back* ] }
156 ] [ drop f >>prev f >>next drop ] 2bi ;
158 : delete-node-if* ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
159 dupd dlist-find-node [
161 [ swap delete-node ] keep obj>> t
169 : delete-node-if ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f )
170 '[ obj>> @ ] delete-node-if* drop ; inline
172 M: dlist clear-deque ( dlist -- )
177 : dlist-each ( ... dlist quot: ( ... value -- ... ) -- ... )
178 '[ obj>> @ ] dlist-each-node ; inline
180 : dlist>sequence ( dlist -- seq )
181 [ ] collector [ dlist-each ] dip ;
183 : >dlist ( seq -- dlist )
184 <dlist> [ '[ _ push-back ] each ] keep ;
186 : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
188 : dlist-filter ( ... dlist quot: ( ... value -- ... ? ) -- ... dlist' )
190 <dlist> [ '[ dup obj>> @ [ drop ] [ obj>> _ push-back ] if ] dlist-each-node ] keep ; inline
193 <dlist> [ '[ _ push-back ] dlist-each ] keep ;
197 : (push-before-node) ( obj dlist-node -- new-dlist-node )
198 [ [ prev>> ] keep <dlist-node> ] keep {
199 [ prev>> [ next<< ] [ drop ] if* ]
204 : push-before-node ( obj dlist-node dlist -- new-dlist-node )
208 drop (push-before-node)
213 : push-before ( ... obj dlist quot: ( ... obj -- ... ? ) -- ... dlist-node )
214 [ obj>> ] prepose over [ dlist-find-node ] dip swap
215 [ swap push-before-node ] [ push-back* ] if* ; inline
217 : push-sorted ( obj dlist -- dlist-node )
218 dupd [ before? ] with push-before ; inline
220 INSTANCE: dlist deque
222 SYNTAX: DL{ \ } [ >dlist ] parse-literal ;
224 { "dlists" "prettyprint" } "dlists.prettyprint" require-when