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

Check in core/dlists

release
Doug Coleman 2007-11-05 01:43:29 -06:00
parent b8561fdc1d
commit 6c8808dd8d
1 changed files with 25 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
core/dlists/dlists.factor
View File

@ -8,12 +8,12 @@ TUPLE: dlist front back length ;
dlist construct-empty dlist construct-empty
0 over set-dlist-length ; 0 over set-dlist-length ;
: dlist-empty? ( dlist -- ? ) dlist-front not ;
<PRIVATE <PRIVATE
TUPLE: dlist-node obj prev next ; TUPLE: dlist-node obj prev next ;
C: <dlist-node> dlist-node C: <dlist-node> dlist-node
: dlist-empty? ( dlist -- ? ) dlist-front not ;
: inc-length ( dlist -- ) : inc-length ( dlist -- )
[ dlist-length 1+ ] keep set-dlist-length ; inline [ dlist-length 1+ ] keep set-dlist-length ; inline
@ -42,6 +42,24 @@ C: <dlist-node> dlist-node
: set-front-to-back ( dlist -- ) : set-front-to-back ( dlist -- )
dup dlist-front dup dlist-front
[ drop ] [ dup dlist-back swap set-dlist-front ] if ; [ drop ] [ dup dlist-back swap set-dlist-front ] if ;
: (dlist-find-node) ( quot dlist-node -- node/f ? )
dup dlist-node-obj pick dupd call [
drop nip t
] [
drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
] if ;
: dlist-find-node ( quot dlist -- node/f ? )
dlist-front [ (dlist-find-node) ] [ drop f f ] if* ;
: (dlist-each-node) ( quot dlist -- )
over
[ 2dup call >r dlist-node-next r> (dlist-each-node) ]
[ 2drop ] if ;
: dlist-each-node ( quot dlist -- )
>r dlist-front r> (dlist-each-node) ; inline
PRIVATE> PRIVATE>
: push-front ( obj dlist -- ) : push-front ( obj dlist -- )
@ -78,16 +96,6 @@ PRIVATE>
: pop-back* ( dlist -- ) pop-back drop ; : pop-back* ( dlist -- ) pop-back drop ;
: (dlist-find-node) ( quot dlist-node -- node/f ? )
dup dlist-node-obj pick dupd call [
drop nip t
] [
drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
] if ;
: dlist-find-node ( quot dlist -- node/f ? )
dlist-front [ (dlist-find-node) ] [ drop f f ] if* ;
: dlist-find ( quot dlist -- obj/f ? ) : dlist-find ( quot dlist -- obj/f ? )
dlist-find-node dup [ >r dlist-node-obj r> ] when ; dlist-find-node dup [ >r dlist-node-obj r> ] when ;
@ -102,20 +110,15 @@ PRIVATE>
dec-length ] } dec-length ] }
} cond ; } cond ;
: delete-node ( quot dlist -- obj/f ) : delete-node* ( quot dlist -- obj/f ? )
tuck dlist-find-node [ tuck dlist-find-node [
[ (delete-node) ] keep [ dlist-node-obj ] [ f ] if* [ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if*
] [ ] [
2drop f 2drop f f
] if ; ] if ;
: (dlist-each-node) ( quot dlist -- ) : delete-node ( quot dlist -- obj/f )
over delete-node* drop ;
[ 2dup call >r dlist-node-next r> (dlist-each-node) ]
[ 2drop ] if ;
: dlist-each-node ( quot dlist -- )
>r dlist-front r> (dlist-each-node) ; inline
: dlist-each ( dlist quot -- ) : dlist-each ( dlist quot -- )
[ dlist-node-obj ] swap compose dlist-each-node ; inline [ dlist-node-obj ] swap compose dlist-each-node ; inline