combinators.extras: adding sequence-case

diff --git a/extra/combinators/extras/extras-tests.factor b/extra/combinators/extras/extras-tests.factor
index 34c7ede3643c8c1e716d53ddd53732e7291884c4..f507f72715a18beb8b7daf113c02211f06c5111b 100644 (file)
--- 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 eaf53138f0666fe54d81a58a077100fdc32a82b2..7205616b17daafbb5f9083c02b53fa3e29a57293 100644 (file)
--- 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 ] ;