sequences.extras: Add find-pred

diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor
index d4619b1c5fc310efa49e85f9e8fbe924aa224d4d..3baa5721233e8c2c30b88e6a1f371e7c9df87c61 100644 (file)
--- a/basis/shuffle/shuffle.factor
+++ b/basis/shuffle/shuffle.factor
@@ -15,3 +15,5 @@ SYNTAX: shuffle(
     ")" parse-effect suffix! \ shuffle-effect suffix! ;
 
 : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline
+
+: 2pick ( x y z t -- x y z t x y ) reach reach ; inline

diff --git a/extra/sequences/extras/extras-docs.factor b/extra/sequences/extras/extras-docs.factor
index 7084a4daa48806adc05c414f01f9a2b5106a4834..28d1f7da6b0ad2e39554223392caa505d51dfee3 100644 (file)
--- a/extra/sequences/extras/extras-docs.factor
+++ b/extra/sequences/extras/extras-docs.factor
@@ -409,3 +409,13 @@ HELP: zero-loop>sequence
         [[ 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
+    ]=]
+} ;

diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index a85b6c087e8538a4f8f17523009a82fbce4f5e1c..c9207763328967c9b4d39eabda0ca2d9a0ef16ae 100644 (file)
--- a/extra/sequences/extras/extras-tests.factor
+++ b/extra/sequences/extras/extras-tests.factor
@@ -279,3 +279,6 @@ tools.test vectors vocabs ;
 { 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

diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index be95883f3b05fe0fd04a42be604784395e89f8e4..a418da6a4c821292034cd5848e566834c4462cf0 100644 (file)
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -1,7 +1,7 @@
 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 )
@@ -622,6 +622,9 @@ PRIVATE>
 : 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
@@ -649,3 +652,18 @@ PRIVATE>
 : 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