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