;;;; Iterative Improvement Search Algorithms
;;; Currently these do not do repeated-state checking. Each takes a problem
;;; and returns two values: like all search algorithms, the first is a
;;; solution node or nil, but the second value will be the best node found
;;; so far, even if it is not a solution. We will assume that all
;;; evaluations are costs (i.e., we're seeking minima).
;;;; Top Level Functions
(defun hill-climbing-search (problem
&optional (stopping-criterion #'minimum-or-flat))
"Search by picking the best successor according to heuristic h.
Stops according to stopping-criterion."
(let ((current (create-start-node problem))
next)
(loop
(let ((successors (expand current problem)))
(when successors
(setf next (the-smallest-random-tie #'node-h-cost successors)))
(when (or (null successors)
(funcall stopping-criterion current next))
(return (values (goal-test problem current) current)))
(setf current next)))))
(defun simulated-annealing-search (problem &optional
(schedule (make-exp-schedule)))
"Like hill-climbing-search, except that we pick a next node randomly;
if it is better, or if the badness of the next node is small and the
'temperature' is large, then we accpet it, otherwise we ignore it.
We halt when the temperature, TEMP, hits zero [p 113]."
;; Unlike [p 113], we keep track of successors to avoid generating them twice.
;; Also, we return the best node, rather than the current node
(let* ((current (create-start-node problem))
(successors (expand current problem))
(best current)
next temp delta)
(for time = 1 to infinity do
(setf temp (funcall schedule time))
(when (or (= temp 0) (null successors))
(RETURN (values (goal-test problem best) best)))
(when (< (node-h-cost current) (node-h-cost best))
(setf best current))
(setf next (random-element successors))
(setf delta (- (node-h-cost next) (node-h-cost current)))
(when (or (< delta 0.0) ; < because we are minimizing
(< (random 1.0) (exp (/ (- delta) temp))))
(setf current next
successors (expand next problem))))))
(defun random-restart-search (problem-fn &optional (n 10))
"Random-restart hill-climbing repeatedly calls hill-climbing-search.
PROBLEM-FN should return a problem with a random initial state.
We look at N different initial states, and keep the best solution found."
(let ((best-node nil))
(for i = 1 to n do
(multiple-value-bind (solution node)
(hill-climbing-search (funcall problem-fn))
(declare (ignore solution))
(when (or (null best-node)
(< (node-h-cost node) (node-h-cost best-node)))
(setf best-node node))))
best-node))
(defun hill-climbing-until-flat-n-times-search (problem &optional (n 4))
"Do hill climbing, but stop after no improvement N times in a row."
(hill-climbing-search problem (minimum-or-flat-n-times n)))
;;;; Auxiliary Functions
(defun local-minimum (current next)
"Stop when the next state is worse than the current."
(> (node-h-cost next) (node-h-cost current)))
(defun minimum-or-flat (current next)
"Stop when the next state is no better than the current."
(>= (node-h-cost next) (node-h-cost current)))
(defun minimum-or-flat-n-times (n)
"Return a function that stops when no improvement is made N times in a row."
(let ((times-in-a-row 0))
#'(lambda (current next)
(cond ((< (node-h-cost next) (node-h-cost current))
(setf times-in-a-row 0)
nil)
((>= (incf times-in-a-row) n))))))
(defun CSP-termination (current next)
(declare (ignore next))
(CSP-goalp (node-state current)))
(defun make-exp-schedule (&key (k 20) (lambda 0.005) (limit 100))
"Return an exponential schedule function with time limit."
#'(lambda (time) (if (< time limit)
(* k (exp (- (* lambda time))))
0)))