Source Code for The NxN Puzzle Domain

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; n-puzzle-domain.lisp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *domain*
  (make-domain :name 'n-puzzle :basic-ops '(U D L R) :heur-fn 'puzzle-heur :parameter 3
	       :apply-op-fn 'puzzle-apply-op-fn :gen-goal-fn  'puzzle-gen-goal
	       :copy-fn 'puzzle-copy ))
(deftype puzzle-array () '(simple-array fixnum (* *)))
(defun puzzle-copy (state &aux (arr (second state)))
  (let ((new-arr (make-array (array-dimensions arr) :element-type 'fixnum)))
    (declare (type puzzle-array new-arr)(type puzzle-array arr)(optimize (speed 3)))
    (loop for i fixnum below (array-total-size arr) do
      (setf (row-major-aref new-arr i) (row-major-aref arr i)))
    (list (copy-list (first state)) new-arr)))
	

(defun puzzle-apply-op-fn (op state dom &optional (dont-copy nil) &aux new-state)
  (incf *ops-applications*)
  (when (puzzle-legal-op op state dom)
    (setq new-state (if dont-copy state (puzzle-copy state)))
    (move-tile op new-state) new-state))

(defun puzzle-legal-op (op state dom &aux (n (domain-parameter dom)))
  (let ((loc (offset-loc (get-empty-loc state) op)))
    (and (>= (first loc) 0)(>= (second loc) 0)
         (< (first loc) n)(< (second loc) n))))

(defun move-tile (op state)
  (let* ((empty-loc (get-empty-loc state))
         (new-loc (offset-loc empty-loc op)))
    (set-tile empty-loc state (get-tile new-loc state))
    (set-tile new-loc state 0)))
  
(defun offset-loc (loc op &aux (nl (copy-list loc)))
  (case op (r (incf (second nl)))(l (decf (second nl)))
        (d (incf (first nl)))(u (decf (first nl)))) nl)
                                                                 
(defun puzzle-heur (state goal-s dom &key (order *order-function*)
			  &aux (n (domain-parameter dom)))
   (multiple-value-bind (next-loc prefix-size)
      (find-next-tile-loc state goal-s n order)
  (let ((cur-loc (and next-loc (find-tile-loc (get-tile next-loc goal-s) state)))
	(empty-loc (get-empty-loc state)))
    (cond ((null next-loc) 0)
          (t (+  (manhatan-distance empty-loc cur-loc)
                 (* 2 n  (manhatan-distance cur-loc next-loc))
                 (* 2 n 2 n   (- (* n n) prefix-size))))))))

(defparameter *order-function* 'row-order)
(defun find-next-tile-loc (state goal-s n order)
  (loop with next-loc for count from 0
        do (setq next-loc  (funcall order next-loc n))
        until (or (null next-loc)
                  (/= (get-tile next-loc state)(get-tile next-loc goal-s)))
        finally (return (values next-loc count))))

(defun row-order (last-loc n &aux (i (first last-loc))(j (second last-loc)))
  (cond ((null last-loc)(list 0 0))
        ((< j (1- n))(list i (1+ j)))
        ((< i (1- n))(list (1+ i) 0))
        (t nil)))

(defun manhatan-distance  (loc1 loc2)
  (+ (abs (- (first loc1)(first loc2))) (abs (- (second loc1)(second loc2)))))

(defun find-tile-loc (tile-to-find state &aux (arr (second state)))
  (loop for i below (array-dimension arr 0) do
	(loop for j  below (array-dimension arr 1)
	      when (= tile-to-find (aref arr i j))
	      do (return-from find-tile-loc (list i j)))))

(defun get-empty-loc (state)(first state))
(defun get-tile (loc state) (aref (second state) (first loc)(second loc)))
(defun set-tile (loc state val)
  (when (zerop val)(setf (first state) loc))
  (setf (aref (second state) (first loc)(second loc)) val))

(defun puzzle-gen-goal (dom &aux (n (domain-parameter dom)))
  (let ((b (list nil (make-array (list n n) :element-type 'fixnum))))
    (loop with next-loc for k from 1  do
          (setq next-loc (funcall *order-function* next-loc n))
          (when next-loc (set-tile next-loc b (mod k (* n n))))
          while next-loc)
    (list (find-tile-loc 0 b) (second b))))