diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor index 2ea5abf787..5a19936a97 100644 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -24,7 +24,10 @@ $nl ABOUT: "dlists" -HELP: ( -- search-deque ) +HELP: +{ $description "Creates a new double-linked list." } ; + +HELP: { $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." } ; diff --git a/basis/unrolled-lists/unrolled-lists-docs.factor b/basis/unrolled-lists/unrolled-lists-docs.factor new file mode 100644 index 0000000000..387bb3dc7b --- /dev/null +++ b/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: +{ $values { "list" unrolled-list } } +{ $description "Creates a new unrolled list." } ; + +HELP: +{ $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 } +{ $subsection } ; + +ABOUT: "unrolled-lists" diff --git a/basis/unrolled-lists/unrolled-lists-tests.factor b/basis/unrolled-lists/unrolled-lists-tests.factor new file mode 100644 index 0000000000..89eb1cdebd --- /dev/null +++ b/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 ] [ 1 over push-front pop-front ] unit-test +[ 1 ] [ 1 over push-front pop-back ] unit-test +[ 1 ] [ 1 over push-back pop-front ] unit-test +[ 1 ] [ 1 over push-back pop-back ] unit-test + +[ 1 2 ] [ + 1 over push-back 2 over push-back + [ pop-front ] [ pop-front ] bi +] unit-test + +[ 2 1 ] [ + 1 over push-back 2 over push-back + [ pop-back ] [ pop-back ] bi +] unit-test + +[ 1 2 3 ] [ + + 1 over push-back + 2 over push-back + 3 over push-back + [ pop-front ] [ pop-front ] [ pop-front ] tri +] unit-test + +[ 3 2 1 ] [ + + 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 } ] [ + + 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 } ] [ + + 32 [ over push-front ] each + 32 [ dup pop-front ] replicate reverse + nip +] unit-test + +[ t ] [ + + 1000 [ 1000 random ] replicate + [ [ over push-front ] each ] + [ [ dup pop-back ] replicate ] + [ ] + tri + = + nip +] unit-test + +[ t ] [ + + 1000 [ 1000 random ] replicate + [ + 10 group [ + [ [ over push-front ] each ] + [ [ dup pop-back ] replicate ] + bi + ] map concat + ] keep + = + nip +] unit-test + +[ t ] [ deque-empty? ] unit-test + +[ t ] [ + + 1 over push-front + dup pop-front* + deque-empty? +] unit-test + +[ t ] [ + + 1 over push-back + dup pop-front* + deque-empty? +] unit-test + +[ t ] [ + + 1 over push-front + dup pop-back* + deque-empty? +] unit-test + +[ t ] [ + + 1 over push-back + dup pop-back* + deque-empty? +] unit-test + +[ t ] [ + + 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 diff --git a/basis/unrolled-lists/unrolled-lists.factor b/basis/unrolled-lists/unrolled-lists.factor new file mode 100644 index 0000000000..27f7175315 --- /dev/null +++ b/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 + + + +TUPLE: unrolled-list +{ front ?node } { front-pos fixnum } +{ back ?node } { back-pos fixnum } ; + +: ( -- list ) + unrolled-list new + unroll-factor >>back-pos ; inline + +: ( -- list ) + 20 ; + +ERROR: empty-unrolled-list list ; + +> ] [ 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 ; + +: ( elt front -- node ) + [ + unroll-factor 0 + [ 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 + [ ] 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 ; + +: ( elt back -- node ) + [ + unroll-factor 0 [ 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 + [ ] 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