From c34129928e1074f33e336117625dfcc1ee59dcff Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Wed, 8 May 2013 09:49:19 -0400
Subject: [PATCH] Add `permutations' and `in-permutations'.

---
 collects/racket/list.rkt                   | 78 ++++++++++++++++++++++
 collects/scribblings/reference/pairs.scrbl | 20 ++++++
 collects/tests/racket/list.rktl            | 47 +++++++++++++
 3 files changed, 145 insertions(+)

diff --git a/collects/racket/list.rkt b/collects/racket/list.rkt
index 430587f58a..11946358c8 100644
--- a/collects/racket/list.rkt
+++ b/collects/racket/list.rkt
@@ -36,6 +36,8 @@
          append-map
          filter-not
          shuffle
+         permutations
+         in-permutations
          argmin
          argmax)
 
@@ -446,6 +448,82 @@
 (define (shuffle l)
   (sort l < #:key (λ(_) (random)) #:cache-keys? #t))
 
+;; This implements an algorithm known as "Ord-Smith".  (It is described in a
+;; paper called "Permutation Generation Methods" by Robert Sedgewlck, listed as
+;; Algorithm 8.)  It has a number of good properties: it is very fast, returns
+;; a list of results that has a maximum number of shared list tails, and it
+;; returns a list of reverses of permutations in lexical order of the input,
+;; except that the list itself is reversed so the first permutation is equal to
+;; the input and the last is its reverse.  In other words, (map reverse
+;; (permutations (reverse l))) is a list of lexicographically-ordered
+;; permutations (but of course has no shared tails at all -- I couldn't find
+;; anything that returns sorted results with shared tails efficiently).  I'm
+;; not listing these features in the documentation, since I'm not sure that
+;; there is a need to expose them as guarantees -- but if there is, then just
+;; revise the docs.  (Note that they are tested.)
+;;
+;; In addition to all of this, it has just one loop, so it is easy to turn it
+;; into a "streaming" version that spits out the permutations one-by-one, which
+;; could be used with a "callback" argument as in the paper, or can implement
+;; an efficient `in-permutations'.  It uses a vector to hold state -- it's easy
+;; to avoid this and use a list instead (in the loop, the part of the c vector
+;; that is before i is all zeros, so just use a list of the c values from i and
+;; on) -- but that makes it slower (by about 70% in my timings).
+(define (swap+flip l i j)
+  ;; this is the main helper for the code: swaps the i-th and j-th items, then
+  ;; reverses items 0 to j-1; with special cases for 0,1,2 (which are
+  ;; exponentially more frequent than others)
+  (case j
+    [(0) `(,(cadr l) ,(car l) ,@(cddr l))]
+    [(1) (let ([a (car l)] [b (cadr l)] [c (caddr l)] [l (cdddr l)])
+           (case i [(0)  `(,b ,c ,a ,@l)]
+                 [else `(,c ,a ,b ,@l)]))]
+    [(2) (let ([a (car l)] [b (cadr l)] [c (caddr l)] [d (cadddr l)]
+               [l (cddddr l)])
+           (case i [(0)  `(,c ,b ,d ,a ,@l)]
+                   [(1)  `(,c ,d ,a ,b ,@l)]
+                   [else `(,d ,b ,a ,c ,@l)]))]
+    [else (let loop ([n i] [l1 '()] [r1 l])
+            (if (> n 0) (loop (sub1 n) (cons (car r1) l1) (cdr r1))
+                (let loop ([n (- j i)] [l2 '()] [r2 (cdr r1)])
+                  (if (> n 0) (loop (sub1 n) (cons (car r2) l2) (cdr r2))
+                      `(,@l2 ,(car r2) ,@l1 ,(car r1) ,@(cdr r2))))))]))
+(define (permutations l)
+  (cond [(not (list? l)) (raise-argument-error 'permutations "list?" 0 l)]
+        [(or (null? l) (null? (cdr l))) (list l)]
+        [else
+         (define N (- (length l) 2))
+         ;; use a byte-string instead of a vector -- doesn't matter much for
+         ;; speed, but permutations of longer lists are impractical anyway
+         (when (> N 254) (error 'permutations "input list too long: ~e" l))
+         (define c (make-bytes (add1 N) 0))
+         (let loop ([i 0] [acc (list (reverse l))])
+           (define ci (bytes-ref c i))
+           (cond [(<= ci i) (bytes-set! c i (add1 ci))
+                            (loop 0 (cons (swap+flip (car acc) ci i) acc))]
+                 [(< i N)   (bytes-set! c i 0)
+                            (loop (add1 i) acc)]
+                 [else      acc]))]))
+(define (in-permutations l)
+  (cond [(not (list? l)) (raise-argument-error 'in-permutations "list?" 0 l)]
+        [(or (null? l) (null? (cdr l))) (in-value l)]
+        [else
+         (define N (- (length l) 2))
+         (when (> N 254) (error 'permutations "input list too long: ~e" l))
+         (define c (make-bytes (add1 N) 0))
+         (define i 0)
+         (define cur (reverse l))
+         (define (next)
+           (define r cur)
+           (define ci (bytes-ref c i))
+           (cond [(<= ci i) (bytes-set! c i (add1 ci))
+                            (begin0 (swap+flip cur ci i) (set! i 0))]
+                 [(< i N)   (bytes-set! c i 0)
+                            (set! i (add1 i))
+                            (next)]
+                 [else      #f]))
+         (in-producer (λ() (begin0 cur (set! cur (next)))) #f)]))
+
 ;; mk-min : (number number -> boolean) symbol (X -> real) (listof X) -> X
 (define (mk-min cmp name f xs)
   (unless (and (procedure? f)
diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl
index 0e3b6639a0..9df10f9212 100644
--- a/collects/scribblings/reference/pairs.scrbl
+++ b/collects/scribblings/reference/pairs.scrbl
@@ -1152,6 +1152,26 @@ Returns a list with all elements from @racket[lst], randomly shuffled.
   (shuffle '(1 2 3 4 5 6))]}
 
 
+@defproc[(permutations [lst list?])
+         list?]{
+
+Returns a list of all permutations of the input list.  Note that this
+function works without inspecting the elements, and therefore it ignores
+repeated elements (which will result in repeated permutations).
+
+@mz-examples[#:eval list-eval
+  (permutations '(1 2 3))
+  (permutations '(x x))]}
+
+
+@defproc[(in-permutations [lst list?])
+         sequence?]{
+
+Returns a sequence of all permutations of the input list.  It is
+equivalent to @racket[(in-list (permutations l))] but much faster since
+it builds the permutations one-by-one on each iteration}
+
+
 @defproc[(argmin [proc (-> any/c real?)] [lst (and/c pair? list?)])
          any/c]{
 
diff --git a/collects/tests/racket/list.rktl b/collects/tests/racket/list.rktl
index d9bc60be98..6faf8dd3f2 100644
--- a/collects/tests/racket/list.rktl
+++ b/collects/tests/racket/list.rktl
@@ -410,6 +410,53 @@
     (test expected length+sum (shuffle l)))
   (when (pair? l) (loop (cdr l))))
 
+;; ---------- permutations ----------
+(let ()
+  (define (perm<? l1 l2) ; (works only on tests with numeric lists)
+    (let loop ([l1 l1] [l2 l2])
+      (and (pair? l1) (or (< (car l1) (car l2))
+                          (and (= (car l1) (car l2))
+                               (loop (cdr l1) (cdr l2)))))))
+  (define (sorted-perms l)
+    (define l1 (sort (permutations l) perm<?))
+    (define l2 (sort (for/list ([p (in-permutations l)]) p) perm<?))
+    (test #t equal? l1 l2)
+    l1)
+  (test '(())  sorted-perms '())
+  (test '((1)) sorted-perms '(1))
+  (test '((1 2) (2 1)) sorted-perms '(1 2))
+  (test '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))
+        sorted-perms '(1 2 3))
+  (define ll (range 7))
+  (define pl (permutations ll))
+  (test (* 1 2 3 4 5 6 7) length pl)
+  (test (* 1 2 3 4 5 6 7) length (remove-duplicates pl))
+  ;; check maximal sharing, and reverse-lexicographic order; these properties
+  ;; are not documented guarantees (see comment in the implementation), but
+  ;; it's worth testing for them to avoid losing them if they're needed in the
+  ;; future.  (The above tests don't rely on this, it explicitly sorts the
+  ;; result.)
+  (test #t equal? (reverse (map reverse pl)) (sort pl perm<?))
+  (test '((x y) (y x)) permutations '(x y))
+  (test '((x x) (x x)) permutations '(x x))
+  (test '((x y z) (y x z) (x z y) (z x y) (y z x) (z y x))
+        permutations '(x y z))
+  (test '((x y x) (y x x) (x x y) (x x y) (y x x) (x y x))
+        permutations '(x y x))
+  (define (count-cons x)
+    (define t (make-hasheq))
+    (let loop ([x x])
+      (when (and (pair? x) (not (hash-ref t x #f)))
+        (hash-set! t x #t) (loop (car x)) (loop (cdr x))))
+    (hash-count t))
+  (define (minimize-cons l)
+    (let ([t (make-hash)])
+      (let loop ([x l])
+        (if (pair? x)
+          (hash-ref! t x (λ() (cons (loop (car x)) (loop (cdr x)))))
+          x))))
+  (test #t = (count-cons pl) (count-cons (minimize-cons pl))))
+
 ;; ---------- argmin & argmax ----------
 
 (let ()