home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / Programming / Source / winterp-1.13 / examples / xlisp-1.6 / queens2.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  3.5 KB  |  110 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         queens2.lsp
  5. ; RCS:          $Header: $
  6. ; Description:  Place n queens on a board (graphical version)
  7. ;        See Winston and Horn Ch. 11
  8. ;        Usage:
  9. ;            (queens <n>)
  10. ;        where <n> is an integer -- the size of the board - try (queens 4)
  11. ; Author:       Winston and Horn 
  12. ; Created:      Sat Oct  5 21:02:18 1991
  13. ; Modified:     Sat Oct  5 21:03:18 1991 (Niels Mayer) mayer@hplnpm
  14. ; Language:     Lisp
  15. ; Package:      N/A
  16. ; Status:       X11r5 contrib tape release
  17. ;
  18. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  19. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  20. ;
  21. ; Permission to use, copy, modify, distribute, and sell this software and its
  22. ; documentation for any purpose is hereby granted without fee, provided that
  23. ; the above copyright notice appear in all copies and that both that
  24. ; copyright notice and this permission notice appear in supporting
  25. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  26. ; used in advertising or publicity pertaining to distribution of the software
  27. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  28. ; makes no representations about the suitability of this software for any
  29. ; purpose.  It is provided "as is" without express or implied warranty.
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31.  
  32. (defun cadar (x)
  33.   (car (cdr (car x))))
  34.  
  35. ; Do two queens threaten each other ?
  36. (defun threat (i j a b)
  37.   (or (equal i a)            ;Same row
  38.       (equal j b)            ;Same column
  39.       (equal (- i j) (- a b))        ;One diag.
  40.       (equal (+ i j) (+ a b))))        ;the other diagonal
  41.  
  42. ; Is poistion (n,m) on the board safe for a queen ?
  43. (defun conflict (n m board)
  44.   (cond ((null board) nil)
  45.     ((threat n m (caar board) (cadar board)) t)
  46.     (t (conflict n m (cdr board)))))
  47.  
  48.  
  49. ; Place queens on a board of size SIZE
  50. (defun queens (size)
  51.   (prog (n m board soln)
  52.     (setq soln 0)            ;Solution #
  53.     (setq board nil)
  54.     (setq n 1)            ;Try the first row
  55.     loop-n
  56.     (setq m 1)            ;Column 1
  57.     loop-m
  58.     (cond ((conflict n m board) (go un-do-m))) ;Check for conflict
  59.     (setq board (cons (list n m) board))       ; Add queen to board
  60.     (cond ((> (setq n (1+ n)) size)            ; Placed N queens ?
  61.            (print-board (reverse board) (setq soln (1+ soln))))) ; Print it
  62.     (go loop-n)                       ; Next row which column?
  63.     un-do-n
  64.     (cond ((null board) (return 'Done))        ; Tried all possibilities
  65.           (t (setq m (cadar board))           ; No, Undo last queen placed
  66.          (setq n (caar board))
  67.          (setq board (cdr board))))
  68.  
  69.     un-do-m
  70.     (cond ((> (setq m (1+ m)) size)          ; Go try next column
  71.            (go un-do-n))
  72.           (t (go loop-m)))))
  73.  
  74.  
  75. ;Print a board
  76. (defun print-board  (board soln &aux size)
  77.   (setq size (length board))        ;we can find our own size
  78.   (terpri)
  79.   (princ "\t\tSolution: ")
  80.   (print soln)
  81.   (terpri)
  82.   (princ "\t")
  83.   (print-header size 1)
  84.   (terpri)
  85.   (print-board-aux board size 1)
  86.   (terpri))
  87.  
  88. ; Put Column #'s on top
  89. (defun print-header (size n)
  90.   (cond ((> n size) 
  91.      (terpri))
  92.     (t (princ n)
  93.        (princ " ")
  94.        (print-header size (1+ n)))))
  95.  
  96. (defun print-board-aux (board size row)
  97.   (terpri)
  98.   (cond ((null board))
  99.     (t (princ row)            ;print the row #
  100.        (princ "\t")
  101.        (print-board-row (cadar board) size 1) ;Print the row
  102.        (print-board-aux (cdr board) size (1+ row)))))  ;Next row
  103.  
  104. (defun print-board-row (column size n)
  105.   (cond ((> n size))
  106.     (t (cond ((equal column n) (princ "Q"))
  107.          (t (princ ".")))
  108.        (princ " ")
  109.        (print-board-row column size (1+ n)))))
  110.