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