;;
;; ILC 2003 Programming Contest Entry.
;; Michael Naunton
;; michael@naunton.us
;;
;; Run with: (solve)
;;
;;
;; Code shoould be portable.  No macros, but some functions declared inline.
;; Compile at high speed settings if you want.
;;
;; Prize categories to be considered:
;;
;;   First working answer to be submitted.
;;     I suspect I'm a bit late here.
;;
;;   Fastest running program.
;;     Hmm, does this count?

(defun i-win-i-win ()
  (format t "j F F F F W W t~%")
  (format t "j j j F W W t t~%")
  (format t "l l l T W Q Q t~%")
  (format t "l T T T T Q L L~%")
  (format t "s N N S Q Q Z L~%")
  (format t "s s N S S Z Z L~%")
  (format t "J s N N S Z 3 L~%")
  (format t "J J J J S Z 3 3~%")
  (values))

;;     More seriously, any greedy searching algorithm's runtime will be
;;     sensitive to the input data order.  If I ordered my input data
;;     as "LtZQWS...." I'd be done in no time.
;;
;;   Most elegant algorithm.
;;     Sign me up - the other categories seem too hard.
;;
;;   Most elegant use of lisp.
;;     Well, it didn't core dump while I was using it.
;;
;;   Best use of really obscure lisp features.
;;     Which obscure features?
;;
;;   Contestants under the age of 21 on the first day of the conference.
;;     Drat, missed it by a little.
;;
;;   Best "added value".
;;     Hmm...

;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;
;;
;; The algorithm:  depth first search, adding pieces to the frame from
;; bottom to top, right to left:
;;
;;  . . . . . D
;;  . . . . . C
;;  . . . . G B
;;  . . . . 3 A
;;  . . . . 3 3
;;
;;  I.e. A candidate piece with always have covered space B in the frame
;;  before space C is considered, and so on.
;;
;;  The right-most, bottom-most unoccupied point in the frame is the
;;  insertion point (e.g. A is the initial insertion point.)  The
;;  insertion point of a piece is the part of the piece that occupies
;;  the frame's insertion point.
;;
;;  First we define a piece:

(defvar *throw-out* nil)

(defstruct piece
  (name)
  (male-layouts)
  (female-layouts))

;; It has a name, e.g. "S", and a set of layouts (i.e. possible orientations.)
;; Layouts are divided into male and female, based on the tabs of the piece's
;; insertion point.
;;
;; A layout represents a piece in a specific orientation....

(defstruct layout
  (co-ords)
  (is-male)
  (y-add)
  (fast-co-ords)
  (valid-locations))

;; co-ords is a list of dotted pairs of the form (x . y) based on an insertion
;; point of (0 . 0).  The co-ords represent the coverage of the piece in this
;; orientation.
;;
;; is-male describes the gender of the insertion point.
;;
;; The other slots are for optimization:
;;
;; valid-locations is an 8x8 array of booleans that represent 'can this layout
;; be placed in the frame at x,y?'
;;
;; y-add is an integer that describes the next possible open point (n) in the
;; frame after we have added this layout to the frame.  Obviously is always
;; on the y-axis of the insertion point.  E.g.
;;
;;    n                             n
;; 1234  y-add = 2                  1  y-add = 4
;;    0                             2
;;                                  3
;;                                 40
;;
;; fast-co-ords are a subset of co-ords.  They are the co-ords that pieces
;; placed later in the depth-first search might possible collide with.  In the
;; above two cases, the fast co-ords would be the points "123" in the first
;; case, and "4" in the second case.  Beacause of the bottom-to-top,
;; right-to-left placement of pieces, the other (non-fast) points will not
;; be considered by a future piece.  
;;
;; Complete description of the algorithm:
;;   Given a frame and a list of pieces, for each piece, try to add it to
;;   the frame.  If this works, recurse with the rest of the pieces and
;;   the new frame.  Return the filled frame if the rest were successfully
;;   placed, otherwise remove the piece we added, and continue.
;;
;;
;; Implementation:
;;   Two parts, initialization (which makes no attempt to be efficient,)
;;   and then the depth-first search which tries to be fast and have
;;   zero conses.

;; A frame is just a 8x8 array, we use these to descibe the current pieces
;; on the board, and also the valid locations for a layout.

(defconstant +size+ 8)

(defconstant +empty+ ())

(defun make-frame ()
  (let ((frame (make-array (list +size+ +size+) :initial-element +empty+)))
    frame))

;; Define the pieces: name, male or female (out or in,) shape...
;; Start for the lower right, then move up, left, or right, with 'buds'
;; defined with < and >...
;;
;; F = U       J =  U
;;     U>           U
;;     U            U
;;     0           0R

(defconstant +pieces+
  '(("F" I "UU>U")
    ("J" O "RUUU")
    ("L" I "LUUU")
    ("N" I "URRU")
    ("Q" O "ULLU")
    ("S" I "UULU")
    ("T" O "UU<U")
    ("W" O "LULU")
    ("Z" O "LULL")
    ("j" O "RUU")     
    ("l" I "LUU")     
    ("s" O "ULU")     
    ("t" I "U<U")))   

(defconstant +tri+ '(3 O "LU"))

;;
;;  The goal of the next few routines is to convert a piece definition (an
;;  element of +pieces+) into a piece structure - a group of layouts with all
;;  the bells and whistles attached.
;;  (generate-piece raw-piece) is the result.
;;

(defun generate-co-ords (piece)
  "given a piece, as defined in +pieces+, generate a list of (x . y) co-ordinates for it."
  (let ((x 0)
	(y 0)
	(string (caddr piece))
	(result (list (cons 0 0))))
    (loop for i from 0 below (length string)
	  do (push (case (aref string i)
		     (#\U (cons x (incf y)))
		     (#\L (cons (decf x) y))
		     (#\R (cons (incf x) y))
		     (#\> (cons (1+ x) y))
		     (#\< (cons (1- x) y))
		     (otherwise (break)))
		   result))
    result))

(defun generate-rotations (co-ords)
  "given a piece in co-ord form, generate a list of the 4 orientations for it."
  (let ((c1)
	(c2)
	(c3))
    (mapcar (lambda (c)
	      (destructuring-bind (x . y) c
		(push (cons y     (- x)) c1)
		(push (cons (- x) (- y)) c2)
		(push (cons (- y) x)     c3)))
	    co-ords)
    (list co-ords c1 c2 c3)))

(defun generate-valid-frame (co-ords)
  "make a frame of booleans to describe valid locations for these co-ords to be placed."
  (let ((frame (make-frame)))
    (dotimes (x 8)
      (dotimes (y 8)
	(setf (aref frame x y) 
	      (dolist (l co-ords t)
		(if (or (>= (+ x (car l)) +size+)
			(>= (+ y (cdr l)) +size+)
			(< (+ x (car l)) 0)
			(< (+ y (cdr l)) 0))
		    (return nil))))))
    frame))
					  
(defun make-offset-layout (co-ords base-is-female)
  "Find the insert point for this list of co-ords, normalize the co-ords
   to the insertion point. Return a layout structure with the pre-computated
   optimizations."
  (let* ((max-x (apply #'max (mapcar #'car co-ords)))
	 (ys-for-rightmost (mapcar #'cdr (remove-if-not
					  (lambda (co-ord) (= (car co-ord) max-x))
					  co-ords)))
	 (max-y (apply #'max ys-for-rightmost))
	 (min-y (apply #'min ys-for-rightmost)))
    (mapc (lambda (co-ord)
	    (decf (car co-ord) max-x)
	    (decf (cdr co-ord) min-y))
	  co-ords)
    (make-layout :co-ords co-ords
		 :y-add (1+ (- max-y min-y))
		 :fast-co-ords (mapcan (lambda (co-ord) (if (zerop (car co-ord)) () (list co-ord)))
				       co-ords)
		 :is-male (equal base-is-female (oddp (+ max-x min-y)))
		 :valid-locations (generate-valid-frame co-ords))))

(defun generate-valid-layouts (piece)
  "Generate all layouts for a piece - spin it, for each spin find its valid insertion point"
  (let ((rotated-co-ords (generate-rotations (generate-co-ords piece))))
    (mapcar (lambda (s)
	      (make-offset-layout s (equal (cadr piece) 'I)))
	    rotated-co-ords)))

(defun generate-piece (raw-piece)
  "Given a piece, make a layout from its four rotations, categorized by gender of the insertion
   point."
  (let ((layouts (generate-valid-layouts raw-piece)))
    (make-piece :name (car raw-piece)
		:male-layouts   (mapcan (lambda (l) (if (layout-is-male l) (list l))) layouts)
		:female-layouts (mapcan (lambda (l) (if (not (layout-is-male l)) (list l))) layouts))))

;;;
;;; Ok, that's it for the initialization, now a few utility functions...
;;;

(defun print-frame (frame)
  (dotimes (y +size+)
    (dotimes (x +size+)
      (format t "~A " (aref frame x (- (1- +size+) y))))
    (format t "~%")))
  
(declaim (inline valid))
(defun valid (frame co-ords x y)
  "Can we insert co-ords at x,y in the current frame?"
  (dolist (l co-ords t)
    (if (not (eq (aref frame (+ x (car l)) (+ y (cdr l))) +empty+))
	(return nil))))

(declaim (inline add))
(defun add (frame co-ords name x y)
  "Insert co-ords at x,y in the current frame.
   A name of +empty+ has the effect of removing a piece."
  (mapc (lambda (l)
	  (setf (aref frame (+ x (car l)) (+ y (cdr l))) name))
	co-ords))

(defun next-x-y-rec (frame x y)
  "A recursive version of next-x-y."
  (cond ((>= y +size+) (next-x-y-rec frame (1- x) 0))
	((eq (aref frame x y) +empty+) (values x y))
	(t (next-x-y-rec frame x (1+ y)))))

(declaim (inline next-x-y))
(defun next-x-y (frame x y)
  "Find the next available x,y insertion point on the board.
   Try up, then bottom of column to left until empty x,y is found.
   If y is in bounds and x,y is empty, then just return x,y,
   otherwise punt to the recursive version of this
   function."
  (cond ((>= y +size+) (next-x-y-rec frame (1- x) 0))
	((eq (aref frame x y) +empty+) (values x y))
	(t (next-x-y-rec frame x (1+ y)))))

;;;
;;; The main depth-first solver...
;;;

(defun solve (*throw-out*)
  "Solve the puzzle."
  (let ((frame (make-frame))
	(pieces (mapcar #'generate-piece +pieces+))
	(tri (generate-co-ords +tri+)))
    (labels ((psolve (piece pieces x y is-male)
		     "Try to add piece in each of its possible orientations, then recursively solve.
                      Only try to insert the layouts with the correct gender.
                      Use fast-co-ords for trial insertions."
		     (loop for layout in (if is-male (piece-male-layouts piece) (piece-female-layouts piece))
			   do
			   (let ((p (layout-co-ords layout)))
			     (when (and (aref (layout-valid-locations layout) x y)  ; piece lies completely on board
					(valid frame p x y))                        ; and doesn't overlap previous piece.
			       (when (null pieces)                             ; we're done
				 (add frame p (piece-name piece) x y)          ; write full piece onto frame
				 (return frame))
			       (add frame (layout-fast-co-ords layout) (piece-name piece) x y) ; add short form of piece
			       (multiple-value-bind (next-x next-y)                            ; get next insertion point
				   (next-x-y frame x (+ y (layout-y-add layout)))
				 (let ((ret (rsolve pieces next-x next-y)))              ; recursively solve.
				   (when ret                                      ; success?
				     (add frame p (piece-name piece) x y)         ; write full piece into frame.
				     (return ret))))
			       (add frame (layout-fast-co-ords layout) +empty+ x y))))) ; back out this piece's short form.
	     (rsolve (pieces x y)
		     "Try to add each piece in pieces to the frame, then call psolve to recursively solve.
                      Note that we destructively swap each candidate piece to the head of the pieces list,
                      so we can just use (cdr pieces) in the recursion."
		     (let ((is-male (oddp (+ x y))))
		       (loop for p on pieces
			     do (if p
				    (let ((temp (car pieces)))
				      (setf (car pieces) (car p))
				      (setf (car p) temp)
				      (let ((ret (psolve (car pieces) (cdr pieces) x y is-male)))
					(if ret (return ret)))
				      ))))))
      (add frame tri 3 7 0)
      (catch nil
        (print-frame (rsolve pieces 7 1))
        (when *throw-out*
          (throw nil nil))))))

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