home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume1 / 8707 / 49 / puzzle.cl < prev    next >
Lisp/Scheme  |  1990-07-13  |  4KB  |  164 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ; File:         puzzle.cl
  3. ; Description:  PUZZLE benchmark
  4. ; Author:       Richard Gabriel, after Forrest Baskett
  5. ; Created:      12-Apr-85
  6. ; Modified:     12-Apr-85 14:20:23 (Bob Shaw)
  7. ; Language:     Common Lisp
  8. ; Package:      User
  9. ; Status:       Public Domain
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11.  
  12. ;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
  13.  
  14. (eval-when (compile load eval)
  15.   (defconstant size 511)    
  16.   (defconstant classmax 3)
  17.   (defconstant typemax 12)
  18. )
  19.  
  20. (defvar *iii* 0)
  21. (defvar *kount* 0)
  22. (defvar *d* 8)
  23.  
  24. (defvar *piececount* (make-array (1+ classmax) :initial-element 0))
  25. (defvar *class* (make-array (1+ typemax) :initial-element 0))
  26. (defvar *piecemax* (make-array (1+ typemax) :initial-element 0))
  27. (defvar *puzzle* (make-array (1+ size)))
  28. (defvar *p* (make-array (list (1+ typemax) (1+ size))))
  29.  
  30. (proclaim '(type fixnum *iii* *kount* *d*))
  31. (proclaim '(type vector *piececount* *class* *piecemax* *puzzle*))
  32.  
  33. (defun fit (i j)
  34.   (declare (fixnum i j))
  35.   (let ((end (aref *piecemax* i)))
  36.     (do ((k 0 (1+ k)))
  37.     ((> k end) t)
  38.       (declare (fixnum k))
  39.       (cond ((aref *p* i k)
  40.          (cond ((aref *puzzle* (+ j k))
  41.             (return nil))))))))
  42.  
  43. (defun place (i j)
  44.   (let ((end (aref *piecemax* i)))
  45.     (do ((k 0 (1+ k)))
  46.     ((> k end))
  47.       (declare (fixnum k))
  48.       (cond ((aref *p* i k) 
  49.          (setf (aref *puzzle* (+ j k)) t))))
  50.     (decf (aref *piececount* (aref *class* i)))
  51.     (do ((k j (1+ k)))
  52.     ((> k size)
  53. ;     (terpri)
  54. ;     (princ "*Puzzle* filled")
  55.      0)
  56.       (declare (fixnum k))
  57.       (cond ((not (aref *puzzle* k))
  58.          (return k))))))
  59.  
  60. (defun puzzle-remove (i j)
  61.   (declare (fixnum i j))
  62.   (let ((end (aref *piecemax* i)))
  63.     (declare (fixnum end))
  64.     (do ((k 0 (1+ k)))
  65.     ((> k end))
  66.       (declare (fixnum k))
  67.       (cond ((aref *p* i k)
  68.          (setf (aref *puzzle* (+ j k)) nil))))
  69.       (incf (aref *piececount* (aref *class* i)))))
  70.  
  71. (defun trial (j)
  72.   (declare (fixnum j))
  73.   (let ((k 0))
  74.     (declare (fixnum k))
  75.     (do ((i 0 (1+ i)))
  76.     ((> i typemax) (setq *kount* (1+ *kount*))      nil)
  77.       (declare (fixnum i))
  78.       (cond ((not (= (aref *piececount* (aref *class* i)) 0))
  79.          (cond ((fit i j)
  80.             (setq k (place i j))
  81.             (cond ((or (trial k)
  82.                    (= k 0))
  83. ;               (format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1))
  84.                (incf *kount*)
  85.                (return t))
  86.               (t (puzzle-remove i j))))))))))
  87.  
  88. (defun definepiece (iclass ii jj kk)
  89.   (declare (fixnum iclass ii jj kk))
  90.   (let ((index 0))
  91.     (declare (fixnum index))
  92.     (do ((i 0 (1+ i)))
  93.     ((> i ii))
  94.       (declare (fixnum i))
  95.       (do ((j 0 (1+ j)))
  96.       ((> j jj))
  97.         (declare (fixnum j))
  98.     (do ((k 0 (1+ k)))
  99.         ((> k kk))
  100.       (declare (fixnum k))
  101.       (setq index (+ i (* *d* (+ j (* *d* k)))))
  102.       (setf (aref *p* *iii* index)  t))))
  103.     (setf (aref *class* *iii*) iclass)
  104.     (setf (aref *piecemax* *iii*) index) 
  105.     (cond ((not (= *iii* typemax))
  106.        (incf *iii*)))))
  107.  
  108. (defun start ()
  109.   (do ((m 0 (1+ m)))
  110.       ((> m size))
  111.     (declare (fixnum m))
  112.     (setf (aref *puzzle* m) t))
  113.   (do ((i 1 (1+ i)))
  114.       ((> i 5))
  115.     (declare (fixnum i))
  116.     (do ((j 1 (1+ j)))
  117.     ((> j 5))
  118.       (declare (fixnum j))
  119.       (do ((k 1 (1+ k)))
  120.       ((> k 5))
  121.         (declare (fixnum k))
  122.     (setf (aref *puzzle* (+ i (* *d* (+ j (* *d* k))))) nil))))
  123.   (do ((i 0 (1+ i)))
  124.       ((> i typemax))
  125.     (declare (fixnum i))
  126.     (do ((m 0 (1+ m)))
  127.     ((> m size))
  128.       (declare (fixnum m))
  129.       (setf (aref *p* i m)  nil)))
  130.   (setq *iii* 0)
  131.   (definePiece 0 3 1 0)
  132.   (definePiece 0 1 0 3)
  133.   (definePiece 0 0 3 1)
  134.   (definePiece 0 1 3 0)
  135.   (definePiece 0 3 0 1)
  136.   (definePiece 0 0 1 3)
  137.   
  138.   (definePiece 1 2 0 0)
  139.   (definePiece 1 0 2 0)
  140.   (definePiece 1 0 0 2)
  141.   
  142.   (definePiece 2 1 1 0)
  143.   (definePiece 2 1 0 1)
  144.   (definePiece 2 0 1 1)
  145.  Bas (definePiece 3 1 1 1)
  146.   
  147.   (setf (aref *piececount* 0) 13)
  148.   (setf (aref *piececount* 1) 3)
  149.   (setf (aref *piececount* 2) 1)
  150.   (setf (aref *piececount* 3) 1)
  151.   (let ((m (+ 1 (* *d* (1+ *d*))))
  152.     (n 0)
  153.     (*kount* 0))
  154.     (declare (fixnum m n))
  155.     (cond ((fit 0 m) (setq n (place 0 m)))
  156.       (t (format t "~%Error.")))
  157.     (cond ((trial n) 
  158.        (format t "~%Success in ~S trials." *kount*))
  159.       (t (format t "~%Failure.")))))
  160.  
  161. ;;; call:  (start)
  162.  
  163. (run-benchmark "Puzzle" '(start))
  164.