;;;-*- Mode:LISP; Package:BENCH-PUZZLEu; Base:10;source->source-optimizations:t -*-
;;; From the "Dick Gabriel" Benchmark Series.
;;; Enhancements (C) Copyright 1983, Lisp Machine, Inc.

;;;BEGIN
;;;PUZZLE
(declare (special size classmax typemax d true false)
 #-lispm	  (FIXNUM size classmax typemax d))

(EVAL-WHEN (EVAL COMPILE LOAD)
  (DEFCONST *TO-UCOMPILE* '(fit place remove trial definepiece start))
  (MAPC #'(LAMBDA (X)
	    (PUTPROP X T 'COMPILER:MICROCOMPILE)
	    (PUTPROP X
		     T ; ':DYNAMIC
		     ':DEPEND-ON-BEING-MICROCOMPILED))
	    *TO-UCOMPILE*))

;(defmacro tab () '(tyo 9.))

(eval-when (eval compile load)
  (special true false)
  (setq true t false ()))

(setq size 511.)
(setq classmax 3.)
(setq typemax 12.)
(setq d 8.)

(declare (special iii kount) #-lispm (fixnum iii kount))

(defarray piececount fixnum (1+ classmax))
(defarray class fixnum (1+ typemax))
(defarray piecemax fixnum (1+ typemax))
(defarray puzzle t (1+ size))
(defarray p t (1+ typemax) (1+ size))

(defun fit (i j)
  (declare (fixnum i j))
 (let ((end (piecemax i)))
      (do ((k 0 (the fixnum (1+ k))))
	  ((> k (the fixnum end)) #.true)
	(declare (fixnum k))
	  (cond ((p i k)
		 (cond ((puzzle (the fixnum (+ j k)))
			(return #.false))))))))

(defun place (i j)
  (declare (fixnum i j))
       (let ((end (piecemax i)))
	    (do ((k 0 (the fixnum (1+ k))))
		((> k (the fixnum end)))
	      (declare (fixnum k))
		(cond ((p i k) 
		       (setf (puzzle (the fixnum (+ j k))) #.true))))
	    (setf (piececount (class i)) (the fixnum (- (piececount (class i)) 1)))
	    (do ((k j (the fixnum (1+ k))))
		((> k (the fixnum size))
		 
;		 (terpri)
;		 (princ "Puzzle filled") 

		 0)
	      (declare (fixnum k))
		(cond ((not (puzzle k))
		       (return k))))))

(defun remove (i j)
  (declare (fixnum i j))
       (let ((end (piecemax i)))
	    (do ((k 0 (the fixnum (1+ k))))
		((> k (the fixnum end)))
	      (declare (fixnum k))
		(cond ((p i k) (setf (puzzle (the fixnum (+ j k))) #.false))))
	    (setf (piececount (class i)) (the fixnum (+ (piececount (class i)) 1)))))

(defun trial (j)
  (declare (fixnum j))
       (let ((k 0))
	 (declare (fixnum k))
	    (do ((i 0 (the fixnum (1+ i))))
		((> i (the fixnum typemax)) (setq kount (the fixnum (1+ kount)) )
			       #.false)
	      (declare (fixnum i))
		(cond ((not (= (the fixnum (piececount (class i))) 0))
		       (cond ((fit i j)
			      (setq k (place i j))
			      (cond ((or (trial k)
					 (= k 0))

;				     (terpri)
;				     (princ "Piece") (tab)
;				     (princ (+ i 1)) (tab)
;				     (princ "at")(tab)(princ (+ k 1))

				     (setq kount (+ (the fixnum kount) 1))
				     (return #.true))
				    (t (remove i j))))))))))

(defun definepiece (iclass ii jj kk)
       (let ((index 0))
	    (do ((i 0 (the fixnum (1+ i))))
		((> i (the fixnum ii)))
	      (declare (fixnum i))
		(do ((j 0 (the fixnum (1+ j))))
		    ((> j (the fixnum jj)))
		  (declare (fixnum j))
		    (do ((k 0 (the fixnum (1+ k))))
			((> k (the fixnum kk)))
		      (declare (fixnum k))
			(setq index  (+ i (the fixnum (* d (+ j (the fixnum (* d k)))))))
			(setf (p iii index) #.true))))
	    (setf (class iii) iclass)
	    (setf (piecemax iii) index)
	    (cond ((not (= (the fixnum iii) (the fixnum typemax)))
		   (setq iii (+ (the fixnum iii) 1))))))

(defun start ()
       (do ((m 0 (the fixnum (1+ m))))
	   ((> m (the fixnum size)))
	 (declare (fixnum m))
	   (setf (puzzle m) #.true)) 
       (do ((i 1 (the fixnum (1+ i))))
	   ((> i 5))
	 (declare (fixnum i))
	   (do ((j 1 (the fixnum (1+ j))))
	       ((> j 5))
	     (declare (fixnum j))
	       (do ((k 1 (the fixnum (1+ k))))
		   ((> k 5))
		 (declare (fixnum k))
		   (setf (puzzle (+ i (the fixnum (* d (+ j (the fixnum (* d k))))))) #.false))))
       (do ((i 0 (the fixnum (1+ i))))
	   ((> i (the fixnum typemax)))
	 (declare (fixnum i))
	   (do ((m 0 (the fixnum (1+ m))))
	       ((> m (the fixnum size)))
	     (declare (fixnum m))
	       (setf (p i m) #.false)))
       (setq iii 0)
       (definePiece 0 3 1 0)
       (definePiece 0 1 0 3)
       (definePiece 0 0 3 1)
       (definePiece 0 1 3 0)
       (definePiece 0 3 0 1)
       (definePiece 0 0 1 3)

       (definePiece 1 2 0 0)
       (definePiece 1 0 2 0)
       (definePiece 1 0 0 2)

       (definePiece 2 1 1 0)
       (definePiece 2 1 0 1)
       (definePiece 2 0 1 1)

       (definePiece 3 1 1 1)

       (setf (pieceCount 0) 13.)
       (setf (pieceCount 1) 3)
       (setf (pieceCount 2) 1)
       (setf (pieceCount 3) 1)
       (let ((m (+ 1 (* d (+ 1 d))))
	     (n 0)(kount 0))
	    (cond ((fit 0 m) (setq n (place 0 m)))
		  (t (terpri)(princ "Error")))
	    (cond ((trial n) 
		   (terpri)(princ "success in ")(princ kount) (princ " trials")) 
		  (t (terpri)(princ "failure"))) 
	    (terpri)))

;(include "timer.lsp")
(defconst *ucode-loaded? nil)

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

(timer-without-interrupts timit
       (if *ucode-loaded? (start) "ucode not loaded"))

;;;END