basis/sequences/deep/deep.factor

   1 ! Copyright (C) 2007, 2008 Daniel Ehrenberg, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences kernel strings math fry ;
   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 ] each ] [ 2drop ] if ; inline recursive
  18
  19 : deep-map ( obj quot: ( elt -- elt' ) -- newobj )
  20     [ call ] keep over branch?
  21     [ '[ _ deep-map ] map ] [ drop ] if ; inline recursive
  22
  23 : deep-filter ( obj quot: ( elt -- ? ) -- seq )
  24     over [ pusher [ deep-each ] dip ] dip
  25     dup branch? [ like ] [ drop ] if ; inline recursive
  26
  27 : (deep-find) ( obj quot: ( elt -- ? ) -- elt ? )
  28     [ call ] 2keep rot [ drop t ] [
  29         over branch? [
  30             [ f ] 2dip '[ nip _ (deep-find) ] find drop >boolean
  31         ] [ 2drop f f ] if
  32     ] if ; inline recursive
  33
  34 : deep-find ( obj quot -- elt ) (deep-find) drop ; inline
  35
  36 : deep-any? ( obj quot -- ? ) (deep-find) nip ; inline
  37
  38 : deep-all? ( obj quot -- ? )
  39     '[ @ not ] deep-any? not ; inline
  40
  41 : deep-member? ( obj seq -- ? )
  42     swap '[
  43         _ swap dup branch? [ member? ] [ 2drop f ] if
  44     ] deep-find >boolean ;
  45
  46 : deep-subseq? ( subseq seq -- ? )
  47     swap '[
  48         _ swap dup branch? [ subseq? ] [ 2drop f ] if
  49     ] deep-find >boolean ;
  50
  51 : deep-change-each ( obj quot: ( elt -- elt' ) -- )
  52     over branch? [
  53         '[ _ [ call ] keep over [ deep-change-each ] dip ] change-each
  54     ] [ 2drop ] if ; inline recursive
  55
  56 : flatten ( obj -- seq )
  57     [ branch? not ] deep-filter ;