basis/unrolled-lists/unrolled-lists.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays math kernel accessors sequences sequences.private
   4 deques search-deques hashtables ;
   5 IN: unrolled-lists
   6
   7 CONSTANT: unroll-factor 32
   8
   9 <PRIVATE
  10
  11 MIXIN: ?node
  12 INSTANCE: f ?node
  13 TUPLE: node { data array } { prev ?node } { next ?node } ;
  14 INSTANCE: node ?node
  15
  16 PRIVATE>
  17
  18 TUPLE: unrolled-list
  19 { front ?node } { front-pos fixnum }
  20 { back ?node } { back-pos fixnum } ;
  21
  22 : <unrolled-list> ( -- list )
  23     unrolled-list new
  24         unroll-factor >>back-pos ; inline
  25
  26 : <hashed-unrolled-list> ( -- search-deque )
  27     20 <hashtable> <unrolled-list> <search-deque> ;
  28
  29 ERROR: empty-unrolled-list list ;
  30
  31 <PRIVATE
  32
  33 M: unrolled-list deque-empty?
  34     dup [ front>> ] [ back>> ] bi dup [
  35         eq? [ [ front-pos>> ] [ back-pos>> ] bi eq? ] [ drop f ] if
  36     ] [ 3drop t ] if ;
  37
  38 M: unrolled-list clear-deque
  39     f >>front
  40     0 >>front-pos
  41     f >>back
  42     unroll-factor >>back-pos
  43     drop ;
  44
  45 : <front-node> ( elt front -- node )
  46     [
  47         unroll-factor 0 <array>
  48         [ unroll-factor 1 - swap set-nth ] keep f
  49     ] dip [ node boa dup ] keep
  50     [ prev<< ] [ drop ] if* ; inline
  51
  52 : normalize-back ( list -- )
  53     dup back>> [
  54         dup prev>> [ drop ] [ swap front>> >>prev ] if
  55     ] [ dup front>> >>back ] if* drop ; inline
  56
  57 : push-front/new ( elt list -- )
  58     unroll-factor 1 - >>front-pos
  59     [ <front-node> ] change-front
  60     normalize-back ; inline
  61
  62 : push-front/existing ( elt list front -- )
  63     [ [ 1 - ] change-front-pos ] dip
  64     [ front-pos>> ] [ data>> ] bi* set-nth-unsafe ; inline
  65
  66 M: unrolled-list push-front*
  67     dup [ front>> ] [ front-pos>> 0 eq? not ] bi
  68     [ drop ] [ and ] 2bi
  69     [ push-front/existing ] [ drop push-front/new ] if f ;
  70
  71 M: unrolled-list peek-front*
  72     dup front>>
  73     [ [ front-pos>> ] dip data>> nth-unsafe t ]
  74     [ drop f f ]
  75     if* ;
  76
  77 : pop-front/new ( list front -- )
  78     [ 0 >>front-pos ] dip
  79     [ f ] change-next drop dup [ f >>prev ] when >>front
  80     dup front>> [ normalize-back ] [ f >>back drop ] if ; inline
  81
  82 : pop-front/existing ( list front -- )
  83     [ dup front-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
  84     [ 1 + ] change-front-pos
  85     drop ; inline
  86
  87 M: unrolled-list pop-front*
  88     dup front>> [ empty-unrolled-list ] unless*
  89     over front-pos>> unroll-factor 1 - eq?
  90     [ pop-front/new ] [ pop-front/existing ] if ;
  91
  92 : <back-node> ( elt back -- node )
  93     [
  94         unroll-factor 0 <array> [ set-first ] keep
  95     ] dip [ f node boa dup ] keep
  96     [ next<< ] [ drop ] if* ; inline
  97
  98 : normalize-front ( list -- )
  99     dup front>> [
 100         dup next>> [ drop ] [ swap back>> >>next ] if
 101     ] [ dup back>> >>front ] if* drop ; inline
 102
 103 : push-back/new ( elt list -- )
 104     1 >>back-pos
 105     [ <back-node> ] change-back
 106     normalize-front ; inline
 107
 108 : push-back/existing ( elt list back -- )
 109     [ [ 1 + ] change-back-pos ] dip
 110     [ back-pos>> 1 - ] [ data>> ] bi* set-nth-unsafe ; inline
 111
 112 M: unrolled-list push-back*
 113     dup [ back>> ] [ back-pos>> unroll-factor eq? not ] bi
 114     [ drop ] [ and ] 2bi
 115     [ push-back/existing ] [ drop push-back/new ] if f ;
 116
 117 M: unrolled-list peek-back*
 118     dup back>>
 119     [ [ back-pos>> 1 - ] dip data>> nth-unsafe t ]
 120     [ drop f f ]
 121     if* ;
 122
 123 : pop-back/new ( list back -- )
 124     [ unroll-factor >>back-pos ] dip
 125     [ f ] change-prev drop dup [ f >>next ] when >>back
 126     dup back>> [ normalize-front ] [ f >>front drop ] if ; inline
 127
 128 : pop-back/existing ( list back -- )
 129     [ [ 1 - ] change-back-pos ] dip
 130     [ dup back-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
 131     drop ; inline
 132
 133 M: unrolled-list pop-back*
 134     dup back>> [ empty-unrolled-list ] unless*
 135     over back-pos>> 1 eq?
 136     [ pop-back/new ] [ pop-back/existing ] if ;
 137
 138 PRIVATE>
 139
 140 INSTANCE: unrolled-list deque