(in-package :polyominos)


(defvar *actions* nil "The actions we've taken")
(defvar *to-be-placed* nil "The polyominos that need to be placed")
(defvar *branches* nil "The branches not taken")

(defun setup ()
  (reset-board)
  (setq *actions* (make-array 14 :fill-pointer 0))
  (setq *to-be-placed* (make-array 13 :fill-pointer 13 :initial-contents '(cF cJ cL cN cQ cS cT cW cZ lj ll ls lt)))
  (setq *branches* (make-array 13 :fill-pointer 0))
  (take-action '(three 1 1 2)))

(defun run ()
  (setup)
  (solve-board)
  (print-board-condensed *board*))
  
(defun test-placement (board test-cases x y)
  (labels ((test-passed-p (test-case)
                          (let ((the-elmt (funcall #'board-elt board
						   (+ (aref test-case 1 0) x)
						   (+ (aref test-case 1 1) y))))
                            (or (not (board-element-placed? the-elmt))
                                (and (not (null (aref test-case 0 0)))
                                     (eql (board-element-notch the-elmt (aref test-case 0 0))
                                          (aref test-case 0 1)))))))
    (every #'test-passed-p test-cases)))

;; Remove calls to list from this function
(defun test-polyomino (board poly x y)
  (let ((placeable-positions '()))
    (dotimes (i 4) ;; iterate through rotations of the polyomino
      (let* ((the-piece (polyomino-rotation poly i))
             (the-test-cases (polyomino-test-case poly i))
             (height (piece-height the-piece))
             (width (piece-width the-piece))
             (min-height (max (- y height -1) 1)))
        (do* ((offset-y min-height (1+ offset-y))
	      (offset-piece-y (- y offset-y) (1- offset-piece-y)))
            ((> offset-y y) nil)
          (if (or (>= (+ x width) (car (array-dimensions board)))
                  (>= (+ offset-y height) (car (array-dimensions board))))
              nil
            (when (and (or (and (board-element-placed? (board-elt board x (+ offset-y offset-piece-y)))
				(null (piece-elt the-piece 0 offset-piece-y)))
			   (not (null (piece-elt the-piece 0 offset-piece-y))))
		       (test-placement board the-test-cases x offset-y))
              (push (list x offset-y i) placeable-positions))))))
    (list (polyomino-symbol poly)
          placeable-positions)))

(defun place-section (board section label x y)
  (let ((segment (board-elt board x y)))
    (setf (board-element-label segment) label)
    (setf (board-element-left segment) (section-left section))
    (setf (board-element-top segment) (section-top section))
    (setf (board-element-right segment) (section-right section))
    (setf (board-element-bottom segment) (section-bottom section))
    (setf (board-element-placed? segment) t)))

(defun place-piece (board piece label x y)
  (dotimes (j (piece-height piece))
    (dotimes (i (piece-width piece))
      (awhen (piece-elt piece i j)
             (place-section board it label (+ x i) (+ y j))))))
              
(defun place-polyomino (board poly x y rotation)
  (place-piece board (polyomino-rotation poly rotation) (polyomino-label poly) x y))

(defun clear-section (board x y)
  (let ((segment (board-elt board x y)))
    (setf (board-element-label segment) #\ )
    (setf (board-element-placed? segment) nil)))

(defun remove-piece (board piece x y)
  "Remove the piece (a specific rotation of a polyomino) from the board
at the given coordinates"
  (dotimes (j (piece-height piece))
    (dotimes (i (piece-width piece))
      (awhen (piece-elt piece i j)
             (clear-section board (+ x i) (+ y j))))))

(defun remove-polyomino (board poly x y rotation)
  "Remove the polyomino from the board with the given
coordinates assuming the given rotation"
  (remove-piece board (polyomino-rotation poly rotation) x y))

(defun take-action (form)
  (let ((poly-symbol (car form)))
    (vector-push form *actions*)
    (delete-if #'(lambda (x) (eq x poly-symbol)) *to-be-placed*)
    (apply #'place-polyomino (append (list *board*)
                                     (list (symbol-value poly-symbol))
                                     (rest form))))
  form)

(defun rewind-action ()
  (if (> (length *actions*) 1)
      (destructuring-bind (poly-symbol x y rot) (vector-pop *actions*)
        (vector-push poly-symbol *to-be-placed*)
        (remove-polyomino *board* (symbol-value poly-symbol) x y rot)
	t)
    nil))

(defun push-branches (branches)
  (vector-push branches *branches*))

(defun pop-branches ()
  (vector-pop *branches*))

(defun solved-p ()
  (= 0 (length *to-be-placed*)))

(defun find-placements (x y)
  "Return a list (suitable to be fed to take-action) of branches that could be
 taken at this point.  Each of the (non-null) placements returned fit into the
 board at the returned coordinates, and result in position (x, y) in the board
 being filled"
  (let ((fits (remove-if #'(lambda (a) (null (second a)))
                         (loop for i across *to-be-placed*
                               collect (test-polyomino *board* (symbol-value i) x y)))))
    (flet ((process-node (node)
                         (destructuring-bind (symbol coords-and-rotations) node
                             (mapcar #'(lambda (n)
                                         (push symbol n))
                                     coords-and-rotations))))
      (mapcan #'process-node fits))))
                             
(defun backtrack ()
  (if (rewind-action)
      (destructuring-bind (action . other-actions) (pop-branches)
	(if action
	    (destructuring-bind (poly-symbol x y rot) action
	      (take-action action)
	      (push-branches other-actions)
	      (list x y))
	  (backtrack)))
    nil))

(defun next-indices (x y)
  "Find the next null space on the board."
  (labels ((null-in-column (x y)
                         (cond ((null (board-element-placed? (board-elt *board* x y))) y)
                               ((= y 9) nil)
                               (t (null-in-column x (1+ y))))))
    (do* ((x x (1+ x))
	  (y (if (= 9 y)
                 0
               (1+ y)) 0)
	  (row (null-in-column x y) (null-in-column x y)))
	((or row (= 10 x))
	 (if row (values x row) (values nil nil))))))

(defun solve-board ()
  (let ((x 1)
        (y 1))
    (while (not (solved-p))
      (multiple-value-bind (x y) (next-indices x y)
        (acond ((find-placements x y)
                (take-action (car it))
                (push-branches (cdr it)))
               ((backtrack) nil)
               (t
                (error "We couldn't find a solution...")))))))

;; $Id: //info.ravenbrook.com/user/ndl/lisp/contest/entries/anthony-juckel/solution1/solver.lisp#1 $