This page contains the source code for Hillary and the source code for the NxN puzzle domain. To execute Hillary on the NxN puzzle domain just execute "(parametric-hillary)". Updates and demos can be found at http://www.cs.technion.ac.il/~shaulm/hillary.html
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Hillary.lisp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct domain name basic-ops apply-op-fn heur-fn gen-goal-fn
(copy-fn #'copy-tree) parameter)
(defparameter *escape-fn* 'iterative-limited-bfs)(defvar *macros* nil)
(defparameter *macros-in-escape* nil)
(defvar *quiescence* 0)(defparameter *max-quiescence* 50)
(defvar *ops-applications* 0)(defvar *learning* t)(defvar *n-problems* 0)
(defvar *domain* nil)(defvar *transitions* 0)(defparameter *trans-step* 100)
(defun hillary (&optional (domain *domain*)(macros nil))
(setf *macros* macros *quiescence* 0 *transitions* 0 *learning* t)
(loop until (> *quiescence* *max-quiescence*) for p from 1
for problem = (generate-training-problem domain)
do (solve-problem (first problem)(second problem) domain)
(format t "~% Solved ~d Problems" p)
finally (return *macros*)))
(defun parametric-hillary (&optional (dom *domain*)(macros nil) &aux (domain (copy-domain dom)))
(setq *macros* macros)
(loop for macros-before = (length macros)
for macros = (hillary domain macros)
do (incf (domain-parameter domain))
(format t "~%***~%Parameter=~d~%***~%" (domain-parameter domain))
until (= macros-before (length macros))
finally (return macros)))
(defun solve-problem (init-s goal-s dom)
(let ((cur-s init-s) solution)
(loop until (or (equalp cur-s goal-s)(eql solution 'fail))
for local-minimum = t
for cur-v = (funcall (domain-heur-fn dom) cur-s goal-s dom)
do (loop for op in (get-operators dom)
for next-s = (apply-op op cur-s dom) until (not local-minimum)
when (and next-s (< (funcall (domain-heur-fn dom) next-s goal-s dom) cur-v))
do (setq local-minimum nil cur-s next-s) (push op solution))
(when local-minimum
(let ((escape-route (funcall *escape-fn* cur-s goal-s dom)))
(cond ((and escape-route (not (eql escape-route 'fail)))
(when *learning* (acquire-macro escape-route))
(setq cur-s (apply-op escape-route cur-s dom))
(setq solution (append (reverse escape-route) solution)))
(t (setq solution 'fail))))))
(if (eql solution 'fail) solution (reverse solution))))
(defun acquire-macro (macro)
(setf *quiescence* 0)
(format t "~%Macro: ~A Length : ~d n-macros: ~d " macro (length macro)(+ 1 (length *macros*)))
(setq *macros* (merge 'list (list macro) *macros* #'< :key #'(lambda (a) (length a)))))
(defun apply-op (op state dom &aux new-s)
(cond ((listp op)(setf new-s (funcall (domain-copy-fn dom) state))
(loop for basic-op in op while new-s
do (setq new-s (funcall (domain-apply-op-fn dom)
basic-op new-s dom t))
finally (return new-s)))
(t (funcall (domain-apply-op-fn dom) op state dom))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun generate-training-problem (dom)
(incf *quiescence*)(incf *n-problems*) (incf *transitions* *trans-step*)
(let ((goal (funcall (domain-gen-goal-fn dom) dom)))
(list (generate-random-state goal *transitions* dom) goal)))
(defun generate-random-state (goal n dom &aux (basic-ops (domain-basic-ops dom)))
(loop for s = (funcall (domain-copy-fn dom) goal)
then (or (funcall (domain-apply-op-fn dom) op s dom t) s)
for op = (elt basic-ops (random (length basic-ops)))
repeat n finally (return s)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct node state v op)
(defparameter *init-breadth* 100)(defparameter *depth-limit* 50)
(defun iterative-limited-bfs (cur-state goal-s dom)
(loop with base = (length (get-operators dom *macros-in-escape*))
for exponent from 1 to *depth-limit*
for breadth-limit = (+ *init-breadth* (expt base exponent))
for result = (limited-bfs breadth-limit *depth-limit* cur-state goal-s dom)
until result finally (return result)))
(defun limited-bfs (breadth-limit depth-limit init-s goal-s dom)
(let* ((init-val (funcall (domain-heur-fn dom) init-s goal-s dom))
open improving-path
(new-open (list (make-node :state init-s :v init-val :op nil))))
(loop until improving-path for depth from 1 to depth-limit do
(setq open new-open new-open nil)
(loop for node in open until improving-path
for state = (node-state node) for cur-op = (node-op node) do
(loop for op in (get-operators dom *macros-in-escape*)
for new-s = (apply-op op state dom)
until improving-path when new-s do
(let ((new-v (funcall (domain-heur-fn dom) new-s goal-s dom))
(new-op (if (listp op)(append (reverse op) cur-op)
(cons op cur-op))))
(cond ((< new-v init-val) (setq improving-path (reverse new-op)))
(t (setq new-open
(insert (make-node :state new-s :v new-v :op new-op)
new-open breadth-limit))))))))
improving-path))
(defun insert (new-node list breadth-limit)
(unless (member new-node list :test
#'(lambda (a b)(and (= (node-v a)(node-v b))(equalp (node-state a)(node-state b)))))
(setf list (merge 'list (list new-node) list #'< :key #'node-v))
(when (> (length list) breadth-limit)(nbutlast list))) list)
(defun get-operators (dom &optional (include-macros t) &aux (basic (domain-basic-ops dom)))
(if include-macros (append basic *macros*) basic))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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))))