;; -*- Mode: Lisp; -*-

;;; CPS, the Classical Problem Solver
;;;; File name: search.lsp
;;;;  modified: Thursday, January 10, 2008 at 10:28:49 by Ken Forbus

;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University,
;;; and Johan de Kleer, the Xerox Corporation.
;;; All rights reserved.

;;; See the file legal.txt for a paragraph stating scope of permission
;;; and disclaimer of warranty.  The above copyright notice and that
;;; paragraph must be included in any separate copy of this file.

;;; This program implements the classical "problem space"
;;; model of AI problem solving.

;;; This version uses CLOS, to simplify the implementation

(in-package :cl-user) 

(defvar *debug-cps* nil
  "When non-nil, prints extra information for debugging.") 

;;; Problem definition
;;; ----------------------------------------------------------------------------
(defclass problem nil
  ((name
   :accessor name :initarg :name
   :documentation "something recognizable by user")
  (operators
   :accessor operators :initarg :operators
   :documentation "list of available operators")))

(defmethod print-object ((obj problem)
                         (stream t))
  (format stream "<ProblemSpace ~A>" (name obj)))


(defgeneric goal-found? (state problem)
  (:documentation "Returns non-nil if the state satisfies the goal of the problem."))

(defgeneric apply-operator (operator state problem)
  (:documentation "Returns a list of entries with the form (<operator instance> . <state>)
representing the instances of operator that can be applied to state, and the
states which result."))

(defgeneric states-identical? (state1 state2 problem)
  (:documentation
   "Returns non-nil if state1 and state2 are the same with respect to problem."))

(defgeneric solution-element->string (state operator-instance problem)
  (:documentation "Returns a string suitable for explaining a step in the solution."))

(defgeneric state->string (state problem)
  (:documentation "Returns a string suitable for describing a state of the problem."))

(defgeneric path-filter (path problem)
  (:documentation "Returns non-nil if path isn't suitable for the problem."))

(defmethod path-filter ((path t) (problem t)) nil) ;; Defaults to everything okay.

(defgeneric distance-remaining (state problem)
  (:documentation "Returns a number indicating how far the state is from the goal."))

;;; Path definition
;;; ----------------------------------------------------------------------------
(defclass path nil
  ((problem
    :accessor problem :initarg :problem
    :documentation "the problem it is a part of")
   (current
    :reader current-state :initarg :current-state
    :documentation "the current state")
   (so-far
    :reader so-far :initarg :so-far
    :documentation "alternating states and operator instances")
   (distance
    :accessor path-distance :initarg :path-distance
    :documentation "used in advanced versions"))
  (:documentation "defines a taken path within a search space"))

(defmethod print-object ((obj path)
                         (stream t))
  (format stream "<Path ~A>" (state->string (current-state obj) (problem obj))))

(defun make-new-path (problem initial-state &optional distance-remaining)
   "Create a new path for the given problem, starting with given state."
  (make-instance 'path 
    :problem problem
    :current-state initial-state 
    :so-far (list initial-state)
    :path-distance distance-remaining))
   

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CPS using breadth-first search
;;; ----------------------------------------------------------------------------
;;; Returns three values, the final state, the path, and the number
;;; of states examined.

(defun bsolve (initial problem)
   "Perform breadth-first search on given problem with given start state."
  (do ((queue (list (make-new-path problem initial)) ;; FIFO queue of paths.
	      (append (cdr queue) new-paths))
       (current-path nil)   ;; Current path from queue.
       (current-state nil)  ;; Current state in path.
       (new-paths nil)      ;; New paths generated from current path.
       (number-examined 1 (1+ number-examined))) ;gather statistics
      ((null queue))
     (setq current-path (car queue)) ;; Pop path from queue.
     (setq current-state (current-state current-path))
     (when (goal-found? current-state problem)
        (when *debug-cps* 
           (format t "~% CPS: Found goal state: ~A"
             (state->string current-state problem)))
        (return (values current-path number-examined)))
     (setq new-paths (extend-path current-path))
     (when *debug-cps*
        (format t "~% CPS: State explored: ~A" 
          (state->string current-state problem))
        (format t "~% CPS: New operator instances:")
        (print-new-paths new-paths))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Extend paths using domain-specific procedures

(defun extend-path (path &aux new-paths new-path p)
  (setq p (problem path))
  (dolist (op (operators p) new-paths)
    (dolist (op-pair (apply-operator op
                                     (current-state path)
                                     p))
	   ;; There can be more than one instantiation of the operator
	   ;; for each state, hence this inner loop.
      (setq new-path (make-instance 'path
                       :problem p
                       :current-state (cdr op-pair) ;new state
                       :so-far (cons (cdr op-pair) 
                                     (cons (car op-pair) ;op instance
                                           (so-far path)))))
      (unless (path-has-loop? new-path) ;avoid loops
        (unless (path-filter new-path p)
          (push new-path new-paths))))))

(defun path-has-loop? (ipath)
   "Returns true if path contains multiple instances of same state."
   ;;Go backwards down path to see if a state is
   ;;duplicated.  Must skip over operator instances.
   (do ((path (cddr (so-far ipath)) (cddr path))
        (state (current-state ipath))
        (p (problem ipath)))
       ((null path))
      (when (states-identical? state (car path) p)
         (return t))))

(defun print-new-paths (new-paths)
  (dolist (new-path new-paths)
    (format t "~%  ~A" (cadr (so-far new-path))))
  (format t "."))

(defun print-answer (path &optional (stream *standard-output*) &aux rpath p)
   "Print out a representation of the solution path."
   (setq rpath (reverse (so-far path))
         p (problem path))
   (format stream "~%Initial state: ~A." (state->string (car rpath) p))
   (do ((path (cdr rpath) (cddr path))
        (step 1 (1+ step)))
       ((null path) (format stream "~% Done."))
      (format stream "~%~D.  ~A" step
        (solution-element->string (cadr path)
                                  (car path)
                                  p))))