-! Copyright (C) 2007 Daniel Ehrenberg
+! Copyright (C) 2007, 2008 Daniel Ehrenberg, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel strings math ;
+USING: fry kernel make math sequences strings ;
IN: sequences.deep
! All traversal goes in postorder
M: string branch? drop f ;
M: object branch? drop f ;
-: deep-each ( obj quot: ( elt -- ) -- )
+: deep-each ( ... obj quot: ( ... elt -- ... ) -- ... )
[ call ] 2keep over branch?
- [ [ deep-each ] curry each ] [ 2drop ] if ; inline recursive
+ [ '[ _ deep-each ] each ] [ 2drop ] if ; inline recursive
-: deep-map ( obj quot: ( elt -- elt' ) -- newobj )
+: deep-reduce ( ... obj identity quot: ( ... prev elt -- ... next ) -- ... result )
+ swapd deep-each ; inline
+
+: deep-map ( ... obj quot: ( ... elt -- ... elt' ) -- ... newobj )
[ call ] keep over branch?
- [ [ deep-map ] curry map ] [ drop ] if ; inline recursive
+ [ '[ _ deep-map ] map ] [ drop ] if ; inline recursive
+
+: deep-filter-as ( ... obj quot: ( ... elt -- ... ? ) exemplar -- ... seq )
+ [ selector [ deep-each ] dip ] dip [ like ] when* ; inline recursive
+
+: deep-filter ( ... obj quot: ( ... elt -- ... ? ) -- ... seq )
+ over dup branch? [ drop f ] unless deep-filter-as ; inline
+
+: deep-reject-as ( ... obj quot: ( ... elt -- ... ? ) exemplar -- ... seq )
+ [ [ not ] compose ] dip deep-filter-as ; inline
-: deep-filter ( obj quot: ( elt -- ? ) -- seq )
- over >r
- pusher >r deep-each r>
- r> dup branch? [ like ] [ drop ] if ; inline recursive
+: deep-reject ( ... obj quot: ( ... elt -- ... ? ) -- ... seq )
+ [ not ] compose deep-filter ; inline
-: deep-find-from ( obj quot: ( elt -- ? ) -- elt ? )
+: (deep-find) ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ? )
[ call ] 2keep rot [ drop t ] [
over branch? [
- f -rot [ >r nip r> deep-find-from ] curry find drop >boolean
- ] [ 2drop f f ] if
+ [ f ] 2dip '[ nip _ (deep-find) ] any?
+ ] [ 2drop f f ] if
] if ; inline recursive
-: deep-find ( obj quot -- elt ) deep-find-from drop ; inline
+: deep-find ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ) (deep-find) drop ; inline
-: deep-contains? ( obj quot -- ? ) deep-find-from nip ; inline
+: deep-any? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? ) (deep-find) nip ; inline
-: deep-all? ( obj quot -- ? )
- [ not ] compose deep-contains? not ; inline
+: deep-all? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? )
+ '[ @ not ] deep-any? not ; inline
-: deep-change-each ( obj quot: ( elt -- elt' ) -- )
- over branch? [ [
- [ call ] keep over >r deep-change-each r>
- ] curry change-each ] [ 2drop ] if ; inline recursive
+: deep-member? ( obj seq -- ? )
+ swap '[
+ _ swap dup branch? [ member? ] [ 2drop f ] if
+ ] deep-find >boolean ;
+
+: deep-subseq-of? ( seq subseq -- ? )
+ '[
+ _ over branch? [ subseq-of? ] [ 2drop f ] if
+ ] deep-find >boolean ;
+
+: deep-map! ( ... obj quot: ( ... elt -- ... elt' ) -- ... obj )
+ over branch? [
+ '[ _ [ call ] keep over [ deep-map! drop ] dip ] map!
+ ] [ drop ] if ; inline recursive
: flatten ( obj -- seq )
- [ branch? not ] deep-filter ;
+ [ branch? ] deep-reject ;
+
+: flatten-as ( obj exemplar -- seq )
+ [ branch? ] swap deep-reject-as ;
+
+: flatten1 ( obj -- seq )
+ [
+ [
+ dup branch? [
+ [ dup branch? [ % ] [ , ] if ] each
+ ] [ , ] if
+ ]
+ ] keep dup branch? [ drop f ] unless make ;