basis/dlists/dlists.factor

   1 ! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
   2 ! Slava Pestov.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: combinators kernel math sequences accessors dequeues ;
   5 IN: dlists
   6
   7 TUPLE: dlist front back length ;
   8
   9 : <dlist> ( -- obj )
  10     dlist new
  11         0 >>length ;
  12
  13 M: dlist dequeue-length length>> ;
  14
  15 <PRIVATE
  16
  17 TUPLE: dlist-node obj prev next ;
  18
  19 C: <dlist-node> dlist-node
  20
  21 M: dlist-node node-value obj>> ;
  22
  23 : inc-length ( dlist -- )
  24     [ 1+ ] change-length drop ; inline
  25
  26 : dec-length ( dlist -- )
  27     [ 1- ] change-length drop ; inline
  28
  29 : set-prev-when ( dlist-node dlist-node/f -- )
  30     [ (>>prev) ] [ drop ] if* ;
  31
  32 : set-next-when ( dlist-node dlist-node/f -- )
  33     [ (>>next) ] [ drop ] if* ;
  34
  35 : set-next-prev ( dlist-node -- )
  36     dup next>> set-prev-when ;
  37
  38 : normalize-front ( dlist -- )
  39     dup back>> [ f >>front ] unless drop ;
  40
  41 : normalize-back ( dlist -- )
  42     dup front>> [ f >>back ] unless drop ;
  43
  44 : set-back-to-front ( dlist -- )
  45     dup back>> [ dup front>> >>back ] unless drop ;
  46
  47 : set-front-to-back ( dlist -- )
  48     dup front>> [ dup back>> >>front ] unless drop ;
  49
  50 : (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
  51     over [
  52         [ call ] 2keep rot
  53         [ drop t ] [ >r next>> r> (dlist-find-node) ] if
  54     ] [ 2drop f f ] if ; inline recursive
  55
  56 : dlist-find-node ( dlist quot -- node/f ? )
  57     >r front>> r> (dlist-find-node) ; inline
  58
  59 : dlist-each-node ( dlist quot -- )
  60     [ f ] compose dlist-find-node 2drop ; inline
  61
  62 : unlink-node ( dlist-node -- )
  63     dup prev>> over next>> set-prev-when
  64     dup next>> swap prev>> set-next-when ;
  65
  66 PRIVATE>
  67
  68 M: dlist push-front* ( obj dlist -- dlist-node )
  69     [ front>> f swap <dlist-node> dup dup set-next-prev ] keep
  70     [ (>>front) ] keep
  71     [ set-back-to-front ] keep
  72     inc-length ;
  73
  74 M: dlist push-back* ( obj dlist -- dlist-node )
  75     [ back>> f <dlist-node> ] keep
  76     [ back>> set-next-when ] 2keep
  77     [ (>>back) ] 2keep
  78     [ set-front-to-back ] keep
  79     inc-length ;
  80
  81 ERROR: empty-dlist ;
  82
  83 M: dlist peek-front ( dlist -- obj )
  84     front>> [ obj>> ] [ empty-dlist ] if* ;
  85
  86 M: dlist pop-front* ( dlist -- )
  87     dup front>> [ empty-dlist ] unless
  88     [
  89         dup front>>
  90         dup next>>
  91         f rot (>>next)
  92         f over set-prev-when
  93         swap (>>front)
  94     ] keep
  95     [ normalize-back ] keep
  96     dec-length ;
  97
  98 M: dlist peek-back ( dlist -- obj )
  99     back>> [ obj>> ] [ empty-dlist ] if* ;
 100
 101 M: dlist pop-back* ( dlist -- )
 102     dup back>> [ empty-dlist ] unless
 103     [
 104         dup back>>
 105         dup prev>>
 106         f rot (>>prev)
 107         f over set-next-when
 108         swap (>>back)
 109     ] keep
 110     [ normalize-front ] keep
 111     dec-length ;
 112
 113 : dlist-find ( dlist quot -- obj/f ? )
 114     [ obj>> ] prepose
 115     dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
 116
 117 : dlist-contains? ( dlist quot -- ? )
 118     dlist-find nip ; inline
 119
 120 M: dlist dequeue-member? ( value dlist -- ? )
 121     [ = ] with dlist-contains? ;
 122
 123 M: dlist delete-node ( dlist-node dlist -- )
 124     {
 125         { [ 2dup front>> eq? ] [ nip pop-front* ] }
 126         { [ 2dup back>> eq? ] [ nip pop-back* ] }
 127         [ dec-length unlink-node ]
 128     } cond ;
 129
 130 : delete-node-if* ( dlist quot -- obj/f ? )
 131     dupd dlist-find-node [
 132         dup [
 133             [ swap delete-node ] keep obj>> t
 134         ] [
 135             2drop f f
 136         ] if
 137     ] [
 138         2drop f f
 139     ] if ; inline
 140
 141 : delete-node-if ( dlist quot -- obj/f )
 142     [ obj>> ] prepose delete-node-if* drop ; inline
 143
 144 M: dlist clear-dequeue ( dlist -- )
 145     f >>front
 146     f >>back
 147     0 >>length
 148     drop ;
 149
 150 : dlist-each ( dlist quot -- )
 151     [ obj>> ] prepose dlist-each-node ; inline
 152
 153 : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
 154
 155 INSTANCE: dlist dequeue