basis/dlists/dlists.factor

   1 ! Copyright (C) 2007, 2009 Mackenzie Straight, Doug Coleman,
   2 ! Slava Pestov, John Benediktsson.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: accessors combinators combinators.short-circuit deques
   5 hashtables kernel kernel.private math math.order parser
   6 search-deques sequences vocabs.loader ;
   7 IN: dlists
   8
   9 TUPLE: dlist-link
  10     { prev maybe{ dlist-link } }
  11     { next maybe{ dlist-link } } ;
  12
  13 TUPLE: dlist-node < dlist-link obj ;
  14
  15 M: dlist-link obj>> ;
  16
  17 M: dlist-link node-value obj>> ;
  18
  19 : new-dlist-link ( obj prev next class -- node )
  20     new
  21         swap >>next
  22         swap >>prev
  23         swap >>obj ; inline
  24
  25 : <dlist-node> ( obj prev next -- dlist-node )
  26     \ dlist-node new-dlist-link ; inline
  27
  28 TUPLE: dlist
  29     { front maybe{ dlist-link } }
  30     { back maybe{ dlist-link } } ;
  31
  32 : <dlist> ( -- list )
  33     dlist new ; inline
  34
  35 : <hashed-dlist> ( -- search-deque )
  36     20 <hashtable> <dlist> <search-deque> ;
  37
  38 M: dlist deque-empty? front>> not ; inline
  39
  40 M: dlist equal?
  41     over dlist? [
  42         [ front>> ] bi@
  43         [ 2dup { [ and ] [ [ obj>> ] same? ] } 2&& ]
  44         [ [ next>> ] bi@ ] while
  45         or not
  46     ] [
  47         2drop f
  48     ] if ;
  49
  50 : set-prev-when ( dlist-node dlist-node/f -- )
  51     [ prev<< ] [ drop ] if* ; inline
  52
  53 : set-next-when ( dlist-node dlist-node/f -- )
  54     [ next<< ] [ drop ] if* ; inline
  55
  56 : set-next-prev ( dlist-node -- )
  57     dup next>> set-prev-when ; inline
  58
  59 : set-prev-next ( dlist-node -- )
  60     dup prev>> set-next-when ;
  61
  62 : normalize-front ( dlist -- )
  63     dup back>> [ f >>front ] unless drop ; inline
  64
  65 : normalize-back ( dlist -- )
  66     dup front>> [ f >>back ] unless drop ; inline
  67
  68 : set-back-to-front ( dlist -- )
  69     dup back>> [ dup front>> >>back ] unless drop ; inline
  70
  71 : set-front-to-back ( dlist -- )
  72     dup front>> [ dup back>> >>front ] unless drop ; inline
  73
  74 : (dlist-find-node) ( ... dlist-node quot: ( ... node -- ... ? ) -- ... node/f )
  75     over [
  76         [ call ] 2keep rot
  77         [ drop ] [ [ next>> ] dip (dlist-find-node) ] if
  78     ] [ 2drop f ] if ; inline recursive
  79
  80 : dlist-find-node ( ... dlist quot: ( ... node -- ... ? ) -- ... node/f )
  81     [ front>> ] dip (dlist-find-node) ; inline
  82
  83 : dlist-find-node-prev ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
  84     dlist-find-node [ prev>> ] [ f ] if* ; inline
  85
  86 : dlist-each-node ( ... dlist quot: ( ... node -- ... ) -- ... )
  87     '[ @ f ] dlist-find-node drop ; inline
  88
  89 : unlink-node ( dlist-node -- )
  90     [ prev>> ] [ next>> ] bi
  91     [ set-prev-when ]
  92     [ swap set-next-when ] 2bi ; inline
  93
  94 M: dlist push-front*
  95     [
  96         f swap <dlist-node> dup dup set-next-prev
  97     ] change-front set-back-to-front ;
  98
  99 : push-node-front ( dlist-node dlist -- )
 100     dupd [ >>next ] change-front
 101     [ set-next-prev ] [ set-back-to-front ] bi* ;
 102
 103 : push-node-back ( dlist-node dlist -- )
 104     dupd [ >>prev ] change-back
 105     [ set-prev-next ] [ set-front-to-back ] bi* ;
 106
 107 M: dlist push-back*
 108     [
 109         [ f <dlist-node> dup dup ]
 110         [ set-next-when ] bi
 111     ] change-back set-front-to-back ;
 112
 113 M: dlist peek-front*
 114     front>> [ obj>> t ] [ f f ] if* ;
 115
 116 M: dlist peek-back*
 117     back>> [ obj>> t ] [ f f ] if* ;
 118
 119 M: dlist pop-front*
 120     [
 121         [ empty-deque ] unless*
 122         next>>
 123         f over set-prev-when
 124     ] change-front normalize-back ;
 125
 126 M: dlist pop-back*
 127     [
 128         [ empty-deque ] unless*
 129         prev>>
 130         f over set-next-when
 131     ] change-back normalize-front ;
 132
 133 : dlist-find ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
 134     '[ obj>> @ ] dlist-find-node [ obj>> t ] [ f f ] if* ; inline
 135
 136 : dlist-any? ( ... dlist quot: ( ... value -- ... ? ) -- ... ? )
 137     dlist-find nip ; inline
 138
 139 M: dlist deque-member?
 140     [ = ] with dlist-any? ;
 141
 142 M: dlist delete-node
 143     [
 144         {
 145             { [ 2dup front>> eq? ] [ nip pop-front* ] }
 146             { [ 2dup back>> eq? ] [ nip pop-back* ] }
 147             [ drop unlink-node ]
 148         } cond
 149     ] [ drop f >>prev f >>next drop ] 2bi ;
 150
 151 : delete-node-if* ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
 152     dupd dlist-find-node [
 153         dup [
 154             [ swap delete-node ] keep obj>> t
 155         ] [
 156             2drop f f
 157         ] if
 158     ] [
 159         drop f f
 160     ] if* ; inline
 161
 162 : delete-node-if ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f )
 163     '[ obj>> @ ] delete-node-if* drop ; inline
 164
 165 M: dlist clear-deque
 166     f >>front f >>back drop ;
 167
 168 : dlist-length ( dlist -- n )
 169     0 swap [
 170         drop { fixnum } declare 1 + f
 171     ] dlist-find-node drop ; flushable
 172
 173 : dlist-each ( ... dlist quot: ( ... value -- ... ) -- ... )
 174     '[ obj>> @ ] dlist-each-node ; inline
 175
 176 : dlist>sequence ( dlist -- seq )
 177     [ ] collector [ dlist-each ] dip ;
 178
 179 : >dlist ( seq -- dlist )
 180     <dlist> [ '[ _ push-back ] each ] keep ;
 181
 182 : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
 183
 184 : dlist-filter ( ... dlist quot: ( ... value -- ... ? ) -- ... dlist' )
 185     <dlist> [
 186         '[ _ keep swap [ _ push-back ] [ drop ] if ] dlist-each
 187     ] keep ; inline
 188
 189 M: dlist clone
 190     <dlist> [ '[ _ push-back ] dlist-each ] keep ;
 191
 192 <PRIVATE
 193
 194 : (push-before-node) ( obj dlist-node -- new-dlist-node )
 195     [ [ prev>> ] keep <dlist-node> dup ] keep
 196     [ dupd next<< ] change-prev drop ; inline
 197
 198 : push-before-node ( obj dlist-node dlist -- new-dlist-node )
 199     2dup front>> eq? [
 200         nip push-front*
 201     ] [
 202         drop (push-before-node)
 203     ] if ; inline
 204
 205 PRIVATE>
 206
 207 : push-before ( ... obj dlist quot: ( ... obj -- ... ? ) -- ... dlist-node )
 208     [ obj>> ] prepose over [ dlist-find-node ] dip swap
 209     [ swap push-before-node ] [ push-back* ] if* ; inline
 210
 211 : push-sorted ( obj dlist -- dlist-node )
 212     dupd [ before? ] with push-before ; inline
 213
 214 INSTANCE: dlist deque
 215
 216 SYNTAX: DL{ \ } [ >dlist ] parse-literal ;
 217
 218 { "dlists" "prettyprint" } "dlists.prettyprint" require-when