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

;;;BEGIN
;;;PUZZLE
(declare (special size classmax typemax d)
	 #-LISPM (FIXNUM (place fixnum fixnum)
		 size classmax typemax d))

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


(eval-when (eval compile load)
  (SPECIAL TRUE FALSE)
  (setq true t false ()))

(DECLARE (SPECIAL SIZE CLASSMAX TYPEMAX D))

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

(declare (special iii kount)
	 #-LISPM (FIXNUM iii i j k kount m n))

(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)
 (let ((end (piecemax i)))
      (do ((k 0 (1+ k)))
	  ((> k end) #.true)
	  (cond ((p i k)
		 (cond ((puzzle (+ j k))
			(return #.false))))))))

(defun place (i j)
       (let ((end (piecemax i)))
	    (do ((k 0 (1+ k)))
		((> k end))
		(cond ((p i k) 
		       (setf (puzzle (+ j k)) #.true))))
		 (setf (piececount (class i)) (- (piececount (class i)) 1))
	    (do ((k j (1+ k)))
		((> k size)

;		 (terpri)
;		 (princ "Puzzle filled") 

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

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

(defun trial (j)
       (let ((k 0))
	    (do ((i 0 (1+ i)))
		((> i typemax) (setq kount (1+ kount)) 
			       #.false)
		(cond ((not (= (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 (+ kount 1))
				     (return #.true))
				    (t (remove i j))))))))))

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

(defun start ()
       (do ((m 0 (1+ m)))
	   ((> m size))
	   (setf (puzzle m) #.true)) 
       (do ((i 1 (1+ i)))
	   ((> i 5))
	   (do ((j 1 (1+ j)))
	       ((> j 5))
	       (do ((k 1 (1+ k)))
		   ((> k 5))
		   (setf (puzzle (+ i (* d (+ j (* d k))))) #.false))))
       (do ((i 0 (1+ i)))
	   ((> i typemax))
	   (do ((m 0 (1+ m)))
	       ((> m size))
	       (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")

(timer timit
       (start))

;;;END