From 71a7f0e4ad972a3ab505962613d44e2b11968c38 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Sun, 24 Mar 2013 09:55:44 -0700
Subject: [PATCH] combinators.extras: adding cond-case.

---
 extra/combinators/extras/extras-docs.factor  | 24 ++++++++++++++++++++
 extra/combinators/extras/extras-tests.factor | 12 +++++++++-
 extra/combinators/extras/extras.factor       | 12 ++++++++--
 3 files changed, 45 insertions(+), 3 deletions(-)
 create mode 100644 extra/combinators/extras/extras-docs.factor

diff --git a/extra/combinators/extras/extras-docs.factor b/extra/combinators/extras/extras-docs.factor
new file mode 100644
index 0000000000..f40e4f7e69
--- /dev/null
+++ b/extra/combinators/extras/extras-docs.factor
@@ -0,0 +1,24 @@
+USING: combinators help.markup help.syntax ;
+
+IN: combinators.extras
+
+HELP: cond-case
+{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
+{ $description
+    "Similar to " { $link case } ", this evaluates an " { $snippet "obj" } " according to the first quotation in each pair.  If any quotation returns true, calls the second quotation without " { $snippet "obj" } " on the stack."
+    $nl
+    "If there is no quotation that returns true, the default case is taken.  If the last element of " { $snippet "assoc" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack.  Otherwise, a " { $link no-cond } " error is raised."
+}
+{ $examples
+    { $example
+        "USING: combinators.extras io kernel math ;"
+        "0 {"
+        "    { [ 0 > ] [ \"positive\" ] }"
+        "    { [ 0 < ] [ \"negative\" ] }"
+        "    [ drop \"zero\" ]"
+        "} cond-case print"
+        "zero"
+    }
+} ;
+
+
diff --git a/extra/combinators/extras/extras-tests.factor b/extra/combinators/extras/extras-tests.factor
index c72b493c33..6ad66adafc 100644
--- a/extra/combinators/extras/extras-tests.factor
+++ b/extra/combinators/extras/extras-tests.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2013 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test combinators.extras sequences ;
+USING: math tools.test combinators.extras sequences ;
 IN: combinators.extras.tests
 
 { "a b" }
@@ -11,3 +11,13 @@ IN: combinators.extras.tests
 
 { "a b c d" }
 [ "a" "b" "c" "d" [ " " glue ] thrice ] unit-test
+
+[ { "negative" 0 "positive" } ] [
+    { -1 0 1 } [
+        {
+           { [ 0 > ] [ "positive" ] }
+           { [ 0 < ] [ "negative" ] }
+           [ ]
+        } cond-case
+    ] map
+] unit-test
diff --git a/extra/combinators/extras/extras.factor b/extra/combinators/extras/extras.factor
index 03025b81c8..a5c106e40c 100644
--- a/extra/combinators/extras/extras.factor
+++ b/extra/combinators/extras/extras.factor
@@ -1,8 +1,16 @@
-! Copyright (C) 2013 Doug Coleman.
+! Copyright (C) 2013 Doug Coleman, John Benediktsson.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ;
+USING: arrays combinators kernel macros quotations sequences ;
 IN: combinators.extras
 
 : once ( quot -- ) call ; inline
 : twice ( quot -- ) dup [ call ] dip call ; inline
 : thrice ( quot -- ) dup dup [ call ] 2dip [ call ] dip call ; inline
+
+MACRO: cond-case ( assoc -- )
+    [
+        dup callable? not [
+            [ first [ dup ] prepose ]
+            [ second [ drop ] prepose ] bi 2array
+        ] when
+    ] map [ cond ] curry ;