エイト・クイーン、ついでに N-クイーン

エイト・クイーンを解くプログラムを Common Lisp で書いてみた。
関数 queen にボードのサイズ N を与えると、N×N のボードで N-クイーン問題を解く。
キーワード引数はふたつ。display に nil でない値を与えると、見つけたパターンをすべて表示する。base-only に nil でない値を与えると、回転・反転で同じになるものはそのうちの１つだけが解となる。

コード：

(defun queen (size &key display base-only)
  (if base-only
      (queen-base size :display display)
      (queen-all  size :display display)))


(defun queen-all (size &key display)
  (let ((board nil)
        (total 0))
    (labels ((rec (j)
               (dotimes (i size)
                 (unless (conflict i j board)
                   (if (= j (1- size))
                       (progn
                         (incf total)
                         (when display
                           (format t "~%[~A]~%" total)
                           (print-board (cons (list i j) board)))
                         (return))
                       (progn
                         (push (list i j) board)
                         (rec (1+ j))
                         (pop board)))))))
      (rec 0))
    (format t "~&~%Total: ~A~%" total)))


(defun queen-base (size &key display)
  (let ((board nil)
        (bases nil)
        (total 0)
        (base-total 0))
    (labels
        ((rec (j)
           (dotimes (i size)
             (unless (conflict i j board)
               (if (= j (1- size))
                   (let ((normalized
                          (sort-board (cons (list i j)
                                            (copy-tree board)))))
                     (incf total)
                     (when (base? normalized bases)
                       (incf base-total)
                       (push normalized bases)
                       (when display
                         (format t "~%[~A]~%" base-total)
                         (print-board normalized)))
                     (return))
                   (progn
                     (push (list i j) board)
                     (rec (1+ j))
                     (pop board)))))))
      (rec 0))
    (format t "~&Base/total: ~A/~A~%" base-total total)))



(defun print-board (board)
  (let* ((size (length board))
         (pos-table (make-array (list size size)
                               :initial-element nil)))
    (dolist (pos board)
      (setf (aref pos-table (first pos) (second pos)) t))
    (princ "*")
    (dotimes (i (1+ (* 2 size))) (princ "-"))
    (format t "*~%")
    (dotimes (i size)
      (princ "|")
      (dotimes (j size)
        (princ (if (aref pos-table i j) " Q" " X")))
      (format t " |~%"))
    (princ "*")
    (dotimes (i (1+ (* 2 size))) (princ "-"))
    (format t "*~%")))


(defun threat (i j a b)
  (or (= i a)
      (= j b)
      (= (+ i j) (+ a b))
      (= (- i j) (- a b))))


(defun conflict (i j board)
  (cond ((null board) nil)
        ((threat i
                 j
                 (first (car board))
                 (second (car board)))
         t)
        (t (conflict i j (cdr board)))))


(defun sort-board (board)
  (sort board #'< :key #'car))


(defun roll-board (board)
  (let ((new-board nil)
        (max-index (1- (length board))))
    (dolist (pos board)
      (push (list (second pos)
                  (- max-index (first pos)))
            new-board))
    (sort-board new-board)))


(defun mirror-board (board)
  (let ((new-board nil)
        (max-index (1- (length board))))
    (dolist (pos board)
      (push (list (first pos)
                  (- max-index (second pos)))
            new-board))
    (sort-board new-board)))


(defun base? (board bases)
  (let ((rolled board))
    (flet ((return-test ()
             (when (member rolled bases :test #'equal)
               (return-from base? nil))))
      (dotimes (i 3)
        (setq rolled (roll-board rolled))
        (return-test))
      (setq rolled (mirror-board board))
      (return-test)
      (dotimes (i 3)
        (setq rolled (roll-board rolled))
        (return-test))))
  t)

使用例：

CL-USER> (queen 4 :display t)

[1]
*---------*
| X X Q X |
| Q X X X |
| X X X Q |
| X Q X X |
*---------*

[2]
*---------*
| X Q X X |
| X X X Q |
| Q X X X |
| X X Q X |
*---------*

Total: 2
NIL
CL-USER> (queen 4 :display t :base-only t)

[1]
*---------*
| X X Q X |
| Q X X X |
| X X X Q |
| X Q X X |
*---------*
Base/total: 1/2
NIL
CL-USER> (queen 4 :base-only t)
Base/total: 1/2
NIL
CL-USER> (queen 8 :display t :base-only t)

[1]
*-----------------*
| Q X X X X X X X |
| X X X X X X Q X |
| X X X X Q X X X |
| X X X X X X X Q |
| X Q X X X X X X |
| X X X Q X X X X |
| X X X X X Q X X |
| X X Q X X X X X |
*-----------------*

[2]
*-----------------*
| Q X X X X X X X |
| X X X X X X Q X |
| X X X Q X X X X |
| X X X X X Q X X |
| X X X X X X X Q |
| X Q X X X X X X |
| X X X X Q X X X |
| X X Q X X X X X |
*-----------------*

[3]
*-----------------*
| X X X X X Q X X |
| Q X X X X X X X |
| X X X X Q X X X |
| X Q X X X X X X |
| X X X X X X X Q |
| X X Q X X X X X |
| X X X X X X Q X |
| X X X Q X X X X |
*-----------------*

[4]
*-----------------*
| X X X Q X X X X |
| Q X X X X X X X |
| X X X X Q X X X |
| X X X X X X X Q |
| X Q X X X X X X |
| X X X X X X Q X |
| X X Q X X X X X |
| X X X X X Q X X |
*-----------------*

[5]
*-----------------*
| X X X X Q X X X |
| Q X X X X X X X |
| X X X X X X X Q |
| X X X Q X X X X |
| X Q X X X X X X |
| X X X X X X Q X |
| X X Q X X X X X |
| X X X X X Q X X |
*-----------------*

[6]
*-----------------*
| X X Q X X X X X |
| Q X X X X X X X |
| X X X X X X Q X |
| X X X X Q X X X |
| X X X X X X X Q |
| X Q X X X X X X |
| X X X Q X X X X |
| X X X X X Q X X |
*-----------------*

[7]
*-----------------*
| X X X X Q X X X |
| Q X X X X X X X |
| X X X Q X X X X |
| X X X X X Q X X |
| X X X X X X X Q |
| X Q X X X X X X |
| X X X X X X Q X |
| X X Q X X X X X |
*-----------------*

[8]
*-----------------*
| X X X X X X Q X |
| Q X X X X X X X |
| X X Q X X X X X |
| X X X X X X X Q |
| X X X X X Q X X |
| X X X Q X X X X |
| X Q X X X X X X |
| X X X X Q X X X |
*-----------------*

[9]
*-----------------*
| X X X X Q X X X |
| Q X X X X X X X |
| X X X X X X X Q |
| X X X X X Q X X |
| X X Q X X X X X |
| X X X X X X Q X |
| X Q X X X X X X |
| X X X Q X X X X |
*-----------------*

[10]
*-----------------*
| X X X X Q X X X |
| X X Q X X X X X |
| Q X X X X X X X |
| X X X X X X Q X |
| X Q X X X X X X |
| X X X X X X X Q |
| X X X X X Q X X |
| X X X Q X X X X |
*-----------------*

[11]
*-----------------*
| X X X X Q X X X |
| X X X X X X Q X |
| Q X X X X X X X |
| X X X Q X X X X |
| X Q X X X X X X |
| X X X X X X X Q |
| X X X X X Q X X |
| X X Q X X X X X |
*-----------------*

[12]
*-----------------*
| X X X X X Q X X |
| X X Q X X X X X |
| Q X X X X X X X |
| X X X X X X X Q |
| X X X Q X X X X |
| X Q X X X X X X |
| X X X X X X Q X |
| X X X X Q X X X |
*-----------------*
Base/total: 12/92
NIL
CL-USER> (queen 12 :base-only t)
Base/total: 1787/14200
NIL