all perms N nested loops callback backtracking

;; https://stackoverflow.com/questions/49848994
;;   /how-to-generate-all-the-permutations-of-elements-in-a-list-one-at-a-time-in-lisp
;;   /49907365#49907365
;; by https://stackoverflow.com/users/849891/will-ness

(defun permutations (list callback)
  (when list
    (let* ((all (cons 'head (copy-list list)))           ; head sentinel FTW!
           (perm (make-array (length list))))
      (labels ((g (p i &optional (q (cdr p)))
                (cond
                  ((null (cdr q))
                     (setf (svref perm i) (car q))       ; the last item
                     (funcall callback perm))
                  ((null (cddr q))
                     (setf (svref perm i) (car q))       ; the last two items
                     (setf (svref perm (+ i 1)) (cadr q))
                     (funcall callback perm)
                     (setf (svref perm i) (cadr q))
                     (setf (svref perm (+ i 1)) (car q))
                     (funcall callback perm))
                  (T (loop while q do
                        (setf (svref perm i) (car q))    ; pick the item
                        (rplacd p (cdr q))               ; shrink the domain
                        (g all (+ 1 i))                  ; recurse!
                        (rplacd p q)                     ; heal the list back
                        (pop p)
                        (pop q))))))                     ; advance the pointers
        (g all 0)))))

(time (let ((c 0))
  (permutations '(1 2 3) #'(lambda(p)(format t "~A " p)))      ; incf c
  (print c)))