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

dlists: some cleanup.

db4
John Benediktsson 2014-12-11 17:33:31 -08:00
parent b9dc159949
commit 028b50fd19
1 changed files with 37 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
basis/dlists/dlists.factor
View File

@ -6,7 +6,9 @@ deques fry hashtables kernel math.order parser search-deques
sequences summary vocabs.loader ; sequences summary vocabs.loader ;
IN: dlists IN: dlists
TUPLE: dlist-link { prev maybe{ dlist-link } } { next maybe{ dlist-link } } ; TUPLE: dlist-link
{ prev maybe{ dlist-link } }
{ next maybe{ dlist-link } } ;
TUPLE: dlist-node < dlist-link obj ; TUPLE: dlist-node < dlist-link obj ;
@ -91,52 +93,44 @@ PRIVATE>
[ set-prev-when ] [ set-prev-when ]
[ swap set-next-when ] 2bi ; inline [ swap set-next-when ] 2bi ; inline
M: dlist push-front* ( obj dlist -- dlist-node ) M: dlist push-front*
[ front>> f swap <dlist-node> dup dup set-next-prev ] keep [
[ front<< ] keep f swap <dlist-node> dup dup set-next-prev
set-back-to-front ; ] change-front set-back-to-front ;
: push-node-front ( dlist-node dlist -- ) : push-node-front ( dlist-node dlist -- )
[ front>> >>next drop ] dupd [ >>next ] change-front
[ front<< ] [ set-next-prev ] [ set-back-to-front ] bi* ;
[ [ set-next-prev ] [ set-back-to-front ] bi* ] 2tri ;
: push-node-back ( dlist-node dlist -- ) : push-node-back ( dlist-node dlist -- )
[ back>> >>prev drop ] dupd [ >>prev ] change-back
[ back<< ] [ set-prev-next ] [ set-front-to-back ] bi* ;
[ [ set-prev-next ] [ set-front-to-back ] bi* ] 2tri ;
M: dlist push-back* ( obj dlist -- dlist-node ) M: dlist push-back*
[ back>> f <dlist-node> ] keep [
[ back>> set-next-when ] 2keep [ f <dlist-node> dup dup ]
[ back<< ] 2keep [ set-next-when ] bi
set-front-to-back ; ] change-back set-front-to-back ;
M: dlist peek-front* ( dlist -- obj/f ? ) M: dlist peek-front*
front>> [ obj>> t ] [ f f ] if* ; front>> [ obj>> t ] [ f f ] if* ;
M: dlist peek-back* ( dlist -- obj/f ? ) M: dlist peek-back*
back>> [ obj>> t ] [ f f ] if* ; back>> [ obj>> t ] [ f f ] if* ;
M: dlist pop-front* ( dlist -- ) M: dlist pop-front*
[ [
[ [ empty-deque ] unless*
[ empty-deque ] unless* next>>
next>> f over set-prev-when
f over set-prev-when ] change-front normalize-back ;
] change-front drop
] keep
normalize-back ;
M: dlist pop-back* ( dlist -- ) M: dlist pop-back*
[ [
[ [ empty-deque ] unless*
[ empty-deque ] unless* prev>>
prev>> f over set-next-when
f over set-next-when ] change-back normalize-front ;
] change-back drop
] keep
normalize-front ;
: dlist-find ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? ) : dlist-find ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
'[ obj>> @ ] dlist-find-node [ obj>> t ] [ f f ] if* ; inline '[ obj>> @ ] dlist-find-node [ obj>> t ] [ f f ] if* ; inline
@ -144,10 +138,10 @@ M: dlist pop-back* ( dlist -- )
: dlist-any? ( ... dlist quot: ( ... value -- ... ? ) -- ... ? ) : dlist-any? ( ... dlist quot: ( ... value -- ... ? ) -- ... ? )
dlist-find nip ; inline dlist-find nip ; inline
M: dlist deque-member? ( value dlist -- ? ) M: dlist deque-member?
[ = ] with dlist-any? ; [ = ] with dlist-any? ;
M: dlist delete-node ( dlist-node dlist -- ) M: dlist delete-node
[ [
{ {
{ [ 2dup front>> eq? ] [ nip pop-front* ] } { [ 2dup front>> eq? ] [ nip pop-front* ] }
@ -170,10 +164,8 @@ M: dlist delete-node ( dlist-node dlist -- )
: delete-node-if ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ) : delete-node-if ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f )
'[ obj>> @ ] delete-node-if* drop ; inline '[ obj>> @ ] delete-node-if* drop ; inline
M: dlist clear-deque ( dlist -- ) M: dlist clear-deque
f >>front f >>front f >>back drop ;
f >>back
drop ;
: dlist-each ( ... dlist quot: ( ... value -- ... ) -- ... ) : dlist-each ( ... dlist quot: ( ... value -- ... ) -- ... )
'[ obj>> @ ] dlist-each-node ; inline '[ obj>> @ ] dlist-each-node ; inline
@ -187,8 +179,9 @@ M: dlist clear-deque ( dlist -- )
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ; : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
: dlist-filter ( ... dlist quot: ( ... value -- ... ? ) -- ... dlist' ) : dlist-filter ( ... dlist quot: ( ... value -- ... ? ) -- ... dlist' )
[ not ] compose <dlist> [
<dlist> [ '[ dup obj>> @ [ drop ] [ obj>> _ push-back ] if ] dlist-each-node ] keep ; inline '[ _ keep swap [ _ push-back ] [ drop ] if ] dlist-each
] keep ; inline
M: dlist clone M: dlist clone
<dlist> [ '[ _ push-back ] dlist-each ] keep ; <dlist> [ '[ _ push-back ] dlist-each ] keep ;
@ -196,11 +189,8 @@ M: dlist clone
<PRIVATE <PRIVATE
: (push-before-node) ( obj dlist-node -- new-dlist-node ) : (push-before-node) ( obj dlist-node -- new-dlist-node )
[ [ prev>> ] keep <dlist-node> ] keep { [ [ prev>> ] keep <dlist-node> dup ] keep
[ prev>> [ next<< ] [ drop ] if* ] [ dupd next<< ] change-prev drop ; inline
[ prev<< ]
[ drop ]
} 2cleave ; inline
: push-before-node ( obj dlist-node dlist -- new-dlist-node ) : push-before-node ( obj dlist-node dlist -- new-dlist-node )
2dup front>> eq? [ 2dup front>> eq? [