;;; ILC 2003 Programming Contest Entry
;;; Written by: Vladimir Sedach (sedachv@cpsc.ucalgary.ca)

;;; Permission is given to reproduce and use code as anyone sees fit,
;;; I'm not responsible for anything, etc.

;;; References:
; _Common Lisp Hyperspec_, Kent Pitman
; _Common Lisp the Language, 2nd edition_, Guy L. Steele
; _The Elements of artificial intelligence : an introduction using LISP_, Steven L. Tanimoto

;;; Declaim declarations to prevent compiler warnings
;;; Note: if you feel this violates contest rules per
;;; the "no type declarations" clause, feel free to remove it

(declaim (special *the-board*))
(declaim (special *the-piece*))
(declaim (special *piece-list*))

;;; Puzzle solving code

(defun solve-puzzle ()
  "Main puzzle solving function - call it with no arguments to solve the puzzle.
Prints a successfuly filled board,
Returns a list of lists containing the piece object, it's rotation index,
and x and y placements on the board."
  (quick-place-piece *the-piece* 0 0 0)
  (catch 'puzzle-solved
    (try-pieces *piece-list* '())))

(defun quick-place-piece (the-piece orientation board-x board-y)
  (let ((piece (piece-rotated-by the-piece orientation)))
    (dotimes (x (array-dimension piece 0))
      (dotimes (y (array-dimension piece 1))
	(when (aref piece x y)
	  (place-block *the-board* (aref piece x y) (+ x board-x) (+ y board-y)))))))

(defun place-piece (the-piece orientation board-x board-y)
  "Checks if a piece can be placed in the specified position with specified orientation,
and if so places the piece and returns T, NIL otherwise."
  (let ((piece (piece-rotated-by the-piece orientation)))
    (dotimes (x (array-dimension piece 0))
      (dotimes (y (array-dimension piece 1))
	(when (aref piece x y)
	  (when (or (occupied-p *the-board* (+ x board-x) (+ y board-y))
		    (not (equal (block-type (aref piece x y))
				(block-typeat *the-board* (+ x board-x) (+ y board-y)))))
	    (return-from place-piece nil)))))
    (quick-place-piece the-piece orientation board-x board-y))
  (return-from place-piece t))

(defun repack-board (the-board piece-list)
  "Since the board is a mutable structure, it has to be re-populated every time the algorithm backtracks."
  (wipe the-board)
  (dolist (piece piece-list)
    (apply #'quick-place-piece piece)))

(defun try-piece (placed-pieces remaining)
  "Tries to place (car placed-pieces) on the board.
Mutually recursive with try-pieces."
  (let ((piece (car remaining)))
    (multiple-value-bind (minyx minyy)
	(find-unused-place *the-board*)
      (dotimes (rot 4)			; try all four rotations
	(let ((varx (array-dimension (piece-rotated-by piece rot) 0))
	      (vary (array-dimension (piece-rotated-by piece rot) 1)))
	  (dotimes (x varx) ; try all possible placements around unused-place
	    (dotimes (y vary)
	      (let ((minx (- minyx x))
		    (miny (- minyy y)))
		(when (place-piece piece rot minx miny)
		  (try-pieces (cdr remaining) (cons (list piece rot minx miny) placed-pieces))
		  (repack-board *the-board* placed-pieces))))))))))

(defun try-pieces (remaining placed)
  "Tries various permutations of a list containing pieces."
  (if remaining
      (do ((tried '() (cons (car rest) tried))
           (rest remaining (cdr rest)))
          ((endp rest) nil)
        (try-piece placed (append rest tried)))
      (progn (print-board *the-board*)
             (throw 'puzzle-solved placed))))

;;; Base block class

(defclass block ()
  ((block-type :accessor block-type :initarg :block-type)
   (name :accessor name :initarg :name)))

;;; Piece representation code

(defclass piece ()
  ((init-piece :accessor init-piece :initarg :init-piece)
   (combo-array :accessor combo-array :initform (make-array 4))
   (name :accessor name :initarg :name)))

;;; A note about piece representation:
;;; Piece origin is always (0,0) - that is, the right-most bottom corner of the piece's bounding box
;;; Piece rotations are defined in clockwise order
;;; Rest orientation is taken to be the same as in Section 3.1 of contest website

(defmethod initialize-instance :after ((obj piece) &key)
  (setf (aref (combo-array obj) 0) (init-piece obj))
  (make-permutations obj))

(defun piece-rotated-by (piece index)
  "Get piece as rotated by index*90 degrees clockwise. Index must be an integer, 0 to 3."
  (aref (combo-array piece) index))

(defun make-permutations (piece)
  (let ((piece-array (combo-array piece)))
    (loop :for index :from 1 :to 3 :do
	  (setf (aref piece-array index) (rotate-array (aref piece-array (1- index)))))))

(defun rotate-array (piece-array)
  "Returns a copy of the given array rotated 90-degrees clockwise."
  (let* ((sizex (array-dimension piece-array 0))
	 (sizey (array-dimension piece-array 1))
	 (new-array (make-array (list sizey sizex))))
    (dotimes (x sizex)
      (dotimes (y sizey)
        (setf (aref new-array y (- sizex x 1)) (aref piece-array x y))))
    new-array))

;;; Board representation code

(defclass board ()
  ((tab-array :accessor tab-array :initform (make-array '(8 8) :initial-element nil))
   (fil-array :accessor fil-array :initform (make-array '(8 8) :initial-element nil))))

(defmethod initialize-instance :after ((the-board board) &key)
  (dotimes (x 8)
    (dotimes (y 8)
      (setf (aref (tab-array the-board) x y) (if (oddp (+ x y)) :slot :tab)))))

(defparameter *the-board* (make-instance 'board))

(defun place-block (the-board block x y)
  (setf (aref (fil-array the-board) x y) block))

(defun occupied-p (the-board x y)
  (if (and (<= x 7) (<= 0 x) (<= y 7) (<= 0 y))
      (aref (fil-array the-board) x y)
      t))

(defun block-typeat (the-board x y)
  (aref (tab-array the-board) x y))

(defun wipe (the-board)
  (dotimes (x 8)
    (dotimes (y 8)
      (setf (aref (fil-array the-board) x y) nil)))
  (quick-place-piece *the-piece* 0 0 0))

(defun find-unused-place (the-board)
  "Find the next unused block on the board."
  (dotimes (x 8)
    (dotimes (y 8)
      (unless (aref (fil-array the-board) y x)
        (return-from find-unused-place (values y x))))))

(defun print-board (board)
  "Prints the board like the 'incorrect' example on the last bullet of section 4 of the contest page.
8x8 grid of characters - pieces are represented by the same characters as given on contest page."
  (terpri)
  (let ((array (fil-array board)))
    (loop :for x :from 7 :downto 0 :do
	  (loop :for y :from 7 :downto 0 :do
		(if (aref array y x)
		    (princ (aref (name (aref array y x)) 0))
		    (princ 0)))
	  (fresh-line))))

;;; The (very messy) piece descriptions

(defparameter *the-piece*
  (make-instance 'piece :name "3" :init-piece
		 (make-array '(2 2) :initial-contents
			     (list (list (make-instance 'block :name "3" :block-type :tab) nil)
				   (list (make-instance 'block :name "3" :block-type :slot)
					 (make-instance 'block :name "3" :block-type :tab))))))

(defparameter *piece-list*
  (list
   (make-instance 'piece :name "j" :init-piece
		  (make-array (list 2 3) :initial-contents
			      (list (list (make-instance 'block :name "j" :block-type :slot) (make-instance 'block :name "j" :block-type :tab) (make-instance 'block :name "j" :block-type :slot))
				    (list (make-instance 'block :name "j" :block-type :tab) nil nil))))
   
   (make-instance 'piece :name "F" :init-piece
		  (make-array (list 2 4) :initial-contents
			      (list (list nil nil (make-instance 'block :name "F" :block-type :tab) nil)
				    (list (make-instance 'block :name "F" :block-type :slot) (make-instance 'block :name "F" :block-type :tab) (make-instance 'block :name "F" :block-type :slot) (make-instance 'block :name "F" :block-type :tab)))))
   
   (make-instance 'piece :name "t" :init-piece
		  (make-array (list 2 3) :initial-contents
			      (list (list (make-instance 'block :name "t" :block-type :slot) (make-instance 'block :name "t" :block-type :tab) (make-instance 'block :name "t" :block-type :slot))
				    (list nil (make-instance 'block :name "t" :block-type :slot) nil))))
   
   (make-instance 'piece :name "S" :init-piece
		  (make-array (list 2 4) :initial-contents
			      (list (list (make-instance 'block :name "S" :block-type :slot) (make-instance 'block :name "S" :block-type :tab) (make-instance 'block :name "S" :block-type :slot) nil)
				    (list nil nil (make-instance 'block :name "S" :block-type :tab) (make-instance 'block :name "S" :block-type :slot)))))
   
   (make-instance 'piece :name "N" :init-piece
		  (make-array (list 3 3) :initial-contents
			      (list (list nil (make-instance 'block :name "N" :block-type :tab) (make-instance 'block :name "N" :block-type :slot))
				    (list nil (make-instance 'block :name "N" :block-type :slot) nil)
				    (list (make-instance 'block :name "N" :block-type :slot) (make-instance 'block :name "N" :block-type :tab) nil))))
   
   (make-instance 'piece :name "s" :init-piece
		  (make-array (list 2 3) :initial-contents
			      (list (list (make-instance 'block :name "s" :block-type :tab) (make-instance 'block :name "s" :block-type :slot) nil)
				    (list nil (make-instance 'block :name "s" :block-type :tab) (make-instance 'block :name "s" :block-type :slot)))))
   
   (make-instance 'piece :name "Z" :init-piece
		  (make-array (list 4 2) :initial-contents
			      (list (list (make-instance 'block :name "Z" :block-type :tab) nil)
				    (list (make-instance 'block :name "Z" :block-type :slot) (make-instance 'block :name "Z" :block-type :tab))
				    (list nil (make-instance 'block :name "Z" :block-type :slot))
				    (list nil (make-instance 'block :name "Z" :block-type :tab)))))
   
   (make-instance 'piece :name "Q" :init-piece
		  (make-array (list 3 3) :initial-contents
			      (list (list (make-instance 'block :name "Q" :block-type :tab) (make-instance 'block :name "Q" :block-type :slot) nil)
				    (list nil (make-instance 'block :name "Q" :block-type :tab) nil)
				    (list nil (make-instance 'block :name "Q" :block-type :slot) (make-instance 'block :name "Q" :block-type :tab)))))
   
   (make-instance 'piece :name "W" :init-piece
		  (make-array (list 3 3) :initial-contents
			      (list (list (make-instance 'block :name "W" :block-type :tab) nil nil)
				    (list (make-instance 'block :name "W" :block-type :slot) (make-instance 'block :name "W" :block-type :tab) nil)
				    (list nil (make-instance 'block :name "W" :block-type :slot) (make-instance 'block :name "W" :block-type :tab)))))
   
   (make-instance 'piece :name "T" :init-piece
		  (make-array (list 2 4) :initial-contents
			      (list (list (make-instance 'block :name "T" :block-type :tab) (make-instance 'block :name "T" :block-type :slot) (make-instance 'block :name "T" :block-type :tab) (make-instance 'block :name "T" :block-type :slot))
				    (list nil nil (make-instance 'block :name "T" :block-type :slot) nil))))
   
   (make-instance 'piece :name "l" :init-piece
		  (make-array (list 2 3) :initial-contents
			      (list (list (make-instance 'block :name "l" :block-type :slot) nil nil)
				    (list (make-instance 'block :name "l" :block-type :tab) (make-instance 'block :name "l" :block-type :slot) (make-instance 'block :name "l" :block-type :tab)))))
   
   (make-instance 'piece :name "J" :init-piece
		  (make-array (list 2 4) :initial-contents
			      (list (list (make-instance 'block :name "J" :block-type :slot) (make-instance 'block :name "J" :block-type :tab) (make-instance 'block :name "J" :block-type :slot) (make-instance 'block :name "J" :block-type :tab))
				    (list (make-instance 'block :name "J" :block-type :tab) nil nil nil))))
   
   (make-instance 'piece :name "L" :init-piece
		  (make-array (list 2 4) :initial-contents
			      (list (list (make-instance 'block :name "L" :block-type :slot) nil nil nil)
				    (list (make-instance 'block :name "L" :block-type :tab) (make-instance 'block :name "L" :block-type :slot) (make-instance 'block :name "L" :block-type :tab) (make-instance 'block :name "L" :block-type :slot)))))))


;; $Id: //info.ravenbrook.com/user/ndl/lisp/contest/entries/vladimir-sedach.lisp#1 $