Source Code for Hillary
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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))