;;;; Copyright 2003 Nils Goesche <ngo@cartan.de>
;;;;
;;;; License: Do whatever you want with this code at your own risk.
;;;; Should solve a puzzle, but no guarantees whatsoever.
;;;;
;;;; Second submission  #|| aka Third submission - NDL 2003-08-21 ||#
;;;;
;;;; Compile and load this file, then evaluate (puzzle:solve)
;;;;

(defpackage "PUZZLE"
  (:use "CL")
  (:export "SOLVE"))

(in-package "PUZZLE")

(defvar *throw-out* nil)

;;; For readability, we first represent pieces as lists of
;;; coordinate vectors.  The first coordinate is always (0 0)
;;; and is chosen to be a square of the piece with slots!
;;; Later, these lists will be used to compute our real
;;; representation which is less readable.  Note also,
;;; that we will think of the x-axis as going from right to
;;; left, so we reverse signs right now.

(defparameter *piece-vecs*
  (mapcar (lambda (piece)
            (loop for (x y) in piece collect
                  (list (- x) y)))
          '(((0 1) (0 2) (0 3) (1 2))    ; F
            ((-1 0) (0 1) (0 2) (0 3))   ; J
            ((-1 0) (-1 1) (-1 2) (-1 3)); L
            ((0 1) (1 1) (2 1) (2 2))    ; N
            ((0 1) (1 0) (2 0) (2 -1))   ; Q
            ((0 1) (0 2) (-1 2) (-1 3))  ; S
            ((1 0) (1 1) (1 -1) (1 -2))  ; T
            ((1 0) (0 1) (-1 1) (-1 2))  ; W
            ((1 0) (0 1) (-1 1) (-2 1))  ; Z
            ((-1 0) (0 1) (0 2))         ; j
            ((-1 0) (-1 1) (-1 2))       ; l
            ((0 -1) (-1 0) (-1 1))       ; s
            ((0 1) (0 2) (-1 1)))))      ; t

(defparameter *rotations*
  '(((1 0)
     (0 1))
    ((0 -1)
     (1 0))
    ((-1 0)
     (0 -1))
    ((0 1)
     (-1 0))))

;;; I've always wanted to use this matrix representation some time ;-)

(defun dot-product (vector-1 vector-2)
  (reduce #'+ (mapcar #'* vector-1 vector-2)))

(defun rotate-vector (matrix vector)
  (mapcar (lambda (row)
            (dot-product row vector))
          matrix))

;;; Don't worry about duplicates for now

(defun compute-rotated-pieces ()
  (loop for piece in *piece-vecs* collect
        (loop for rotation in *rotations* collect
              (loop for vector in piece collect
                    (rotate-vector rotation vector)))))

;;; We will represent both a piece and the whole frame as a
;;; 64-bit number.  The bits are ordered as follows:

;;; 63 62 ... 56
;;; 55 54 ... 48
;;;     ...
;;; 07 06 ... 00

;;; Two-dimensional coordinates: x-axis goes left, y-axis up

(defun frame-ref (frame i j)
  (if (logbitp (logior i (ash j 3)) frame)
      1
    0))

(defun set-frame-ref (frame i j)
  (logior frame (ash 1 (logior i (ash j 3)))))

(defun make-start-frame ()
  (loop for ret = 0 then (set-frame-ref ret stone-x stone-y)
        for (stone-x stone-y) in '((0 0) (1 0) (1 1))
        finally (return ret)))

(defconstant +start-frame+ (make-start-frame))

;;; Now we compute every possible placement of a piece
;;; on the start-frame and collect its integer representation.
;;; Turns out there are 826 of them.

(defun compute-placements ()
  (loop for vec-list in (compute-rotated-pieces) collect
        (delete-duplicates
         (loop for vecs in vec-list nconc
               (flet ((convert-coordinates (start-x start-y)
                        (let ((ret (set-frame-ref 0 start-x start-y)))
                          (unless (logtest ret +start-frame+)
                            (loop for (dx dy) in vecs
                                  for next-x = (+ start-x dx)
                                  for next-y = (+ start-y dy) do
                                  (unless (and (<= 0 next-x 7) (<= 0 next-y 7))
                                    (return-from convert-coordinates))
                                  (setq ret (set-frame-ref ret next-x next-y))
                                  (when (logtest ret +start-frame+)
                                    (return-from convert-coordinates)))
                            ret))))
                 (loop for start-y below 8 nconc
                       (loop for start-x from (if (evenp start-y) 7 6)
                             downto 0 by 2
                             when (convert-coordinates start-x start-y)
                             collect it)))))))

;;; A strategic decision: Put unsymmetric pieces at the end of the list

(defparameter *all-placements*
  (sort (compute-placements) #'< :key #'length))

(defun compute-neighbor-table ()
  (let ((buf (make-array 64)))
    (dotimes (bit 64 buf)
      (let ((list nil)
            (i (logand bit 7))
            (j (ash bit -3)))
        (flet ((check-at (dx dy)
                 (let ((new-x (+ i dx))
                       (new-y (+ j dy)))
                   (when (and (<= 0 new-x 7)
                              (<= 0 new-y 7))
                     (push (set-frame-ref 0 new-x new-y) list)))))
          (check-at 1 0)
          (check-at -1 0)
          (check-at 0 1)
          (check-at 0 -1))
        (setf (svref buf bit) list)))))

(defparameter *neighbors* (compute-neighbor-table))

(defun compute-neighbors (frame)
  (let ((ret 0))
    (dotimes (i 64 ret)
      (unless (logbitp i frame)
        (dolist (neighbor (svref *neighbors* i))
          (when (logtest neighbor frame)
            (setq ret (logior ret (ash 1 i)))
            (return)))))))

(defun check-neighbors (frame neighbors pieces)
  (dotimes (i 64 t)
    (when (logbitp i neighbors)
      (block ok
        (dolist (piece pieces)
          (dolist (action piece)
            (when (and (logbitp i action)
                       (not (logtest frame action)))
              (return-from ok))))
        (return-from check-neighbors)))))

;;; It's a brute force search, but we place pieces so they
;;; touch some that are already there to discover dead ends
;;; early.  Remember, also, that the order we try pieces is
;;; not totally arbitrary.  Note how Common Lisp's RETURN-FROM
;;; simplifies the code a lot without the overhead of throwing
;;; exceptions.  And isn't it funny how we cons so much in loops
;;; and still get fast code?

(defun choose-neighbor (neighbors)
  (dotimes (i 64)
    (when (logbitp i neighbors)
      (return i))))

(defun compute-action ()
  (labels ((fill-with (frame pieces action-list)
             (if (null pieces)
                 (progn 
                   (print-action (nreverse action-list))
                   (when *throw-out*
                     (throw nil nil)))
               (let ((neighbors (compute-neighbors frame)))
                 (unless (check-neighbors frame neighbors pieces)
                   (return-from fill-with))
                 (let ((bit (choose-neighbor neighbors)))
                   (loop for piece in pieces
                         for rest-pieces = (remove piece pieces :test #'eq) do
                         (loop for action in piece do
                               (when (logbitp bit action)
                                 (let ((next (logior frame action)))
                                   (block walk
                                     (let ((next-pieces
                                            (loop for rest-piece in rest-pieces collect
                                                  (let ((ret (loop for action in rest-piece
                                                                   unless (logtest action next)
                                                                   collect action)))
                                                    (or ret
                                                        (return-from walk))))))
                                       (fill-with next
                                                  next-pieces
                                                  (cons action action-list)))))))))))))
    (fill-with +start-frame+ *all-placements* nil)))

(defun solve (*throw-out*)
  (catch nil
    (compute-action)
    (values)))

(defun print-action (action-list)
  (let ((buf (make-array '(8 8) :initial-element #\.)))
    (loop for i from 0
          for char = (digit-char i 24)
          for action in action-list do
          (dotimes (bit 64)
            (when (logbitp bit action)
              (let ((i (logand bit 7))
                    (j (ash bit -3)))
                (setf (aref buf i j) char)))))
    (loop for j from 7 downto 0 do
          (fresh-line)
          (loop for i from 7 downto 0 do
                (write-char (aref buf i j))))
    (terpri)))

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