(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? vector?))
(permutation-next (-> vector? vector?))
(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))
(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 n)
(:permutations cc var (index i) n))
((:permutations cc var (index i) n)
(:do cc
((var (permutation-identity n))
(i 0))
var
((permutation-next var)
(+ i 1)))))))