;;; .EnTete "Le-Lisp (c) version 15.2" " " "The Le-Lisp Benchmarks (17)"
;;; .EnPied "puzzle.ll" "%" " "
;;; .SuperTitre "The Le-Lisp Benchmarks (17)"
;;;
;;; .Centre "*****************************************************************"
;;; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA.  "
;;; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
;;; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA                 "
;;; .Centre "*****************************************************************"
;;;
;;; .Centre "$Header: puzzle.ll,v 1.1 88/12/06 19:25:05 chaillou Exp $"

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

(defun check-puzzle ()
   (check-value '(test-puzzle 1) t))

(defun meter-puzzle ()
   (perform-meter '(puzzle-start) 'puzzle))

(defun test-puzzle (n)
   (if (eq n 1)
       (puzzle-start)
       (repeat n (puzzle-start))))

;;;

(defvar puzzle-size 511)	
(defvar puzzle-classmax 3)
(defvar puzzle-typemax 12)

(defvar iii 0)
(defvar kount 0)
(defvar puzzle-d 8)

;(proclaim '(type fixnum iii kount puzzle-d))

(defvar piececount (makearray (add1 puzzle-classmax) 0))
(defvar puzzle-class (makearray (add1 puzzle-typemax) 0))
(defvar piecemax (makearray (add1 puzzle-typemax) 0))
(defvar puzzle (makearray (add1 puzzle-size) 0))
(defvar puzzle-p (makearray (add1 puzzle-typemax) (add1 puzzle-size) 0))

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

;(proclaim '(type (simple-array t (* *)) puzzle-p))
		 
(defun fit (i j)
  (let ((end (aref piecemax i)))
    (do ((k 0 (add1 k)))
	((or
           (gt k end)
           (and (aref puzzle-p i k) (aref puzzle (add j k))))
         (if (gt k end) t nil)))))


(defun place (i j)
  (let ((end (aref piecemax i)))
    (do ((k 0 (add1 k)))
	((gt k end))
      (cond ((aref puzzle-p i k) 
	     (setf (aref puzzle (add j k)) t))))
    (setf (aref piececount (aref puzzle-class i)) 
	  (sub (aref piececount (aref puzzle-class i)) 1))
    (do ((k j (add1 k)))
	((or
          (gt k puzzle-size)
          (not (aref puzzle k)))
          (if (gt k puzzle-size) 0 k)))))

(defun puzzle-remove (i j)
  (let ((end (aref piecemax i)))
    (do ((k 0 (add1 k)))
	((gt k end))
      (cond ((aref puzzle-p i k)
	     (setf (aref puzzle (add j k))  nil ))))
      (setf (aref piececount (aref puzzle-class i))
	    (add (aref piececount (aref puzzle-class i)) 1))))

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

(defun trial (j)
  (let ((k 0))
    (do ((i 0 (add1 i)))
	((or
          (gt i puzzle-typemax)
          (cond ((not (eq (aref piececount (aref puzzle-class i)) 0))
	         (cond ((fit i j)
		        (setq k (place i j))
		        (cond ((or (trial k)
			           (eq k 0))
			       ;;(format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1))
			       (setq kount (add kount 1))
                               t)
			      (t (puzzle-remove i j) nil)))))))
        (if (gt i puzzle-typemax)
           (progn
              (setq kount (add1 kount))
              nil)
           t)))))


(defun definepiece (iclass ii jj kk)
  (let ((index 0))
    (do ((i 0 (add1 i)))
	((gt i ii))
      (do ((j 0 (add1 j)))
	  ((gt j jj))
	(do ((k 0 (add1 k)))
	    ((gt k kk))
	  (setq index  
		(add i 
  		     (mul puzzle-d 
			  (add j 
			       (mul puzzle-d k)))))
	  (setf (aref puzzle-p iii index)  t))))
    (setf (aref puzzle-class iii) iclass)
    (setf (aref piecemax iii) index) 
    (cond ((not (eq iii puzzle-typemax))
	   (setq iii (add iii 1))))))

(defun puzzle-start ()
  (do ((m 0 (add1 m)))
      ((gt m puzzle-size))
    (setf (aref puzzle m) t))
  (do ((i 1 (add1 i)))
      ((gt i 5))
    (do ((j 1 (add1 j)))
	((gt j 5))
      (do ((k 1 (add1 k)))
	  ((gt k 5))
	(setf (aref puzzle 
		    (add i 
			 (mul puzzle-d 
			      (add j 
			           (mul puzzle-d k)))))
	      nil)))) 
  (do ((i 0 (add1 i)))
      ((gt i puzzle-typemax))
    (do ((m 0 (add1 m)))
	((gt m puzzle-size))
      (setf (aref puzzle-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 (aref pieceCount 0) 13)
  (setf (aref pieceCount 1) 3)
  (setf (aref pieceCount 2) 1)
  (setf (aref pieceCount 3) 1)
  (let ((m (add1 (mul puzzle-d (add1 puzzle-d))))
	(n 0)(kount 0))
    (cond ((fit 0 m) (setq n (place 0 m)))
	  (t (format t "~%Error.")))
    (cond ((trial n) 
	   (format t "~%Success in ~4D trials." kount))
	  (t (format t "~%Failure.")))))

;;; call:  (puzzle-start)