#||
Running the program:
  (play +pieces+)
     -or-
  (play +pieces-arranged-nicely+)
The first version starts with the pieces sorted and rotated as they
appear on the contest site.  The second has them sorted and rotated
such that the algorithm runs optimally.  Obviously only the first is
in the spirit of the contest.

The algorithm is one of simple brute force - it tries each piece on
sequential squares, and if it successfully finds a slot, it goes on to
the next piece on the list.  The only concession to `intelligence' is
that it checks for `lonely' squares - empty tiles bounded on all sides
by used ones.  Each piece has a "center" (a square with tabs) about
which it is rotated.  The program attempts to place that center square
on every available tabbed position.

There were no publications used while writing this code.

For reference, this runs in 6 minutes on a 733MHz Linux system in
CMUCL with no special optimizations.  It is *much* slower on Allegro,
taking nearly an hour to run.

The source code:
---CUT HERE---
||#

(defconstant +board-width+ 10)
(defconstant +board-height+ 10)
(defconstant +board-working-width+ (- +board-width+ 2))
(defconstant +board-working-height+ (- +board-height+ 2))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defstruct piece
    name tiles)

  (defmethod make-load-form ((piece piece) &optional env)
    (declare (ignore env))
    `(make-piece :name ',(piece-name piece)
                 :tiles ',(piece-tiles piece)))

  (defun board-idx (x y &optional include-border-p)
    (if include-border-p
	(+ x (* y +board-width+))
	(+ (1+ x) (* (1+ y) +board-width+))))

  (defun boardref (board x y &optional include-border-p)
    (aref board (board-idx x y include-border-p))))

(defun (setf boardref) (val board x y &optional include-border-p)
  (setf (aref board (board-idx x y include-border-p)) val))

(defun make-board ()
  (let ((board (make-array (* +board-width+ +board-height+) :initial-element nil)))
    (dotimes (x +board-width+)
      (setf (boardref board x 0 t) '-
	    (boardref board x (1- +board-height+) t) '-))
    (dotimes (y +board-height+)
      (setf (boardref board 0 y t) '-
	    (boardref board (1- +board-width+) y t) '-))
    (setf (boardref board 0 0) '|3|
	  (boardref board 1 0) '|3|
	  (boardref board 1 1) '|3|)
    board))

(defun print-board (board)
  (dotimes (ry +board-height+)
    (dotimes (rx +board-width+)
      (let ((y (- +board-height+ ry 1))
	    (x (- +board-width+ rx 1)))
	(if (boardref board x y t)
	    (princ (boardref board x y t))
	    (princ #\space))))
    (terpri))
  board)

(defun rotate-piece-tiles (piece)
  ;; Rotates a piece left 90 degrees
  (let* ((len (array-dimension piece 0))
	 (new-piece (make-array (list len 2))))
    (dotimes (idx len new-piece)
      (setf (aref new-piece idx 0) (aref piece idx 1)
	    (aref new-piece idx 1) (- (aref piece idx 0))))))

(defun rotate-piece (piece)
  (make-piece :name (piece-name piece)
	      :tiles (rotate-piece-tiles (piece-tiles piece))))

(defun canonicalize-piece-tiles (piece-tiles)
  (let* ((len (array-dimension piece-tiles 0))
	 (new-tiles (make-array len)))
    (dotimes (idx len)
      (setf (svref new-tiles idx) (cons (aref piece-tiles idx 0)
					(aref piece-tiles idx 1))))
    ;; Sort the tiles so that, while walking along the tile-vector, we
    ;; won't "jump past" the outer border.
    (let ((sorted-tiles (sort new-tiles (lambda (a b)
					  (< (+ (abs (car a))
						(abs (cdr a)))
					     (+ (abs (car b))
						(abs (cdr b))))))))
      ;; Sorted-tiles might or might not be the same as new-tiles, and
      ;; if it's not it might or might not be simple.  The first
      ;; doesn't matter (this loop becomes nt[i]=f(nt[i]), but the
      ;; second means aref instead of svref to access sorted-tiles.
      (dotimes (idx len)
	(setf (svref new-tiles idx) (+ (car (aref sorted-tiles idx))
				       (* +board-width+
					  (cdr (aref sorted-tiles idx))))))
      new-tiles)))

(defun canonicalize-piece (piece)
  (make-piece :name (piece-name piece)
	      :tiles (canonicalize-piece-tiles (piece-tiles piece))))

(defun try-place-piece (board piece p)
  (let ((name (piece-name piece))
	(tiles (piece-tiles piece)))
    (dotimes (idx (length tiles) t)
      (let ((tile (+ p (svref tiles idx))))
	(when (svref board tile)
	  ;; collision, retreat
	  (dotimes (unidx idx)
	    (setf (svref board (+ p (svref tiles unidx))) nil))
	  (return-from try-place-piece nil))
	(setf (svref board tile) name)))))

(defun unplace-piece (board piece p)
  (let ((tiles (piece-tiles piece)))
    (dotimes (idx (length tiles))
      (setf (svref board (+ p (svref tiles idx))) nil))))

(defconstant +pieces+
  ;; "(0 0)" is always an "out" piece.
  '(#S(piece :name F
             :tiles #2A((0 0)
			(0 1) (1 1)
			(0 2)
			(0 3)))
    #S(piece :name J
             :tiles #2A((0 0)
			(0 1)
			(0 2)
		 (-1 3)	(0 3)))
    #S(piece :name L
             :tiles #2A((0 -1)
                        (0 0)
			(0 1)
			(0 2) (1 2)))
    #S(piece :name N
             :tiles #2A((2 -1)
            (0 0) (1 0) (2 0)
	    (0 1)))
    #S(piece :name Q
             :tiles #2A((0 0)
			(0 1) (1 1) (2 1)
			            (2 2)))
    #S(piece :name S
             :tiles #2A((0 -1)
			(0 0) (1 0)
			      (1 1)
			      (1 2)))
    #S(piece :name T
             :tiles #2A((0 -1)
                 (-1 0) (0 0)
			(0 1)
			(0 2)))
    #S(piece :name W
             :tiles #2A((0 0)
			(0 1) (1 1)
			      (1 2) (2 2)))
    #S(piece :name Z
             :tiles #2A((0 0) (1 0) (2 0)
			            (2 1) (3 1)))
    #S(piece :name |j|
             :tiles #2A((0 -1)
			(0 0)
		 (-1 1) (0 1)))
    #S(piece :name |l|
             :tiles #2A((0 0)
			(0 1)
			(0 2) (1 2)))
    #S(piece :name |s|
             :tiles #2A((0 -1)
			(0 0) (1 0)
			      (1 1)))
    #S(piece :name |t|
             :tiles #2A((0 -1)
		 (-1 0) (0 0)
			(0 1)))))

(defconstant +pieces-arranged-nicely+
  '(#S(piece :name F
             :tiles #2A((0 0)
			(0 1) (1 1)
			(0 2)
			(0 3)))
    #S(piece :name T
             :tiles #2A((-1 0) (0 0) (1 0) (2 0)
                               (0 1)))
    #S(piece :name N
             :tiles #2A((2 -1)
            (0 0) (1 0) (2 0)
	    (0 1)))
    #S(piece :name |t|
             :tiles #2A((0 -1)
		        (0 0) (1 0)
			(0 1)))
    #S(piece :name |l|
             :tiles #2A((-1 0) (0 0)
			       (0 1)
			       (0 2)))
    #S(piece :name L
             :tiles #2A((0 0) (1 0)
                              (1 1)
			      (1 2)
			      (1 3)))
    #S(piece :name Z
             :tiles #2A((0 0)
                 (-1 1) (0 1)
                 (-1 2)
		 (-1 3)))
    #S(piece :name W
             :tiles #2A((0 0)
		 (-1 1) (0 1)
          (-2 2) (-1 2)))
    #S(piece :name J
             :tiles #2A((0 0) (1 0)
			(0 1)
			(0 2)
		        (0 3)))
    #S(piece :name S
             :tiles #2A((0 0)
			(0 1)
			(0 2) (1 2)
			      (1 3)))
    #S(piece :name Q
             :tiles #2A((0 0) (1 0)
                        (0 1)
                 (-1 2) (0 2)))
    #S(piece :name |s|
             :tiles #2A((-1 0) (0 0)
		 (-2 1) (-1 1)))
    #S(piece :name |j|
             :tiles #2A((0 0)
			(0 1) (1 1) (2 1)))))

(defun make-canonicalized-pieces (pieces)
  (loop for piece in pieces
	collect (let* ((b (rotate-piece piece))
		       (c (rotate-piece b))
		       (d (rotate-piece c)))
		  (mapcar 'canonicalize-piece (list piece b c d)))))

(defconstant +upper-left+ (board-idx 0 0))
(defconstant +lower-left+ (board-idx 0 +board-working-height+))

(defun try-to-fill (board pieces)
  (if (null pieces)
      board
      (loop for lp from +upper-left+ upto +lower-left+ by +board-width+
	    for offset = 0 then (1- offset)
	    do (loop for p from lp below (+ lp +board-working-width+)
		     when (and (not (svref board p)) ; Lonely square check
			       (svref board (1+ p))
			       (svref board (+ p +board-width+))
			       (svref board (1- p))
			       (svref board (- p +board-width+)))
		       do (return-from try-to-fill nil))
	       (loop for p from (+ lp offset) below (+ lp +board-working-width+) by 2
		     when (not (svref board p))
		       do (dolist (piece (car pieces))
			    (when (try-place-piece board piece p)
			      (let ((full-board (try-to-fill board (cdr pieces))))
				(when full-board
				  (return-from try-to-fill full-board)))
			      (unplace-piece board piece p)))))))

(defun play (pieces)
  (print-board (try-to-fill (make-board) (make-canonicalized-pieces pieces))))

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