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