;;; The function LOOKUP-BINDINGS retrieves facts from the
;;; database. It collects a list of binding lists, each of which
;;; contains the necessary bindings to unify the fact pattern with
;;; a fact stored in the database tree. A lexical closure is
;;; created for collecting the results.
(defun lookup-bindings (fact-pattern)
(let ((bindingslstlst nil))
(traverse-facts fact-pattern
*fact-tree*
nil
nil
#'(lambda (bindings)
(push bindings bindingslstlst)))
bindingslstlst))

;;; The function TRAVERSE-FACTS traverses the tree (database) of
;;; facts for both storage and retrieval purposes. It recursively
;;; descends the tree by moving down the input pattern and
;;; selecting those tree branches that match the next input
;;; pattern element. For storage, it traverses until there is no
;;; matching subtree for the next element. Then it creates a
;;; subtree for the rest of the pattern and inserts it into the
;;; database at the appropriate tree location. For retrieval, it
;;; collects the bindings made at each matching point when
;;; variables are involved. When a complete match is made, these
;;; bindings are then pushed directly onto the result list of the
;;; calling function, LOOKUP-BINDINGS, by using a lexical
;;; closure.
(defun traverse-facts (pattern
tree
store?
bindings
result-stash-fn)
(let ((subtrees (cdr tree))
(next-term (car pattern)))
(cond ((null next-term)
;; Is this the end of the pattern?
(if store?
;; Tell user that the fact is already stored.
(print "already stored")
;; It is a retrieval operation and the fact has been
;; found, so push the resulting bindings onto the
;; result list of LOOKUP-BINDINGS.
(funcall result-stash-fn bindings)))
((varp next-term)
;; If the next term is a variable, bind the
;; variable to the next node in each subtree before
;; continuing traversal on the subtrees.
(loop for sub in subtrees
do (traverse-facts (cdr pattern)
sub
store?
(cons (cons next-term (car sub))
bindings)
result-stash-fn)))
(t
;; Otherwise, find the branch whose subtree starts with
;; a node matching the next element.
(let ((match (loop for sub in subtrees
when (eq next-term (car sub))
return sub)))
(if match
;; If a matching branch is found, follow it.
(traverse-facts (cdr pattern)
match
store?
bindings
result-stash-fn)
;; If no match is found and this is a storage
;; operation, create a new subtree at this
;; branch point for the remainder of the fact.
(when store?
(setf (cdr tree)
(cons (index-form pattern)
(cdr tree))))))))))

;;; The function TRAVERSE-RULES traverses the tree of rule-
;;; conclusion patterns for both storage and retrieval purposes.
;;; It recursively descends the tree by moving down the input
;;; pattern and selects those tree branches that match the next
;;; input pattern element. For retrieval, it collects the
;;; bindings made at each matching point when variables are
;;; involved. When a complete match is made, these bindings are
;;; pushed directly onto the result list of the calling function,
;;; FIND-MATCHING-RULES, by using a lexical closure.

(defun traverse-rules (pattern
rule
tree
store?
bindings
result-stash-fn)
(let ((subtrees (cdr tree))
(next-term (car pattern)))
(cond ((and subtrees (eq (caar subtrees) '*rules*))
;; The next node is a rule pointer.
(if store?
;; This is a storage operation. If this rule is
;; known, tell the user; otherwise, push this rule
;; onto the list of rules known to match the
;; pattern.
(if (loop for r in (cdr subtrees)
thereis (eq r rule))
(print "already stored")
(setf (cdr (car subtrees))
(cons rule (cdar subtrees))))
;; If it is a retrieval operation, make a cons of each
;; matching rule and its match bindings; store it as
;; a result in the top-level retrieval function,
;; FIND-MATCHING-RULES.
(loop for r in (cdar subtrees)
do (funcall result-stash-fn (cons r bindings)))))
((and (not store?) (varp next-term))
;; If it is a retrieval operation and the next element
;; of the input pattern is a variable, bind the
;; variable to the next node in each subtree, and then
;; continue traversal on each of those subtrees.
(loop for sub in subtrees
do (traverse-rules
(cdr pattern) rule sub store?
(cons (cons (car sub) next-term) bindings)
result-stash-fn)))
(t
;; Otherwise, collect the list of matching subtrees
;; to pursue. A subtree matches if its top node is a
;; variable or if it is identical to the next element
;; of the input pattern.
(let ((matches (loop for sub in subtrees
when (or (and (not store?)
(varp (car sub)))
(eq next-term (car sub)))
collect sub)))
(if matches
;; Continue traversal on each matching subtree.
;; If the top node of a subtree is a variable,
;; bind it to the input element during the
;; traversal of the subtree.
(loop for match in matches
do (traverse-rules (cdr pattern) rule
match
store?
(if (varp (car match))
(cons
(cons
(car match)
next-term)
bindings)
bindings)
result-stash-fn))
;; If there are no matches and this is a storage
;; operation, create a new subtree at this point
;; for the remainder of the input pattern.
(when store?
(setf (cdr tree)
(cons (rule-index-form pattern rule)
(cdr tree))))))))))

;;; The function TOP-GOAL-PROCESS creates the top-level process
;;; for the user-entered goal pattern. The goal stack of that
;;; process is initialized to contain only the entered pattern.
;;; The local variable RESULTS always contains a list of the
;;; bindings for each instance of the pattern achieved.

;;; When a process is created with an empty goal stack, it
;;; sends the bindings as a success message to its parent. Each
;;; node in the process tree creates a success message that is a
;;; lexical closure. The closure is passed to the subprocesses.
;;; Eventually, the success messages propagate up to the top-
;;; level process, whose success message causes the successful
;;; bindings to be stored in RESULTS. The lexical closure created
;;; here also counts the number of instances found and kills all
;;; reasoning processes when the required number has been found,
;;; as determined by the HOW-MANY argument to QUERY.
;;; Lexical closures are also used to allow each process to
;;; maintain a list of all of its descendants. Each time a child
;;; process is created, the parent evaluates its NEW-CHILD-MSG.
;;; This closure pushes the child onto a list of children and then
;;; tells its parent to do the same thing. The top-level process
;;; receives a message about every reasoning process that is
;;; created, so this NEW-CHILD-MSG also stores each child on the
;;; list of all processes for use by the BC scheduler.
(defun top-goal-process (pattern how-many)
(let ((goalstack (list pattern))
(results nil)
(children nil))
(flet ((stash-results-fn (bindings)
(push bindings results)
(print-top-level-result pattern bindings)
(when (and how-many (>= (length results) how-many))
(kill-extra-bc-processes children)))
(child-created-msg (proc)
(push proc children)
(push proc *bc-processes*)))
;; Start at the top level.
(setq *current-bc-proc-level* 0)
;; Create the top-level process.
(let ((new-child
(make-process :name "top-goal"
:function
(goal-object-achievement-method
(first goalstack))
:args
(list goalstack nil #'stash-results-fn
(list "root")
#'child-created-msg))))
(add-node-to-derivation-tree
new-child (list "root") *derivation-tree*)
(push new-child children)
;; Initialize the list of all backward chainer processes.
(setq *bc-processes* (list new-child))
;; Set up the BC scheduler.
(create-bc-scheduler-process)))))

;; Create a subnode for each matching fact.
(loop for i in (lookup-bindings (first goalstack))
do (make-subnode-for-matching-fact
i goalstack bindings
#'child-success-msg
#'child-created-msg
lineage))))))

;;; The following two functions deal with the only type of
;;; nondefault process. Instead of a simple pattern, the user can
;;; specify a disjunction of goal patterns. The user can
;;; additionally specify the number of the disjuncts that must be
;;; achieved for the disjunctive goal to be achieved.
;;; Consider a rule premise of the form
;;; (OR (THE BROTHER OF ?WHO IS JOE)
;;; (THE SISTER OF ?WHO IS SUE) 2)
;;; When a process is created with this as the top goal on its
;;; goal stack, the process is initialized with OR-GOAL-PROCESS
;;; instead of with DEFAULT-GOAL-PROCESS. A subprocess is
;;; created for deriving each disjunct. The success message to
;;; this "OR-node" counts the number of successes received. When
;;; that number equals the number specified by the user in the OR
;;; goal, the node kills all of its children and then proceeds
;;; like a default node whose top goal has been acheived.
(defun or-goal-process (goalstack bindings success-msg
lineage new-child-msg)
(let* ((children nil)
(successes nil)
(default-mode? nil)
(self *current-process*)
(top-goal (pop goalstack))
(how-many (get-how-many-arg top-goal)))
(labels ((child-created-msg (proc)
(push proc children)
(funcall new-child-msg proc))
(child-success-msg (bindlst)
(push bindlst successes)
(when (and (>= (length successes) how-many)
(not default-mode?))
(setq default-mode? t)
(process-or-goal-satisfaction children
successes
new-child-msg
goalstack
bindings
#'child-success-msg
lineage
#'child-created-msg
self))
(funcall success-msg (car successes))))
(unless (= (length lineage) 1)
(deactivate-process *current-process*))
(loop for disjunct in (get-disjuncts top-goal)
for new-child =
(make-process
:name (new-node-name (format nil "~a" disjunct))
:function (goal-object-achievement-method disjunct)
:args (list (list disjunct)
bindings
#'child-success-msg
(cons *current-process* (copy-tree lineage))
#'child-created-msg))
do (add-node-to-derivation-tree
new-child
(cons *current-process* (copy-tree lineage))
*derivation-tree*)
do (push new-child children)
do (funcall new-child-msg new-child)
do (print-process-created-msg
new-child disjunct lineage)))))

;;;; UTILITY FUNCTIONS
;;;
;;; The function VARP determines whether its argument is a pattern
;;; variable by checking that the first character in its name is a
;;; question mark.
(defun varp (x)
(and (symbolp x) (eql (elt (symbol-name x) 0) '#\\?)))

;;; The function FACT-SUBST returns the instance of the pattern
;;; with all of the variables replaced by their bindings from the
;;; bindings list.
(defun fact-subst (pattern bindingslst)
(sublis bindingslst pattern))

;;; The function INSERT-RULE-CONCLUSIONS inserts a set of rules
;;; into the set of rules currently considered during backward
;;; chaining.
(defun insert-rule-conclusions-into-tree (rules)
(setq *rule-tree* (list 'root))
(setq *current-rule-sets* (append rules *current-rule-sets*))
(loop for rule in *current-rule-sets* for num from 1
do (loop for clause in (second rule) when (consp clause)
do (rename-vars clause num))
(loop for clause in (loop for clauses on (second rule)
when (eq (car clauses) 'then)
return (cdr clauses))
do (add-rule-pattern clause (first rule)))))

;;; The function RENAME-VARS renames all variables in each rule
;;; with that rule's own copy of those variables so that users can
;;; specify rules using the same variables without confusing the
;;; system.
(defun rename-vars (clause num)
(loop for list on clause
when (varp (car list))
do (setf (car list)
(intern (format nil "~a<~a"
(original-varname (car list)) num))))
clause)

;;; The function ALL-BC-PROCS-INACTIVE? is a predicate that is
;;; used by the BC scheduler to determine when a level in the
;;; process tree has completed its processing.
(defun all-bc-procs-inactive? ()
(loop for proc in *bc-processes*
until (process-alive-p proc)
do (pop *bc-processes*))
(or (null *bc-processes*)
(not (loop for proc in *bc-processes*
thereis (process-active-p proc)))))

;;; The function NEW-NODE-NAME creates the process name for the
;;; nodes in the backward chainer decision tree.
;;; NOTE: the last number in the name always indicates the order
;;; in which the processes were created. The second-to-last item
;;; in the name is the top goal in the process's goal stack. If
;;; the goal stack is empty, the node is marked "solved" and the
;;; instance bindings are placed in this position of the name.
(defun new-node-name (top-goal )
(setq *node-count* (1+ *node-count*))
(concatenate 'string top-goal
"-"
(format nil "~a" *node-count*)))

;;; The function GET-HOW-MANY-ARG returns the number of instances
;;; of disjuncts required by the "OR-node".
(defun get-how-many-arg (or-goal-pattern)
(or (loop for term in or-goal-pattern
when (numberp term) return term)
1))