home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / EFFO / forum3.lzh / LISP / queens.lsp < prev    next >
Lisp/Scheme  |  1988-01-22  |  2KB  |  86 lines

  1. ;
  2. ; Place n queens on a board (graphical version)
  3. ;  See Winston and Horn Ch. 11
  4. ; Usage:
  5. ;    (queens <n>)
  6. ;          where <n> is an integer -- the size of the board - try (queens 4)
  7.  
  8. (defun cadar (x)
  9.   (car (cdr (car x))))
  10.  
  11. ; Do two queens threaten each other ?
  12. (defun threat (i j a b)
  13.   (or (equal i a)            ;Same row
  14.       (equal j b)            ;Same column
  15.       (equal (- i j) (- a b))        ;One diag.
  16.       (equal (+ i j) (+ a b))))        ;the other diagonal
  17.  
  18. ; Is poistion (n,m) on the board safe for a queen ?
  19. (defun conflict (n m board)
  20.   (cond ((null board) nil)
  21.     ((threat n m (caar board) (cadar board)) t)
  22.     (t (conflict n m (cdr board)))))
  23.  
  24.  
  25. ; Place queens on a board of size SIZE
  26. (defun queens (size)
  27.   (prog (n m board soln)
  28.     (setq soln 0)            ;Solution #
  29.     (setq board nil)
  30.     (setq n 1)            ;Try the first row
  31.     loop-n
  32.     (setq m 1)            ;Column 1
  33.     loop-m
  34.     (cond ((conflict n m board) (go un-do-m))) ;Check for conflict
  35.     (setq board (cons (list n m) board))       ; Add queen to board
  36.     (cond ((> (setq n (1+ n)) size)            ; Placed N queens ?
  37.            (print-board (reverse board) (setq soln (1+ soln))))) ; Print it
  38.     (go loop-n)                       ; Next row which column?
  39.     un-do-n
  40.     (cond ((null board) (return 'Done))        ; Tried all possibilities
  41.           (t (setq m (cadar board))           ; No, Undo last queen placed
  42.          (setq n (caar board))
  43.          (setq board (cdr board))))
  44.  
  45.     un-do-m
  46.     (cond ((> (setq m (1+ m)) size)          ; Go try next column
  47.            (go un-do-n))
  48.           (t (go loop-m)))))
  49.  
  50.  
  51. ;Print a board
  52. (defun print-board  (board soln &aux size)
  53.   (setq size (length board))        ;we can find our own size
  54.   (terpri)
  55.   (princ "\t\tSolution: ")
  56.   (print soln)
  57.   (terpri)
  58.   (princ "\t")
  59.   (print-header size 1)
  60.   (terpri)
  61.   (print-board-aux board size 1)
  62.   (terpri))
  63.  
  64. ; Put Column #'s on top
  65. (defun print-header (size n)
  66.   (cond ((> n size) terpri)
  67.     (t (princ n)
  68.        (princ " ")
  69.        (print-header size (1+ n)))))
  70.  
  71. (defun print-board-aux (board size row)
  72.   (terpri)
  73.   (cond ((null board))
  74.     (t (princ row)            ;print the row #
  75.        (princ "\t")
  76.        (print-board-row (cadar board) size 1) ;Print the row
  77.        (print-board-aux (cdr board) size (1+ row)))))  ;Next row
  78.  
  79. (defun print-board-row (column size n)
  80.   (cond ((> n size))
  81.     (t (cond ((equal column n) (princ "Q"))
  82.          (t (princ ".")))
  83.        (princ " ")
  84.        (print-board-row column size (1+ n)))))
  85.