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 ;
6 ! All traversal goes in postorder
8 GENERIC: branch? ( object -- ? )
10 M: sequence branch? drop t ;
11 M: integer branch? drop f ;
12 M: string branch? drop f ;
13 M: object branch? drop f ;
15 : deep-each ( ... obj quot: ( ... elt -- ... ) -- ... )
16 [ call ] 2keep over branch?
17 [ '[ _ deep-each ] each ] [ 2drop ] if ; inline recursive
19 : deep-reduce ( ... obj identity quot: ( ... prev elt -- ... next ) -- ... result )
20 swapd deep-each ; inline
22 : deep-map ( ... obj quot: ( ... elt -- ... elt' ) -- ... newobj )
23 [ call ] keep over branch?
24 [ '[ _ deep-map ] map ] [ drop ] if ; inline recursive
26 : deep-filter-as ( ... obj quot: ( ... elt -- ... ? ) exemplar -- ... seq )
27 [ selector [ deep-each ] dip ] dip [ like ] when* ; inline recursive
29 : deep-filter ( ... obj quot: ( ... elt -- ... ? ) -- ... seq )
30 over dup branch? [ drop f ] unless deep-filter-as ; inline
32 : deep-reject-as ( ... obj quot: ( ... elt -- ... ? ) exemplar -- ... seq )
33 [ [ not ] compose ] dip deep-filter-as ; inline
35 : deep-reject ( ... obj quot: ( ... elt -- ... ? ) -- ... seq )
36 [ not ] compose deep-filter ; inline
38 : (deep-find) ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ? )
39 [ call ] 2keep rot [ drop t ] [
41 [ f ] 2dip '[ nip _ (deep-find) ] any?
43 ] if ; inline recursive
45 : deep-find ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ) (deep-find) drop ; inline
47 : deep-any? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? ) (deep-find) nip ; inline
49 : deep-all? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? )
50 '[ @ not ] deep-any? not ; inline
52 : deep-member? ( obj seq -- ? )
54 _ swap dup branch? [ member? ] [ 2drop f ] if
55 ] deep-find >boolean ;
57 : deep-subseq-index? ( seq subseq -- ? )
59 _ over branch? [ subseq-index? ] [ 2drop f ] if
60 ] deep-find >boolean ;
62 : deep-map! ( ... obj quot: ( ... elt -- ... elt' ) -- ... obj )
64 '[ _ [ call ] keep over [ deep-map! drop ] dip ] map!
65 ] [ drop ] if ; inline recursive
67 : flatten ( obj -- seq )
68 [ branch? ] deep-reject ;
70 : flatten-as ( obj exemplar -- seq )
71 [ branch? ] swap deep-reject-as ;
73 : flatten1 ( obj -- seq )
77 [ dup branch? [ % ] [ , ] if ] each
80 ] keep dup branch? [ drop f ] unless make ;