From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 17 Feb 2023 04:17:34 +0000 (-0600)
Subject: combinators.extras: trying to figure out a combinator that does `[ predicate? ] ... 
X-Git-Tag: 0.99~551
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=115a62a0d90b0a332e37ad776504891a7ffdfd29

combinators.extras: trying to figure out a combinator that does `[ predicate? ] [ action ] 1check-when`
---

diff --git a/extra/combinators/extras/extras-tests.factor b/extra/combinators/extras/extras-tests.factor
index 6a10620c85..9e96a3a64b 100644
--- a/extra/combinators/extras/extras-tests.factor
+++ b/extra/combinators/extras/extras-tests.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2013 Doug Coleman.
 ! See https://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators.extras io.files kernel math
-modern.slices sequences splitting tools.test ;
+USING: alien.c-types arrays assocs combinators.extras io.files
+kernel math modern.slices sequences splitting tools.test ;
 IN: combinators.extras.tests
 
 
@@ -186,3 +186,5 @@ IN: combinators.extras.tests
 
 { 103 203 { { 1 1 } { 2 2 } { 3 3 } } }
 [ 100 200 { { 1 1 } { 2 2 } { 3 3 } } [ [ 1 + ] bi@ ] 2temp2d assoc-map ] unit-test
+
+{ t } [ int [ c-type-name? ] [ lookup-c-type ] 1check-when c-type? ] unit-test
\ No newline at end of file
diff --git a/extra/combinators/extras/extras.factor b/extra/combinators/extras/extras.factor
index 8e1f312042..0e4338ce83 100644
--- a/extra/combinators/extras/extras.factor
+++ b/extra/combinators/extras/extras.factor
@@ -209,3 +209,11 @@ MACRO: 4keep-under ( quot -- quot' )
 
 : closure-limit ( vertex quot: ( vertex -- edges ) n -- set )
     HS{ } closure-limit-as ; inline
+
+: 1check ( obj quot -- obj ? ) over [ call ] dip swap ; inline
+: 2check ( obj1 obj2 quot -- obj ? ) 2over [ call ] 2dip rot ; inline
+
+: 1check-when ( ..a obj cond: ( ..a obj -- obj/f ) true: ( ..a obj cond -- ..b ) -- ..b )
+    [ 1check ] dip when ; inline
+: 2check-when ( ..a obj1 obj2 cond: ( ..a obj1 obj2 -- obj/f ) true: ( ..a obj1 obj2 cond -- ..b ) -- ..b )
+    [ 2check ] dip when ; inline