Re: permutation

Here is the library i normally use to do permutation calculations.
If anyone wants to give me feed-back or suggestions, i'll be happy
to hear them.


(defpackage perm-gen
(:use "COMMON-LISP")
(:export "COUNT-PERMUTATIONS"
"LIST-PERMUTATIONS"
"APPLY-PERMUTATIONS"
"FIND-FIRST-PERMUTATION"))

(in-package :perm-gen)

;; Like lconc except that it does not
;; advance the cdr of the conc to the end of the list
;; until necessary. for lconc and tconc the conc structure
;; usually is in a state where (cdr conc) is the last cons
;; cell of the list. in the case of lazy-lconc and lazy-tconc
;; (cdr conc) is just some cons cell but will be advanced to the
;; end on demand whenevery anything needs to be added.
(defun lazy-lconc (conc list)
(let ((ptr (cdr conc)))
(if ptr
(progn
(loop while (cdr ptr)
do (pop ptr))
(setf (cdr ptr) list)
(setf (cdr conc) ptr))
(progn
(setf (car conc) list)
(setf (cdr conc) list)))))

;; Efficiently append a single item descructively to the end
;; of a conc-list.
(defun lazy-tconc (conc item)
(lazy-lconc conc (list item)))

;; Remove the given element the first time it occurs
;; in the list consing as few cells as possible,
;; and only traversing as far as necessary into the list.
;; This function is completely non-destructive.
;; This is done by using tconc to collect the elements
;; of the list until we reach the unwanted item,
;; then using lconc to setf cdr to the remaining elements
;; without traversing any further.
;; An annoying side effect is that if the unwanted element
;; is not found then the entire list is re-allocated and then simply
;; thrown away for the garbage collector.
;; This does not matter for our application because we always
;; call remove-preserving-tail with an item that is for sure in
;; the list, but an in-general a safer implementation would save list
;; and return that value rather than returning nil in case the
;; item is unfound.
(defun remove-preserving-tail (item list)
(declare (list list))
(if (eql item (car list))
(cdr list)
(let ((conc (list nil)))
(declare (list conc))
(loop for sub on list
do (if (eql item (car sub))
(progn (lazy-lconc conc (cdr sub))
(return-from remove-preserving-tail (car conc)))
(lazy-tconc conc (car sub))))
list)))

;; Iteratively calculate all the permutations of LIMIT number
;; of elements from the list OBJECTS, and call the function VISIT
;; on each of them.
(defun apply-permutations (objects limit visit)
(declare (function visit)
(list objects))
(labels ((apply-rec (limit remaining current-perm)
(cond
((plusp limit)
(dolist (i remaining)
(apply-rec (1- limit)
(remove-preserving-tail i remaining)
(cons i current-perm))))
(t
(funcall visit current-perm)))))
(when (<= limit (length objects))
(apply-rec limit objects nil))))

;; Find a permutation of a given list of objects which is a 4 element
;; palindrome.
;; e.g., (find-first-permutation '(1 4 3 5 2 4 1 2)
;; 4
;; (lambda (perm)
;; (equal perm (reverse perm))))
;; --> (1 4 4 1)
(defun find-first-permutation (objects limit predicate)
(apply-permutations objects
limit
(lambda (perm)
(when (funcall predicate perm)
(return-from find-first-permutation perm)))))

;; Count the number of permutations of a given list which make
;; the given predicate TRUE.
;; e.g., count the number of symmetric permutations, (Palindromes)
;; (count-permutations '(1 2 2 3 3 2 2 4 4 1)
;; 5
;; (lambda (perm)
;; (equal perm (reverse perm))))
;; --> 1152
(defun count-permutations (objects limit &optional (predicate
(constantly t)))
(declare (optimize (speed 2))
(function predicate))
(let ((count 0))
(declare (integer count))
(apply-permutations objects
limit
(lambda (perm)
(when (funcall predicate perm)
(incf count))))
count))

(defun list-permutations (objects limit &optional (predicate
(constantly t)))
(let (perms)
(apply-permutations objects
limit
(lambda (perm)
(when (funcall predicate perm)
(push perm perms))))
perms))

;; examples
;; .
;; .
;; .
(defun print-it (obj)
(fresh-line)
(format t "~A" obj)
(force-output))

(defun visit-and-print (objects)
(apply-permutations objects
(length objects)
(lambda (x)
(print-it x)
(read-char))))

.

Relevant Pages

  • Re: Collect from a recursion
    ... this will only work for small lists. ... number of permutations grows very fast with increasing number ... ;; advance the cdr of the conc to the end of the list ... ;; usually is in a state where (cdr conc) is the last cons ...
    (comp.lang.lisp)
  • Re: how to remove but preserve tail.
    ... the ideas of tconc and lconc. ... ;; then using lconc to setf cdr to the remaining elements ... (progn (lazy-lconc conc (cdr sub)) ... (if ptr ...
    (comp.lang.lisp)