;; solution to ILC 2003 Programming Contest
;; author: Miroslaw Osys (27.09.2003)
;; e-mail: omirek10/at/poczta.onet.pl
;; software: Clisp + pico + Linux

;; see tail of this file for comments


    ; shapes encoded by me with a little help from "compute" function 

(defparameter *shapes*
  '((#\F  (117) (254 87) (245) (234))
    (#\J  (0 117) (0 250) (0 245) (93 235))
    (#\L  (186) (245) (250) (221 171))
    (#\N  (0 0 186) (125 175 215) (234))

    (#\Q  (117) (238 95 187) (0 0 213))
    (#\S (186) (221 187) (0 245) (0 234))
    (#\T  (0 186) (174 247) (0 250) (0 213))
    (#\W  (117) (238 119) (0 238 87))
    (#\Z  (93 175 119) (0 0 238 87))

    (#\j  (0 186) (0 245) (93 235))
    (#\l  (117) (250) (221 171))
    (#\s (186) (221 187) (0 213))
    (#\t  (0 186) (174 247) (0 234))

    (#\3  (117) (222 87))))


	; plane in range [1..8]x[1..8], frame on boundary 
	; (i.e. 0th and 9th row and column)
        ; each element is piece (8 bits)

(defvar *plane* 
  (make-array '(10 10) :element-type 'fixnum :initial-element 0))


        ; for labels of blocks
        ; only [1..8]x[1..8] area used 

(defvar *plane-symbols* (make-array '(10 10)))


	; indicates whether block (in one of 4th configuration)
	; was placed on plane (indicated by 1)

(defvar *used-blocks* 
  (make-array 14 :element-type 'fixnum :initial-element 0))


	; shapes of blocks and their rotations as 14*4 arrays

(defvar *blocks* (make-array '(14 4)))


        ; ready to fill ...

(defvar *solutions* ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun make-plane ()
  (loop for i from 1 to 8 doing
    (loop for j from 1 to 8 doing
      (setf (aref *plane* i j) 0)))

  (loop for i from 1 to 8 do
    ; left
    (setf (aref *plane* i 0) 
          (if (oddp i) 251 247))
    ; top 
    (setf (aref *plane* 0 i) 
          (if (oddp i) 239 223))
    ; right
    (setf (aref *plane* i 9) 
          (if (oddp i) 253 254))
    ; bottom
    (setf (aref *plane* 9 i) 
          (if (oddp i) 127 191)))

  (setf (aref *plane* 0 0) 255
        (aref *plane* 9 0) 255
        (aref *plane* 0 9) 255
        (aref *plane* 9 9) 255
        (aref *plane* 9 7) 191))   ; exceptional slot

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; these two functinos are most interesting to user

(defun solve ()
  (setf *solutions* ())
  (make-blocks *blocks*)
  (make-plane)
  (fill *used-blocks* 0)
  (place-block (aref *blocks* 13 0) #\3 7 7 0 0)
  (setf (aref *used-blocks* 13) 1)
  (print-plane) 
  (format T "~&solving ...~&")
  (catch 'only-first (solve-aux 13)))

(defun print-solutions ()
  (dolist (sol *solutions*)
    (loop for i from 0 to 7 doing
      (loop for j from 0 to 7 doing (princ (aref sol i j)))
      (format T "~%"))
    (read-char))) 


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun copy-of-plane ()
  (let ((A  (make-array '(8 8))))
    (loop for i from 0 to 7 doing
      (loop for j from 0 to 7 doing
        (setf (aref A i j) (aref *plane-symbols* (1+ i) (1+ j)))))
    A))

(defun solve-aux (num)
  (when (zerop num)
        (push (copy-of-plane) *solutions*)
        ; (print-plane) 
        (throw 'only-first T)
        (return-from solve-aux T))
  (let* ((c (find-empty-cell))    ; here c must be non NIL
         (i (car c)) (j (cadr c)))
    (loop for n from 0 to 12      ; "3" block is not considered
          if (zerop (aref *used-blocks* n))
          doing
      (setf (aref *used-blocks* n) 1)
      (loop for orientation from 0 to 3
            for shape = (aref *blocks* n orientation) 
            for width = (array-dimension shape 1)
            for height = (array-dimension shape 0)
            doing
        (loop for ii from 0 below height
              doing
          (loop for jj from 0 below width
                for val = (aref shape ii jj)
                when (and (not (zerop val))
                          (check-piece-at-plane val i j)
                          (try-place-block shape i j ii jj))
                doing
            (place-block shape (car (nth n *shapes*)) i j ii jj)
            (solve-aux (1- num))
            (remove-block shape i j ii jj))))
      (setf (aref *used-blocks* n) 0)
) ) ) 


(defun find-empty-cell ()
"finds empty cell in plane j=max then i=max"
  (loop for j from 8 downto 1
        for ii = (loop for i from 8 downto 1 
                       thereis (and (zerop (aref *plane* i j)) i)) 
        thereis (and ii (list ii j))))


(defun place-block (shape label di dj si sj)
"places block described by shape in such the way that cell (si,sj)
from source is placed at (di,dj)"
  (let* ((height (array-dimension shape 0))
         (width  (array-dimension shape 1)))
    (loop for i from 0 below height
          for ti = (+ i di (- si))
          when (< 0 ti 9) do
      (loop for j from 0 below width
            for tj = (+ j dj (- sj))
            when (< 0 tj 9) 
            unless (zerop (aref shape i j)) do
        (setf (aref *plane* ti tj) 
              (aref shape i j))
        (setf (aref *plane-symbols* ti tj) label)
) ) ) )

(defun try-place-block (shape di dj si sj)
"places block described by shape in such the way that cell (si,sj)
from source is placed at (di,dj)"
  (let* ((height (array-dimension shape 0))
         (width  (array-dimension shape 1)))
    (loop for i from 0 below height
          for ti = (+ i di (- si))
          doing
      (unless (< 0 ti 9)
              (return-from try-place-block NIL))
      (loop for j from 0 below width
            for tj = (+ j dj (- sj))
            unless (zerop (aref shape i j))
            doing
        (unless (< 0 tj 9)
                (return-from try-place-block NIL))
        (unless (check-piece-at-plane (aref shape i j) ti tj)
                (return-from try-place-block NIL))))
    T))

(defun check-piece-at-plane (val i j)
"checks if piece val can be placed at position i j"
  (and (zerop (aref *plane* i j))
       (check-pieces-vert  val (aref *plane* (1+ i) j))
       (check-pieces-horiz (aref *plane* i (1- j)) val)
       (check-pieces-horiz  val (aref *plane* i (1+ j)))
       (check-pieces-vert  (aref *plane* (1- i) j) val)))

	; next 2 functions give proper results with exception when
	;   one of the edges is 'line

(defun check-pieces-horiz (L R)
"check if pieces L and R can be placed side to side (left/right)"
  (zerop (logand (ash (logand L #b1100) -2) 
                 (logand R #b11))))

(defun check-pieces-vert (U D)
"check if pieces U and D can be placed side to side (up/down)"
  (zerop (logand (ash (logand U #b110000) -4)
                 (ash (logand D #b11000000) -6))))

(defun remove-block (shape di dj si sj)
"places block described by shape in such the way that cell (si,sj)
from source is placed at (di,dj)"
  (let* ((height (array-dimension shape 0))
         (width  (array-dimension shape 1)))
    (loop for i from 0 below height
          for ti = (+ i di (- si))
          when (< 0 ti 9) do
      (loop for j from 0 below width
            for tj = (+ j dj (- sj))
            when (< 0 tj 9) do
        (unless (zerop (aref shape i j))
          (setf (aref *plane* ti tj) 0))
) ) ) )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun make-blocks (array)
"converts *shapes* to arrays of pieces;
array is n x 4, every element will be array describing shape"
  (dotimes (k 14) ; compute bbox for every block
    (let* ((descr (nth k *shapes*))
           (shape (cdr descr))
           (height (list-length shape))
           (width (loop for row in shape 
                        maximizing (list-length row))))
      ; (format T "~&~A is ~d x ~d~%" (car descr) width height)     
      (setf (aref array k 0)
            (make-array (list height width) 
                        :element-type 'fixnum 
                        :initial-element 0))
      (loop for i from 0 below height doing
        (loop for val in (nth i shape)
              for j from 0 doing
          (setf (aref (aref array k 0) i j) val)))
      (setf (aref array k 1) (rotate-block (aref array k 0)))
      (setf (aref array k 2) (rotate-block (aref array k 1)))
      (setf (aref array k 3) (rotate-block (aref array k 2)))))
  array)

(defun rotate-block (shape)
"rotates entire block +90 degrees and returns result in new array"
  (let* ((height (array-dimension shape 0))
         (width  (array-dimension shape 1))
         (rotated-shape (make-array (list width height)
                                    :element-type 'fixnum 
                                    :initial-element 0)))
    (loop for i from 0 below height doing
      (loop for j from 0 below width doing
        (setf (aref rotated-shape (- width j 1) i)
              (rotate-piece (aref shape i j)))))
    rotated-shape)) 

(defun rotate-piece (val)
"rotates piece description +90 degrees"
  (+ (logand val #xff00)
     (ash (logand val #b11000000) -6)	; T -> L 
     (ash (logand val #b110000) -2)	; B -> R
     (ash (logand val #b11) 4)		; L -> B
     (ash (logand val #b1100) 4)))	; R -> T

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun print-plane ()
  (loop for i from 0 to 9 doing
    (loop for j from 0 to 9 
          for val = (aref *plane* i j) 
          doing 
      (format T "~A" (case (piece-edge-type val 'top)
        (nothing "    ")
        (line "### ")
        (tab "#^# ")
        (slot "#U# "))))
    (format T "~%")
    (loop for j from 0 to 9 
          for val = (aref *plane* i j) 
          doing 
      (format T "~A" (case (piece-edge-type val 'left)
        (nothing " +")
        (line "##")
        (tab "(#")
        (slot ")#")))
      (format T "~A" (case (piece-edge-type val 'right)
        (nothing "  ")
        (line "# ")
        (tab ") ")
        (slot "( "))))
    (format T "~%")
    (loop for j from 0 to 9 
          for val = (aref *plane* i j) 
          doing 
      (format T "~A" (case (piece-edge-type val 'bottom)
        (nothing "    ")
        (line "### ")
        (tab "#U# ")
        (slot "#^# "))))
    (format T "~%"))
  (format T "~%")) 

(defun print-block (shape)
  (let* ((height (array-dimension shape 0))
         (width  (array-dimension shape 1)))
    (loop for i from 0 below height doing
      (loop for j from 0 below width
            for val = (aref shape i j) 
            doing 
        (format T "~A" (case (piece-edge-type val 'top)
          (nothing "    ")
          (line "### ")
          (tab "#^# ")
          (slot "#U# "))))
      (format T "~%")
      (loop for j from 0 below width
            for val = (aref shape i j) 
            doing 
        (format T "~A" (case (piece-edge-type val 'left)
          (nothing " +")
          (line "##")
          (tab "(#")
          (slot ")#")))
        (format T "~A" (case (piece-edge-type val 'right)
          (nothing "  ")
          (line "# ")
          (tab ") ")
          (slot "( "))))
      (format T "~%")
      (loop for j from 0 below width
            for val = (aref shape i j) 
            doing 
        (format T "~A" (case (piece-edge-type val 'bottom)
          (nothing "    ")
          (line "### ")
          (tab "#U# ")
          (slot "#^# "))))
      (format T "~%")
) ) )

(defun piece-edge-type (val edge)
"checks if edge ('top 'bottom 'right 'left) of piece described by val 
has 'slot or 'tab or 'nothing or 'line"
  (elt '(nothing tab slot line) 
    (case edge
      (top (ash (logand val #b11000000) -6))
      (bottom (ash (logand val #b110000) -4))
      (right (ash (logand val #b1100) -2))
      (left (logand val #b11)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; functions used to establish *shapes*

(defun compute (l u r b)
  (+ (tr l) (* 4 (tr r)) (* 16 (tr b)) (* 64 (tr u))))

(defun tr (arg)
  (case arg (o 1) (i 2) (m 3) (e 0)))
   
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;; algorithm finds empty piece at plane and tries to put block here
;; by matching all possibilities (not used blocks yet in all 
;; orientations)

;; match checking is performed by bits checking. Shapes are encoded
;; as folloes:
;;     tab and slot of each piece is encoded in one byte
;;     from MSB: top[7..6] bottom[5..4] right[3..2] left[1..0]
;;     every pair is inside=10/outside=01
;;                and 11 if edge is in the middle of block
;;                and 00 if place is empty
;; name conventions:
;;   shape - array for given block and orientation which consists of 
;;           pieces
;;   piece - small rectangle with tabs, slots or middle lines as edges
;;   val   - fixnum encoding piece
;;   coordinates - always in row and column order


;; all solutions can be found after removing (throw ...)
;; from solve-aux function

;; program finds more than one solution and these are repeated
;; probably due to symmetry of blocks placed at end

;; first solution obtained is correct:
;;   lllNJJJJ
;;   lNNNTWWJ
;;   FNTTTTWW
;;   FFssSSSW
;;   FssSSQQt
;;   FLLLLQtt
;;   jLZZQQ3t
;;   jjjZZZ33
;; the "s" block is not symmetrical and this presentation of solution does 
;; not provide its orientation but algorithm can be easily changed to give
;; list of sentences like "point ... of block ... rotated ... at ..."

;; next solutions are correct as well

;; second solution:
;;   LLLLlllF
;;   LZQQlSSF
;;   ZZQSSSFF
;;   ZQQJJJJF
;;   ZssjjjJt
;;   ssNWWjtt
;;   NNNTWW3t
;;   NTTTTW33

;; third one:
;;   lllNZjjj
;;   lNNNZWWj
;;   sNJZZLWW
;;   ssJZtLSW
;;   TsJttLSS
;;   TJJQtLLS
;;   TTFQQQ3S
;;   TFFFFQ33

;; 4th:
;;   LLLLJJJJ
;;   LlllTWWJ
;;   QlTTTTWW
;;   QQQsNNSW
;;   ZZQssNSS
;;   tZZZsNNS
;;   ttFjjj3S
;;   tFFFFj33

;; and finally 5th:
;;   jFFFFWWt
;;   jjjFWWtt
;;   lllTWQQt
;;   lTTTTQLL
;;   sNNSQQZL
;;   ssNSSZZL
;;   JsNNSZ3L
;;   JJJJSZ33

;; usage:
;;   (compile-file ...)
;;   (load         ...)
;;   (time (solve))
;;     (print-plane)
;; or
;;     (print-solutions)


;; $Id: //info.ravenbrook.com/user/ndl/lisp/contest/entries/miroslaw-osys.lisp#2 $