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: fry kernel make math sequences strings ;
   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-reduce ( ... obj identity quot: ( ... prev elt -- ... next ) -- ... result )
  20     swapd deep-each ; inline
  21
  22 : deep-map ( ... obj quot: ( ... elt -- ... elt' ) -- ... newobj )
  23     [ call ] keep over branch?
  24     [ '[ _ deep-map ] map ] [ drop ] if ; inline recursive
  25
  26 : deep-filter-as ( ... obj quot: ( ... elt -- ... ? ) exemplar -- ... seq )
  27     [ selector [ deep-each ] dip ] dip [ like ] when* ; inline recursive
  28
  29 : deep-filter ( ... obj quot: ( ... elt -- ... ? ) -- ... seq )
  30     over dup branch? [ drop f ] unless deep-filter-as ; inline
  31
  32 : deep-reject-as ( ... obj quot: ( ... elt -- ... ? ) exemplar -- ... seq )
  33     [ [ not ] compose ] dip deep-filter-as ; inline
  34
  35 : deep-reject ( ... obj quot: ( ... elt -- ... ? ) -- ... seq )
  36     [ not ] compose deep-filter ; inline
  37
  38 : (deep-find) ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ? )
  39     [ call ] 2keep rot [ drop t ] [
  40         over branch? [
  41             [ f ] 2dip '[ nip _ (deep-find) ] any?
  42         ] [ 2drop f f ] if
  43     ] if ; inline recursive
  44
  45 : deep-find ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ) (deep-find) drop ; inline
  46
  47 : deep-any? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? ) (deep-find) nip ; inline
  48
  49 : deep-all? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? )
  50     '[ @ not ] deep-any? not ; inline
  51
  52 : deep-member? ( obj seq -- ? )
  53     swap '[
  54         _ swap dup branch? [ member? ] [ 2drop f ] if
  55     ] deep-find >boolean ;
  56
  57 : deep-subseq-of? ( seq subseq -- ? )
  58    '[
  59         _ over branch? [ subseq-of? ] [ 2drop f ] if
  60     ] deep-find >boolean ;
  61
  62 : deep-map! ( ... obj quot: ( ... elt -- ... elt' ) -- ... obj )
  63     over branch? [
  64         '[ _ [ call ] keep over [ deep-map! drop ] dip ] map!
  65     ] [ drop ] if ; inline recursive
  66
  67 : flatten ( obj -- seq )
  68     [ branch? ] deep-reject ;
  69
  70 : flatten-as ( obj exemplar -- seq )
  71     [ branch? ] swap deep-reject-as ;
  72
  73 : flatten1 ( obj -- seq )
  74     [
  75         [
  76             dup branch? [
  77                 [ dup branch? [ % ] [ , ] if ] each
  78             ] [ , ] if
  79         ]
  80     ] keep dup branch? [ drop f ] unless make ;