141 lines
3.7 KiB
Factor
141 lines
3.7 KiB
Factor
! Copyright (C) 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: arrays math kernel accessors sequences sequences.private
|
|
deques search-deques hashtables ;
|
|
IN: unrolled-lists
|
|
|
|
: unroll-factor 32 ; inline
|
|
|
|
<PRIVATE
|
|
|
|
MIXIN: ?node
|
|
INSTANCE: f ?node
|
|
TUPLE: node { data array } { prev ?node } { next ?node } ;
|
|
INSTANCE: node ?node
|
|
|
|
PRIVATE>
|
|
|
|
TUPLE: unrolled-list
|
|
{ front ?node } { front-pos fixnum }
|
|
{ back ?node } { back-pos fixnum } ;
|
|
|
|
: <unrolled-list> ( -- list )
|
|
unrolled-list new
|
|
unroll-factor >>back-pos ; inline
|
|
|
|
: <hashed-unrolled-list> ( -- search-deque )
|
|
20 <hashtable> <unrolled-list> <search-deque> ;
|
|
|
|
ERROR: empty-unrolled-list list ;
|
|
|
|
<PRIVATE
|
|
|
|
M: unrolled-list deque-empty?
|
|
dup [ front>> ] [ back>> ] bi dup [
|
|
eq? [ [ front-pos>> ] [ back-pos>> ] bi eq? ] [ drop f ] if
|
|
] [ 3drop t ] if ;
|
|
|
|
M: unrolled-list clear-deque
|
|
f >>front
|
|
0 >>front-pos
|
|
f >>back
|
|
unroll-factor >>back-pos
|
|
drop ;
|
|
|
|
: <front-node> ( elt front -- node )
|
|
[
|
|
unroll-factor 0 <array>
|
|
[ unroll-factor 1- swap set-nth ] keep f
|
|
] dip [ node boa dup ] keep
|
|
dup [ (>>prev) ] [ 2drop ] if ; inline
|
|
|
|
: normalize-back ( list -- )
|
|
dup back>> [
|
|
dup prev>> [ drop ] [ swap front>> >>prev ] if
|
|
] [ dup front>> >>back ] if* drop ; inline
|
|
|
|
: push-front/new ( elt list -- )
|
|
unroll-factor 1- >>front-pos
|
|
[ <front-node> ] change-front
|
|
normalize-back ; inline
|
|
|
|
: push-front/existing ( elt list front -- )
|
|
[ [ 1- ] change-front-pos ] dip
|
|
[ front-pos>> ] [ data>> ] bi* set-nth-unsafe ; inline
|
|
|
|
M: unrolled-list push-front*
|
|
dup [ front>> ] [ front-pos>> 0 eq? not ] bi
|
|
[ drop ] [ and ] 2bi
|
|
[ push-front/existing ] [ drop push-front/new ] if f ;
|
|
|
|
M: unrolled-list peek-front
|
|
dup front>>
|
|
[ [ front-pos>> ] dip data>> nth-unsafe ]
|
|
[ empty-unrolled-list ]
|
|
if* ;
|
|
|
|
: pop-front/new ( list front -- )
|
|
[ 0 >>front-pos ] dip
|
|
[ f ] change-next drop dup [ f >>prev ] when >>front
|
|
dup front>> [ normalize-back ] [ f >>back drop ] if ; inline
|
|
|
|
: pop-front/existing ( list front -- )
|
|
[ dup front-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
|
|
[ 1+ ] change-front-pos
|
|
drop ; inline
|
|
|
|
M: unrolled-list pop-front*
|
|
dup front>> [ empty-unrolled-list ] unless*
|
|
over front-pos>> unroll-factor 1- eq?
|
|
[ pop-front/new ] [ pop-front/existing ] if ;
|
|
|
|
: <back-node> ( elt back -- node )
|
|
[
|
|
unroll-factor 0 <array> [ set-first ] keep
|
|
] dip [ f node boa dup ] keep
|
|
dup [ (>>next) ] [ 2drop ] if ; inline
|
|
|
|
: normalize-front ( list -- )
|
|
dup front>> [
|
|
dup next>> [ drop ] [ swap back>> >>next ] if
|
|
] [ dup back>> >>front ] if* drop ; inline
|
|
|
|
: push-back/new ( elt list -- )
|
|
1 >>back-pos
|
|
[ <back-node> ] change-back
|
|
normalize-front ; inline
|
|
|
|
: push-back/existing ( elt list back -- )
|
|
[ [ 1+ ] change-back-pos ] dip
|
|
[ back-pos>> 1- ] [ data>> ] bi* set-nth-unsafe ; inline
|
|
|
|
M: unrolled-list push-back*
|
|
dup [ back>> ] [ back-pos>> unroll-factor eq? not ] bi
|
|
[ drop ] [ and ] 2bi
|
|
[ push-back/existing ] [ drop push-back/new ] if f ;
|
|
|
|
M: unrolled-list peek-back
|
|
dup back>>
|
|
[ [ back-pos>> 1- ] dip data>> nth-unsafe ]
|
|
[ empty-unrolled-list ]
|
|
if* ;
|
|
|
|
: pop-back/new ( list back -- )
|
|
[ unroll-factor >>back-pos ] dip
|
|
[ f ] change-prev drop dup [ f >>next ] when >>back
|
|
dup back>> [ normalize-front ] [ f >>front drop ] if ; inline
|
|
|
|
: pop-back/existing ( list back -- )
|
|
[ [ 1- ] change-back-pos ] dip
|
|
[ dup back-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
|
|
drop ; inline
|
|
|
|
M: unrolled-list pop-back*
|
|
dup back>> [ empty-unrolled-list ] unless*
|
|
over back-pos>> 1 eq?
|
|
[ pop-back/new ] [ pop-back/existing ] if ;
|
|
|
|
PRIVATE>
|
|
|
|
INSTANCE: unrolled-list deque
|