#|  permutations.ss: Generate and manipulate permutations.
    Copyright (C) Will M. Farr <farr@mit.edu>

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License along
    with this program; if not, write to the Free Software Foundation, Inc.,
    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
|#

(module permutations mzscheme
  (require (lib "42.ss" "srfi")
           (all-except (lib "43.ss" "srfi") vector-fill! vector->list)
           (lib "contract.ss")
           (only (lib "list.ss" "srfi" "1") iota)
           (lib "list.ss"))
  
  (provide/contract
   (permutation? (-> any/c boolean?))
   (permutation-identity (-> natural-number/c vector?))
   (pvector-ref (-> vector? vector? natural-number/c any))
   (pvector-set! (-> vector? vector? natural-number/c any/c any))
   (permutation-next! (-> vector? (or/c vector?
                                        false/c)))
   (permutation-next (-> vector? (or/c vector?
                                       false/c)))
   (permutation-signature (-> vector? (one-of/c -1 1))))
  
  (provide :permutations)
  
  (define (permutation? obj)
    (and (vector? obj)
         (equal? (sort (vector->list obj) <)
                 (iota (vector-length obj)))))
  
  (define (permutation-identity n)
    (vector-of-length-ec n (:range i n) i))
  
  (define (pvector-ref p v i)
    (vector-ref v (vector-ref p i)))
  
  (define (pvector-set! p v i x)
    (vector-set! v (vector-ref p i) x))
  
  ;; Algorithm borrowed from Knuth's Art of Computer Programming Vol. IV, Section 7.2.1.2.
  ;; Preview version available at http://www-cs-faculty.stanford.edu/~knuth/fasc2b.ps.gz
  ;; The algorithm is the first Knuth gives, and is "reasonably efficient", as discussed in
  ;; Exercise 6 of that section.
  (define (permutation-next! p)
    (let ((n (vector-length p)))
      (let ((j (first-ec #f (:range j (- n 2) -1 -1)
                 (if (< (vector-ref p j)
                        (vector-ref p (+ j 1))))
                 j)))
        (and j
             (let ((l (first-ec #f (:range l (- n 1) -1 -1)
                        (if (< (vector-ref p j)
                               (vector-ref p l)))
                        l)))
               (vector-swap! p j l)
               (do-ec (:while
                       (:parallel
                        (:range k (+ j 1) n)
                       (:range l (- n 1) -1 -1))
                      (< k l))
                (vector-swap! p k l))
               p)))))
  
  (define (permutation-next p)
    (permutation-next! (vector-copy p)))
  
  (define (permutation-signature p)
    (let ((sig 1))
      (do-ec (:vector px (index i) p) (:range j (+ i 1) (vector-length p))
        (if (< (vector-ref p j) (vector-ref p i)))
        (set! sig (* sig -1)))
      sig))
  
  (define-syntax :permutations
    (syntax-rules (index)
      ((:permutations cc var (index i) n)
       (:do cc
            ((var (permutation-identity n))
             (i 0))
            var
            ((permutation-next var)
             (+ i 1))))
      ((:permutations cc var n)
       (:permutations cc var (index i) n)))))