;;;; -*- Mode: Lisp; Package: User -*-
;;;;

(in-package "USER")
(proclaim '(optimize (safety 0) (speed 3)))

;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.

(defconstant size 511)	
(defconstant classmax 3)
(defconstant typemax 12)

(defvar iii 0)
(defvar kount 0)
(defconstant dee 8)

(proclaim '(type fixnum size classmax typemax iii kount dee))

(defvar piececount (make-array (1+ classmax) :initial-element 0))
(defvar class (make-array (1+ typemax) :initial-element 0))
(defvar piecemax (make-array (1+ typemax) :initial-element 0))
(defvar puzzle (make-array (1+ size)))
(defvar p (make-array (list (1+ typemax) (1+ size))))

(proclaim '(type simple-vector piececount class piecemax puzzle))

(defun fit (i j)
  (declare (fixnum i j))
  (let ((end (svref piecemax i)))
    (do ((k 0 (1+ k)))
	((> k end) t)
      (declare (fixnum k))
      (cond ((aref p i k)
	     (cond ((svref puzzle (+ j k))
		    (return nil))))))))

(defun place (i j)
  (declare (fixnum i j))
  (let ((end (svref piecemax i)))
    (do ((k 0 (1+ k)))
	((> k end))
      (declare (fixnum k))
      (cond ((aref p i k) 
	     (setf (svref puzzle (+ j k)) t))))
    (setf (svref piececount (svref class i))
	  (- (svref piececount (svref class i)) 1))
    (do ((k j (1+ k)))
	((> k size)
;	 (terpri)
;	 (princ "Puzzle filled")
	 0)
      (declare (fixnum k))
      (cond ((not (svref puzzle k))
	     (return k))))))

(defun puzzle-remove (i j)
  (declare (fixnum i j))
  (let ((end (svref piecemax i)))
    (do ((k 0 (1+ k)))
	((> k end))
      (declare (fixnum k))
      (cond ((aref p i k)
	     (setf (svref puzzle (+ j k))  nil))))
    (setf (svref piececount (svref class i))
	  (+ (svref piececount (svref class i)) 1))))

(defun trial (j)
  (declare (fixnum j))
  (let ((k 0))
    (declare (fixnum k))
    (do ((i 0 (1+ i)))
	((> i typemax) (setq kount (1+ kount)) 	 nil)
      (declare (fixnum i))
      (cond ((not (= (svref piececount (svref class i)) 0))
	     (cond ((fit i j)
		    (setq k (place i j))
		    (cond ((or (trial k)
			       (= k 0))
;			   (format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1))
			   (setq kount (+ kount 1))
			   (return t))
			  (t (puzzle-remove i j))))))))))

(defun definepiece (iclass ii jj kk)
  (declare (fixnum ii jj kk))
  (let ((index 0))
    (do ((i 0 (1+ i)))
	((> i ii))
      (declare (fixnum i))
      (do ((j 0 (1+ j)))
	  ((> j jj))
	(declare (fixnum j))
	(do ((k 0 (1+ k)))
	    ((> k kk))
	  (declare (fixnum k))
	  (setq index  (+ i (* dee (+ j (* dee k)))))
	  (setf (aref p iii index)  t))))
    (setf (svref class iii) iclass)
    (setf (svref piecemax iii) index) 
    (cond ((not (= iii typemax))
	   (setq iii (+ iii 1))))))

(defun puzzle ()
  (do ((m 0 (1+ m)))
      ((> m size))
    (declare (fixnum m))
    (setf (svref puzzle m) t))
  (do ((i 1 (1+ i)))
      ((> i 5))
    (declare (fixnum i))
    (do ((j 1 (1+ j)))
	((> j 5))
      (declare (fixnum j))
      (do ((k 1 (1+ k)))
	  ((> k 5))
	(declare (fixnum k))
	(setf (svref puzzle (+ i (* dee (+ j (* dee k))))) nil))))
  (do ((i 0 (1+ i)))
      ((> i typemax))
    (declare (fixnum i))
    (do ((m 0 (1+ m)))
	((> m size))
      (declare (fixnum m))
      (setf (aref p i m)  nil)))
  (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 (svref pieceCount 0) 13.)
  (setf (svref pieceCount 1) 3)
  (setf (svref pieceCount 2) 1)
  (setf (svref pieceCount 3) 1)
  (let ((m (+ 1 (* dee (+ 1 dee))))
	(n 0)
	(kount 0))
    (declare (fixnum m n kount))
    (cond ((fit 0 m) (setq n (place 0 m)))
	  (t
	   (write-string "
Error.")))
    (cond ((trial n)
	   (write-string "
Success in ")
	   (print kount)
	   (write-string " trials."))
	  (t
	   (write-string "
Failure.")
	   ))))


(defun time-puzzle ()
  (time (puzzle)))
