From e3c06b99e09f17b893bcfba58f7727f4caa2cede Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Sun, 10 Sep 2023 12:46:11 -0700
Subject: [PATCH] combinators.extras: adding sequence-case

---
 extra/combinators/extras/extras-tests.factor | 26 +++++++++++++++++++-
 extra/combinators/extras/extras.factor       | 15 +++++++++++
 2 files changed, 40 insertions(+), 1 deletion(-)

diff --git a/extra/combinators/extras/extras-tests.factor b/extra/combinators/extras/extras-tests.factor
index 34c7ede364..f507f72715 100644
--- a/extra/combinators/extras/extras-tests.factor
+++ b/extra/combinators/extras/extras-tests.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2013 Doug Coleman.
 ! See https://factorcode.org/license.txt for BSD license.
 USING: alien.c-types arrays assocs combinators.extras io.files
-kernel math modern.slices sequences splitting tools.test ;
+kernel math modern.slices parser ranges sequences splitting
+tools.test ;
 IN: combinators.extras.tests
 
 
@@ -24,6 +25,29 @@ IN: combinators.extras.tests
     ] map
 ] unit-test
 
+<<
+SYNTAX: ..= dup pop scan-object [a..b] suffix! ;
+SYNTAX: ..< dup pop scan-object [a..b) suffix! ;
+>>
+
+<<
+: describe-number ( n -- str )
+    {
+        { 0 [ "no" ] }
+        { 1 ..= 3 [ "a few" ] }
+        { 4 ..= 9 [ "several" ] }
+        { 12 [ "twelve" ] }
+        { 10 ..= 99 [ "tens of" ] }
+        { 100 ..= 999 [ "hundreds of" ] }
+        { 1000 ..= 999,999 [ "thousands of" ] }
+        [ drop "millions and millions of" ]
+    } sequence-case ;
+>>
+
+{ "twelve" } [ 12 describe-number ] unit-test
+{ "several" } [ 5 describe-number ] unit-test
+{ "millions and millions of" } [ 1,000,000 describe-number ] unit-test
+
 { { 1 2 3 } } [ 1 { [ ] [ 1 + ] [ 2 + ] } cleave-array ] unit-test
 
 { 2 15 } [ 1 2 3 4 5 6 [ - - ] [ + + ] 3bi* ] unit-test
diff --git a/extra/combinators/extras/extras.factor b/extra/combinators/extras/extras.factor
index eaf53138f0..7205616b17 100644
--- a/extra/combinators/extras/extras.factor
+++ b/extra/combinators/extras/extras.factor
@@ -25,6 +25,21 @@ MACRO: cond-case ( assoc -- quot )
         ] when
     ] map '[ _ cond ] ;
 
+<PRIVATE
+GENERIC: sequence-case-contains? ( elt obj -- ? )
+M: object sequence-case-contains? = ;
+M: sequence sequence-case-contains? member? ;
+M: sets:set sequence-case-contains? in? ;
+PRIVATE>
+
+MACRO: sequence-case ( assoc -- quot )
+    [
+        dup callable? [
+            [ first '[ dup _ sequence-case-contains? ] ]
+            [ second '[ drop @ ] ] bi 2array
+        ] unless
+    ] map [ cond ] curry ;
+
 MACRO: cleave-array ( quots -- quot )
     dup length '[ _ cleave _ narray ] ;
 
-- 
2.34.1