Search Program

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  GENERAL-PURPOSE SEARCH PROCEDURE.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MANIPULATING STATES.
;;; Each state is a list of the following form:
;;; (distance_traveled  estimated_distance_left  configuration)
;;; where configuration is a problem-specific representation of the
;;; arrangement of the relevant objects.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Access procedures for states.

(define state-distance car)
(define state-estimate cadr)
(define state-config caddr)

;;; Turns an initial configuration into a state.
;;; INPUT:
;;;  config -- a problem-specific configuration
;;;  estimate -- the problem-specific procedure for estimating
;;;    distance from a state to a goal state
;;; OUTPUT:
;;;  a state: (distance_sofar distance_left configuration)
;;; Takes estimate as an argument because it needs to assign
;;; an estimated distance remaining to the configuration.

(define config->state
  (lambda (config estimate)
    (list 0 (estimate (list 0 0 config)) config)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Procedures for MERGING NEW PATHS into the queue of
;;; paths.
;;; INPUT:
;;;  queue -- a queue of states
;;;  new-paths -- a partial queue, the new paths generated
;;;    after removing one from the front of a queue
;;;  estimate -- the problem-specific estimate procedure,
;;;    required only by those merge procedures which sort
;;;    the queue by distance remaining
;;; OUTPUT:
;;;  a new queue consisting of the queue and the new-paths
;;;    (possibly with some redundancies removed)
;;; (The ones that sort could do it more efficiently.)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Merge for depth-first search.  Just put the new paths
;;; on the front of the queue.

(define depth-first-merge
  (lambda (queue new-paths estimate)
    (append! new-paths queue)))

;;; Merge for breadth-first search.  Just put the new paths
;;; on the end of the queue.

(define breadth-first-merge
  (lambda (queue new-paths estimate)
    (append! queue new-paths)))

;;; Merge for best-first search.  Add the new paths to the queue,
;;; and then sort the whole cue using the estimate procedure.
;;; This actually assigns estimates to the first state in each new
;;; path, so these do not have to already be in place.

(define best-first-merge
  (lambda (queue new-paths estimate)
    (sort
     (lambda (path1 path2)
       (< (state-estimate (car path1))
	  (state-estimate (car path2))))
     (append queue
	     ;; Add estimates to first states in new paths
	     (map
	      (lambda (path)
		(cons
		 (list (state-distance (car path))
		       (estimate (car path))
		       (state-config (car path)))
		 (cdr path)))
	      new-paths)))))

;;; Merge for branch-and-bound search, and also eliminate redundant paths.
;;; Add the new paths to the queue and sort by distance already
;;; traveled, which is already specified for each end state.

(define branch-and-bound-merge
  (lambda (queue new-paths estimate)
    (elim-redundant-paths
     (sort
      (lambda (path1 path2)
	(< (state-distance (car path1))
	   (state-distance (car path2))))
      (append queue new-paths)))))

;;; Merge for A* search.  Add the new paths to the queue and sort by
;;; the sum of the distance traveled (already specified for each end
;;; state) and the estimated distance remaining (which must be an
;;; underestimate and which is calculated here for each of the new
;;; states).  Eliminate redundant paths.

(define a*-merge
  (lambda (queue new-paths estimate)
    (elim-redundant-paths
     (sort
      (lambda (path1 path2)
	(< (+ (state-distance (car path1)) (state-estimate (car path1)))
	   (+ (state-distance (car path2)) (state-estimate (car path2)))))
      (append queue
	      ;; Add estimates to first states in new paths
	      (map
	       (lambda (path)
		 (cons
		  (list (state-distance (car path))
			(estimate (car path))
			(state-config (car path)))
		  (cdr path)))
	       new-paths))))))

;;; When more than one path on the queue ends in the same state,
;;; eliminate all but the one with the shortest distance.
;;; INPUT:
;;;  queue -- a queue of paths
;;; OUTPUT:
;;;  the queue with redundant paths eliminated

(define elim-redundant-paths
  (lambda (queue)
    (letrec
	((helper
	  (lambda (checked left)
	    (cond ((null? left)
		   (reverse checked))
		  (else
		   (let ((same-1st
			  (some
			   (lambda (p)
			     (equal? (state-config (car p))
				     (state-config (car (car left)))))
			   checked)))
		     ;; same-1st is some path in checked which has the
		     ;; same last state configuration as the last
		     ;; state in the first path on left
		     (if same-1st
			 ;; Keep around the one with the smaller distance.
			 (if (< (state-distance (car same-1st))
				(state-distance (car (car left))))
			     (helper checked (cdr left))
			     (helper
			      (substitute checked same-1st (car left))
			      (cdr left)))
			 (helper (cons (car left) checked)
				 (cdr left)))))))))
      (helper '() queue))))

;;; Help procedure which returns the first thing in list ls which
;;;  satisfies predicate pred.

(define some
  (lambda (pred ls)
    (cond ((null? ls) #f)
	  ((pred (car ls))
	   (car ls))
	  (else
	   (some pred (cdr ls))))))

;;; Help procedure which substitutes new for old in list ls.

(define substitute
  (lambda (ls old new)
    (cond ((null? ls) '())
	  ((equal? (car ls) old)
	   (cons new (substitute (cdr ls) old new)))
	  (else
	   (cons (car ls) (substitute (cdr ls) old new))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; EXTEND a path to new successor states, leaving out ones with loops
;;; in them, that is, ones in which the configuration is the same as
;;; that for another state in path
;;; INPUT:
;;;  successors -- list of new states
;;;  path -- path of states
;;; OUTPUT:
;;;  list of new paths, extending path to each of the successors
;;;    which were not eliminated
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define extend-path
  (lambda (successors path)
    (cond ((null? successors) '())
	  ((any? (lambda (x)
		   (equal? (state-config (car successors))
			   (state-config x)))
		 path)
           (extend-path (cdr successors) path))
          (t
           (cons (cons (car successors) path)
                 (extend-path (cdr successors) path))))))

;;; Help procedure which returns #t if anything in list ls satisfies
;;; predicate pred.

(define any?
  (lambda (pred ls)
    (and (not (null? ls))
	 (or (pred (car ls))
	     (any? pred (cdr ls))))))

;;; Help procedure that returns all elements in list ls which are not
;;; members of any lists in list of lists ls-of-ls.

(define all-not-mem-of-lists
  (lambda (ls ls-of-ls)
    (cond ((null? ls) '())
          ((some (lambda (x) (member (car ls) x))
                 ls-of-ls)
           (all-not-mem-of-lists
            (cdr ls) ls-of-ls))
          (t
           (cons (car ls)
                 (all-not-mem-of-lists (cdr ls)
                                    ls-of-ls))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; PRINT a path of states.
;;; INPUT:
;;;  path -- a path of states
;;;  print-state -- a problem-specific procedure which takes a
;;;    state and prints it out in a nice way.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define print-path
  (lambda (path print-state)
    (if (null? path)
	(printf "EMPTY PATH~%")
	(begin
	  (print-state (car path))
	  (printf "  + ~s PREVIOUS STATES~%" (length (cdr path)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SEARCH PROCEDURE itself.
;;; Performs depth-first, breadth-first, best-first, branch-and-bound, or A*
;;; search.  Starts with an initial configuration (not a "state", which also
;;; has a distance and an estimate).
;;; INPUT:
;;;  merge-queue -- procedure which takes a list of new paths, a queue,
;;;    and the estimate procedure and returns a new queue (see
;;;    depth-first-merge, etc. above
;;;  init-config -- a configuration (not a state) to start from
;;;  extend -- problem-specific procedure which returns new states
;;;    reachable from a given state
;;;    INPUT:
;;;     state -- a problem state
;;;    OUTPUT:
;;;     list of states that are legally reached in one "move" from
;;;       state 
;;;  goal? -- problem-specific predicate which returns true when
;;;    its state argument is a goal state, false otherwise
;;;    INPUT:
;;;     state -- a problem state
;;;    OUTPUT:
;;;     #t if the state is a goal state, #f otherwise
;;;  estimate -- problem-specific procedure which returns an estimate
;;;    of the distance to a goal state (an underestimate in the case of
;;;    A*)
;;;    INPUT:
;;;     state -- a problem state
;;;    OUTPUT:
;;;     a number which is an estimate of the distance from state to
;;;       the nearest goal state
;;;  print-state -- problem-specific procedure which pretty-prints its
;;;    state argument
;;;    INPUT:
;;;     state -- a problem state
;;;    SIDE-EFFECT
;;;     pretty prints the state
;;; OUTPUT:
;;;  a path from the initial state to a goal state, if one is found, #f
;;;    otherwise
;;;
;;; Here is how search is called for an A* search on the Tower
;;; of Hanoi problem:
;;;   (search a*-merge '((1 2 3) () ()) hanoi-extend hanoi-goal?
;;;            hanoi-estimate hanoi-print-state)

(define search
  (lambda (merge-queue init-config extend goal? estimate print-state)
    (letrec
      ((helper
         (lambda (queue)
	   (newline)
	   (printf "C U R R E N T   Q U E U E:~%")
	   (for-each
	    (lambda (p) (print-path p print-state))
	    queue)
           (cond ((null? queue)
                  ;; Unable to find a goal state
                  #f)
                 ((goal? (caar queue))
		  (printf "R E A C H E D   G O A L   S T A T E~%")
		  (print-state (caar queue))
		  (newline)
		  (let ((ans (reverse (car queue))))
		    (printf "PATH TO GOAL STATE:~%")
		    (for-each (lambda (x) (print-state x) (newline)) ans)
		    ans))
                 (else
                  ;; Take the first path of the queue and extend the
                  ;; last state in that path (the car)
                  (let ((successors (extend (caar queue))))
		    (printf "EXTENDING FIRST STATE ON QUEUE:~%")
		    (print-state (caar queue)) (newline)
                    (cond ((null? successors)
			   (printf "NO SUCCESSOR STATES (DEAD END)~%")
                           (helper (cdr queue)))
                          (else
			   (printf "LEGAL SUCCESSOR STATES:~%")
			   (for-each (lambda (x) (print-state x) (newline))
				     successors)
			   (helper
                            ;; Create a new path for successor (unless
                            ;; there are loops), and merge the new paths
                            ;; into the rest of the queue using the
                            ;; merge-queue procedure.
			    (merge-queue (cdr queue)
					 (extend-path successors (car queue))
					 estimate))))))))))
      (helper
       ;; Create the initial queue from init-config.
       (list (list (config->state init-config estimate)))))))