;; puzzle.l - the ILC 2003 Programming Contest entry.
;; The basic idea is that a board is an alist of point:piece
;; with one entry for each point occupied. Solve takes
;; the globals and finds something that then works
;; using a brute-force search.
;;
;; -Scott Fenton <scott@fenton.baltimore.md.us>

(proclaim '(inline rotlst rotate translate onboard? pieceat nxtpnt mkboard))

;; *board* - the inital board
(defconstant *board* '(((6 6) . #\3) ((6 7) . #\3) ((7 7) . #\3)))

;; *bsize* - the board size
(defconstant *bsize* 8)

;; *pieces* - the pieces to be put on the board
(defconstant *pieces*
  '((((0 0) (0 1) (1 1) (0 2) (0 3)) . #\F)
    (((0 0) (0 1) (0 2) (0 3) (-1 3)) . #\J)
    (((0 0) (0 1) (0 2) (0 3) (1 3)) . #\L)
    (((0 0) (0 1) (1 0) (2 0) (0 -1)) . #\N)
    (((0 0) (0 1) (1 1) (2 1) (2 2)) . #\Q)
    (((0 0) (0 1) (1 1) (1 2) (1 3)) . #\S)
    (((0 0) (0 1) (0 2) (0 3) (-1 1)) . #\T)
    (((0 0) (0 1) (1 1) (1 2) (2 2)) . #\W)
    (((0 0) (1 0) (2 0) (2 1) (2 2)) . #\Z)
    (((0 0) (0 1) (0 2) (-1 2)) . #\j)
    (((0 0) (0 1) (0 2) (1 2)) . #\l)
    (((0 0) (0 1) (1 1) (1 2)) . #\s)
    (((0 0) (0 1) (0 2) (-1 1)) . #\t)))

(defmacro acond (&rest clauses)
  (if (null clauses)
      nil
      (let ((cl1 (car clauses))
            (sym (gensym)))
        `(let ((,sym ,(car cl1)))
           (if ,sym
               (let ((it ,sym)) ,@(cdr cl1))
               (acond ,@(cdr clauses)))))))

;; rotlst - rotate lst
(defun rotlst (lst) (append (cdr lst) (list (car lst))))

;; rotate - rotate a piece 90 degrees clockwise
(defun rotate (pce) (mapcar #'(lambda (p) (list (- (cadr p)) (car p))) pce))

;; translate - adjust p so that (0 0) would be q
(defun translate (p q) (mapcar #'+ p q))

;; onboard? - test if p is on the board
(defun onboard? (p) (and (< -1 (car p) *bsize*) (< -1 (cadr p) *bsize*)))

;; pieceat - return the piece at pnt or nil if nothing
(defun pieceat (board pnt) (cdr (assoc pnt board :test #'equal)))

;; nxtpnt - return the next point in left-right up-down
;; form or nil if at end of board
(defun nxtpnt (p) 
  (cond ((and (= (car p) (1- *bsize*)) (= (cadr p) (1- *bsize*))) nil)
	((= (cadr p) (1- *bsize*)) (list (1+ (car p)) 0))
	('t (list (car p) (1+ (cadr p))))))

;; fits? - find if piece fits on board w/ (0 0) at point
(defun fits? (board piece point)
  (or (null piece) 
      (let ((p (translate (car piece) point)))
	(and (onboard? p) (not (pieceat board p)) 
	     (fits? board (cdr piece) point)))))

;; rotfits? - fits? + rotation - returns nil or the correct rotation
(defun rotfits? (board piece point)
  (labels ((rec (p try)
		(cond ((not p) 'nil)
		      ((= try 4) nil)
		      ((fits? board p point) p)
		      ('t (rec (rotate p) (1+ try))))))
	  (rec piece 0)))

;; firstavail - return the first avaliable point (from upleft)
(defun firstavail (board)
  (labels ((rec (try)
		(cond ((null try) nil)
		      ((not (pieceat board try)) try)
		      ('t (rec (nxtpnt try))))))
	  (rec '(0 0))))

;; place - return the board with piece put on it starting from pnt 
;; (assumes that fits? passed). Implemented as a sorta pairlis+translation.
(defun place (board piece pnt pname)
  (if (null piece)
      board
      (place (acons (translate (car piece) pnt) pname board) 
	     (cdr piece) pnt pname)))


;; solve - the core algorithm
(defun solve ()
  (labels ((rec (brd pcs seen pnt)
		(acond ((not pcs) brd)
		       ((not pnt) nil)
		       ((pieceat brd pnt) (rec brd pcs nil (nxtpnt pnt)))
		       ((equal seen (car pcs)) (rec brd pcs nil (nxtpnt pnt)))
		       ((rotfits? brd (caar pcs) pnt) 
			(or (rec (place brd it pnt (cdar pcs)) (cdr pcs) nil 
				 (nxtpnt pnt))
			    (rec brd (rotlst pcs) (or seen (car pcs)) pnt)))
		      ('t (rec brd (rotlst pcs) (or seen (car pcs)) pnt)))))
	  (rec *board* *pieces* nil (firstavail *board*))))

;; mkboard - for visualization purposes makes an array of the alist returned
;; by solve.
#+The_definition_I_gave_in_my_previous_email_was_incorrect
(defun mkboard (solution)
  (let ((a (make-array (list *bsize* *bsize*))))
    (mapcar #'(lambda (p) (setf (aref a (caddr p) (cadr p)) (car p))) solution)
    a))

(defun mkboard (solution)
  (let ((a (make-array (list *bsize* *bsize*))))
    (mapcar #'(lambda (p) (setf (aref a (cadar p) (caar p)) (cdr p))) solution)
    a))

;; $Id: //info.ravenbrook.com/user/ndl/lisp/contest/entries/scott-fenton.lisp#1 $
;; DOB 1986-11-02