;;;-*-mode:lisp;package:bench-triangu;base:10; source->source-optimizations:(ucode cspecials)-*-
;;; From the "Dick Gabriel" Benchmark Series.
;;; Enhancements (C) Copyright 1983, Lisp Machine, Inc.

(EVAL-WHEN (EVAL COMPILE LOAD)
  (DEFCONST *TO-UCOMPILE* '(last-position try))
  (MAPC #'(LAMBDA (X)
	    (PUTPROP X T 'COMPILER:MICROCOMPILE)
	    (PUTPROP X
		     T ; ':DYNAMIC
		     ':DEPEND-ON-BEING-MICROCOMPILED))
	    *TO-UCOMPILE*))

;;;BEGIN
;;;TRIANG
(declare (special answer final))

(eval-when (compile load eval)
	   (setq base 10. ibase 10.))

(defarray board fixnum 16.)
(defarray sequence fixnum 14.)
(defarray a fixnum 37.)
(defarray b fixnum 37.)
(defarray c fixnum 37.)

(fillarray board '(1))
(setf (board 5) 0)

(fillarray a '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4
		  4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6))

(fillarray b '(2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5
		  2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5))

(fillarray c '(4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6
		  1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4))

(defun last-position ()
  (do ((i 1 (the fixnum (1+ i))))
      ((= i 16.) 0)
  (declare (fixnum i))
  (cond ((= 1 (board i)) (return i)))))

(defun try (i depth)
  (declare (fixnum i depth))
  (cond ((= depth 14) 
	 (let ((lp (last-position)))
	   (cond ((member lp final))
		 (t (push lp final))))
	 (push (cdr (listarray sequence)) answer) t)
	((and (= 1 (the fixnum (board (a i))))
	      (= 1 (the fixnum (board (b i))))
	      (= 0 (the fixnum (board (c i)))))
	 (setf (board (a i)) 0)
	 (setf (board (b i)) 0)
	 (setf (board (c i)) 1)
	 (setf (sequence depth) i)
	 (do ((j 0 (the fixnum (1+ j)))
	      (depth (the fixnum (1+ depth))))
	     ((or (= j 36.)
		  (try j depth)) ())
	   (declare (fixnum depth j)))
	 (setf (board (a i)) 1)
	 (setf (board (b i)) 1)
	 (setf (board (c i)) 0)())))

(defun gogogo (i)
       (let ((answer ())
	     (final ()))
	    (try i 1)))

;(include "timer.lsp")

(defconst *ucode-loaded? nil)

(defun load-ucode ()
  (apply #'compiler:ma-load *to-ucompile*)
  (setq *ucode-loaded? t))

(timer-without-interrupts timit 
       (progn (if (not *ucode-loaded?) (print "ucode not loaded"))
	      (gogogo 22.)))

(defun test ()
       (let ((answer ())
	     (final ()))
	    (try 22. 1)
	    (= (length answer) 775.)))
;;;END