From 37bddfba54f2b5d6bf4470cf099f2edf6e5abb03 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 14 Jul 2010 09:09:57 -0700
Subject: [PATCH] math.combinatorics: all-subsets and selections words
 (contributed by John Benediktsson)

---
 .../combinatorics/combinatorics-docs.factor   | 26 +++++++++++++++++++
 .../combinatorics/combinatorics-tests.factor  | 17 ++++++++++++
 basis/math/combinatorics/combinatorics.factor | 25 ++++++++++++++++--
 3 files changed, 66 insertions(+), 2 deletions(-)

diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor
index 0a2a0d4011..75a54c2300 100644
--- a/basis/math/combinatorics/combinatorics-docs.factor
+++ b/basis/math/combinatorics/combinatorics-docs.factor
@@ -103,3 +103,29 @@ HELP: >permutation
 { $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } }
 { $examples { $example "USING: math.combinatorics.private prettyprint ;" "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ;
 
+HELP: all-subsets
+{ $values { "seq" sequence } { "subsets" sequence } }
+{ $description
+    "Returns all the subsets of a sequence."
+}
+{ $examples
+    { $example
+        "USING: math.combinatorics prettyprint ;"
+        "{ 1 2 3 } all-subsets ."
+        "{ { } { 1 } { 2 } { 3 } { 1 2 } { 1 3 } { 2 3 } { 1 2 3 } }"
+    }
+} ;
+
+HELP: selections
+{ $values { "seq" sequence } { "n" integer } { "selections" sequence } }
+{ $description
+    "Returns all the ways to take n (possibly the same) items from the "
+    "sequence of items."
+} 
+{ $examples
+    { $example
+        "USING: math.combinatorics prettyprint ;"
+        "{ 1 2 } 2 selections ."
+        "{ { 1 1 } { 1 2 } { 2 1 } { 2 2 } }"
+    }
+} ;
diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor
index bbf5a1cb85..8a551bfe9d 100644
--- a/basis/math/combinatorics/combinatorics-tests.factor
+++ b/basis/math/combinatorics/combinatorics-tests.factor
@@ -70,3 +70,20 @@ IN: math.combinatorics.tests
 [ { { "a" "b" } { "a" "c" }
     { "a" "d" } { "b" "c" }
     { "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test
+
+[ { { } } ] [ { } all-subsets ] unit-test
+
+[ { { } { 1 } { 2 } { 3 } { 1 2 } { 1 3 } { 2 3 } { 1 2 3 } } ]
+[ { 1 2 3 } all-subsets ] unit-test
+
+[ { } ] [ { 1 2 } 0 selections ] unit-test
+
+[ { { 1 2 } } ] [ { 1 2 } 1 selections ] unit-test
+
+[ { { 1 1 } { 1 2 } { 2 1 } { 2 2 } } ]
+[ { 1 2 } 2 selections ] unit-test
+
+[ { { 1 1 1 } { 1 1 2 } { 1 2 1 } { 1 2 2 }
+    { 2 1 1 } { 2 1 2 } { 2 2 1 } { 2 2 2 } } ]
+[ { 1 2 } 3 selections ] unit-test
+
diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor
index 5a9f627015..b69867fb12 100644
--- a/basis/math/combinatorics/combinatorics.factor
+++ b/basis/math/combinatorics/combinatorics.factor
@@ -1,7 +1,8 @@
-! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer.
+! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer, John Benediktsson.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs binary-search fry kernel locals math math.order
-    math.ranges namespaces sequences sorting ;
+    math.ranges namespaces sequences sorting make sequences.deep arrays
+    combinators ;
 IN: math.combinatorics
 
 <PRIVATE
@@ -126,3 +127,23 @@ PRIVATE>
 
 : reduce-combinations ( seq k identity quot -- result )
     [ -rot ] dip each-combination ; inline
+
+: all-subsets ( seq -- subsets )
+    dup length [0,b] [
+        [ dupd all-combinations [ , ] each ] each
+    ] { } make nip ;
+
+: (selections) ( seq n -- selections )
+    dupd [ dup 1 > ] [
+        swap pick cartesian-product [
+            [ [ dup length 1 > [ flatten ] when , ] each ] each
+        ] { } make swap 1 -
+    ] while drop nip ;
+
+: selections ( seq n -- selections )
+    {
+        { 0 [ drop { } ] }
+        { 1 [ 1array ] }
+        [ (selections) ]
+    } case ;
+