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))))