|
LISP solution to 8 queens problem
;;;The following common lisp program is based on a solution given by
;;;Winston and Horn ("Lisp 3rd edition",1989, p.289, 538-539.)
;;;Significant improvements and alterations were made in all but the most
;;;primitive functions. To run, simply load file and type (queen n) where
;;;n is the width of board.
;discovers if a piece threatens another
(defun threat (i j a b)
(or (= i a)
(= j b)
(= (- i j) (- a b))
(= (+ i j) (+ a b))))
;discovers if a placement is OK
(defun conflict (n m board)
(cond ((endp board) nil)
((threat n
m
(first (first board))
(second (first board)))
t)
(t (conflict n m (rest board)))))
;;this now prints a board no matter what order it is presented in
(defun print-board (board)
; (sort board #'<= :key #'car)
(format t "~%*")
(print-horizontal-border board)
(format t "*")
(dotimes (row (length board))
(format t "~%|")
(dotimes (column (length board))
(if (= column (second (assoc row board)))
(format t " Q")
(format t " .")))
(format t " |"))
(format t "~%*")
(print-horizontal-border board)
(format t "*"))
(defun print-horizontal-border (board)
(dotimes (n (+ 1 (* 2 (length board))))
(format t "-")))
;;;The following is Winston/Horn's original queen-finding algorithm.
;;;It does not discriminate sets of solutions that are closed under rotation
;;;and reflection. Thus, a single solution can be equivalent to up to 8 other
;;;solutions.
(defun queen* (size &optional (board nil) (n 0) (m 0))
(unless (= m size)
;;Check for conflict in current row and column
(unless (conflict n m board)
(if (= (+ 1 n) size)
;;If all queens placed, prin solution:
(print-board (reverse (cons (list n m) board)))
;;Otherwise, proceed to next row:
(queen* size (cons (list n m) board) (+ 1 n) 0)))
;;In any case, try with another column
(queen* size board n (+ 1 m))))
;;; This version improves on Winston/Horn in that it displays only one instance
;;;of a closed set of solutions. Thus, 8-queens solution is reduced from 96 to 12.
;;;It achieves this by using a bindings list of already-found solutions. Since a change
;;;made at a deeper level of recursive search must be accessible to a higher level,
;;;the bindings list was made a global parameter that is re-initialized when queen is called.
;;; This required an auxilliary function, thus labels.
;;;NO-REPEATS predicate returns t if no member of the set of solutions, closed under reflection
;;;and rotation, is on the bindings list.
;;;Finally, the local variable new-board was assigned to save re-calculating that data.
(defun queen (size)
;;initialize bindings variable
(defparameter *bindings* nil)
;;declare auxilliary function
(labels ((n-queen (size &optional (board nil) (n 0) (m 0))
(unless (= m size)
(let ((new-board (cons (list n m) board)))
(unless (conflict n m board)
(if (= (+ 1 n) size)
;;check to see if solution is repeated
(if (no-repeats new-board (- size 1))
(progn ;only print solution if not already printed
(print-board new-board)
(setf *bindings* (append (list (sort-board new-board))
*bindings*)))) ;change bindings
(n-queen size (cons (list n m) board) (+ 1 n) 0))))
(n-queen size board n (+ 1 m)))))
;;call auxilliary function:
(n-queen size nil 0 0)))
(defun no-repeats (board size)
"looks to see if a permutation of current board has already been found--assumes a properly sorted bindings list"
;(format t "~&Bindings are: ~a" *bindings*)
;(format t "~&Equiv. Class is: ~a" (make-set board size))
(if (equal *bindings* nil) ;check to see if bindings in nil---find has a problem with this
t
(labels ((find-double (-eq-class-)
(if (equal nil -eq-class-)
t
(and (not (find (first -eq-class-) *bindings* :test #'equal)) ;find solution in bindings
(find-double (rest -eq-class-))))))
(find-double (make-set board size)))))
(defun reflect-horizontal (board size &optional (new-board nil))
"reflects across horizontal axis"
(if (equal board nil)
new-board
(reflect-horizontal (rest board) size (cons (list (- size (first (first board)))
(second (first board)))
new-board))))
(defun rotate-90 (board size &optional (new-board nil))
"reflects across diagonal axis"
(if (equal board nil)
(sort-board new-board)
(rotate-90 (rest board) size (cons (list (second (first board))
(- size (first (first board))))
new-board))))
(defun make-set (board size)
(let*((board1 (sort-board board))
(board2 (rotate-90 board1 size))
(board3 (rotate-90 board2 size))
(board4 (rotate-90 board3 size))
(board5 (reflect-horizontal board1 size))
(board6 (rotate-90 board5 size))
(board7 (rotate-90 board6 size))
(board8 (rotate-90 board7 size)))
(list board1
board2
board3
board4
board5
board6
board7
board8)))
(defun sort-board (board &optional (counter 0))
"sorts a board configuration into ascending order by rows"
(if (= counter (length board))
nil
(cons (assoc counter board)
(sort-board board (+ counter 1)))))
Link to Shane's Home
Page | Link to Main 8 queens page
Shane Mueller <smueller@obereed.net>
http://www.obereed.net/queens/algorithm.html |