From b2b1d3def2e2f665185ae202d78752b783a9a630 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Mon, 22 Mar 2021 17:25:56 -0700
Subject: [PATCH] math.combinatorics: adding all-unique-permutations.

---
 .../combinatorics/combinatorics-docs.factor   | 13 +++++++++
 .../combinatorics/combinatorics-tests.factor  |  7 ++++-
 basis/math/combinatorics/combinatorics.factor | 29 +++++++++++++++++--
 3 files changed, 46 insertions(+), 3 deletions(-)

diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor
index 538654dc1f..f34f537cf0 100644
--- a/basis/math/combinatorics/combinatorics-docs.factor
+++ b/basis/math/combinatorics/combinatorics-docs.factor
@@ -118,6 +118,19 @@ HELP: next-permutation
 { $notes "Performs an in-place modification of " { $snippet "seq" } "." }
 { $examples { $example "USING: math.combinatorics prettyprint ;" "\"ABC\" next-permutation ." "\"ACB\"" } } ;
 
+HELP: all-unique-permutations
+{ $values { "seq" sequence } { "seq'" sequence } }
+{ $description "Outputs a sequence containing all " { $strong "unique" } " permutations of " { $snippet "seq" } " in lexicographical order." }
+{ $examples
+    { $example "USING: math.combinatorics prettyprint ;"
+        "{ 1 1 2 } all-unique-permutations ."
+        "{ { 1 1 2 } { 1 2 1 } { 2 1 1 } }" }
+} ;
+
+HELP: each-unique-permutation
+{ $values { "seq" sequence } { "quot" { $quotation ( ... elt -- ... ) } } }
+{ $description "Applies the quotation to each " { $strong "unique" } " permutation of " { $snippet "seq" } " in order." } ;
+
 HELP: all-subsets
 { $values { "seq" sequence } { "subsets" sequence } }
 { $description
diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor
index 3accc2f6e6..e18771e333 100644
--- a/basis/math/combinatorics/combinatorics-tests.factor
+++ b/basis/math/combinatorics/combinatorics-tests.factor
@@ -1,5 +1,5 @@
 USING: arrays kernel math math.combinatorics
-math.combinatorics.private tools.test sequences ;
+math.combinatorics.private tools.test sequences sets ;
 
 { 1 } [ -1 factorial ] unit-test ! required by other math.combinatorics words
 { 1 } [ 0 factorial ] unit-test
@@ -100,6 +100,11 @@ math.combinatorics.private tools.test sequences ;
 { f } [ { 1 2 3 } [ last 4 = ] find-permutation ] unit-test
 { { 2 1 3 } } [ { 1 2 3 } [ first 2 = ] find-permutation ] unit-test
 
+{ t } [
+    { 1 1 1 1 1 1 1 1 2 }
+    [ all-permutations members ] [ all-unique-permutations ] bi =
+] unit-test
+
 { { { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } } }
 [ 3 <iota> <permutations> >array ] unit-test
 
diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor
index f2aefb985d..5d4a0d7b26 100644
--- a/basis/math/combinatorics/combinatorics.factor
+++ b/basis/math/combinatorics/combinatorics.factor
@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: accessors arrays assocs classes.tuple combinators hints
-kernel kernel.private math math.functions math.order math.ranges
-sequences sequences.private sorting strings vectors ;
+kernel kernel.private make math math.functions math.order
+math.ranges sequences sequences.private sorting strings vectors ;
 IN: math.combinatorics
 
 <PRIVATE
@@ -154,6 +154,31 @@ PRIVATE>
 : next-permutation ( seq -- seq )
     dup empty? [ (next-permutation) ] unless ;
 
+<PRIVATE
+
+: should-swap? ( start curr seq -- ? )
+    [ nipd nth ] [ <slice> member? not ] 3bi ; inline
+
+:: unique-permutations ( ... seq i n quot: ( ... elt -- ... ) -- ... )
+    i n >= [
+        seq clone quot call
+    ] [
+        i n [a..b) [| j |
+            i j seq should-swap? [
+                i j seq exchange-unsafe
+                seq i 1 + n quot unique-permutations
+                i j seq exchange-unsafe
+            ] when
+        ] each
+    ] if ; inline recursive
+
+PRIVATE>
+
+: each-unique-permutation ( ... seq quot: ( ... elt -- ... ) -- ... )
+    [ 0 over length ] dip unique-permutations ; inline
+
+: all-unique-permutations ( seq -- seq' )
+    [ [ , ] each-unique-permutation ] { } make ;
 
 ! Combinadic-based combination methodology
 
-- 
2.34.1