Calculating permutations using Steinhaus–Johnson–Trotter alg

(defun permutations (function vector)
  (declare (type function function))
  (declare (type vector vector))
  (declare (optimize (speed 3) (safety 0)))
  (let* ((vector-length (length vector))
     (ordered
      (do ((i 0 (1+ i))
           (result (make-hash-table)))
          ((= i vector-length)
           (return result))
        (setf (gethash (aref vector i) result) i)))
     (directions
      (make-array
       vector-length
       :element-type 'function
       :initial-element #'1-)))
    (labels ((elt< (a b)
           (< (gethash a ordered)
          (gethash b ordered))))
      (setf (aref directions 0) #'identity)
      (do ((i 1 (1+ i))
       (a 1)
       (b 1))
      ((= b (1+ vector-length)))
    (when (= i a)
      (setf b (1+ b) a (* a b)))
    (if (= i 1) (funcall function vector)
        (do* ((n 0 (1+ n))
          (sign (aref directions n) (aref directions n))
          (element (aref vector n) (aref vector n))
          (largest) (largest-index)
          (swap) (swap-index))
         (nil)
          (when (and (not (eq sign #'identity))
             (or (null largest)
                 (elt< largest element)))
        (setf largest element
              largest-index n
              swap-index (funcall sign n)
              swap (aref vector swap-index)))
          (when (= n (1- vector-length))
        (setf (aref vector swap-index) largest
              (aref vector largest-index) swap
              sign (aref directions swap-index)
              (aref directions swap-index) (aref directions largest-index)
              (aref directions largest-index) sign)
        (when (or (= swap-index 0)
              (= swap-index (1- vector-length))
              (elt< largest
                (aref vector
                      (funcall (aref directions swap-index)
                           swap-index))))
          (setf (aref directions swap-index) #'identity))
        (funcall function vector)
        (dotimes (j vector-length)
          (cond
            ((and (< j swap-index)
              (elt< largest (aref vector j)))
             (setf (aref directions j) #'1+))
            ((and (> j swap-index)
              (elt< largest (aref vector j)))
             (setf (aref directions j) #'1-))))
        (return))))))))

(permutations
 #'(lambda (x)
     (format t "~{~s ~}~&" (coerce x 'list)))
 #(1 2 3 4))