#lang scheme

#|  permutations-core.ss: Generate and manipulate permutations.
    Copyright (C) 2008 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 3 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, see <http://www.gnu.org/licenses/>.
|#


(require (lib "42.ss" "srfi")
         (except-in (lib "43.ss" "srfi") vector-fill! vector->list)
         (lib "contract.ss")
         (only-in (lib "list.ss" "srfi" "1") iota)
         (lib "list.ss"))

(provide 
 permutation?
 permutation-identity
 pvector-ref
 pvector-set!
 permutation-next!
 permutation-next
 permutation-signature
 :permutations
 in-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 (for/first ((j (in-range (- n 2) -1 -1))
                         #:when (< (vector-ref p j)
                                   (vector-ref p (+ j 1))))
               j)))
      (and j
           (let ((l (for/first ((l (in-range (- n 1) -1 -1))
                                #:when (< (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))
    (for*/fold ((sig 1))
      (((px i) (in-indexed (in-vector p)))
       (j (in-range (add1 i) (vector-length p))))
      (if (< (vector-ref p j) (vector-ref p i))
          (* sig -1)
          sig))))

(define-generator :permutations
  (lambda (stx)
    (syntax-case stx (index)
      ((:permutations var (index i) n)
       (syntax/loc stx
        (:do ((var (permutation-identity n))
              (i 0))
             var
             ((permutation-next var)
              (+ i 1)))))
      ((:permutations var n)
       (syntax/loc stx 
        (:permutations var (index i) n))))))

(define (in-permutations* n)
  (make-do-sequence
   (lambda ()
     (values
      values
      permutation-next
      (permutation-identity n)
      values
      (lambda (arg) #t)
      (lambda (arg arg2) #t)))))

(define-sequence-syntax in-permutations
  (lambda () (syntax in-permutation*))
  (lambda (stx)
    (syntax-case stx ()
      (((p) (in-permutations n-expr))
       (syntax/loc stx
         ((p) (:do-in (((n) n-expr))
                      #t
                      ((p (permutation-identity n)))
                      p
                      ()
                      #t
                      #t
                      ((permutation-next p)))))))))