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