;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Fri Jan 27 22:00:59 2006 +0530 <enometh@meer.net>
;;;   Time-stamp: <06/01/28 15:00:55 madhu>
;;;
;;;  $Id: permutations.lisp,v 1.2 2006/01/28 09:31:05 madhu Exp madhu $
;;;
(defpackage "PERMUTE"
  (:use "CL")
  (:export "FOR-AS-PERMUTATION-IN"))
(in-package "PERMUTE")

(defun factorial (n) (if (zerop n) 1 (* n (factorial (1- n)))))

(defun q (m)
  "Return least number whose factorial does not divide M."
  (let ((h 2)) 
    (loop (multiple-value-bind (f r) (floor m h)
	    (if (zerop r)
		(setq h (1+ h) m f)
		(return h))))))

(defun permutations-f (bag f)
  "Call F repeatedly on a sequence containing in turn each
permutation of the given sequence BAG"
  (let* ((seq (copy-seq bag))
	 (n (length seq))
	 (a (apply 'vector (loop for i below n collect i))))
    (funcall f seq)
    (when (>= n 2)
      (let* ((fact-n (factorial n))
	     (m 1))
	(loop
	   (rotatef (elt a 0) (elt a 1))
	   (rotatef (elt seq 0) (elt seq 1))
	   (incf m)
	   (funcall f seq)
	   (if (= m fact-n) (return))
	   ;;  H is the least number whose factorial does not divide M.
	   (let ((h (q m))
		 (min n)
		 j)
	     (assert h)
	     ;; J is the index such that a[J] - a[H] (MOD N) is minimal.
	     (loop for i from 1 to (1- h)
		   for temp = (- (elt a (1- i))
				 (elt a (1- h)))
		   if (< temp 0) do (incf temp n)
		   if (< temp min) do (setq min temp j i))
	     (assert j)
	     (decf h)
	     (decf j)
	     (rotatef (elt a h) (elt a j))
	     (rotatef (elt seq h) (elt seq j)))
	   (incf m)
	   (funcall f seq))))))

#+nil
(permutations-f #(1 2 3) #'print)

#+nil
(permutations-f '(foo bar) #'print)

;; TODO lobby for inclusion as LOOP clause
(defmacro for-as-permutation-in ((var bag &optional RESULT) &body body)
  "WITH-PERMUTATION (VAR BAG) &BODY. Execute BODY with VAR bound
to each of all permutations of the sequence BAG"
  (let ((body-name (gensym)))
    `(block nil
       (flet ((,body-name (,var) ,@body))
	 (permutations-f ,BAG  #',body-name)
	 ,result))))

#+nil
(for-as-permutation-in (x (list 1 2 3 'bar))
  (print x))

#+nil
(for-as-permutation-in (x "foobar")
  (print x))

#+nil
(defun test-perm ()
  (let ((n 0))
    (for-as-permutation-in (x (vector 1 2 3 4'bar 'foo) T)
      (incf n))
    (values n (factorial 6))))

#+nil
(test-perm)