;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: xp-solve-v1.lsp
;;;;    System: FIRE
;;;;    Author: Praveen Paritosh
;;;;   Created: November 1, 2003 16:42:32
;;;;   Purpose: En route to the AND/OR solver 
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Thursday, December 4, 2003 at 14:30:36 by paritosh
;;;; ---------------------------------------------------------------------------


(in-package :fire)

;; Xtreme programming. Simple end to end systems with test.

;; SOLVE, V1
;; If the goal is a conjunct, and we expand it into an and node with as many 
;; children as the number of conjuncts. This will expose the problems of counters
;; at the level of suggestions. 
;; Test cases: 
;;  (solve '(data::and (data::bordersOn ?x Finland)))
;;  (solve '(data::and (data::bordersOn ?x Finland) (data::bordersOn Finland ?x)))
;;  (solve '(data::and (data::bordersOn ?x Finland) (data::bordersOn ?y Nepal)))
;;  (solve '(data::and (data::bordersOn ?x ?y) (data::bordersOn ?y ?z)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ** v1 Notes/Comments [This was earlier v1-2]
;; On a succesful solution of a subgoal, once we run out of solutions, 
;; it seems we'll see a :RAN-OUT-OF-THINGS-TO-DO, since agenda is 
;; empty at this point. Do we need :EXHAUSTED here?
;; ** write accessors for siblings, rewrite get-next-goal-form
;; ** rewrite update- and propagate- code as methods
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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
   ))
   
(defclass and-node (ao-node) ;; This is a simplification of what will be a suggestion node
  ((subgoals-list :accessor subgoals-list :initarg :subgoals-list :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. 

(defvar *kb-path* "c:\\paritosh\\qrg\\fire\\kbs\\qrg-general\\")

(defun setup-solver ()
  (format t "Loading QRG-GENERAL kb... ~%") 
  (fire:make-kb *kb-path* "qrg-general")
  (format t "Creating reasoner... ~%")
  (setq data::r (fire:make-reasoner "Testing Solve"))
  (fire:in-reasoner data::r))

;; There is no :number argument. SOLVE returns one answer, and a 
;; pointer to the ao-tree object. If you want more answers, then 
;; call GET-NEXT-SOLUTION with the ao-tree object, and it will 
;; keep giving you solutions until there are no more, in which 
;; case it will return :EXHAUSTED. 

;;; -- Test Case -- 
;;;Nepal
;;;(((?x . Tibet)) ((?x . China-PeoplesRepublic)))
;;;Finland
;;;(((?x . GulfOfBothnia)) ((?x . Sweden)) ((?x . Scandinavia-Nordic)) ((?x . Norway)) ((?x . Russia)))

(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))
  (let* ((ao-tree (make-instance 'ao-tree :reasoner reasoner))
         (goal-node (make-goal-node goal ao-tree)))
    (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))
          ((and-node? agenda-item)
           (process-and-node agenda-item ao-tree))
          (t (error "Strange Object ~S on agenda. Quitting~%" agenda-item)))))

(defun process-goal-node (goal-node ao-tree)
  (open-ao-node goal-node)
  ;; ** Hardwiring for conjunctive subgoals, ASK will do them, 
  ;; ** but for test purposes we want to see if we can accomplish
  ;; ** the same with AND nodes. 
  (if (conjunction? (form goal-node))
    ;; create an AND node and queue it on the agenda
    (let ((and-node (add-and-node (form goal-node) ao-tree goal-node))) 
      (enqueue-agenda-item and-node)
      (return-from process-goal-node)))
  ;; Regular goal. 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-bad-bindings bindings goal-node)))      
    (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. 
      (update-solved-goal goal-node good-bindings)
      (return-from process-goal-node))
    
    ;; ** We didnt get any bindings for this specific node. 
    ;; ** At this stage, in later versions we'll go gather suggestions.
    ;; ** Should we? 
    ;; ** See if we have bindings from our previous siblings to 
    ;; ** re-instantiate this one. 
    
    ;; In this version, we are done with processing on this specific 
    ;; node [if this node is not the youngest one, then we have 
    ;; failed on the instance of this node that was obtained from
    ;; the current set of bindings from the logical environment of 
    ;; this node]. This node fails when -- 1) there is no previous 
    ;; node, or 2) There is no more bindings our logical environment
    ;; has to give us. 
    (if (previous goal-node)
	(let ((prev-bindings (get-next-solution (previous goal-node))))
	  (if prev-bindings
	      (enqueue-agenda-item (re-instantiate-node goal-node prev-bindings))
	    (update-failed goal-node)))
      (update-failed goal-node))))

;; We stipulate that all the subgoals of the and-node 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-and-node (and-node ao-tree)
  (open-ao-node and-node)
  (let ((daughter-node (add-goal-node (car (subgoals-list and-node)) ao-tree and-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)
    (values goal-node)))
         
(defmethod update-failed ((goal-node ao-node))
  ;; propagate failed status all the way up to the parent
  ;; here, it means only one level. 
  (setf (solution-status goal-node) :FAILED
	(control-status goal-node) :CLOSED)
  (if (parent goal-node)
    (update-failed (parent goal-node))))

;;;(defmethod update-solved ((goal-node goal-node)
;;;                          (bindings-just-found t))
;;;  (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))
;;;  (propagate-bindings goal-node))
;;;
;;;(defmethod update-solved ((and-node and-node)
;;;                          (bindings-just-found t)) ; a list of binding lists
;;;  (setf (solution-status and-node) :SOLVED)
;;;  (add-bindings and-node bindings-just-found)
;;;  (update-solved (parent and-node) bindings-just-found))

(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-and (and-node bindings-just-found)  ; a list of binding lists
  (setf (solution-status and-node) :SOLVED)
  (add-bindings and-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 and-node) (+ (cur-bmarker and-node) (length bindings-just-found)))
  (update-solved-goal (parent and-node) bindings-just-found))

(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 and-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.  
    (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)))
        (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 (and-node). 
    (when parent-node
      ;; Since this binding has been pushed up from where it will be
      ;; extracted when needed, increment the counter appropriately. 
      (incf (cur-bmarker goal-node)) 
      (update-solved-and parent-node (list bindings))))) ; need to make it a list of binding lists

(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 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))
  (let ((cached-solution (get-next-cached-bindings goal-node)))
    (if 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
            (add-bindings goal-node (list solution))
            (incf (cur-bmarker goal-node))
            (return-from get-next-solution solution)))
        ;; 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 
            (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 ((and-node and-node))
  (let ((cached-solution (get-next-cached-bindings and-node)))
    (if 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 and-node))))
        ;; Add this in-play solution to the bindings, and update 
        ;; the cur-bmarker, since we are passing this up. 
        (when solution 
          (add-bindings and-node (list solution))
          (incf (cur-bmarker and-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 

(defun make-goal-node (form ao-tree &key (bindings nil) 
                            (prev-bindings nil)
                            (parent nil) 
                            (previous nil)
                            (next nil)
                            (children nil))
  (make-instance 'goal-node :form form :prev-bindings prev-bindings :bindings bindings 
    :parent parent :previous previous :next next :ao-tree ao-tree 
    :children children :id (incf (node-counter ao-tree))))
                            
(defun make-and-node (form ao-tree &key (bindings nil) 
                           (parent nil) 
                           (children nil)
                           (subgoals-list nil))
  (make-instance 'and-node :form form :ao-tree ao-tree  
    :parent parent :children children :bindings bindings
    :subgoals-list subgoals-list :id (incf (node-counter ao-tree))))

;; The add-node functions create the node, and connect it to the tree 
;; appropriately. 
(defun add-and-node (form ao-tree parent-node)
  (let ((and-node (make-and-node form ao-tree :parent parent-node 
				 :subgoals-list (cdr form))))
    ;; Add this to the list of children (of the parent that introduced this)
    (setf (children parent-node) (nconc (children parent-node) (list and-node)))
    (values and-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)))
    (if parent-node
      (setf (children parent-node) (nconc (children parent-node) (list goal-node))))
    (if previous
      (setf (next previous) goal-node))
    (values goal-node)))
  

;;; Helper functions

(defmethod goal-node? ((ao goal-node)) t) 
(defmethod goal-node? ((ao t)) nil)

(defmethod and-node? ((ao and-node)) t)
(defmethod and-node? ((ao t)) nil)

(defmethod print-object ((goal goal-node) stream)
  (format stream "<Goal: ~A>" (form goal)))

(defmethod print-object ((goal and-node) stream)
  (format stream "<And-Goal: ~A>" (form goal)))

(defun leaf? (node)
  (null (children node)))

(defun root? (node)
  (null (parent node)))

(defun eldest-child (and-node)
  (car (last (children and-node))))

(defun solved? (ao-node)
  (eql (solution-status ao-node) :SOLVED))

(defun failed? (ao-node)
  (eql (solution-status ao-node) :FAILED))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Debugging

(defun trace-xp-solve ()
  (trace fire::goal-node? fire::make-and-node fire::empty-agenda?
         fire::dequeue-agenda-item fire::enqueue-agenda-item fire::solved?
         fire::failed? fire::remove-bad-bindings fire::add-bindings
         fire::cached-solutions? fire::get-current-cached-bindings
         fire::get-next-cached-bindings fire::process-and-node
         fire::propagate-bindings fire::get-next-goal-form
         fire::update-solved fire::update-failed
         fire::re-instantiate-node fire::process-goal-node
         fire::process-agenda fire::open-ao-node fire::combine-bindings
         fire::get-next-solution fire::solve fire::setup-solver
         fire::and-node?))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; End of Code


;; *** Implementing IN-PLAY? right will be important in the next version 
;; *** Notes about that here
; More about in-play: For goal-nodes -- if a goal-node is in-play, either it is leaf and has cached solutions, 
; or it has a pointer to the child suggestion that is currently in-play (should be 
; only one). For suggestion-node, if it is in-play, that means there are more solutions
; at its eldest child.