Unrolled lists

basis/dlists/dlists-docs.factor

@@ -24,7 +24,10 @@ $nl
 
 ABOUT: "dlists"
 
-HELP: <hashed-dlist> ( -- search-deque )
+HELP: <dlist>
+{ $description "Creates a new double-linked list." } ;
+
+HELP: <hashed-dlist>
 { $values { "search-deque" search-deque } }
 { $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ;
 

basis/unrolled-lists/unrolled-lists-docs.factor

@@ -0,0 +1,22 @@
+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"

basis/unrolled-lists/unrolled-lists-tests.factor

@@ -0,0 +1,130 @@
+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

basis/unrolled-lists/unrolled-lists.factor

@@ -0,0 +1,140 @@
+! 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