basis/sequences/deep/deep.factor

   1 ! Copyright (C) 2007 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences kernel strings math ;
   4 IN: sequences.deep
   5
   6 ! All traversal goes in postorder
   7
   8 GENERIC: branch? ( object -- ? )
   9
  10 M: sequence branch? drop t ;
  11 M: integer branch? drop f ;
  12 M: string branch? drop f ;
  13 M: object branch? drop f ;
  14
  15 : deep-each ( obj quot: ( elt -- ) -- )
  16     [ call ] 2keep over branch?
  17     [ [ deep-each ] curry each ] [ 2drop ] if ; inline recursive
  18
  19 : deep-map ( obj quot: ( elt -- elt' ) -- newobj )
  20     [ call ] keep over branch?
  21     [ [ deep-map ] curry map ] [ drop ] if ; inline recursive
  22
  23 : deep-filter ( obj quot: ( elt -- ? ) -- seq )
  24     over >r
  25     pusher >r deep-each r>
  26     r> dup branch? [ like ] [ drop ] if ; inline recursive
  27
  28 : deep-find-from ( obj quot: ( elt -- ? ) -- elt ? )
  29     [ call ] 2keep rot [ drop t ] [
  30         over branch? [
  31             f -rot [ >r nip r> deep-find-from ] curry find drop >boolean
  32         ] [ 2drop f f ] if
  33     ] if ; inline recursive
  34
  35 : deep-find ( obj quot -- elt ) deep-find-from drop ; inline
  36
  37 : deep-contains? ( obj quot -- ? ) deep-find-from nip ; inline
  38
  39 : deep-all? ( obj quot -- ? )
  40     [ not ] compose deep-contains? not ; inline
  41
  42 : deep-change-each ( obj quot: ( elt -- elt' ) -- )
  43     over branch? [ [
  44         [ call ] keep over >r deep-change-each r>
  45     ] curry change-each ] [ 2drop ] if ; inline recursive
  46
  47 : flatten ( obj -- seq )
  48     [ branch? not ] deep-filter ;