basis/dlists/dlists.factor

   1 ! Copyright (C) 2007, 2009 Mackenzie Straight, Doug Coleman,
   2 ! Slava Pestov.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: accessors arrays combinators combinators.short-circuit
   5 deques fry hashtables kernel parser search-deques sequences
   6 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>> ] bi@ = ] } 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     dup prev>> over next>> set-prev-when
  91     dup next>> swap prev>> set-next-when ; inline
  92
  93 M: dlist push-front* ( obj dlist -- dlist-node )
  94     [ front>> f swap <dlist-node> dup dup set-next-prev ] keep
  95     [ front<< ] keep
  96     set-back-to-front ;
  97
  98 : push-node-front ( dlist-node dlist -- )
  99     [ front>> >>next drop ]
 100     [ front<< ]
 101     [ [ set-next-prev ] [ set-back-to-front ] bi* ] 2tri ;
 102
 103 : push-node-back ( dlist-node dlist -- )
 104     [ back>> >>prev drop ]
 105     [ back<< ]
 106     [ [ set-prev-next ] [ set-front-to-back ] bi* ] 2tri ;
 107
 108 M: dlist push-back* ( obj dlist -- dlist-node )
 109     [ back>> f <dlist-node> ] keep
 110     [ back>> set-next-when ] 2keep
 111     [ back<< ] 2keep
 112     set-front-to-back ;
 113
 114 M: dlist peek-front* ( dlist -- obj/f ? )
 115     front>> [ obj>> t ] [ f f ] if* ;
 116
 117 M: dlist peek-back* ( dlist -- obj/f ? )
 118     back>> [ obj>> t ] [ f f ] if* ;
 119
 120 M: dlist pop-front* ( dlist -- )
 121     [
 122         [
 123             [ empty-deque ] unless*
 124             next>>
 125             f over set-prev-when
 126         ] change-front drop
 127     ] keep
 128     normalize-back ;
 129
 130 M: dlist pop-back* ( dlist -- )
 131     [
 132         [
 133             [ empty-deque ] unless*
 134             prev>>
 135             f over set-next-when
 136         ] change-back drop
 137     ] keep
 138     normalize-front ;
 139
 140 : dlist-find ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
 141     '[ obj>> @ ] dlist-find-node [ obj>> t ] [ f f ] if* ; inline
 142
 143 : dlist-any? ( ... dlist quot: ( ... value -- ... ? ) -- ... ? )
 144     dlist-find nip ; inline
 145
 146 M: dlist deque-member? ( value dlist -- ? )
 147     [ = ] with dlist-any? ;
 148
 149 M: dlist delete-node ( dlist-node dlist -- )
 150     [
 151         {
 152             { [ 2dup front>> eq? ] [ nip pop-front* ] }
 153             { [ 2dup back>> eq? ] [ nip pop-back* ] }
 154             [ drop unlink-node ]
 155         } cond
 156     ] [ drop f >>prev f >>next drop ] 2bi ;
 157
 158 : delete-node-if* ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
 159     dupd dlist-find-node [
 160         dup [
 161             [ swap delete-node ] keep obj>> t
 162         ] [
 163             2drop f f
 164         ] if
 165     ] [
 166         drop f f
 167     ] if* ; inline
 168
 169 : delete-node-if ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f )
 170     '[ obj>> @ ] delete-node-if* drop ; inline
 171
 172 M: dlist clear-deque ( dlist -- )
 173     f >>front
 174     f >>back
 175     drop ;
 176
 177 : dlist-each ( ... dlist quot: ( ... value -- ... ) -- ... )
 178     '[ obj>> @ ] dlist-each-node ; inline
 179
 180 : dlist>sequence ( dlist -- seq )
 181     [ ] collector [ dlist-each ] dip ;
 182
 183 : >dlist ( seq -- dlist )
 184     <dlist> [ '[ _ push-back ] each ] keep ;
 185
 186 : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
 187
 188 : dlist-filter ( ... dlist quot: ( ... value -- ... ? ) -- ... dlist' )
 189     [ not ] compose
 190     <dlist> [ '[ dup obj>> @ [ drop ] [ obj>> _ push-back ] if ] dlist-each-node ] keep ; inline
 191
 192 M: dlist clone
 193     <dlist> [ '[ _ push-back ] dlist-each ] keep ;
 194
 195 INSTANCE: dlist deque
 196
 197 SYNTAX: DL{ \ } [ >dlist ] parse-literal ;
 198
 199 { "dlists" "prettyprint" } "dlists.prettyprint" require-when