;;;; Solution for the Last Piece Puzzle.
;;;; http://www.ravenbrook.com/doc/2003/05/28/contest/
;;;;
;;;; Author: Gabor Melis <mega@hotpop.com>
;;;; Licence: Public domain
;;;;
;;;;
;;;; Some Rationale
;;;;
;;;; Piece "3" has only one place to go, so it is considered to be
;;;; part of the starting position. The remaining pieces and the board
;;;; position are regular in the sense that tabs and slots alternate.
;;;;
;;;; Let's take two basic pieces of one square: one with four tabs and
;;;; the other with four slots and call them A and B.
;;;;
;;;; 1) Each piece can be constructed non-ambiguously from A's and
;;;; B's. Neighbouring squares in a piece are always of different
;;;; types.
;;;;
;;;; 2) The initial board can be filled with A's and B's
;;;; non-ambiguously like white and black on a chess board. On this
;;;; filled board the type of the square in a position is said to be
;;;; the expected type of the position.
;;;;
;;;; From 1) and 2) it follows that if a piece P fits into a certain
;;;; position on the board, then the type of each square in P matches
;;;; the expected type of the position below it. Furthermore, if they
;;;; don't match, then it is already impossible to fill the board.
;;;;
;;;; Therefore, the tabs and slots fitting problem can be reduced to
;;;; simple matching between the type of squares in the piece and the
;;;; expected types of the positions.
;;;;
;;;;
;;;; The Algorithm
;;;;
;;;; Very simple depth first search. Only moves that cover the most
;;;; critical position on the board are considered.
;;;;
;;;; The speed things up all possible moves are pre-generated and
;;;; indexed by piece and covered board position. So, to each piece
;;;; and board position a move set belongs. A move set is represented
;;;; by an integer with a bit for every more.
;;;;
;;;; Bit vectors may be faster, but :element-type cannot be declared
;;;; according to the rules. Well, a literal #*00000... could be
;;;; copied without touching forbidden fruits, but that would be
;;;; cheap. On the other hand using bignums for the same purpose is
;;;; not :-).
;;;;
;;;; The solution was tested on CMUCL 18e and Clisp.
;;;;
;;;;
;;;; Usage
;;;;
;;;; Just call SOLVE-AND-PRINT. See functions SOLVE and
;;;; SOLVE-AND-PRINT for details.

(defpackage "LAST-PIECE"
  (:use "COMMON-LISP")
  (:export "SOLVE"
           "SOLVE-AND-PRINT"))

(in-package "LAST-PIECE")

(defvar *throw-out* nil)

;;; UTILITIES

(defun copy-array (array)
  "Copy it fast."
  (let ((a (make-array (array-dimensions array) :adjustable nil)))
    (dotimes (i (array-total-size a) a)
      (setf (row-major-aref a i) (row-major-aref array i)))))

;;; from Paul Graham's On Lisp
(defmacro with-gensyms (syms &body body)
  `(let ,(mapcar #'(lambda (s)
                     `(,s (gensym)))
                 syms)
    ,@body))

(defmacro do-log ((bit integer &optional return-form) &body body)
  "Iterate over the set bits in INTEGER. BIT is always the index of
the bit."
  (with-gensyms (x)
    `(let ((,x ,integer))
      (dotimes (,bit (integer-length ,x) ,return-form)
        (when (logbitp ,bit ,x)
          ,@body)))))

;;; A direction is absolute, or in other words always relative to the
;;; board.
(defun rotate-direction (direction)
  "Rotate DIRECTION 90 degrees anti-clockwise."
  (ecase direction
    (:right :up)
    (:up :left)
    (:left :down)
    (:down :right)))

;;; PIECE

(defstruct piece
  "A piece with a particular orientation. Pieces with the same NAME
are considered to differ only in orientation, but it is not enforced
by the implementation.

A piece consists of squares. Squares in a piece are defined in the
DIR-TREE (direction tree) slot. The following example describes a
standing L of 4 squares starting from the topmost one:

  (:down :down :right)

It says to reach the second square from the first one (the topmost in
this example) we should go :down, then :down again to the next and
finally to the :right. There are some pieces, though, that cannot be
described in such a way without stepping on some squares more than
once. In such cases side excursions must be made and the branches
explored put into sublists. To describe a plus sign of five squares
starting from the topmost one:

  (:down (:left) (:right) :down)

First we move :down to the intersection of the plus sign, then make
two side excursions: one to the :left and one to the :right before
moving :down again.

Since all pieces are regular in the sense that squares with slots and
tabs alternate in them, it is only necessary for the first square to
define its TYPE: :tab or :slot."
  name
  type
  dir-tree)

(defun piece= (piece1 piece2)
  "Two pieces are equal if they have the same name."
  (equal (piece-name piece1)
         (piece-name piece2)))

(defun rotate-piece (piece)
  "Rotate PIECE 90 degrees anti-clockwise."
  (labels ((rotate-dir-tree (tree)
             (mapcar #'(lambda (x)
                         (if (listp x)
                             (rotate-dir-tree x)
                             (rotate-direction x)))
                     tree)))
    (make-piece :name (piece-name piece)
                :type (piece-type piece)
                :dir-tree (rotate-dir-tree (piece-dir-tree piece)))))

(defun get-all-piece-rotations (piece)
  "Return a list of the four possible rotations of PIECE."
  (let ((acc (list piece)))
    (dotimes (i 3 acc)
      (setq piece (rotate-piece piece))
      (push piece acc))))

(defparameter *pieces* ())

(defun piece (name &optional (pieces *pieces*))
  "Find the piece of NAME in the PIECES list."
  (find name pieces :key #'piece-name :test #'equal))

(defmacro defpiece (name piece-def)
  "Define a piece of NAME. The first element in PIECE-DEF is the type
and the rest is the dir-tree. Put the defined piece into *PIECES*."
  (with-gensyms (def)
    `(let ((,def ,piece-def))
      (push (make-piece :name ',name
             :type (car ,def)
             :dir-tree (cdr ,def))
       *pieces*))))

;;; BOARD & POSITION

(defmacro position-y-x (pos board)
  `(multiple-value-list (floor ,pos (array-dimension ,board 1))))

(defun valid-position? (position board)
  "See if POSITION is within the boundaries of BOARD."
  (< -1 position (array-total-size board)))

(defun position-type (position board)
  "Return :tab or :slot depending the type of square that should go
onto POSITION."
  ;; types alternate with the top-left position being tabs
  (if (evenp (apply #'+ (position-y-x position board)))
      :tab
      :slot))

(defun step-from-position (position direction board)
  "Move one step from POSITION in DIRECTION on BOARD. Return when
leaving the board."
  (destructuring-bind (y x) (position-y-x position board)
    (destructuring-bind (ys xs) (array-dimensions board)
      (ecase direction
        (:right (if (< (1+ x) xs) (1+ position) nil))
        (:up (if (plusp y) (- position xs) nil))
        (:left (if (plusp x) (1- position) nil))
        (:down (if (< (1+ y) ys) (+ position xs) nil))))))

(defmacro board-position (board position)
  "Return the value of the square at POSITION of the BOARD."
  `(row-major-aref ,board ,position))

(defun create-board (dim1 dim2)
  "Create an empty board of dimensions (DIM1 DIM2)"
  (make-array (list dim1 dim2) :initial-element nil))

(defmacro do-board ((var board &optional return-form) &body body)
  "Iterate VAR over empty BOARD positions."
  (with-gensyms (b)
    `(let ((,b ,board))
      (dotimes (,var (array-total-size ,b) ,return-form)
        (unless (board-position ,b ,var)
          ,@body)))))

(defun board-full? (board)
  (do-board (p board t)
    (return-from board-full? nil)))

(defun print-board (board &optional (stream t))
  (format stream "~&")
  (dotimes (y (array-dimension board 0) board)
    (dotimes (x (array-dimension board 1))
      (format stream "~A " (or (aref board y x)
                               ".")))
    (format stream "~%")))

;;; MOVE

(defstruct move
  "A move describes a PIECE on BOARD covering POSITIONS."
  piece
  board
  positions)

(defun move= (move1 move2)
  "See if two moves are equal meaning they are of the same piece and
cover the same positions."
  (and (piece= (move-piece move1)
               (move-piece move2))
       (equal (move-positions move1)
              (move-positions move2))))

(defun dir-tree-to-positions (dir-tree position board)
  "Create a list of positions by applying DIR-TREE at POSITION on
BOARD. Return nil when falling off the board."
  (labels ((dir-tree-to-pos (tree pos)
             (mapcan #'(lambda (x)
                         (if (listp x)
                             (dir-tree-to-pos x pos)
                             (list (setq pos
                                         (or (step-from-position pos x board)
                                             (return-from dir-tree-to-positions
                                               nil))))))
                     tree)))
    (cons position (dir-tree-to-pos dir-tree position))))

(defun create-move (piece position board)
  "Create a move by placing PIECE at POSITION on BOARD, if
it fits. Otherwise, return nil."
  (when (and (valid-position? position board)
             (eq (piece-type piece)
                 (position-type position board)))
    (let ((positions (dir-tree-to-positions (piece-dir-tree piece)
                                            position
                                            board)))
      (when (and positions (every #'(lambda (p)
                                      (null (board-position board p)))
                                  positions))
        (make-move :piece piece :board board
                   :positions (sort positions #'<))))))

(defmacro do-move ((var move &optional return-form) &body body)
  "Iterate VAR over the MOVE positions."
  `(dolist (,var (move-positions ,move) ,return-form)
    ,@body))

(defun play-move (move board)
  "Play MOVE on BOARD. No error checking."
  (let ((b (copy-array board)))
    (do-move (p move b)
      (setf (board-position b p)
            (piece-name (move-piece move))))))

(defun moves-for-piece (piece board)
  "Return all valid moves for PIECE on BOARD. Rotation is allowed, but
be careful not to return identical moves."
  (flet ((no-rotate (piece)
           (let ((moves ()))
             (do-board (pos board moves)
               (let ((move (create-move piece pos board)))
                 (when move
                   (push move moves)))))))
    (remove-duplicates (mapcan #'no-rotate
                               (get-all-piece-rotations piece))
                       :test #'move=)))

;;; MOVES-BY-PIECE

(defun create-piece-moves-map (moves)
  (let ((map (make-hash-table :test #'equal)))
    (dotimes (i (length moves) map)
      (let ((name (piece-name (move-piece (aref moves i)))))
        (setf (gethash name map)
              (if (gethash name map)
                  (logior (gethash name map) (expt 2 i))
                  (expt 2 i)))))))

(defun get-move-set-for-piece (piece map)
  (gethash (if (typep piece 'piece)
               (piece-name piece)
               piece)
           map))

;;; MOVES-BY-POSITION

(defun create-position-moves-map (moves board)
  (let ((map (make-array (array-dimensions board) :initial-element 0)))
    (dotimes (i (length moves) map)
      (do-move (pos (aref moves i))
        (setf (row-major-aref map pos)
              (logior (row-major-aref map pos) (expt 2 i)))))))

(defun remove-move-set-from-position-map (mask map)
  (let ((new-map (copy-array map)))
    (dotimes (i (array-total-size new-map) new-map)
      (setf (row-major-aref new-map i)
            (logandc2 (row-major-aref new-map i) mask)))))

(defun get-move-set-for-position (position map)
  (row-major-aref map position))

;;;

(defmacro move-set-length (mask)
  `(logcount ,mask))

;;; STATE

(defstruct state
  "The board and a vector of all moves that is really constant and the
move indexes."
  board
  moves
  moves-by-piece
  moves-by-position)

(defun create-state (board pieces)
  "Create a state for BOARD and the available PIECES."
  (let ((moves (coerce (mapcan #'(lambda (p)
                                   (moves-for-piece p board))
                               pieces)
                       'vector)))
    (make-state :board board
                :moves moves
                :moves-by-piece (create-piece-moves-map moves)
                :moves-by-position (create-position-moves-map moves board))))

(defun update-state (move-idx state)
  "Play MOVE on the board. Remove moves that are no longer
valid. Update moves-by-position accordingly."
  (let* ((moves (state-moves state))
         (moves-by-piece (state-moves-by-piece state))
         (moves-by-position (state-moves-by-position state))
         (move (aref moves move-idx))
         (piece (move-piece move))
         (mask 0))
    ;; moves that would cover these positions, shall be removed
    (do-move (pos move)
      (setq mask (logior mask (get-move-set-for-position pos
                                                         moves-by-position))))
    ;; moves of the same piece too
    (setq mask (logior mask
                       (get-move-set-for-piece piece moves-by-piece)))
    (make-state :board (play-move move (state-board state))
                :moves moves
                :moves-by-piece  moves-by-piece
                :moves-by-position (remove-move-set-from-position-map
                                    mask
                                    moves-by-position))))

(defun min-coverage (position-moves-map board)
  "Find an empty position on BOARD with minimal coverage."
  (let ((min-pos nil)
        (min-val nil))
    (dotimes (i (array-total-size position-moves-map) min-pos)
      (unless (row-major-aref board i)
        (let ((c (move-set-length (row-major-aref position-moves-map i))))
          (when (or (null min-val) (< c min-val))
            (setq min-pos i
                  min-val c)))))))

;;; MAIN ALGORITHM

(defun select-moves (state)
  (let ((moves-by-position (state-moves-by-position state)))
    (get-move-set-for-position (min-coverage moves-by-position
                                             (state-board state))
                               moves-by-position)))

(defparameter *default-board* nil)

(defun solve (*throw-out* &key (board *default-board*) (pieces *pieces*))
  "Return a list of *all* possible filled boards that can be reached
from the starting BOARD by placing some of PIECES on it according to
the Last Piece Puzzle rules."
  (let ((solutions ()))
    (labels ((explore (state)
               (if (board-full? (state-board state))
                   (progn
                     (push (state-board state) solutions)
                         (when *throw-out*
                           (throw nil nil)))
                   (do-log (move-idx (select-moves state))
                     (explore (update-state move-idx state))))))
      (catch nil
        (explore (create-state board pieces)))
      solutions)))

(defun solve-and-print (&rest args)
  "Call solve and present the results in human readable format."
  (dolist (board (apply #'solve args))
    (print-board board)
    (terpri)))

;;; LAST PIECE PUZZLE SETUP

(defun create-last-piece-board ()
  "Create a 8x8 board with piece 3 at its rightful place."
  (let ((board (create-board 8 8)))
    (setf (aref board 7 7) 3
          (aref board 7 6) 3
          (aref board 6 6) 3)
    board))

(setq *default-board* (create-last-piece-board))
 
(defpiece F '(:tab :down (:right) :down :down))
(defpiece J '(:tab :down :down :down :left))
(defpiece L '(:slot :down :down :down :right))
(defpiece N '(:slot :up :right :right :up))
(defpiece Q '(:tab :down :right :right :down))
(defpiece S '(:slot :down :right :down :down))
(defpiece T '(:slot :down (:left) :down :down))
(defpiece W '(:tab :down :right :down :right))
(defpiece Z '(:tab :down :left :down :down))
(defpiece |j| '(:slot :down :down :left))
(defpiece |l| '(:tab :down :down :right))
(defpiece |s| '(:slot :down :right :down))
(defpiece |t| '(:slot :down (:left) :down))

;; $Id: //info.ravenbrook.com/user/ndl/lisp/contest/entries/timings/gabor-melis.lisp#2 $