home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume1 / 8707 / 49 / triangle.cl < prev   
Lisp/Scheme  |  1990-07-13  |  2KB  |  78 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ; File:         triangle.cl
  3. ; Description:  TRIANGLE benchmark
  4. ; Author:       Richard Gabriel
  5. ; Created:      12-Apr-85
  6. ; Modified:     12-Apr-85 10:30:32 (Bob Shaw)
  7. ; Language:     Common Lisp
  8. ; Package:      User
  9. ; Status:       Public Domain
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11.  
  12. ;;; TRIANG -- Board game benchmark.  
  13.  
  14. (eval-when (compile load eval)
  15.  
  16. (defvar *board* (make-array 16 :initial-element 1))
  17. (defvar *sequence* (make-array 14 :initial-element 0))
  18. (defvar *a* (make-array 37
  19.           :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11 12
  20.                   13 7 8 4 4 7 11 8 12 13 6 10
  21.                   15 9 14 13 13 14 15 9 10
  22.                   6 6)))
  23. (defvar *b* (make-array 37
  24.           :initial-contents '(2 4 7 5 8 9 3 6 10 5 9 8
  25.                   12 13 14 8 9 5 2 4 7 5 8
  26.                   9 3 6 10 5 9 8 12 13 14
  27.                   8 9 5 5)))
  28. (defvar *c* (make-array 37
  29.           :initial-contents '(4 7 11 8 12 13 6 10 15 9 14 13
  30.                   13 14 15 9 10 6 1 2 4 3 5 6 1
  31.                   3 6 2 5 4 11 12 13 7 8 4 4)))
  32. (defvar *answer*)
  33. (defvar *final*)
  34. (setf (aref *board* 5) 0)
  35.  
  36. (proclaim '(type (vector fixnum) *board* *sequence* *a* *b* *c*))
  37.  
  38. )
  39.  
  40. (defun last-position ()
  41.   (do ((i 1 (1+ i)))
  42.       ((= i 16) 0)
  43.     (declare (fixnum i))
  44.     (if (= 1 (aref *board* i))
  45.     (return i))))
  46.  
  47. (defun try (i depth)
  48.   (declare (fixnum i depth))
  49.   (cond ((= depth 14) 
  50.      (let ((lp (last-position)))
  51.        (unless (member lp *final*)
  52.          (push lp *final*)))
  53.      (push (cdr (coerce *sequence* 'list)) *answer*)
  54.      t)
  55.     ((and (= 1 (aref *board* (aref *a* i)))
  56.           (= 1 (aref *board* (aref *b* i)))
  57.           (= 0 (aref *board* (aref *c* i))))
  58.      (setf (aref *board* (aref *a* i)) 0)
  59.      (setf (aref *board* (aref *b* i)) 0)
  60.      (setf (aref *board* (aref *c* i)) 1)
  61.      (setf (aref *sequence* depth) i)
  62.      (do ((j 0 (1+ j))
  63.           (depth (1+ depth)))
  64.          ((or (= j 36) (try j depth)) nil)
  65.          (declare (fixnum j depth)))
  66.      (setf (aref *board* (aref *a* i)) 1) 
  67.      (setf (aref *board* (aref *b* i)) 1)
  68.      (setf (aref *board* (aref *c* i)) 0) ())))
  69.  
  70. (defun gogogo (i)
  71.   (let ((*answer* ())
  72.     (*final* ()))
  73.     (try i 1)))
  74.  
  75. ;;; call:  (gogogo 22))
  76.  
  77. (run-benchmark "Triangle" '(gogogo 22))
  78.