--- /dev/null
+IN: unrolled-lists
+USING: help.markup help.syntax hashtables search-deques dlists
+deques ;
+
+HELP: unrolled-list
+{ $class-description "The class of unrolled lists." } ;
+
+HELP: <unrolled-list>
+{ $values { "list" unrolled-list } }
+{ $description "Creates a new unrolled list." } ;
+
+HELP: <hashed-unrolled-list>
+{ $values { "search-deque" search-deque } }
+{ $description "Creates a new " { $link search-deque } " backed by an " { $link unrolled-list } ", with a " { $link hashtable } " for fast membership tests." } ;
+
+ARTICLE: "unrolled-lists" "Unrolled lists"
+"The " { $vocab-link "unrolled-lists" } " vocabulary provides an implementation of the " { $link deque } " protocol with constant time insertion and removal at both ends, and lower memory overhead than a " { $link dlist } " due to packing 32 elements per every node. The one tradeoff is that unlike dlists, " { $link delete-node } " is not supported for unrolled lists."
+{ $subsection unrolled-list }
+{ $subsection <unrolled-list> }
+{ $subsection <hashed-unrolled-list> } ;
+
+ABOUT: "unrolled-lists"
--- /dev/null
+USING: unrolled-lists tools.test deques kernel sequences
+random prettyprint grouping ;
+IN: unrolled-lists.tests
+
+[ 1 ] [ <unrolled-list> 1 over push-front pop-front ] unit-test
+[ 1 ] [ <unrolled-list> 1 over push-front pop-back ] unit-test
+[ 1 ] [ <unrolled-list> 1 over push-back pop-front ] unit-test
+[ 1 ] [ <unrolled-list> 1 over push-back pop-back ] unit-test
+
+[ 1 2 ] [
+ <unrolled-list> 1 over push-back 2 over push-back
+ [ pop-front ] [ pop-front ] bi
+] unit-test
+
+[ 2 1 ] [
+ <unrolled-list> 1 over push-back 2 over push-back
+ [ pop-back ] [ pop-back ] bi
+] unit-test
+
+[ 1 2 3 ] [
+ <unrolled-list>
+ 1 over push-back
+ 2 over push-back
+ 3 over push-back
+ [ pop-front ] [ pop-front ] [ pop-front ] tri
+] unit-test
+
+[ 3 2 1 ] [
+ <unrolled-list>
+ 1 over push-back
+ 2 over push-back
+ 3 over push-back
+ [ pop-back ] [ pop-back ] [ pop-back ] tri
+] unit-test
+
+[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [
+ <unrolled-list>
+ 32 [ over push-front ] each
+ 32 [ dup pop-back ] replicate
+ nip
+] unit-test
+
+[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [
+ <unrolled-list>
+ 32 [ over push-front ] each
+ 32 [ dup pop-front ] replicate reverse
+ nip
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1000 [ 1000 random ] replicate
+ [ [ over push-front ] each ]
+ [ [ dup pop-back ] replicate ]
+ [ ]
+ tri
+ =
+ nip
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1000 [ 1000 random ] replicate
+ [
+ 10 group [
+ [ [ over push-front ] each ]
+ [ [ dup pop-back ] replicate ]
+ bi
+ ] map concat
+ ] keep
+ =
+ nip
+] unit-test
+
+[ t ] [ <unrolled-list> deque-empty? ] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1 over push-front
+ dup pop-front*
+ deque-empty?
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1 over push-back
+ dup pop-front*
+ deque-empty?
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1 over push-front
+ dup pop-back*
+ deque-empty?
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1 over push-back
+ dup pop-back*
+ deque-empty?
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 21 over push-front
+ 22 over push-front
+ 25 over push-front
+ 26 over push-front
+ dup pop-back 21 assert=
+ 28 over push-front
+ dup pop-back 22 assert=
+ 29 over push-front
+ dup pop-back 25 assert=
+ 24 over push-front
+ dup pop-back 26 assert=
+ 23 over push-front
+ dup pop-back 28 assert=
+ dup pop-back 29 assert=
+ dup pop-back 24 assert=
+ 17 over push-front
+ dup pop-back 23 assert=
+ 27 over push-front
+ dup pop-back 17 assert=
+ 30 over push-front
+ dup pop-back 27 assert=
+ dup pop-back 30 assert=
+ deque-empty?
+] unit-test
--- /dev/null
+! 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> ( -- list )
+ 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