;;; Solution for the ILC 2003 Programming Contest problem
;;; Copyright (c) 2002 Carlos Ungil (Carlos.Ungil@cern.ch)
;;; Distributed under a FreeBSD style license 

;;; Second version:
;;;
;;; more comments added, and some typos fixed
;;;
;;; the form (print-board (search-solution)) has been added at the end
;;; to provide the solution when the file is compiled and loaded
;;; without requiring any other action  
;;;
;;; a new function where-to-put-next-piece-better used instead of the original
;;; where-to-put-next-piece, searches for the most restrictive square to fill
;;; looking not at the number of empty neighbours, but at the sum of the count 
;;; for each neighbour
;;;
;;; the function find-mimumum changed as well to chose the last square found with
;;; the minimum value instead of the first one; this change favours trying to 
;;; put pieces near to the lower right corner, where the *action* is
;;;
;;; this two changes in the strategy to decide "what to try next",
;;; which represent better what a person would do to solve the puzzle,
;;; make the program more than twice as fast
;;;
;;; note that the list of pieces is in the order they appear in the contest web 
;;; page; maybe the algorithm could be optimized if the order was cleverly chosen
;;; (and for sure it could be "optimized" by testing which order leads to the 
;;; solution faster). I've preferred to keep the original order, I find the 
;;; proposed algorithm is easy to understand and clever enough. 

;;; Load the file and execute
;;; (print-board (search-solution))
;;; or 
;;; (mapcar #'print-board (search-all-solutions))

(in-package :common-lisp-user)

(defun search-solution ()
  "Inspired by Artificial Intelligence--A Modern Approach, by Norvig &
Russell. A list of nodes in the search tree is kept in a stack. The
first state in the stack is taken. If there are no remaining pieces to
be used, we have found the solution. Otherwise the possible next
states are computed and added to the top of the stack. The possible
states are those which cover the target square with one of the
remaining pieces, the target square being the one with less empty
neighbours, or the first one found if there are many. If this node was
a dead end and no next states are found, another one is taken from the
stack.  The first solution found is returned:

jFFFFWWt
jjjFWWtt
lllTWQQt
lTTTTQLL
sNNSQQZL
ssNSSZZL
JsNNSZ3L
JJJJSZ33"
  (let ((nodes (list (initial-state))) ; puts the initial state in the stack
	node)
    (loop (if (null nodes) (return nil)) ; if the stack is empty, return nil (no solution)
	  (setf node (pop nodes)) ; takes the next state to consider from the stack
          ;(print-state node)
	  (unless (second node) (return (first node))) ; if there are no remaining pieces
                                                       ; return the board representing the solution
          (setf nodes (nconc (next-states node) nodes))))) ; add the possible next states to the stack

;(print-board (search-solution))

(defun search-all-solutions ()
  "returns the list of 5 solutions:

lllNJJJJ
lNNNTWWJ
FNTTTTWW
FFssSSSW
FssSSQQt
FLLLLQtt
jLZZQQ3t
jjjZZZ33

LLLLlllF
LZQQlSSF
ZZQSSSFF
ZQQJJJJF
ZssjjjJt
ssNWWjtt
NNNTWW3t
NTTTTW33

lllNZjjj
lNNNZWWj
sNJZZLWW
ssJZtLSW
TsJttLSS
TJJQtLLS
TTFQQQ3S
TFFFFQ33

LLLLJJJJ
LlllTWWJ
QlTTTTWW
QQQsNNSW
ZZQssNSS
tZZZsNNS
ttFjjj3S
tFFFFj33

jFFFFWWt
jjjFWWtt
lllTWQQt
lTTTTQLL
sNNSQQZL
ssNSSZZL
JsNNSZ3L
JJJJSZ33"
  (let ((nodes (list (initial-state)))
	result node)
    (loop (if (null nodes) (return result))
	  (setf node (pop nodes))
	  (if (null (second node)) (push (first node) result)
            (setf nodes (nconc (next-states node) nodes))))))

;(mapcar #'print-board (search-all-solutions))

(defvar *pieces-list* (list "F" "J" "L" "N" "Q" "S" "T" "W" "Z" "j" "l" "s" "t"))
(defvar *pieces* (make-hash-table :test #'equal))

(defmacro defpiece (name desc)
  `(setf (gethash ,name *pieces*) ,desc))

; pieces are encoded as arrays
; the chessboard analogy is used
; 1 correspond to white squares
; 2 correspond to black squares

(defpiece "F" #2A((2 0)
                  (1 2)
                  (2 0)
                  (1 0)))

(defpiece "J" #2A((0 2)
                  (0 1)
                  (0 2)
                  (2 1)))

(defpiece "L" #2A((1 0)
                  (2 0)
                  (1 0)
                  (2 1)))

(defpiece "N" #2A((0 0 1)
                  (2 1 2)
                  (1 0 0)))

(defpiece "Q" #2A((2 0 0)
                  (1 2 1)
                  (0 0 2)))

(defpiece "S" #2A((1 0)
                  (2 1)
                  (0 2)
                  (0 1)))

(defpiece "T" #2A((0 1)
                  (1 2)
                  (0 1)
                  (0 2)))

(defpiece "W" #2A((2 0 0)
                  (1 2 0)
                  (0 1 2)))

(defpiece "Z" #2A((2 1 2 0)
                  (0 0 1 2)))

(defpiece "j" #2A((0 1)
                  (0 2)
                  (2 1)))

(defpiece "l" #2A((2 0)
                  (1 0)
                  (2 1)))

(defpiece "s" #2A((1 0)
                  (2 1)
                  (0 2)))

(defpiece "t" #2A((0 1)
                  (1 2)
                  (0 1)))

(defun print-piece (name)
  "prints the piece, useful only to check they are correct"
  (format t "~%~A~%" name)
  (let* ((desc (gethash name *pieces*))
         (size (array-dimensions desc)))
    (dotimes (i (first size))
      (dotimes (j (second size))
        (let ((p (aref desc i j)))
          (cond ((= p 0)
                 (format t " "))
                ((= p 1)
                 (format t "+"))
                ((= p 2)
                 (format t "*")))))
      (format t "~%"))))

(defvar *white* (make-hash-table :test #'equal))
(defvar *black* (make-hash-table :test #'equal))

(mapcar #'(lambda (name)
            (let* (whites
                   blacks
                   (piece (gethash name *pieces*))
                   (size (array-dimensions piece)))
              (dotimes (i (first size))
                (dotimes (j (second size))
                  (if (= 1 (aref piece i j))
                      (push (list i j) whites))
                  (if (= 2 (aref piece i j))
                      (push (list i j) blacks))))
              (setf (gethash name *white*) whites)
              (setf (gethash name *black*) blacks))) *pieces-list*)

(defun find-color-in-piece (name color)
  "returns a list with the coordinates of the squares (as in the description 
of the piece) corresponding to the desired color (1 white, 2 black)
[the real computation is done only once and stored in hash tables]"
  (if (= 1 color)
      (gethash name *white*)
    (gethash name *black*)))
  
; Each state is given by:
; - the board (a 8x8 array containg piece names or NIL if the square is empty)
; - the list of names of the remaining pieces

(defun print-board (board)
  "prints the board, the squares forming each piece show the name of the piece"
  (format t "~%")
  (dotimes (i 8)
    (dotimes (j 8)
      (if (aref board i j)
          (format t "~A" (aref board i j))
        (format t "." (aref board i j))))
      (format t "~%")))

(defun print-state (state)
  "prints the board and piece list of the state"
  (let ((board (first state))
        (pieces (second state)))
    (print-board board)
    (format t "~A~%" pieces)))

(defun initial-state ()
  "generates the initial state, with a board containing only the piece '3',
and the list of all the other pieces available to be put on the board"
  (let ((return (make-array '(8 8) :initial-element nil)))
    (setf (aref return 7 7) 3)
    (setf (aref return 6 6) 3) 
    (setf (aref return 7 6) 3)
    (list return *pieces-list*)))

;(print-state (initial-state))

(defun next-states (state)
  "used by the search-solutin function to determine the list of possible next states"
  (let* ((board (first state))
         (pieces (second state))
         (next-pos (where-to-put-next-piece-better board)))
    (mapcan #'(lambda(piece) (get-next-states-piece-pos board pieces piece next-pos)) pieces)))

(defun get-next-states-piece-pos (board pieces piece next-pos)
  "gives the list of next states covering the next-pos square in the board,
each state being containing the new board situation and the list of remaining pieces"
  (let ((remaining-pieces (remove piece pieces :test #'equal)))
    (mapcar #'(lambda(x) (list x remaining-pieces))
            (remove-if #'null (mapcar #'(lambda (x) (combine-arrays board x))
                                      (piece-in-position piece next-pos))))))

;(mapcar #'print-state (next-states (initial-state)))

(defun combine-arrays (b1 b2)
  "merges two 8x8 arrays, or returns nil if there is an overlap"
  (let ((result (make-array '(8 8) :initial-element nil)))
    (dotimes (i 8)
      (dotimes (j 8)
        (if result
            (let ((v1 (aref b1 i j)) (v2 (aref b2 i j)))
              (if (and v1 v2)
                  (setf result nil))
              (if (and (not v1) v2)
                  (setf (aref result i j) v2))
              (if (and (not v2) v1)
                  (setf (aref result i j) v1))))))
    result))

(defun find-minimum (array)
  "finds the minimum of the array counting neighbours
(returns the last one if many), a list of two coordinates"
  (let ((minimum 500) coord)
    (dotimes (i 8)
      (dotimes (j 8)
        (let ((value (aref array i j)))
          (when value
            (if (<= value minimum)
                (progn
                  (setf minimum value coord (list i j))))))))
    coord))

(defun count-neighbours (board i j)
  "counts the number of empty neigbours of a given empty square 
(or nil if the square is not empty)"
  (let (count)
    (unless (aref board i j)
      (progn
        (setf count 0)
        (if (and (> i 0) (not (aref board (1- i) j)))
            (incf count))
        (if (and (< i 7) (not (aref board (1+ i) j)))
            (incf count))
        (if (and (> j 0) (not (aref board i (1- j))))
            (incf count))
        (if (and (< j 7) (not (aref board i (1+ j))))
            (incf count))))
    count))

(defun count-neighbours-sum (neighbours i j)
  "gives the sum of the number of empty neigbours of the given empty square, 
or nil if the square is not empty"
  (let (sum)
    (if (aref neighbours i j)
        (progn
          (setf sum 0)
          (if (and (> i 0) (aref neighbours (1- i) j))
              (incf sum (aref neighbours (1- i) j)))
          (if (and (< i 7) (aref neighbours (1+ i) j))
              (incf sum (aref neighbours (1+ i) j)))
          (if (and (> j 0) (aref neighbours i (1- j)))
              (incf sum (aref neighbours i (1- j))))
          (if (and (< j 7) (aref neighbours i (1+ j)))
              (incf sum (aref neighbours i (1+ j))))))
    sum))

(defun where-to-put-next-piece (board)
  "returns the coordinates of the next square of the board to be
filled: the square with less empty adjacent squares (the first one if
there are many)"
  (let ((neighbours (make-array '(8 8) :initial-element nil)))
    (dotimes (i 8)
      (dotimes (j 8)
        (setf (aref neighbours i j) (count-neighbours board i j))))
    (find-minimum neighbours)))

(defun where-to-put-next-piece-better (board)
  "returns the coordinates of the next square of the board to be
filled: the square with less empty adjacent squares (the first one if
there are many)"
  (let ((neighbours (make-array '(8 8) :initial-element nil))
        (neighbours-sum (make-array '(8 8) :initial-element nil)))
    (dotimes (i 8)
      (dotimes (j 8)
        (setf (aref neighbours i j) (count-neighbours board i j))))
    (dotimes (i 8)
      (dotimes (j 8)
        (setf (aref neighbours-sum i j) (count-neighbours-sum neighbours i j))))
    (find-minimum neighbours-sum)))

(defun piece-in-position (name position)
  "returns a list of 8x8 arrays displaying only the piece in the
required position, including all translation and rotations, only those
which are completely inside the board"
  ;(= 1 (mod (+ i j) 2)) => white squares (1 in the piece description)
  ;(= 0 (mod (+ i j) 2)) => black squares (2 in the piece description)
  (let ((color (- 2 (mod (reduce #'+ position) 2))))
    (remove-if #'null 
               (mapcan #'(lambda (pos) (create-arrays-piece name pos position))
                       (find-color-in-piece name color)))))

  
(defun create-arrays-piece (name pos position)
  "returns a list of 8x8 arrays with the given piece put in such a way
that the particular square of the piece given by _pos_ is in the
_position_ square in the array and the piece is completely contained
in the array- or nil if there are no valid arrays"
  (mapcar #'(lambda (orient)
              (create-array-oriented-piece name pos position orient))
          '(0 1 2 3)))

(defun create-array-oriented-piece (name pos position ori)
  (if (and (> ori 1) (or (equal name "N") (equal name "Q")))
      nil ; the N and Q pieces are symetric under rotations of 180 degrees
    (let* ((result (make-array '(8 8) :initial-element nil)) 
           (piece (gethash name *pieces*))
           (size (array-dimensions piece)))
      (dotimes (i (first size))
        (dotimes (j (second size))
          (if (and result (> (aref piece i j) 0))
              (let* ((xp (- i (first pos)))
                     (yp (- j (second pos)))
                     (x0 (first position))
                     (y0 (second position))
                     x y)
                (cond ((= ori 0)
                       (setf x (+ x0 xp) y (+ y0 yp)))
                      ((= ori 1)
                       (setf x (+ x0 yp) y (- y0 xp)))
                      ((= ori 2)
                       (setf x (- x0 xp) y (- y0 yp)))
                      ((= ori 3)
                       (setf x (- x0 yp) y (+ y0 xp))))
                (if (and (>= x 0) (< x 8) (>= y 0) (< y 8))
                    (setf (aref result x y) name)
                  (setf result nil))))))
      result)))

(print-board (search-solution))  

;; $Id: //info.ravenbrook.com/user/ndl/lisp/contest/entries/carlos-ungil.lisp#3 $
;; First version was received as //info.ravenbrook.com/mail/2003/06/15/20-36-43/0.txt