[[ V{ "zero" "one" "two" "three" "four" }]]
}
} ;
+
+HELP: find-pred
+{ $values seq: sequence quot: quotation pred: quotation calc/f: object i/f: object elt/f: object }
+{ $description A version of \ find that saves the calculation done by the first quotation and returns the calulation, element, and index if the calculation matches a predicate quotation. }
+{ $examples
+ [=[ USING: math kernel sequences.extras prettyprint ;
+ { 4 5 6 } [ sq ] [ 20 > ] find-pred [ . ] tri@
+ 25\n5\n1
+ ]=]
+} ;
{ 4 } [ { 1 2 3 4 } [ 5 < ] count-tail ] unit-test
{ SBUF" aco" SBUF" ftr" } [ SBUF" factor" dup [ even? ] extract! ] unit-test
+
+{ 25 5 1 } [ { 4 5 6 } [ sq ] [ 20 > ] find-pred ] unit-test
+{ f f f } [ { 4 5 6 } [ sq ] [ 200 > ] find-pred ] unit-test
\ No newline at end of file
USING: accessors arrays assocs combinators fry generalizations
grouping growable kernel locals make math math.order math.ranges
-sequences sequences.deep sequences.private sorting splitting
-vectors ;
+sequences sequences.deep sequences.private shuffle sorting
+splitting vectors ;
IN: sequences.extras
: find-all ( ... seq quot: ( ... elt -- ... ? ) -- ... elts )
: map-zip ( quot: ( key -- value ) -- alist )
'[ _ keep swap ] map>alist ; inline
+: assoc-map-zip ( quot: ( key value -- calc ) -- alist )
+ '[ _ 2keep 2array swap ] assoc-map ; inline
+
: take-while ( ... seq quot: ( ... elt -- ... ? ) -- head-slice )
[ '[ @ not ] find drop ] keepd swap
[ dup length ] unless* head-slice ; inline
: extract! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
[ dup ] compose over [ length ] keep new-resizable
[ [ push-if ] 2curry reject! ] keep swap like ; inline
+
+: find-pred-loop ( ... i n seq quot: ( ... elt -- ... calc ? ) -- ... calc/f i/f elt/f )
+ 2pick < [
+ [ nipd call ] 4keep
+ 7 nrot 7 nrot 7 nrot
+ [ [ 3drop ] 2dip rot ]
+ [ 2drop [ 1 + ] 3dip find-pred-loop ] if
+ ] [
+ 4drop f f f
+ ] if ; inline recursive
+
+: find-pred ( ... seq quot: ( ... elt -- ... calc ) pred: ( ... calc -- ... ? ) -- ... calc/f i/f elt/f )
+ [ 0 ] 3dip
+ [ [ length check-length ] keep ] 2dip
+ '[ nth-unsafe _ keep swap _ keep swap ] find-pred-loop swapd ; inline