Algorithm T

algorithm-t.lisp

(defun factorial(x)
  (reduce '* (loop for a from x downto 1 collect a)))

(defun algorithm-t (n &aux (num (factorial n)))
  (let ((table (make-array num :element-type `(integer 1 ,n) :initial-element 0))
        (m 2)
        j k d)
    (setf d (floor num 2)
          (aref table d) 1)
    (loop until (= m n)
          do (progn (incf m)
                    (setf d (floor d m))
                    (setf k 0)
                    (prog ()
                     t3
                       (setf k (+ k d)
                             j (- m 1))
                       (loop while (> j 0)
                            do (setf (aref table k) j
                                     j (1- j)
                                     k (+ k d)))
                      (incf (aref table k))
                      (setf k (+ k d))
                      (loop while (< j (1- m))
                            do (progn
                                 (incf j)
                                 (setf (aref table k) j
                                       k (+ k d))))
                      (if (< k num)
                          (go t3)))
                    )
          finally (return table))))


(defun n-th-permutation (n array table &aux tmp (array (copy-seq array)))
  (loop for k from 1 to n
        do (setf tmp (aref array (1- (aref table k)))
                 (aref array (1- (aref table k))) (aref array (aref table k))
                 (aref array (aref table k)) tmp)
        finally (return array)))