;;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10 -*- ;;;; --------------------------------------------------------------------------- ;;;; File name: solve.lsp ;;;; System: FIRE/Solve ;;;; Author: Praveen Paritosh ;;;; Created: November 1, 2003 16:42:32 ;;;; Purpose: AND/OR Tree based problem solver ;;;; --------------------------------------------------------------------------- ;;;; Modified: Wednesday, May 26, 2004 at 13:51:20 by paritosh ;;;; --------------------------------------------------------------------------- (in-package :fire) ;;; SOLVE v2: Suggestions-based AND/OR problem decomposition/solving. ;;; ;;; Suggestions provide for planful reasoning. When you call SOLVE with a form, ;;; it ASKs it, failing which it QUERYies the KB to see if there are any suggestions ;;; that apply. A suggestion can have additional TEST conditions which test when ;;; it is applicable. A suggestion must have a list of SUBGOALS [which are by default ;;; always interpreted to be ordered, and AND-subgoals, i.e. all of them must get ;;; solved in order for the parent to be solved], and a RESULT-STEP which is a form ;;; that is ASKed when all the subgoals are done -- usually this will do the job of ;;; combining the answers found by the subgoals. Optionally, it can have a ;;; DOCUMENTATION. You can write suggestions into a flat-file using the defSuggestion ;;; macro which expands it into assertions that are stored in the KB. Before you ;;; can use the suggestions, you have to ensure that you have stored them in the KB, ;;; and built a chainer out of the suggestion trigger axioms which is available to ;;; the current reasoner, as we backchain to gather suggestions. ;;; ;;; Before you SOLVE: Right now, before you can use SOLVE at all, you have to call ;;; SETUP-SOLVER which builds a chainer out of all the suggestion trigger axioms in ;;; the KB. Also, for debugging and testing purposes, you can use SETUP-SOLVE-TEST-CASE ;;; which takes two arguments, one a list of suggestions, and another a list of facts -- ;;; it stores the assertions corresponding to the suggestions in the KB, builds a ;;; chainer out of the trigger axioms, and stores the facts in the WM. ;;; ;;; Top Level entry point is SOLVE which has the same arguments as ASK, but for the ;;; :number arguement. We find one solution by default. SOLVE returns the one solution ;;; and a pointer to the AO-TREE object. If more solutions are needed, call GET-SOLUTION ;;; with the AO-TREE object. ;;; ;;; Look at solve-popcorn-example.lsp for an example of how to use this. ;; TODO 12/11/03 -- ;; 2. No reification in the WM except for what ASK automatically does for ;; us. The previous model was that for successful solution found ;; by a suggestion was installed in the WM with appropriate justification. ;; 3. Displaying AO-TREE for debugging, etc. Is ZGraph ready? ;; 4. Documentation of the workings. ;; 5. Make a shakedown with all the test cases in one place. ;; 6. MOOT-VIA-SUCCESS/FAILURE hasnt hit me yet -- am I missing something? ;; 7. For simplicity's sake, should we get rid of result-step altogether? ;; There is no difference between the last subgoal of the suggestion ;; and the result-step, although the code handles it differently right ;; now. ;; 8. Trivial: Handle cases without result-step, too. xx ;; 9. CLOSify the update functions. ;; 10. KB-PROOF it!!! The KB sometimes gives us completely unexpected things ;; causing bugs and crashes. That is bad. ;; 11. RETRIEVE :raw takes a lot of time? ;; Possible issues. 04/30/04 ;; Are the bindings computed in the test step appropriately stored and passed ;; to the rest of the computation? ;; Are suggestions without any result-step handled appropriately? Possible ;; problem: the counter is not updated by one, and it might miss one solution ;; if there is no result-step. Make that symmetric with the result-step case. ;; Add debugging output so we can see in the listener what is going on. ;; Set the global flag *debug-solve* to t to run SOLVE in verbose mode. ;; At some point adding a ZGRAPH interface will be helpful as that lets ;; us see the problem decomposition more neatly. 05/01/04 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass ao-tree () ((root-node :type goal-node :initarg :root-node :accessor root-node) (reasoner :type reasoner :initarg :reasoner :accessor reasoner) (node-counter :initform 0 ;; Unique ID for the nodes :accessor node-counter))) (defclass ao-node () ((id :accessor id :initarg :id :initform nil) (form :accessor form :initarg :form :initform nil) (ao-tree :accessor ao-tree :initarg :ao-tree :initform nil) ;; (reasoner :accessor reasoner :initarg :reasoner :initform *reasoner*) (bindings :accessor bindings :initarg :bindings :initform nil) ; bindings yet found (num-solutions :accessor num-solutions :initarg :num-solutions :initform 0) ; number of solutions yet found (cur-bmarker :accessor cur-bmarker :initarg :cur-bmarker :initform 0) ; counter that points to the current solution (control-status :accessor control-status :initarg :control-status :initform 0) ; OPEN/CLOSED (solution-status :accessor solution-status :initarg :solution-status :initform nil) ;; SOLVED/FAILED/UNKNOWN (parent :accessor parent :initarg :parent :initform nil) (children :accessor children :initarg :children :initform nil))) (defclass goal-node (ao-node) ;; PREV-BINDINGS is a binding list. If non-null, this is the bindings that we got ;; from our previous siblings which we used to instantiate this node. ((prev-bindings :accessor prev-bindings :initarg :prev-bindings :initform nil) (previous :accessor previous :initarg :previous :initform nil) ; younger sisters (next :accessor next :initarg :next :initform nil) ; elder sisters (work :accessor work :initarg :work :initform nil) ; work done till now nil/ASK/SUG ;; The variables for which this goal seeks bindings. ;; Cache these cause these are needed while propagating bindings. (variables :accessor variables :initarg :variables :initform nil) ;; Here we keep a pointer to the suggestion node that last gave us ;; an answer. Claim: At a time there cant be more than one in-play ;; suggestions. (in-play-suggestion :accessor in-play-suggestion :initform nil))) (defclass suggestion-node (ao-node) ((test :accessor test :initarg :test :initform nil) (subgoals-list :accessor subgoals-list :initarg :subgoals-list :initform nil) (result-step :accessor result-step :initarg :result-step :initform nil))) ;; ** Top level entry point to solver, SOLVE. Returns two values, ;; ** bindings, if any, and a pointer to the ao-node. ;; ** Arguments same as ASK. (defun solve (goal &key (reasoner *reasoner*) (context :all) ;; (number 1) ; No more -- we return one answer at a time (response :pattern) (effort :all)) (declare (ignore context effort)) (debug-solve "Starting to work on goal ~A~%" goal) (let* ((ao-tree (make-instance 'ao-tree :reasoner reasoner)) (goal-node (add-goal-node goal ao-tree nil))) (setf (root-node ao-tree) goal-node) (enqueue-agenda-item goal-node) ;; queue-goal on to agenda (multiple-value-bind (solution-bindings flag) (get-solution ao-tree) (if solution-bindings (case response (:bindings (values solution-bindings ao-tree)) (:pattern (values (sublis solution-bindings (form goal-node)) ao-tree)) (:response (values (sublis solution-bindings response) ao-tree))) flag)))) ; The root-node is in-play => can get more solutions without agenda operations ; The root-node has failed ; The agenda is empty ; If none of the above, process-agenda (defun get-solution (ao-tree) ;; Loop until we find a solution, fail, or empty-agenda (do ((root-goal-node (root-node ao-tree)) (solution nil) (done? nil) (flag nil)) (done? (values solution flag)) (cond ((solved? root-goal-node) (setq solution (get-next-solution root-goal-node)) (if solution (setq done? t flag :IN-PLAY-SOLUTION) (if (empty-agenda? ao-tree) (setq done? t flag :AGENDA-EMPTY) (process-agenda ao-tree)))) ((failed? root-goal-node) ;; Failed already? (setq done? t flag :FAILED)) ;; do we need this? ((empty-agenda? ao-tree) (setq done? t flag :AGENDA-EMPTY)) (t (process-agenda ao-tree))))) (defun open-ao-node (ao-node) (setf (control-status ao-node) :OPEN)) (defun process-agenda (ao-tree) (let ((agenda-item (dequeue-agenda-item ao-tree))) (cond ((goal-node? agenda-item) (process-goal-node agenda-item ao-tree)) ((suggestion-node? agenda-item) (process-suggestion-node agenda-item ao-tree)) (t (error "Strange Object ~S on agenda. Quitting~%" agenda-item))))) ;; Pseudocode for process-subgoal ;; process-subgoal goal ;; if no work done on this goal yet ;; ASK ;; if ask succeeds, set flag to ASK-DONE, update solved, return ;; if ask fails, set flag to ASK-DONE, and re enqueue on agenda ;; if work = ASK-DONE ;; gather-suggestions, and add them to tree and agenda ;; if no suggestion found ; this NODE has completely failed and needs to go away ;; try to find bindings from previous node ;; if bindings from previous node ;; re-instantiate this node with those bindings, work = nil ;; else update-failed node (defun process-goal-node (goal-node ao-tree) (debug-solve "Processing node ~A~%" goal-node) (cond ((null (work goal-node)) (open-ao-node goal-node) ;; Let ask do its job on it. No need to have the BLOCKED ;; flag at all, since if the goal was on agenda, it can be done. (let* ((bindings (ask (form goal-node) (reasoner ao-tree) t t :bindings t)) (good-bindings (remove-if-not #'(lambda (binding) (good-bindings? binding goal-node)) bindings))) (setf (work goal-node) :ASK-DONE) (when good-bindings ;; We have solved this node. Update flags, stash bindings, ;; instantiate the next-node with one of the current set of bindings, ;; and put on agenda. (debug-solve "~TFound solutions ~A for ~A by ASK~%" good-bindings goal-node) (update-solved-goal goal-node good-bindings) (return-from process-goal-node)) ;; ASK failed, we re-enqueue this node on agenda. The next time it ;; gets picked up, we'll gather suggestions, etc (debug-solve "~TASK failed for ~A, re-queuing it on agenda for suggestion gathering~%" goal-node) (enqueue-agenda-item goal-node) (return-from process-goal-node))) ((eql (work goal-node) :ASK-DONE) ;; We come here, since we have already ASKED this node, and yet we ;; want more solutions. Lets see if we can find more suggestions. (debug-solve "~TStarting to work on ~A for which ASK found no answers~%" goal-node) (let ((suggestions (gather-suggestions-for goal-node *suggestions-source*))) (when suggestions (debug-solve "~T~TFound ~A suggestions ~A~%" (length suggestions) suggestions) (dolist (suggestion suggestions) (enqueue-agenda-item suggestion)) (return-from process-goal-node)) ;; No suggestions found. This node (instantiated with the current set ;; of bindings from the logical environment) has to go away. So, we ;; see if the logical environment has another set of bindings for this ;; node. If yes, we re-instantiate and re-enqueue this node, if no, we ;; have failed on this node. (debug-solve "~T~TFound 0 suggestions~%") (when (previous goal-node) (let ((prev-bindings (get-next-solution (previous goal-node)))) (when prev-bindings (debug-solve "~T~T~TFound more solutions from a previous subgoal~%") (debug-solve "~T~T~TRe-instantiating ~A with ~A~%" goal-node prev-bindings) (enqueue-agenda-item (re-instantiate-node goal-node prev-bindings)) (return-from process-goal-node)))) (debug-solve "~T~T~TCompletely Failed on ~A, No suggestions or bindings from previous siblings~%") (update-failed goal-node) (return-from process-goal-node))) (t :ODD-OBJECT-ON-AGENDA))) ;; We stipulate that all the subgoals of the suggestion be ordered. ;; When we get in here, this is the first time we are seeing this ;; and node. So we take the youngest daughter, and put it on the ;; queue. When she is done, she will put on the next sister of hers ;; on the agenda. (defun process-suggestion-node (suggestion-node ao-tree) (debug-solve "Processing node ~A~%" suggestion-node) (open-ao-node suggestion-node) (let ((daughter-node (add-goal-node (car (subgoals-list suggestion-node)) ao-tree suggestion-node))) (debug-solve "Enqueuing the youngest daughter ~A~%" daughter-node) (enqueue-agenda-item daughter-node))) (defun re-instantiate-node (goal-node bindings) ;; The temporal extent of a goal node is limited to the single set of ;; bindings that it received from its logical environment. At the end ;; of that, we see if we have any more bindings from that environment, ;; and if we find any, we re-instantiate this node with those bindings. ;; ** Question: Is there any difference between blowing away the old ;; ** node and making a new one, or just re-using the old one? The only ;; ** perceivable change is that the node will have a different ID in ;; ** former case. Lets try RE-USE here. (let* ((parent-node (parent goal-node)) (sibling-number (position goal-node (children parent-node))) (blank-goal-form (nth sibling-number (subgoals-list parent-node))) (new-goal-form (sublis bindings blank-goal-form))) ;; The parent, previous, ao-tree and ID slots remain the same, everything else changes. (setf (form goal-node) new-goal-form (prev-bindings goal-node) bindings ;; These are bindings from previous node(s) (bindings goal-node) nil (num-solutions goal-node) 0 (cur-bmarker goal-node) 0 (control-status goal-node) nil (solution-status goal-node) :UNKNOWN (children goal-node) nil (next goal-node) nil (work goal-node) nil) ; When we re-instantiate, reset work done to nil (values goal-node))) (defmethod update-failed ((goal-node goal-node)) ;; We come here only when there is no bindings in the current logical ;; environment of this node that get us solutions or suggestions. This ;; goal-node has failed, which means that the parent suggestion-node ;; has failed. ;; ** Should we make its siblings moot here? *** ;; ** We should, but when does that make a difference *** (setf (solution-status goal-node) :FAILED (control-status goal-node) :CLOSED) (if (parent goal-node) ;; This has to bottom out at the root node. (update-failed (parent goal-node)))) (defmethod update-failed ((suggestion-node suggestion-node)) (debug-solve "~T~TFailed suggestion ~A~%" suggestion-node) (setf (solution-status suggestion-node) :FAILED (control-status suggestion-node) :CLOSED) (when (every #'failed? (siblings suggestion-node)) (debug-solve "~T~T~T All sibling suggestions failed, propagating failure to parent~%") (update-failed (parent suggestion-node)))) (defun update-solved-goal (goal-node bindings-just-found) (setf (solution-status goal-node) :SOLVED) ;; If we had bindings from younger sister subgoals, then we need to combine ;; those with the ones just found. If there are indeed such bindings, it ;; will be only ONE binding list, in the bindings slot of the goal-node (if (prev-bindings goal-node) (add-bindings goal-node (combine-bindings (prev-bindings goal-node) bindings-just-found)) (add-bindings goal-node bindings-just-found)) (if (not (root? goal-node)) (propagate-bindings goal-node))) (defun update-solved-suggestion (suggestion-node bindings-just-found) ; a list of binding lists (setf (solution-status suggestion-node) :SOLVED) (add-bindings suggestion-node bindings-just-found) ;; Since we are pushing these bindings upwards, need to increment ;; cur-bmarker at this node to reflect that we have used these, since ;; when needed they will be extracted from the upwards node. (setf (cur-bmarker suggestion-node) (+ (cur-bmarker suggestion-node) (length bindings-just-found))) ;; At this point the suggestion might have bindings for 'local' variables ;; that were introduced in the suggestion, and are not needed at the parent ;; goal. Pass only the subset variable bindings the parent wants. ;; Makes sense to assume that we cant fail now, as what the parent wants ;; has to be a subset of all we have accumulated here. (debug-solve "Succeeded ~A, propagating solution to parent and marking this suggestion as IN-PLAY~%" suggestion-node) (update-solved-goal (parent suggestion-node) (mapcar #'(lambda (bindings) (select-bindings (variables (parent suggestion-node)) bindings)) bindings-just-found)) (setf (in-play-suggestion (parent suggestion-node)) suggestion-node)) (defun propagate-bindings (goal-node) ;; Takes the current binding, increments counter, and passes it to ;; the elder subgoal. If this was the last subgoal, then it passes ;; the current bindings to the parent suggestion node. (let ((next-goal-form (get-next-goal-form goal-node)) (ao-tree (ao-tree goal-node)) (bindings (get-current-cached-bindings goal-node)) (parent-node (parent goal-node))) ;; ** Propagation. First we see if we have any elder sisters. ;; ** Instantiate them with the current bindings and add the elder ;; ** node to the queue. (debug-solve "Propagating bindings ~A just found for ~A" bindings goal-node) (when next-goal-form (incf (cur-bmarker goal-node)) ;; cause now these bindings are going to be used, so update counter (let ((cur-node (add-goal-node (sublis bindings next-goal-form) ao-tree (parent goal-node) :previous goal-node :prev-bindings bindings))) (debug-solve "~TPropagating bindings and instantiating ~A~%" cur-node) (enqueue-agenda-item cur-node) (return-from propagate-bindings))) ;; ** There is no elder sister. So this goal that we just solved ;; ** must be the eldest subgoal [or maybe it is the root]. In the case of ;; ** former we push the solutions just found to the parent (suggestion-node). (when parent-node ;; So we are at the point where we all the children subgoals of ;; this parent suggestion are solved. But the suggestion only ;; succeeds if the result-step does. Here we loop through all ;; the in-play suggestions until we can find a solution. If we ;; do that is pushed upward. If we dont, this process will ;; end up getting stuff on the agenda that will later get ;; us more solutions. (debug-solve "~TJust solved the last subgoal here, propagating solution to parent~%") (do ((bindings (get-next-solution goal-node) (get-next-solution goal-node))) ((null bindings) (return-from propagate-bindings nil)) (debug-solve "~T~T Doing result-step ~A~%" (result-step parent-node)) (multiple-value-bind (result-binding-lists success?) (do-result-step parent-node bindings) (when success? (debug-solve "~T~T~T Result step succeeded, propagating to parent~%") (debug-solve "~T~T~T Result bindings: ~A, Parent: ~A~%" result-binding-lists parent-node) (update-solved-suggestion parent-node result-binding-lists))))))) ;; *** Does this need to return two values? Maybe not *** (defun do-result-step (suggestion-node bindings) (cond ((null (result-step suggestion-node)) bindings) (t (let ((result-bindings (ask-it (sublis bindings (result-step suggestion-node)) :reasoner (reasoner (ao-tree suggestion-node)) :response :bindings))) (if result-bindings (values (combine-bindings bindings result-bindings) t) (values nil nil)))))) (defun add-bindings (ao-node bindings) (setf (bindings ao-node) (append (bindings ao-node) bindings)) (setf (num-solutions ao-node) (+ (num-solutions ao-node) (length bindings)))) ;;;(defun remove-bad-bindings (bindings goal-node) ;;; ;; ** stub. check, for instance if all the answer-variables got bound. ;;; (declare (ignore goal-node)) ;;; (values bindings)) (defun good-bindings? (bindings goal-node) ;; ** Check if these answers are good enough. Simplest thing. Make sure ;; ** we got bindings for all vars in goal-node (every #'(lambda (var) (not (null (assoc var bindings)))) (variables goal-node))) (defun combine-bindings (binding-list binding-lists) (mapcar #'(lambda (bindings) (append bindings binding-list)) binding-lists)) (defun get-next-goal-form (goal-node) (if (parent goal-node) (let* ((pos (position goal-node (children (parent goal-node))))) (if (numberp pos) (nth (+ pos 1) (subgoals-list (parent goal-node))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; IN-PLAY stuff: finding solutions without more work, here. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod get-next-solution ((goal-node goal-node)) (debug-solve "Trying to find the next solution for ~A~%" goal-node) (let ((cached-solution (get-next-cached-bindings goal-node))) (when cached-solution (debug-solve "~TFound cached solution ~A" cached-solution) (return-from get-next-solution cached-solution)) ;; Do we have an in-play suggestion in this nodes children? ;; We want to mine the in-play suggestions before we blow away, ;; re-instantiate nodes, etc. (if (in-play-suggestion goal-node) (let ((solution (get-next-solution (in-play-suggestion goal-node)))) (when solution (debug-solve "~TFound a new in-play solution ~A~%" solution) (add-bindings goal-node (list solution)) (incf (cur-bmarker goal-node)) (return-from get-next-solution solution)) ;; The in-play-suggestion has run out of solutions for us ;; So there's no in-play suggestion now (debug-solve "~TNo more in-play solutions here~%") (setf (in-play-suggestion goal-node) nil)) ;; No in-play suggestion, so we cant go downward from this node. See ;; if the previous node has bindings to re-instantiate this node. (let ((previous-bindings (get-next-solution (previous goal-node)))) (when previous-bindings (debug-solve "~T~TFound bindings ~A from previous node, reinstantiating goal~%" previous-bindings) (enqueue-agenda-item (re-instantiate-node goal-node previous-bindings)) (return-from get-next-solution nil)) (return-from get-next-solution nil))))) (defmethod get-next-solution ((suggestion-node suggestion-node)) (debug-solve "Trying to find the next solution for ~A~%" suggestion-node) (let ((cached-solution (get-next-cached-bindings suggestion-node))) (when cached-solution (debug-solve "~TFound cached solution ~A~%" cached-solution) (return-from get-next-solution cached-solution)) ; involves no updating of the bindings slot, only counter increments done by get-next-cached-binding ;; Seek downward (let ((solution (get-next-solution (eldest-child suggestion-node)))) ;; Add this in-play solution to the bindings, and update ;; the cur-bmarker, since we are passing this up. (when solution (add-bindings suggestion-node (list solution)) (incf (cur-bmarker suggestion-node)) (return-from get-next-solution solution)) (return-from get-next-solution nil)))) (defmethod get-next-solution ((foo t)) nil) ;;;(defun in-play-suggestion (goal-node) ;;; ;; ** This will be more complex in later versions. Will ;;; ;; ** need to maintain a pointer ;;; (car (children goal-node))) (defun get-next-cached-bindings (goal-node) (if (cached-solutions? goal-node) (let ((bindings (get-current-cached-bindings goal-node))) (incf (cur-bmarker goal-node)) (return-from get-next-cached-bindings bindings)) nil)) (defun get-current-cached-bindings (goal-node) (nth (cur-bmarker goal-node) (bindings goal-node))) (defun cached-solutions? (goal-node) (and (solved? goal-node) (< (cur-bmarker goal-node) (num-solutions goal-node)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Agenda manipulation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun enqueue-agenda-item (goal-node) ;; ** Add ordering by difficulty estimates here (push goal-node (agenda (reasoner (ao-tree goal-node))))) (defun dequeue-agenda-item (ao-tree) (pop (agenda (reasoner ao-tree)))) (defun empty-agenda? (ao-tree) (null (agenda (reasoner ao-tree)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ** Creating nodes ;; The add-node functions create the node, and connect it to the tree ;; appropriately. There is no point in creating the node and not connecting ;; it to the tree, so this should be the only way to create ao-nodes. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun add-suggestion-node (form subgoals-list result-step ao-tree parent-node) (let ((sug-node (make-suggestion-node form ao-tree :parent parent-node :subgoals-list subgoals-list :result-step result-step))) ;; Add this to the list of children (of the parent that introduced this) (setf (children parent-node) (nconc (children parent-node) (list sug-node))) (values sug-node))) (defun add-goal-node (form ao-tree parent-node &key (previous nil) (prev-bindings nil)) (let ((goal-node (make-goal-node form ao-tree :parent parent-node :previous previous :prev-bindings prev-bindings :variables (extract-vars form)))) (if parent-node (setf (children parent-node) (nconc (children parent-node) (list goal-node)))) (if previous (setf (next previous) goal-node)) (values goal-node))) (defun make-goal-node (form ao-tree &key (bindings nil) (prev-bindings nil) (parent nil) (previous nil) (next nil) (children nil) (variables nil)) (make-instance 'goal-node :form form :prev-bindings prev-bindings :bindings bindings :parent parent :previous previous :next next :ao-tree ao-tree :variables variables :children children :id (incf (node-counter ao-tree)))) (defun make-suggestion-node (form ao-tree &key (bindings nil) (parent nil) (children nil) (subgoals-list nil) (result-step nil)) (make-instance 'suggestion-node :form form :ao-tree ao-tree :parent parent :children children :bindings bindings :subgoals-list subgoals-list :result-step result-step :id (incf (node-counter ao-tree)))) ;;; Helper functions (defmethod goal-node? ((node goal-node)) t) (defmethod goal-node? ((node t)) nil) (defmethod suggestion-node? ((node suggestion-node)) t) (defmethod suggestion-node? ((node t)) nil) (defmethod print-object ((node goal-node) stream) (format stream "" (form node))) (defmethod print-object ((node suggestion-node) stream) (format stream "" (form node))) (defun leaf? (node) (null (children node))) (defun root? (node) (null (parent node))) (defun eldest-child (suggestion-node) (car (last (children suggestion-node)))) (defun solved? (ao-node) (eql (solution-status ao-node) :SOLVED)) (defun failed? (ao-node) (eql (solution-status ao-node) :FAILED)) (defmethod siblings ((node ao-node)) (if (root? node) node (children (parent node)))) (defun select-bindings (varlist bindings) "Returns the bindings for the variables in varlist from the given bindings, returns nil if any of the variables in varlist cant be found in bindings." (mapcar #'(lambda (var) (let ((bnd (car (member var bindings :key #'car)))) (if (null bnd) (return-from select-bindings nil) bnd))) varlist)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Gathering suggestions -- This is for debugging. The suggestions will ;; eventually come from KB, but the interface will look the same. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod gather-suggestions-for ((goal-node goal-node) (*suggestions-source* (eql :KB))) ;; Find the suggestions in the KB that apply for this goal. Find ;; the subgoals and the result-step and builds the nodes for the sugs. ;; Need to change :coverage arg for retrieve since when we retrieve ;; suggestions the forms in the KB have more unbound variables than ;; the specific goal at hand, so we need full unification. (with-retrieve-coverage :general (let* ((suggestion-form `(data::suggestFor ,(form goal-node) ?suggestion)) (query-results (query suggestion-form :reasoner (reasoner (ao-tree goal-node)) :number :all :max-depth 5 :max-nodes 100)) (suggestion-nodes nil)) (dolist (query-result query-results) ;; See if this is a valid suggestion (let ((suggestion-name (cdr (assoc '?suggestion (car query-result))))) (if (valid-suggestion-name? suggestion-name) (let* ((goal-form-in-kb (retrieve-goal-form suggestion-name)) (subgoals (retrieve-subgoals suggestion-name)) (result-step (retrieve-result-step suggestion-name))) (multiple-value-bind (uniquified-suggestion-body kb->uniq-unifier) (uniquize-variables (list goal-form-in-kb subgoals result-step)) ;; We only want the unique names for the variables that are local to this ;; suggestion, need to plug back in all that we are carrying from the goal. (let* ((uniq->goal-unifier (suggestion-goal-unifier (first uniquified-suggestion-body) (form goal-node))) (suggestion-body (sublis uniq->goal-unifier uniquified-suggestion-body))) (push (add-suggestion-node `(data::try ,suggestion-name ,(form goal-node)) (second suggestion-body) (third suggestion-body) (ao-tree goal-node) goal-node) suggestion-nodes))))))) (values suggestion-nodes)))) ;; op-instance looks like (suggestFor ) ;; suggestion-form-of-form looks like (suggestionFormOf ) (defun suggestion-goal-unifier (uniq-goal-form goal-form) "Returns the unifier of the goal as it appears in the suggestionFormOf in KB and current goal. These bindings have to be substituted in rest of the suggestion body, namely the subgoals and the result-steps" (ltre::unify uniq-goal-form goal-form)) (defun retrieve-subgoals (suggestion-name) (let* ((retrieve-results (retrieve `(data::suggestionSubgoals ,suggestion-name ?subgoals-list) :number :all))) (cdr (third (car retrieve-results))))) (defun retrieve-result-step (suggestion-name) (let ((retrieve-results (retrieve `(data::suggestionResultStep ,suggestion-name ?result-step) :number :all))) (third (car retrieve-results)))) (defun retrieve-goal-form (suggestion-name) (let ((retrieve-results (retrieve `(data::suggestionGoalForm ,suggestion-name ?goal-form) :number :all))) (third (car retrieve-results)))) (defun valid-suggestion-name? (name) (atom name)) ;;; For some weird reason this is not working! Is there something wrong with my genls-cache? ;;;(defun valid-suggestion-name? (name) ;;; (if (mixed-case?) ;;; (ask-it `(data::isa ,name data::Suggestion)) ;;; (ask-it `(data::isa ,name data::suggestion)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Mechanism for gathering suggestions without going through the KB. ;; This is just for debugging purposes. It lets you look at Solve ;; without worrying about things in the KB. Right now I am getting ;; a bug in QUERY [No binding for internal variable]. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod gather-suggestions-for ((goal-node goal-node) (*suggestions-source* (eql :NOKB))) (let ((suggestions nil)) ;; Find all the suggestions that might apply for this goal (dolist (sug *suggestions*) (if (valid-suggestion? sug goal-node) (push (suggestion->node sug goal-node) suggestions))) (values suggestions))) (defun valid-suggestion? (sug goal-node) (let ((goal-sug-unifier (ltre::unify (form goal-node) (third sug)))) (if (not (eql goal-sug-unifier :fail)) ;; Goal matches with the suggestion trigger, see if we pass the test (let ((test (sublis goal-sug-unifier (cadr (member :test sug))))) (if test (ask-it test) t))))) ;; If there's no test, we passed it (defun suggestion->node (sug goal-node) (let* ((bindings (ltre::unify (third sug) (form goal-node))) (suggestion-name (second sug)) (form (list 'try suggestion-name (sublis bindings (third sug)))) (subgoals (sublis bindings (cadr (member :subgoals sug)))) (result-step (sublis bindings (cadr (member :result-step sug))))) ; Lets add this later ;(uniquified-suggestion-body (uniquize-variables (list ) (add-suggestion-node form subgoals result-step (ao-tree goal-node) goal-node))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Debugging ;; This flag when set to t runs solve in verbose mode so we can see ;; what is going on. (defparameter *debug-solve* nil) (defmacro debug-solve (msg &rest args) `(when ,*debug-solve* (format t ,msg ,@ args))) (defun trace-solve () (trace fire::make-suggestion-node fire::add-suggestion-node fire::empty-agenda? fire::dequeue-agenda-item fire::enqueue-agenda-item fire::cached-solutions? fire::get-current-cached-bindings fire::get-next-cached-bindings fire::get-next-goal-form fire::combine-bindings fire::good-bindings? fire::add-bindings fire::propagate-bindings fire::update-solved-suggestion fire::update-solved-goal fire::re-instantiate-node fire::process-suggestion-node fire::process-goal-node fire::process-agenda fire::open-ao-node fire::solve fire::suggestion-node? fire:retrieve fire::goal-node? fire::gather-suggestions-for fire:ask fire::get-next-solution fire::retrieve-goal-form fire::update-failed fire::setup-solver fire::valid-suggestion-name? fire::retrieve-result-step fire::do-result-step fire::retrieve-subgoals fire::suggestion-goal-unifier fire::failed? fire::solved? fire::uniquize-variables2 fire::query)) ;; Stuff for running and testing the code. ;; Load the KB. If the suggestions you want to use in problem solving ;; are already not in the KB, then use LOAD-SUGGESTIONS to add them ;; to the KB. Then call SETUP-SOLVER to create reasoner, sources, and ;; the chainer needed by SOLVE. You are ready to SOLVE! (defvar *suggestions* nil) ;; This global flag tells us where our suggestions come from. ;; can be :KB/:NOKB. The latter is useful for debugging purposes. (defvar *suggestions-source* :KB) (defmethod setup-solver ((*suggestions-source* (eql :NOKB))) ;; We dont create the chainer here. (format t "Creating reasoner and analogy source... ~%") (setq cl-user::r (fire:make-reasoner "Reasoner for Solve")) (fire:in-reasoner cl-user::r)) (defmethod setup-solver ((*suggestions-source* (eql :KB))) (format t "Creating reasoner and analogy source... ~%") (setq cl-user::r (fire:make-reasoner "Reasoner for Solve")) (fire:in-reasoner cl-user::r) (format t "Adding chainer for suggestions... ~%") (add-chainer-to-reasoner (create-suggestions-chainer *kb*) cl-user::r)) (defun create-suggestions-chainer (&optional (kb *kb*)) ;; If you want to use suggestions, write them using the defSuggestions ;; macro, store them in the KB. Here we assume all the relevant axioms ;; are already in the KB (create-chainer-from-axioms "Chainer for Solve" (grab-suggestions-trigger-axioms kb))) (defun grab-suggestions-trigger-axioms (kb) ;; Until we figure out a general way to write a RETRIEVE-GENERAL such that ;; we can clearly specify which positions are to be generalized and which ;; not, one has to deal with this on a case to case basis. (retrieve-pattern '(data::implies ?antes (data::suggestFor ?problem ?sug-name)) :kb kb :number :all)) (defun grab-all-suggestions-assertions (&optional (mt 'data::SuggestionMT) (kb *kb*)) "returns all assertions in the SuggestionMT, for handy resetting/debugging" (let* ((ist-stmts (retrieve `(data::ist-Asserted ,mt ?form) :kb kb :number :all :coverage :raw)) ;; Remove other stuff which unified with the query (ist-stmts (delete-if-not #'(lambda (lst) (and (eql (first lst) 'data::ist-Asserted) (eql (second lst) 'data::SuggestionMT))) ist-stmts))) ;; Assume for each stmt, the stmt is in the KB, no more no less (values (append (mapcar #'third ist-stmts) ist-stmts)))) (defun forget-these (axioms) (dolist (ax axioms) (forget ax))) (defun load-suggestions (file-name &optional (kb *kb*)) "Loads suggestions from flat-file into the KB" (flat-file->kb file-name :kb kb)) (defmethod setup-solve-test-case (suggestions facts (*suggestions-source* (eql :KB))) ;; Starting afresh with a new reasoner (in-reasoner (make-reasoner "New")) ;; Adding suggestions to KB (format t "Adding suggestions to KB... ~%") (let ((suggestions-axioms (mapcan #'defSuggestion->assertions suggestions))) (dolist (suggestions-axiom suggestions-axioms) (store suggestions-axiom *kb*))) (format t "Creating and adding the suggestions chainer to reasoner... ~%") (add-chainer-to-reasoner (create-suggestions-chainer *kb*) *reasoner*) (format t "Adding the relevant facts to the WM... ~%") (dolist (fact facts) (ltre:assume! fact :user)) (format t "Ready to solve... ~%")) (defmethod setup-solve-test-case (suggestions facts (*suggestions-source* (eql :NOKB))) (setf *suggestions* suggestions) (dolist (fact facts) (ltre:assume! fact :user)) (format t "Ready to solve... ~%")) (defun assoc-bidirectional (element alist) (or (assoc element alist) (assoc-inverse element alist))) ;;;(defun assoc-inverse (element alist &key (test #'equal)) ;;; (dolist (pair alist) ;;; (if (funcall test element (cdr pair)) ;;; (return-from assoc-inverse pair)))) (defun assoc-inverse (element alist &key (test #'equal)) (car (member element alist :key #'cdr :test test))) ; can methods have optional arguments? ;(defun setup-solve-test-case (suggestions facts &key (kb *kb*) (reasoner *reasoner*)) ; ;; Adding suggestions to KB ; (format t "Adding suggestions to KB... ~%") ; (let ((suggestions-axioms (mapcan #'defSuggestion->assertions suggestions))) ; (dolist (suggestions-axiom suggestions-axioms) ; (store suggestions-axiom kb))) ; (format t "Creating and adding the suggestions chainer to reasoner... ~%") ; (add-chainer-to-reasoner (create-suggestions-chainer kb) reasoner) ; (format t "Adding the relevant facts to the WM... ~%") ; (dolist (fact facts) ; (ltre:assume! fact :user)) ; (format t "Ready to solve... ~%")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; End of Code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;