home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / QUEENS2.LSP < prev    next >
Lisp/Scheme  |  1995-12-27  |  2KB  |  73 lines
  1. ; queens2.lsp
  2. ;
  3. ; Place n queens on a board (graphical version)
  4. ;  See Winston and Horn Ch. 11
  5. ; 
  6. ; Usage:
  7. ;    (queens <n>)
  8. ;          where <n> is an integer -- the size of the board - try (queens 4)
  9.  
  10. ; Do two queens threaten each other ?
  11. (defun threat (i j a b)
  12.   (or (eql i a)            ;Same row
  13.       (eql j b)            ;Same column
  14.       (eql (- i j) (- a b))    ;One diag.
  15.       (eql (+ i j) (+ a b))))    ;the other diagonal
  16.  
  17. ; Is position (n,m) on the board safe for a queen ?
  18. (defun conflict (n m board)
  19.   (cond ((null board) nil)
  20.     ((threat n m (caar board) (cadar board)) t)
  21.     (t (conflict n m (cdr board)))))
  22.  
  23.  
  24. ; Place queens on a board of size SIZE
  25. (defun queens (size)
  26.   (prog (n m board soln)
  27.     (setq soln 0)            ;Solution #
  28.     (setq board nil)
  29.     (setq n 1)            ;Try the first row
  30.     loop-n
  31.     (setq m 1)            ;Column 1
  32.     loop-m
  33.     (cond ((conflict n m board) (go un-do-m))) ;Check for conflict
  34.     (setq board (cons (list n m) board))       ; Add queen to board
  35.     (cond ((> (setq n (1+ n)) size)            ; Placed N queens ?
  36.            (print-board (reverse board) (setq soln (1+ soln))))) ; Print it
  37.     (go loop-n)                       ; Next row which column?
  38.     un-do-n
  39.     (cond ((null board) (return 'Done))        ; Tried all possibilities
  40.           (t (setq m (cadar board))           ; No, Undo last queen placed
  41.          (setq n (caar board))
  42.          (setq board (cdr board))))
  43.  
  44.     un-do-m
  45.     (cond ((> (setq m (1+ m)) size)          ; Go try next column
  46.            (go un-do-n))
  47.           (t (go loop-m)))))
  48.  
  49.  
  50. ;Print a board
  51. (defun print-board  (board soln &aux size)
  52.   (setq size (length board))        ;we can find our own size
  53.   (format t "\t\tSolution ~s\n\n\t" soln)
  54.   (print-header size 1)
  55.   (print-board-aux board size)
  56.   (terpri))
  57.  
  58. ; Put Column #'s on top
  59. (defun print-header (size n)
  60.   (dotimes (i size) (format t "~s " (1+ i)))
  61.   (terpri))
  62.  
  63. (defun print-board-aux (board size &aux (row 0))
  64.   (mapc #'(lambda (x) 
  65.           (format t "~s\t" (setq row (1+ row)))
  66.           (print-board-row (cadr x) size))
  67.     board))
  68.           
  69. (defun print-board-row (column size)
  70.        (dotimes (i size) (princ (if (eql column (1+ i)) "Q " ". ")))
  71.        (terpri))
  72.  
  73.