A Racket implementation of the Tomkins-Paige permutation-generation algorithm

tompkins-paige-permute.rkt

#lang racket/base

;; An implementation of the tompkins-paige algorithm
;;
;; http://en.wikipedia.org/wiki/Tompkins%E2%80%93Paige_algorithm
;;
;; Let P and c be arrays of length n with 1-based indexing
;; (i.e. the first entry of an array has index 1). The algorithm 
;; for generating all n! permutations of the set {1,2,...,n} is
;; given by the following pseudocode:
;;
;; P ← [1, 2, ..., n];
;; yield P;
;; c ← [*, 1, ..., 1]; (the first entry of c is not used)
;; i ← 2;
;; while i ≤ n do
;;     left-rotate the first i entries of P;
;;     (e.g. left-rotating the first 4 entries of
;;     [4,2,5,3,1] would give [2,5,3,4,1])
;;     if c[i]<i then
;;         c[i] ← c[i]+1;
;;         i ← 2;
;;         yield P;
;;     else
;;         c[i] ← 1;
;;         i ← i+1;


;; Let's translate this pseudocode to Racket.

;; vector-left-rotate!: vector natural -> void
;; Left-rotates the first n elements in the vector.
(define (vector-left-rotate! vec n)
  (cond
    [(= n 0)
     (void)]
    [else
     (define temp (vector-ref vec 0))
     (vector-copy! vec 0 vec 1 n)
     (vector-set! vec (sub1 n) temp)]))


;; Let's test the vector left rotate function.
(module+ test
  (require racket/block rackunit)
  
  (block 
   (define vec (vector 1 2 3 4 5))
   (vector-left-rotate! vec 0)
   (check-equal? vec (vector 1 2 3 4 5)))
  
  (block 
   (define vec (vector 1 2 3 4 5))
   (vector-left-rotate! vec 1)
   (check-equal? vec (vector 1 2 3 4 5)))
  
  (block 
   (define vec (vector 1 2 3 4 5))
   (vector-left-rotate! vec 2)
   (check-equal? vec (vector 2 1 3 4 5)))

  (block 
   (define vec (vector 1 2 3 4 5))
   (vector-left-rotate! vec 3)
   (check-equal? vec (vector 2 3 1 4 5)))
  
  (block 
   (define vec (vector 1 2 3 4 5))
   (vector-left-rotate! vec 4)
   (check-equal? vec (vector 2 3 4 1 5)))

  (block 
   (define vec (vector 1 2 3 4 5))
   (vector-left-rotate! vec 5)
   (check-equal? vec (vector 2 3 4 5 1))))




;; We should provide a helper function to generate 
;; fresh permutation states and to get to the next state.


;; make-perm-state: natural -> (values vector (-> boolean))
;; Returns the current permutation vector, and a function that will
;; mutate that vector to the next state.
(define (make-perm-state n)
  (define V (for/vector ([i (in-range n)]) i))
  (define c (make-vector n 0))
  (define i 1)
  
  ;; perm-state-next!: -> boolean
  ;; Returns #t if we can successfully find the next permutation state.  Returns #f
  ;; otherwise.
  (define (perm-state-next!)
    (cond [(< i n)
           (vector-left-rotate! V (add1 i))
           (cond [(< (vector-ref c i) i)
                  (vector-set! c i (add1 (vector-ref c i)))
                  (set! i 1)
                  #t]
                 [else
                  (vector-set! c i 0)
                  (set! i (add1 i))
                  (perm-state-next!)])]
          [else #f]))
  
  (values V perm-state-next!))


;; Let's test perm-state with three elements exhaustively.
(module+ test
  (block 
   (define-values (v n!) (make-perm-state 3))
   (check-equal? v #(0 1 2))
   (check-equal? (n!) #t)
   (check-equal? v #(1 0 2))
   (check-equal? (n!) #t)
   (check-equal? v #(1 2 0))
   (check-equal? (n!) #t)
   (check-equal? v #(2 1 0))
   (check-equal? (n!) #t)
   (check-equal? v #(2 0 1))
   (check-equal? (n!) #t)
   (check-equal? v #(0 2 1))
   ;; At the end of the iteration, we should get
   ;; #f from the next! function
   (check-equal? (n!) #f)))

 

#lang racket/base
(require bind)

;; An implementation of the tompkins-paige algorithm
;;
;; http://en.wikipedia.org/wiki/Tompkins%E2%80%93Paige_algorithm
;;
;; Let P and c be arrays of length n with 1-based indexing
;; (i.e. the first entry of an array has index 1). The algorithm 
;; for generating all n! permutations of the set {1,2,...,n} is
;; given by the following pseudocode:
;;
;; P ← [1, 2, ..., n];
;; yield P;
;; c ← [*, 1, ..., 1]; (the first entry of c is not used)
;; i ← 2;
;; while i ≤ n do
;;     left-rotate the first i entries of P;
;;     (e.g. left-rotating the first 4 entries of
;;     [4,2,5,3,1] would give [2,5,3,4,1])
;;     if c[i]<i then
;;         c[i] ← c[i]+1;
;;         i ← 2;
;;         yield P;
;;     else
;;         c[i] ← 1;
;;         i ← i+1;


;; Let's translate this pseudocode to Racket.

;; vector-left-rotate!: vector natural -> void
;; Left-rotates the first n elements in the vector.
(define (vector-left-rotate! vec n)
  (with ([vec :vector] [n :int])
    (cond
      [(= n 0) 
       (void)]
      [else
       (def temp (vec 0))
       (vector-copy! vec 0 vec 1 n)
       (vec! n-1 temp)])))


;; Let's test the vector left rotate function.
(module+ test
  (require racket/block rackunit)

  (block 
   (define vec (vector 1 2 3 4 5))
   (vector-left-rotate! vec 0)
   (check-equal? vec (vector 1 2 3 4 5)))

  (block 
   (define vec (vector 1 2 3 4 5))
   (vector-left-rotate! vec 1)
   (check-equal? vec (vector 1 2 3 4 5)))

  (block 
   (define vec (vector 1 2 3 4 5))
   (vector-left-rotate! vec 2)
   (check-equal? vec (vector 2 1 3 4 5)))

  (block 
   (define vec (vector 1 2 3 4 5))
   (vector-left-rotate! vec 3)
   (check-equal? vec (vector 2 3 1 4 5)))

  (block 
   (define vec (vector 1 2 3 4 5))
   (vector-left-rotate! vec 4)
   (check-equal? vec (vector 2 3 4 1 5)))

  (block 
   (define vec (vector 1 2 3 4 5))
   (vector-left-rotate! vec 5)
   (check-equal? vec (vector 2 3 4 5 1))))




;; We should provide a helper function to generate 
;; fresh permutation states and to get to the next state.


;; make-perm-state: natural -> (values vector (-> boolean))
;; Returns the current permutation vector, and a function that will
;; mutate that vector to the next state.
(define (make-perm-state n)
  (def V (for/vector ([i (in-range n)]) i))
  (def c :vector (make-vector n 0))
  (def i :int 1)

  ;; perm-state-next!: -> boolean
  ;; Returns #t if we can successfully find the next permutation state.  Returns #f
  ;; otherwise.
  (define (perm-state-next!)
    (cond [(< i n)
           (vector-left-rotate! V i+1)
           (cond [(< (c i) i)
                  (c! i (add1 (c i)))
                  (i! 1)
                  #t]
                 [else
                  (c! i 0)
                  i++ 
                  (perm-state-next!)])]
          [else #f]))

  (values V perm-state-next!))


;; Let's test perm-state with three elements exhaustively.
(module+ test
  (block 
   (define-values (v n!) (make-perm-state 3))
   (check-equal? v #(0 1 2))
   (check-equal? (n!) #t)
   (check-equal? v #(1 0 2))
   (check-equal? (n!) #t)
   (check-equal? v #(1 2 0))
   (check-equal? (n!) #t)
   (check-equal? v #(2 1 0))
   (check-equal? (n!) #t)
   (check-equal? v #(2 0 1))
   (check-equal? (n!) #t)
   (check-equal? v #(0 2 1))
   ;; At the end of the iteration, we should get
   ;; #f from the next! function
   (check-equal? (n!) #f)))