From 890be490748f1b8cdd79919e169600f5e8c0e8d7 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Tue, 21 Feb 2017 14:51:30 -0800
Subject: [PATCH] combinators.extras: adding a variant to cond.

---
 extra/combinators/extras/extras-tests.factor | 23 +++++++++++++++++++
 extra/combinators/extras/extras.factor       | 24 +++++++++++++++++---
 2 files changed, 44 insertions(+), 3 deletions(-)

diff --git a/extra/combinators/extras/extras-tests.factor b/extra/combinators/extras/extras-tests.factor
index 3a34f4f7d0e..39a35046980 100644
--- a/extra/combinators/extras/extras-tests.factor
+++ b/extra/combinators/extras/extras-tests.factor
@@ -38,3 +38,26 @@ IN: combinators.extras.tests
 { t } [ "resource:" [ exists? ] ?1arg >boolean ] unit-test
 { f } [ f [ 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
diff --git a/extra/combinators/extras/extras.factor b/extra/combinators/extras/extras.factor
index 4cb162e439d..274c0e860b4 100644
--- a/extra/combinators/extras/extras.factor
+++ b/extra/combinators/extras/extras.factor
@@ -1,8 +1,9 @@
 ! 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 locals math.order
-sequences.generalizations sequences.private system ;
+USING: arrays assocs combinators combinators.smart fry
+generalizations kernel macros math quotations sequences locals
+math.order sequences.generalizations sequences.private
+stack-checker.transforms system words ;
 IN: combinators.extras
 
 : once ( quot -- ) call ; inline
@@ -88,3 +89,20 @@ MACRO:: n-falsify ( n -- quot )
 
 : ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
     [ ?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* ;