;;; Permutations
;;; John David Stone
;;; Department of Computer Science
;;; Grinnell College
;;; created April 24, 1999
;;; last revised January 6, 2017
(define-library (afp permutations)
(export permutations ordered-permutations
ordered-permutations-source permutation-rank permutation-unrank)
(import (afp primitives)
(only (afp arithmetic) add1 sub1 factorial)
(only (afp procedure-sections) equal-to)
(only (afp lists)
first rest empty-list? prepend catenate position-in
all-but-position)
(only (afp sources)
tap finite-source catenate-sources
ordered-prepend-to-each-source)
(only (afp bags)
bag empty-bag? extract-from-bag fold-bag bag-union
prepend-to-each))
(begin
;; ===== permutations =================================================
;; bag(alpha) -> bag(list(alpha))
;; aro
;; The permutations procedure constructs a bag containing every list
;; that can be formed from the values in aro, using each value exactly
;; once.
(define (permutations aro)
(if (empty-bag? aro)
(bag (list))
((fold-bag bag
(lambda (chosen recursive-result)
(receive (ignored others)
(extract-from-bag (equal-to chosen) aro)
(bag-union (prepend-to-each chosen
(permutations others))
recursive-result))))
aro)))
;; ===== ordered-permutations =========================================
;; list(alpha) -> list(list(alpha))
;; ls
;; The ordered-permutations procedure constructs a list containing all
;; the permutations of ls, in lexicographic order.
;; Precondition:
;; ls is ordered.
(define (ordered-permutations ls)
(let ((len (length ls)))
(if (zero? len)
(list (list))
((rec (recurrer position)
(if (= position len)
(list)
(catenate
(prepend-to-each (list-ref ls position)
(ordered-permutations
(all-but-position ls position)))
(recurrer (add1 position)))))
0))))
;; ===== ordered-permutations-source ==================================
;; list(alpha) -> source(list(alpha))
;; ls
;; The ordered-permutations-source constructs a finite source
;; containing all the permutations of ls, in lexicographic order.
(define (ordered-permutations-source ls)
(let ((len (length ls)))
(if (zero? len)
(finite-source (list))
((rec (recurrer position)
(if (= position len)
(finite-source)
(source
(let ((prepender
(ordered-prepend-to-each-source
(list-ref ls position)
(ordered-permutations-source
(all-but-position ls position)))))
(tap (catenate-sources
prepender
(recurrer (add1 position))))))))
0))))
;; ===== permutation-rank =============================================
;; list(alpha), list(alpha) -> natural-number
;; ls perm
;; The permutation-rank procedure computes the rank of perm in the
;; lexicographic ordering of the permutations of ls.
;; Preconditions:
;; ls is ordered.
;; perm is a permutation of ls.
(define (permutation-rank ls perm)
(if (empty-list? ls)
0
(let ((position (position-in (first perm) ls)))
(+ (* position (factorial (sub1 (length ls))))
(permutation-rank (all-but-position ls position)
(rest perm))))))
;; ===== permutation-unrank ===========================================
;; list(alpha), natural-number -> list(alpha)
;; ls rank
;; The permutation-unrank procedure constructs the permutation that is
;; in position rank in the lexicographic ordering of the permutations
;; of ls.
;; Preconditions:
;; ls is ordered.
;; rank is less than the factorial of the length of ls.
(define (permutation-unrank ls rank)
(if (empty-list? ls)
(list)
(receive (position subrank)
(div-and-mod rank (factorial (sub1 (length ls))))
(prepend (list-ref ls position)
(permutation-unrank (all-but-position ls position)
subrank)))))))
;;; copyright (C) 2011, 2017 John David Stone
;;; This program is free software. You may 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. A copy of the GNU General Public
;;; License is available on the World Wide Web at
;;;
;;; http://www.gnu.org/licenses/gpl.html
;;;
;;; 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.