;;; ilcontesto2.cl (second try)
;;; Submitted by Pierpaolo Bernardi <bernardp@cli.di.unipi.it>

;;; To compile: nothing special.
;;; To run: (CONTEST:FA)
;;; 
;;; The solutions will be shown on *STANDARD-OUTPUT* in graphical
;;; format, and pushed into the variable *SOLUTIONS-FOUND* as a list
;;; of lists of coordinates.

(defpackage :Contest
  (:use "CL")
  (:export "FA" "*SOLUTIONS-FOUND*"))

(in-package :Contest)

;;; ================================================================
;;; Preprocessing phase.  
;;; In this phase pieces are represented as lists of coordinates. 
;;; Preprocessing is done once, and takes only a few milliseconds in total.

(defconstant +max-index+ 8)

(defconstant +pieces+
  ;;; name (not used in the program); sex of first point; points
  '((F5 f ((0 0) (0 1) (0 2) (0 3) (1 2)))
    (J5 m ((0 0) (1 0) (1 1) (1 2) (1 3)))
    (L5 m ((0 0) (0 1) (0 2) (0 3) (1 0)))
    (N5 f ((0 0) (0 1) (1 1) (2 1) (2 2)))
    (Q5 m ((2 0) (2 1) (1 1) (0 1) (0 2)))
    (S5 f ((1 0) (1 1) (1 2) (0 2) (0 3)))
    (T5 m ((1 0) (1 1) (1 2) (1 3) (0 2)))
    (W5 f ((1 0) (2 0) (0 1) (1 1) (0 2)))
    (Z5 f ((2 0) (3 0) (0 1) (1 1) (2 1)))
    (J4 m ((0 0) (1 0) (1 1) (1 2)))
    (L4 m ((0 0) (1 0) (0 1) (0 2)))
    (S4 m ((1 0) (1 1) (0 1) (0 2)))
    (T4 f ((0 1) (1 0) (1 1) (1 2)))
    ))

;;; (DISTRIBUTE-SEX 'F '((0 0) (0 1) (0 2) (0 3) (1 2))) 
;;;   ==> ((0 0 F) (0 1 M) (0 2 F) (0 3 M) (1 2 M))
;;; Meaning: the first point is of the specified sex, the
;;; other points are assigned a sex accordingly.
(defun distribute-sex (sex points)
  (let ((even 'f)
        (odd 'm))
    (when (or (and (evenp (+ (first (first points)) (second (first points))))
                   (eq sex 'm))
              (and (oddp (+ (first (first points)) (second (first points))))
                   (eq sex 'f)))
      (rotatef even odd))
    (mapcar (lambda (p)
              (append p (if (evenp (+ (first p) (second p)))
                          (list even)
                          (list odd))))
            points)))


;;; Canonicalization consists in the translation of the piece
;;; such that it is in the + + quadrant, in contact with the
;;; vertical and horizontal axes, and ordering the points of
;;; the piece according to an arbitrary but fixed predicate.
(defun canonicalize (piece)
  (loop for (x y) in piece
        minimizing x into minx
        minimizing y into miny
        finally (return
                 (sort (mapcar (lambda (p)
                                 (list* (- (first p) minx)
                                        (- (second p) miny)
                                        (cddr p)))
                               piece)
                       #'canonical-point-less-p))))

(defun canonical-point-less-p (p1 p2)
  (or (< (first p1) (first p2))
      (and (= (first p1) (first p2))
           (< (second p1) (second p2)))))


;;; Returns all the rotations of the piece.
(defun rotations (piece)
  (labels ((rotate-point-90 (point)
             (list* (second point)
                    (- (first point))
                    (cddr point)))
           (rotate-piece-90 (piece)
             (mapcar #'rotate-point-90 piece)))
    (delete-duplicates
     (mapcar #'canonicalize
             (loop repeat 4
                   collect piece
                   do (setq piece (rotate-piece-90 piece))))
     :test #'equal)))

(defun translation (piece dx dy)
  (mapcar (lambda (p)
            (list* (+ dx (first p))
                   (+ dy (second p))
                   (cddr p)))
          piece))

(defun piece-in-board-p (piece)
  (every (lambda (p)
           (and (< -1 (first p) +max-index+)
                (< -1 (second p) +max-index+)))
         piece))

;;; Returns a list of all the possible translations/rotations of the piece.
(defun all-positions (piece)
  (loop for rot in (rotations piece)
	nconc (loop for x from 0 below +max-index+
		    nconc (loop for y from 0 below +max-index+
				for translated-piece = (translation rot x y)
                                when (and (check-sex (first translated-piece))
                                          (piece-in-board-p translated-piece))
				collect translated-piece))))

;;; Checks that the sex of the piece is appropriate for its
;;; position on the board.
(defun check-sex (point)
  (eq (third point)
      (if (evenp (+ (first point)
                    (second point)))
        'f
        'm)))


;;; LIST-TO-INTEGER and INTEGER-TO-LIST convert between
;;; the representation of pieces as a list of coordinate pairs
;;; and a representation as bitsets represented as integers.
;;; As an example, point (2 3) is mapped to 524288;
;;; Piece ((0 0) (0 1) (0 2) (0 3) (1 2)) is mapped to 1039.
(defun list-to-integer (l)
  (loop with acc = 0
	for (x y) in l
	do (setq acc (logior acc (ash 1 (+ (* x +max-index+) y))))
        finally (return acc)))

(defun integer-to-list (i)
  (loop for bit from 0 to (integer-length i)
        when (logbitp bit i)
        collect (list (floor bit +max-index+)
                      (mod bit +max-index+))))

;;; Returns a list where each element represents a piece.
;;; Each piece is represented by the list of all its possible 
;;; positions in the board. 
(defun preprocessed-pieces ()
  (sort-pieces
   (loop for piece in +pieces+
         collect (loop for pos in (all-positions
                                   (distribute-sex
                                    (second piece) (third piece)))
                       collect (list-to-integer pos)))))

;;; Pieces with fewer possible positions are sorted
;;; before the others. In this way the search tree
;;; will have the nodes with fewer descendants on top,
;;; making each pruning more effective.
(defun sort-pieces (pieces)
  (sort pieces 
        (lambda (x y)
          (< (length x) (length y)))))

;;; ================================================================
;;; Pruning

;;; Removes from PIECES (a list as returned from PREPROCESSED-PIECES)
;;; the positions which are impossible in the BOARD
(defun prune (pieces board)
  (sort-pieces
   (loop for piece in pieces
         collect (loop for positioned-piece in piece
                       when (zerop (logand positioned-piece board))
                       collect positioned-piece))))

(defconstant +full-board+
  (1- (expt 2 (* +max-index+ +max-index+))))

;;; Checks that using PIECES is possible to cover all the positions
;;; which are still free in BOARD.
(defun check (pieces board)
  (= +full-board+
     (logior board
             (reduce #'logior
                     pieces
                     :key (lambda (x)
                            (apply #'logior x))
                     :initial-value 0))))

;;; ================================================================
;;; Solving

(defvar *solutions-found*)
(defvar *start-time*)

(defun fa ()
  (setq *start-time* (run-time))
  (setq *solutions-found* '())
  (let ((3-omino (list-to-integer '((6 0) (7 0) (6 1)))))
    (solve-pieces (preprocessed-pieces)
                  3-omino ; The initial board contains only the 3-omino.
                  (list 3-omino) ; Every solution will contain the 3-omino.
                  ))
  (write-elapsed-time))

;;; SOLVE-PIECES and SOLVE-PIECE are the functions that effectively 
;;; traverse the choice tree. They do a boring depth first traversal
;;; of the tree, PRUNEing impossible positions of the pieces and 
;;; CHECKing that the new board is still solvable, at every
;;; new piece placed.
(defun solve-pieces (pieces board sol)
  (if (null pieces)
    (eureka sol)
    (let ((pruned-pieces (prune pieces board)))
      (when (check pruned-pieces board)
        (solve-piece (first pruned-pieces) (rest pruned-pieces) board sol)))))

(defun solve-piece (piece pieces board sol)
  (dolist (positioned-piece piece nil)
    (when (zerop (logand positioned-piece board))
      (solve-pieces pieces
                    (logior positioned-piece board)
                    (cons positioned-piece sol)))))

;;; When we find a solution we handle it here.
(defun eureka (sol)
  (let ((solution-decodified (mapcar #'integer-to-list sol)))
    (push solution-decodified *solutions-found*)
    (write-elapsed-time)
    (show-solution solution-decodified)
    (terpri)))

(defun write-elapsed-time () 
  (format t ";;; Time: ~0,2Fs~%" (- (run-time) *start-time*)))

(defun run-time ()
  (/ (get-internal-run-time)
     internal-time-units-per-second))

;;; Hi-tech graphic output engine.
(defun show-solution (sol)
  (when (integerp (first sol))
    (setq sol (mapcar #'integer-to-list sol)))
  (let ((m (make-array (list +max-index+ +max-index+) :initial-element #\Space)))
    (loop for piece in sol
          for char-code from (char-code #\A)
          for code-char = (code-char char-code)
          do (loop for (x y) in piece
                   do (setf (aref m x y) code-char)))
    (princ "+--------+")
    (terpri)
    (loop for y downfrom (1- +max-index+) to 0
          do
          (princ "|")
          (loop for x from 0 below +max-index+
                do (princ (aref m x y)))
          (princ "|")
          (terpri))
    (princ "+--------+")
    (terpri)))

;;; EOF

;; $Id: //info.ravenbrook.com/user/ndl/lisp/contest/entries/pierpaolo-bernardi.lisp#4 $
;; Firts version was received as //info.ravenbrook.com/mail/2003/06/15/22-59-08/0.txt