(defun tile-points (tile &optional (y 0)) ;converts tile bitmap to an alist of points origin = upper left
  (labels ((do-row (row x)
		   (labels ((next ()
				  (do-row (cdr row) (1+ x))))
			   (cond ((not row) nil)
				 ((eql '* (car row)) (cons (cons x y) (next)))
				 (t (next))))))
	  (when tile
	    (append (do-row (car tile) 0) (tile-points (cdr tile) (1+ y))))))

(defun lpp (width height tiles)
  (labels ((try-tiles (grid tiles &optional (x 0) (y 0) (lbl #\A))
		      (unless (let ((gaps 0))
				(dotimes (xt width)
				  (dotimes (yt (- y 1))
				    (if (eql (aref grid yt xt) '-)
					(incf gaps))))
				(> gaps 0))
			(labels ((try-next (cur-tile)
					   (when cur-tile
					     (labels ((find-pivot (cur-pt)
								  (when cur-pt
								    (let ((xc (caar cur-pt))
									  (yc (cdar cur-pt)))
								      (when (evenp (+ xc yc))
									(let ((trans (mapcar (lambda (pt)
											       (cons (- (car pt) xc) (- (cdr pt) yc)))
											     (car cur-tile))))
									  (labels ((rotate (fn)
											   (let ((rot (mapcar (lambda (pt)
														(multiple-value-bind (xr yr) (funcall fn pt)
														      (cons (+ x xr) (+ y yr))))
													      trans)))
											     (unless (find-if (lambda (pt)
														(let ((xx (car pt))
														      (yy (cdr pt)))
														  (or (< xx 0) 
														      (>= xx width) 
														      (< yy 0) 
														      (>= yy height) 
														      (not (eql (aref grid yy xx) '-)))))
													      rot)
											       (labels ((fill (val)
													      (mapc (lambda (pt)
														      (let ((xx (car pt))
															    (yy (cdr pt)))
															(setf (aref grid yy xx) val)))
														    rot)))
												       (fill lbl)
												       (if (= 1 (length tiles))
													   (progn
													     (format t "success! grid=~%")
													     (dotimes (yt height)
													       (dotimes (xt width)
														 (princ (aref grid (1- (- height yt)) (1- (- width xt)))))
													       (fresh-line))
													       (throw 'finished nil))
													 (labels ((next-pt (x y)
															   (if (>= (+ 2 x) width)
															       (let ((xnu (mod (1+ y) 2))
																     (ynu (1+ y)))
																 (if (eql (aref grid ynu xnu) '-)
																     (values xnu ynu)
																   (next-pt xnu ynu)))
															     (let ((xnu (+ x 2))
																   (ynu y))
															       (if (eql (aref grid ynu xnu) '-)
																   (values xnu ynu)
																 (next-pt xnu ynu))))))
														 (multiple-value-bind (xnu ynu) (next-pt x y)
																      (when (< ynu height)
																	(try-tiles grid (remove (car cur-tile) tiles :test #'equal) xnu ynu (int-char (1+ (char-int lbl))))))))
												       (fill '-))))))
										  (rotate (lambda (pt)
											    (values (car pt) (cdr pt))))
										  (rotate (lambda (pt)
											    (values (- 0 (cdr pt)) (car pt))))
										  (rotate (lambda (pt)
											    (values (- 0 (car pt)) (- 0 (cdr pt)))))
										  (rotate (lambda (pt)
											    (values (cdr pt) (- 0 (car pt)))))))))
								    (find-pivot (cdr cur-pt)))))
						     (find-pivot (car cur-tile)))
					     (try-next (cdr cur-tile)))))
				(try-next tiles)))))
  (catch 'finished
    (try-tiles (make-array (list width height) :initial-element '-) (mapcar #'tile-points tiles)))))

(defun solve ()
  (lpp 8 8 
       
	 '(((       )
	    (  - *  )
	    (  * *  ))
	   
	   
	   ((  *    )
	    (  * *  )
	    (  *    )
	    (  *    ))
	   
	   
	   ((       )
	    (  * *  )
	    (  *    )
	    (  *    )
	    (  *    ))
	   
	   
	   ((       )
	    (  *    )
	    (  *    )
	    (  *    )
	    (  * *  ))
	   
	   
	   ((         )
	    (  * *    )
	    (  - *    )
	    (  - * *  ))
	   
	   
	   ((  *      )
	    (  * * *  )
	    (  - - *  ))
	   
	   
	   ((       )
	    (  *    )
	    (  * *  )
	    (  - *  )
	    (  - *  ))
	   
	   
	   ((  - *  )
	    (  * *  )
	    (  - *  )
	    (  - *  ))
	   
	   
	   ((  *      )
	    (  * *    )
	    (  - * *  ))
	   
	   
	   ((  * * *    )
	    (  - - * *  ))
	   
	   
	   ((  - *  )
	    (  - *  )
	    (  * *  ))
	   
	   
	   ((  *    )
	    (  *    )
	    (  * *  ))
	   
	   
	   ((       )
	    (  *    )
	    (  * *  )
	    (  - *  ))
	   
	   
	   ((  - *  )
	    (  * *  )
	    (  - *  )))))

(compile 'lpp)
(solve)


;; $Id: //info.ravenbrook.com/user/ndl/lisp/contest/entries/conrad-barski.lisp#1 $