Source Code for Hillary

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

Domain-independent source code

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

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