From 8330256b1df0d5b32f1bc14095c017969e16abb9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Apr 2016 15:46:15 -0700 Subject: [PATCH] combinators.extras, generalizations:: Add experimental combinators for 1res, 1arg. --- basis/generalizations/generalizations.factor | 3 ++ extra/combinators/extras/extras-tests.factor | 20 +++++++++++- extra/combinators/extras/extras.factor | 33 +++++++++++++++++++- 3 files changed, 54 insertions(+), 2 deletions(-) diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 91b42d5a83..1513c3d580 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -127,3 +127,6 @@ MACRO: nweave ( n -- quot ) : nbi-curry ( n -- ) [ bi-curry ] swap call-n ; inline + +MACRO: map-compose ( quots quot -- quot' ) + '[ _ compose ] map '[ _ ] ; \ No newline at end of file diff --git a/extra/combinators/extras/extras-tests.factor b/extra/combinators/extras/extras-tests.factor index 2d24a901cd..51019a4b7e 100644 --- a/extra/combinators/extras/extras-tests.factor +++ b/extra/combinators/extras/extras-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2013 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: math tools.test combinators.extras sequences ; +USING: combinators.extras io.files kernel math sequences +tools.test ; IN: combinators.extras.tests { "a b" } @@ -32,3 +33,20 @@ IN: combinators.extras.tests { "1" "123" } [ "1" "123" [ length ] [ > ] swap-when ] unit-test { "123" "1" } [ "1" "123" [ length ] [ < ] swap-when ] unit-test + + +{ t } [ "resource:" [ exists? ] 1arg >boolean ] unit-test +{ f } [ f [ exists? ] 1arg ] unit-test +{ f } [ "/homeasdfasdf123123" [ exists? ] 1arg ] unit-test + + + + +{ f f } [ f f 2 n-falsify ] unit-test +{ f f } [ 100 200 2 n-falsify ] unit-test + +{ f f } [ 100 f f 2 n-falsify-unless ] unit-test +{ f f } [ 100 200 f 2 n-falsify-unless ] unit-test + +{ 100 f } [ 100 f t 2 n-falsify-unless ] unit-test +{ 100 200 } [ 100 200 t 2 n-falsify-unless ] unit-test \ No newline at end of file diff --git a/extra/combinators/extras/extras.factor b/extra/combinators/extras/extras.factor index afc7296f7e..4cb162e439 100644 --- a/extra/combinators/extras/extras.factor +++ b/extra/combinators/extras/extras.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2013 Doug Coleman, John Benediktsson. ! See http://factorcode.org/license.txt for BSD license. USING: arrays combinators combinators.smart fry generalizations -kernel macros math quotations sequences +kernel macros math quotations sequences locals math.order sequences.generalizations sequences.private system ; IN: combinators.extras @@ -57,3 +57,34 @@ MACRO: smart-plox ( true -- quot ) : swap-when ( x y quot: ( x -- n ) quot: ( n n -- ? ) -- x' y' ) '[ _ _ 2dup _ bi@ @ [ swap ] when ] call ; inline + + +! ?1arg-result-falsify + +: 1falsify ( obj/f -- obj/f ) ; inline +: 2falsify ( obj1 obj2 -- obj1/f obj2/f ) 2dup and [ 2drop f f ] unless ; inline +: 3falsify ( obj1 obj2 obj3 -- obj1/f obj2/f obj3/f ) 3dup and and [ 3drop f f f ] unless ; inline + +MACRO: n-and ( n -- quot ) + 1 [-] [ and ] n*quot ; + +MACRO: n*obj ( n obj -- quot ) + 1quotation n*quot ; + +MACRO:: n-falsify ( n -- quot ) + [ n ndup n n-and [ n ndrop n f n*obj ] unless ] ; + +! plox +: ?1res ( ..a obj/f quot -- ..b ) + dupd when ; inline + +! when both args are true, call quot. otherwise dont +: ?2res ( ..a obj1 obj2 quot: ( obj1 obj2 -- ? ) -- ..b ) + [ 2dup and ] dip [ 2drop f ] if ; inline + +! try the quot, keep the original arg if quot is true +: ?1arg ( obj quot: ( obj -- ? ) -- obj/f ) + [ ?1res ] 2keep drop '[ _ ] [ f ] if ; inline + +: ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f ) + [ ?2res ] 3keep drop '[ _ _ ] [ f f ] if ; inline