;;; 
;;; The sliding-block puzzles domain
;;;
;;; By Philip W. L. Fong
;;;

;;
;; Tuple
;;
 
(defun make-tuple (tile row col)
  "A tuple describes the location of a tile."
  (list tile row col))

(defun tuple-tile (tuple)
  "Accessing the tile id of a tuple."
  (first tuple))

(defun tuple-row (tuple)
  "Accessing the row number of a tuple."
  (second tuple))

(defun tuple-col (tuple)
  "Accessing the column number of a tuple."
  (third tuple))

;;
;; List of tuples
;;

(defun make-empty-list-of-tuples ()
  "Create an empty list of tuples."
  nil)

(defun list-of-tuples-place-tile (list-of-tuples tile row col)
  "Assuming that TILE is not already represented in the LIST-OF-TUPLES,
place TILE at location (ROW, COL)."
  (let ((tuple (make-tuple tile row col)))
    (if (null list-of-tuples)
	(list tuple)
      (if (< (tuple-tile (first list-of-tuples)) tile)
	  (cons (first list-of-tuples)
		(list-of-tuples-place-tile (rest list-of-tuples) tile row col))
	(cons tuple list-of-tuples)))))

(defun list-of-tuples-remove-tile (list-of-tuples tile)
  "Remove the tuple representing TILE from LIST-OF-TUPLES."
  (remove-if #'(lambda (tuple) (= tile (tuple-tile tuple))) list-of-tuples))

(defun list-of-tuples-get-tile (list-of-tuples row col)
  "Identify the tile located at ROW and COLUMN.  Return NIL if the position
is not occupied."
  (tuple-tile (find-if #'(lambda (tuple) 
			   (and (= row (tuple-row tuple))
				(= col (tuple-col tuple))))
		       list-of-tuples)))

(defun list-of-tuples-move-tile (list-of-tuples i j k l)
  "In LIST-OF-TUPLES, move the tile at row I column J to row K column L."
  (let ((tile (list-of-tuples-get-tile list-of-tuples i j)))
    (list-of-tuples-place-tile (list-of-tuples-remove-tile list-of-tuples tile)
			       tile k l)))

(defun list-of-tuples-locate-blank (list-of-tuples N)
  "Locate the position of blank in LIST-OF-TUPLES, assuming that the
game board has size N.  Returns two values, the row and column position
of the blank."
  (dotimes (i N)
	   (dotimes (j N)
		    (if (null (list-of-tuples-get-tile list-of-tuples i j))
			(return-from list-of-tuples-locate-blank 
				     (values i j))))))

(defun make-list-of-tuples (LL)
  "Create a list of tuples from a list of lists LL.  The j'th member
of the i'th list in LL is the index of the tile at row i column j.
0 represents the blank."
  (let ((row 0)
	(col 0)
	(list-of-tuples nil))
    (dolist (RL LL)
	    (setf col 0)
	    (dolist (tile RL)
		    (if (plusp tile)
			(setf list-of-tuples 
			      (list-of-tuples-place-tile list-of-tuples tile 
							 row col)))
		    (incf col))
	    (incf row))
    list-of-tuples))

;;
;; Puzzle
;;

(defun make-puzzle (N list-of-tuples)
  "Create a puzzle configuration of size NxN, with LIST-OF-TUPLES representing
the locations of the tiles."
  (list N list-of-tuples))

(defun puzzle-N (puzzle)
  "Access the size of the puzzle grid."
  (first puzzle))

(defun puzzle-list-of-tuples (puzzle)
  "Access the list of tuples in a puzzle configuration."
  (second puzzle))

;;
;; Utilities
;;

(defun puzzle-move-tile (puzzle i j k l)
  "Move tile at row I column J to row K column L."
  (make-puzzle (puzzle-N puzzle)
	       (list-of-tuples-move-tile (puzzle-list-of-tuples puzzle) 
					 i j k l)))

(defun puzzle-locate-blank (puzzle)
  "Return a list containing the row and column number of the blank."
  (list-of-tuples-locate-blank (puzzle-list-of-tuples puzzle)
			       (puzzle-N puzzle)))

(defun puzzle-operator-move (puzzle delta-v delta-h operator A)
  "The generic operator for the puzzle domain.  A tile in PUZZLE
will be moved down by DELTA-V and move right by DELTA-H.  OPERATOR
is the identifier of this move.  An effect structure will be 
created if the precondition of the move is satisfied.  In such
case, the effect structure will be CONS'ed with A to produce
the return value."
  (multiple-value-bind
   (blank-row blank-col)
   (puzzle-locate-blank puzzle)
   (let ((tile-row (- blank-row delta-v))
	 (tile-col (- blank-col delta-h)))
     (if (puzzle-legal-position-p puzzle tile-row tile-col)
	 (cons (make-effect operator 1
			    (puzzle-move-tile puzzle tile-row tile-col 
					      blank-row blank-col))
	       A)
       A))))

(defun puzzle-legal-position-p (puzzle row col)
  "Checks if ROW and COL are legal positions in PUZZLE."
  (let ((N (puzzle-N puzzle)))
    (and (>= row 0)
	 (<  row N)
	 (>= col 0)
	 (<  col N))))

(defun puzzle-operator-move-up (puzzle A)
  "Operator: move tile up."
  (puzzle-operator-move puzzle -1 0 'up A))

(defun puzzle-operator-move-down (puzzle A)
  "Operator: move tile down."
  (puzzle-operator-move puzzle 1 0 'down A))

(defun puzzle-operator-move-left (puzzle A)
  "Operator: move tile left."
  (puzzle-operator-move puzzle 0 -1 'left A))

(defun puzzle-operator-move-right (puzzle A)
  "Operator: move tile right."
  (puzzle-operator-move puzzle 0 1 'right A))

(defun puzzle-successor-function (puzzle)
  "The successor function for the puzzle domain."
  (puzzle-operator-move-up 
   puzzle
   (puzzle-operator-move-down 
    puzzle
    (puzzle-operator-move-left 
     puzzle
     (puzzle-operator-move-right 
      puzzle
      nil)))))

(defun puzzle-goal-test (puzzle)
  "The goal test predicate for the puzzle domain."
  (zerop (puzzle-misplaced-tiles puzzle)))

;;
;; Heuristic functions
;;

;;
;; Misplaced tiles heuristic
;;

(defun misplaced-tiles (node)
  "The misplaced tiles heuristics."
  (puzzle-misplaced-tiles (node-state node)))

(defun puzzle-misplaced-tiles (puzzle)
  "Compute the misplaced tiles heuristics for a puzzle state."
  (list-of-tuples-misplaced-tiles (puzzle-list-of-tuples puzzle) 
				  (puzzle-N              puzzle)))

(defun list-of-tuples-misplaced-tiles (list-of-tuples N)
  "Compute the misplaced tiles heuristics for a list of tuples."
  (if (null list-of-tuples)
      0
    (+ (if (tuple-misplaced-tile-p (first list-of-tuples) N) 1 0)
       (list-of-tuples-misplaced-tiles (rest list-of-tuples) N))))

(defun tuple-misplaced-tile-p (tuple N)
  "Check if a tuple represents a misplaced tile."
  (not (= (tuple-tile tuple) (+ (* N (tuple-row tuple)) (tuple-col tuple)))))

;;
;; Manhattan distance heuristic
;;

(defun manhattan-distance (node)
  "The Manhattan distance heuristics."
  (puzzle-manhattan-distance (node-state node)))

(defun puzzle-manhattan-distance (puzzle)
  "Compute the Manhattan distance heuristics for a state."
  (list-of-tuples-manhattan-distance (puzzle-list-of-tuples puzzle)
				     (puzzle-N              puzzle)))

(defun list-of-tuples-manhattan-distance (list-of-tuples N)
  "Compute the Manhattan distance heuristics for a list of tuples."
  (if (null list-of-tuples)
      0
    (+ (tuple-manhattan-distance (first list-of-tuples) N)
       (list-of-tuples-manhattan-distance (rest list-of-tuples) N))))

(defun tuple-manhattan-distance (tuple N)
  "Compute the Manhattan distance heuristics for a tuple."
  (let ((tile     (tuple-tile tuple))
	(row      (tuple-row  tuple))
	(col      (tuple-col  tuple)))
    (multiple-value-bind 
     (goal-row goal-col)
     (floor tile N)
     (+ (abs (- goal-row row)) (abs (- goal-col col))))))

;;
;; Relaxed adjacency heuristic
;;

(defun relaxed-adjacency (node)
  "The relaxed adjacency heuristics."
  (puzzle-relaxed-adjacency (node-state node)))

(defun puzzle-relaxed-adjacency (puzzle)
  "Compute the relaxed adjacency heuristics for a state."
  (let ((N (puzzle-N puzzle))
	(list-of-tuples (puzzle-list-of-tuples puzzle)))
    (multiple-value-bind
     (blank-row blank-col)
     (puzzle-locate-blank puzzle)
     (if (and (zerop blank-row) (zerop blank-col))
	 (let ((tuple (find-if #'(lambda (tuple)
				   (tuple-misplaced-tile-p tuple N))
			       list-of-tuples)))
	   (if (null tuple)
	       0
	     (1+ (puzzle-relaxed-adjacency (puzzle-move-tile puzzle
							     (tuple-row tuple)
							     (tuple-col tuple)
							     blank-row
							     blank-col)))))
       (let ((tuple (find-if #'(lambda (tuple)
				 (= (tuple-tile tuple)
				    (+ (* blank-row N) blank-col)))
			     list-of-tuples)))
	 (1+ (puzzle-relaxed-adjacency (puzzle-move-tile puzzle
							 (tuple-row tuple)
							 (tuple-col tuple)
							 blank-row 
							 blank-col))))))))
       

;;
;; Problem instances
;;

(defparameter *puzzle-1* (make-puzzle 3 (make-list-of-tuples '((0 1 5)
							       (3 2 8)
							       (6 4 7))))
  "Puzzle #1")

(defparameter *puzzle-2* (make-puzzle 4 (make-list-of-tuples '((6 4 5 3)
							       (1 0 2 11)
							       (12 10 7 15)
							       (9 8 13 14))))
  "Puzzle #2")

(defun make-puzzle-problem (puzzle)
  "Create a puzzle problem from PUZZLE."
  (make-problem puzzle #'puzzle-successor-function #'puzzle-goal-test))

(defun solve-puzzle (puzzle strategy)
  "Solve PUZZLE with STRATEGY."
  (solve-problem (make-puzzle-problem puzzle) strategy))

(defun solve-puzzle-1 (strategy)
  "Solve puzzle #1 with STRATEGY."
  (solve-puzzle *puzzle-1* strategy))

(defun solve-puzzle-2 (strategy)
  "Solve puzzle #2 with STRATEGY."
  (solve-puzzle *puzzle-2* strategy))