combinators.extras: adding a variant to cond.
parent
b00aef99e2
commit
890be49074
|
@ -38,3 +38,26 @@ IN: combinators.extras.tests
|
||||||
{ t } [ "resource:" [ exists? ] ?1arg >boolean ] unit-test
|
{ t } [ "resource:" [ exists? ] ?1arg >boolean ] unit-test
|
||||||
{ f } [ f [ exists? ] ?1arg ] unit-test
|
{ f } [ f [ exists? ] ?1arg ] unit-test
|
||||||
{ f } [ "/homeasdfasdf123123" [ exists? ] ?1arg ] unit-test
|
{ f } [ "/homeasdfasdf123123" [ exists? ] ?1arg ] unit-test
|
||||||
|
|
||||||
|
{ "hi " "there" } [
|
||||||
|
"hi there" {
|
||||||
|
{ [ "there" over start ] [ cut ] }
|
||||||
|
[ f ]
|
||||||
|
} cond*
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ "hi " "there" } [
|
||||||
|
"hi there" {
|
||||||
|
{ [ "foo" over start ] [ head f ] }
|
||||||
|
{ [ "there" over start ] [ cut ] }
|
||||||
|
[ f ]
|
||||||
|
} cond*
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ "hi there" f } [
|
||||||
|
"hi there" {
|
||||||
|
{ [ "foo" over start ] [ head f ] }
|
||||||
|
{ [ "bar" over start ] [ cut ] }
|
||||||
|
[ f ]
|
||||||
|
} cond*
|
||||||
|
] unit-test
|
||||||
|
|
|
@ -1,8 +1,9 @@
|
||||||
! Copyright (C) 2013 Doug Coleman, John Benediktsson.
|
! Copyright (C) 2013 Doug Coleman, John Benediktsson.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays combinators combinators.smart fry generalizations
|
USING: arrays assocs combinators combinators.smart fry
|
||||||
kernel macros math quotations sequences locals math.order
|
generalizations kernel macros math quotations sequences locals
|
||||||
sequences.generalizations sequences.private system ;
|
math.order sequences.generalizations sequences.private
|
||||||
|
stack-checker.transforms system words ;
|
||||||
IN: combinators.extras
|
IN: combinators.extras
|
||||||
|
|
||||||
: once ( quot -- ) call ; inline
|
: once ( quot -- ) call ; inline
|
||||||
|
@ -88,3 +89,20 @@ MACRO:: n-falsify ( n -- quot )
|
||||||
|
|
||||||
: ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
|
: ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
|
||||||
[ ?2res ] 3keep drop '[ _ _ ] [ f f ] if ; inline
|
[ ?2res ] 3keep drop '[ _ _ ] [ f f ] if ; inline
|
||||||
|
|
||||||
|
<<
|
||||||
|
: alist>quot* ( default assoc -- quot )
|
||||||
|
[ rot \ if* 3array append [ ] like ] assoc-each ;
|
||||||
|
|
||||||
|
: cond*>quot ( assoc -- quot )
|
||||||
|
[ dup pair? [ [ drop ] prepend [ t ] swap 2array ] unless ] map
|
||||||
|
reverse! [ no-cond ] swap alist>quot* ;
|
||||||
|
|
||||||
|
DEFER: cond*
|
||||||
|
\ cond* [ cond*>quot ] 1 define-transform
|
||||||
|
\ cond* t "no-compile" set-word-prop
|
||||||
|
>>
|
||||||
|
: cond* ( assoc -- )
|
||||||
|
[ dup callable? [ drop t ] [ first call ] if ] map-find
|
||||||
|
[ dup callable? [ nip call ] [ second call ] if ]
|
||||||
|
[ no-cond ] if* ;
|
||||||
|
|
Loading…
Reference in New Issue