8 A Multitasking Application
;;;; GLOBAL VARIABLE DECLARATIONS AND INITIALIZATIONS
(defvar *fact-tree* (list 'root)) ; database tree
(defvar *rule-tree* (list 'root)) ; conclusion pattern tree
(defvar *node-count* 0) ; node counter
(defvar *derivation-tree* (list "root")); tree of reasoning
; processes
(defvar *bc-processes* nil) ; all reasoning processes
(defvar *current-bc-proc-level* 0) ; active tree level
(defvar *current-rule-sets* nil) ; list of all rules in tree
(defvar *extended-text-trace* nil) ; trace info for debugging
(defvar *print-lock* nil) ; lock to use when printing
;;;; DATABASE TREE FUNCTIONS
;;;
;;; The function ADD-FACT is the top-level function for adding
;;; facts to the database.
(defun add-fact (fact)
(traverse-facts fact *fact-tree* t nil nil))
;;; 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))))))))))
;;;; RULE CONCLUSION TREE FUNCTIONS
;;;
;;; The function ADD-RULE-PATTERN stores a pattern with a pointer
;;; to its rule in the tree.
(defun add-rule-pattern (pattern rule)
(traverse-rules pattern rule *rule-tree* t nil nil ))
;;; The function FIND-MATCHING-RULES retrieves matching patterns
;;; from the tree.
(defun find-matching-rules (pattern)
(let ((matches nil))
(traverse-rules pattern nil *rule-tree* nil nil
#'(lambda (rule) (push rule matches)))
matches))
;;; 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))))))))))
;;;; BACKWARD CHAINING FUNCTIONS
;;;
;;; The function QUERY is a top-level function for initiating
;;; backward chaining on some goal pattern. The returned value is
;;; NIL if no instances of the pattern can be derived. Otherwise,
;;; a list of bindings lists is returned.
(defun query (pattern &optional how-many)
(setq *node-code* 0) ; Initialize number of nodes.
(setq *derivation-tree* (list "root"))
; Initialize decision tree.
(top-goal-process pattern how-many)
; Start backward chaining.
)
;;; 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)))))
(defun create-bc-scheduler-process ()
(make-process :name "bc-scheduler"
:function #'bc-scheduler-process))
;;; The function BC-SCHEDULER-PROCESS descends the tree of
;;; processes and allows each level run to completion before
;;; activating the next level.
(defun bc-scheduler-process ()
(loop while *bc-processes* do
(process-wait "until level finishes"
#'all-bc-procs-inactive?)
(setq *current-bc-proc-level*
(1+ *current-bc-proc-level*))
(descend-tree-and-activate-next-level
*derivation-tree*
*current-bc-proc-level*
0)))
;;; The function DEFAULT-GOAL-PROCESS is the initial function to
;;; most backward-chainer processes. As such, it specifies the
;;; default behavior of the nodes in the decision process tree.
;;; Besides taking in a goal stack and bindings, this function
;;; requires the SUCCESS-MSG and NEW-CHILD-MSG lexical closures
;;; from the parent. The lineage argument is a list of the
;;; ancestors of this node in the tree.
(defun default-goal-process
(goalstack bindings success-msg lineage new-child-msg)
(let ((children nil)
(successes nil)
)
;; Create the lexical closures passed to subprocesses as
;; success and new child messages.
(flet ((child-success-msg (bindlst)
(push bindlst successes)
(funcall success-msg (car successes)))
(child-created-msg (proc)
(push proc children)
(funcall new-child-msg proc)))
;; Deactivate if deeper than current scheduler level.
(unless (<= (length lineage) *current-bc-proc-level*)
(deactivate-bc-process *current-process*))
;; Apply all rules whose premises have just been achieved,
;; and inhibit other processes from running until this one
;; finishes.
(with-scheduling-inhibited
(when goalstack
(loop while (eq (caar goalstack) '*rule*)
do (apply-rule (cadar goalstack) bindings)
do (pop goalstack)))
;; If there are no more goals to achieve, inform the
;; parent of success.
(when (null goalstack)
(funcall success-msg bindings)))
;; Update awareness of level in the decision tree.
(setq lineage (cons *current-process* lineage))
(when goalstack
;; Create a subnode for each matching rule.
(loop for r in (find-matching-rules (first goalstack))
do (make-subnode-for-matching-rule r goalstack bindings
#'child-success-msg #'child-created-msg lineage))
;; 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)))))
;;; The function PROCESS-OR-GOAL-SATISFACTION is called by the
;;; "OR-node" success message when the required number of
;;; disjunctive instances has been found.
(defun process-or-goal-satisfaction (children successes
new-child-msg goalstack
bindings child-success-msg
lineage
child-created-msg parent)
(print (list 'killing-children children 'from
*current-process*))
(loop for proc in children
unless (eq proc *current-process*) do
(print (list 'killing proc))
(kill-process proc))
(loop for instance in successes
for new-goalstack = (loop for g in goalstack
collect (fact-subst g instance))
for new-topgoal = (loop for g in goalstack
when (not (eq (car g) '*rule*))
return g)
for new-child = (make-process
:name (new-node-name
(format nil "~a"
(or new-topgoal
(list 'solved instance))))
:function (goal-object-achievement-method
new-topgoal)
:args (list new-goalstack bindings
child-success-msg
(cons parent (copy-tree lineage))
child-created-msg))
do (add-node-to-derivation-tree new-child
(cons parent copy-tree lineage))
*derivation-tree*)
(print-process-created-msg new-child instance
(cons parent lineage))
(push new-child children)
(funcall new-child-msg new-child))
(print (list 'killing-parent parent))
(kill-process parent)
(print (list 'killing-self *current-process*))
(kill-process *current-process*))
;;;; 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 INDEX-FORM takes a pattern or a partial pattern
;;; and turns it into its tree representation for insertion into
;;; the fact database.
(defun index-form (pattern)
(if (not (null (cdr pattern)))
(list (car pattern) (index-form (cdr pattern)))
pattern))
;;; The function RULE-INDEX-FORM takes a pattern or a partial
;;; pattern and turns it into its tree representation for
;;; insertion into the rule conclusion pattern tree.
(defun rule-index-form (pattern rule)
(if (not (null (cdr pattern)))
(list (car pattern) (rule-index-form (cdr pattern) rule))
(cons (car pattern) (list (list '*rules* rule)))))
;;; 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 ORIGINAL-VARNAME strips the system-created,
;;; unique identification suffix off so that a new one can be put
;;; on.
(defun original-varname (varname)
(let* ((var (symbol-name varname))
(pos (position #\> var)))
(if (not (null pos))
(subseq var 0 pos)
var)))
;;; The function TEST-RECURSIVE-PROCESSES is the top-level
;;; function for testing the recursive process functions later
;;; used by the backward chainer.
(defun test-recursive-processes ()
(make-process :name "top-query"
:function #'process-tester
:args (list 0 nil)))
;;; The function PROCESS-TESTER creates a new lexical closure,
;;; called POSTFN, which it passes to the next lower recursive
;;; level. Each level posts its results by executing the lexical
;;; posting closure that is passed down by its parent.
(defun process-tester (level postfn)
(unless (eq level 50)
(let ((board level))
(flet ((post ()
(incf board)
(print board)))
(make-process :name "default"
:function #'process-tester
:args (list (+ 10 level) #'post))
(loop repeat 8
unless (eq level 0)
do (funcall postfn)
(sleep .0005))))))
;;; 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 DESCEND-TREE-AND-ACTIVATE-NEXT-LEVEL is called
;;; by the BC scheduler when ALL-BC-PROCS-INACTIVE? returns T. It
;;; activates the next level of decision processes.
(defun descend-tree-and-activate-next-level (tree target-level
current-level)
(if (= target-level current-level)
(when (and (processp (car tree))
(process-alive-p (car tree)))
(when *extended-text-trace*
(print (list 'activating (car tree)
'level-current-level
(process-active-p *current-process*))))
(activate-process (car tree)))
(loop for branch in (cdr tree)
when (processp (car branch))
do (descend-tree-and-activate-next-level
branch
target-level
(1+ current-level)))))
;;; The function GOAL-OBJECT-ACHIEVEMENT-METHOD provides an
;;; abstraction for associating different goal classes (objects)
;;; with particular process definitions.
(defun goal-object-achievement-method (goal)
(case (car goal)
(or #'or-goal-process)
(and #'and-goal-process)
(cant-find #'cant-find-goal-process)
(t #'default-goal-process)))
;;; The function PRINT-TOP-LEVEL-RESULT prints out its message
;;; when an instance of the top-level (user-entered) pattern has
;;; been derived.
(defun print-top-level-result (pattern bindings)
(format t "~%****** TOP LEVEL RESULT : ~a **********~%"
(fact-subst pattern (propagate-bindings nil bindings))))
;;; 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 MAKE-SUBNODE-FOR-MATCHING-FACT is called by
;;; DEFAULT-GOAL-PROCESS when an instance of the goal pattern is
;;; found in the database. The purpose of the new subnode is to
;;; achieve the next item in the parent process's goal stack.
(defun make-subnode-for-matching-fact
(i goalstack bindings child-success-msg
child-created-msg
lineage)
(pop goalstack)
(let* ((new-bindings (make-bindings-for-matching-fact
i bindings))
(new-goalstack (make-goalstack-for-matching-fact
goalstack new-bindings))
(new-topgoal (loop for g in new-goalstack
when (not (eq (car g) '*rule*))
return g)))
(let ((new-child
(make-process :name (new-node-name
(format nil "~a" (or new-topgoal
(list 'solved i))))
:function (goal-object-achievement- method
new-topgoal)
:args (list new-goalstack new-bindings
child-success-msg
lineage child-created-msg))))
(add-node-to-derivation-tree
new-child
lineage
*derivation-tree*)
(funcall child-created-msg new-child)
(print-process-created-msg new-child i lineage))))
;;; The function MAKE-SUBNODE-FOR-MATCHING-RULE is called by
;;; DEFAULT-GOAL-PROCESS when a rule has been selected for trying
;;; to achieve the goal. The new node tries to achieve the
;;; premises of the rule.
(defun make-subnode-for-matching-rule
(r goalstack bindings child-success-msg child-created-msg lineage)
(pop goalstack)
(let* ((new-bindings
(make-bindings-for-matching-rule r bindings))
(new-goalstack (make-goalstack-for-matching-rule
r goalstack new-bindings)))
(let ((new-child
(make-process :name (new-node-name
(format nil "~a-~a" (car r)
(first new-goalstack)))
:function
(goal-object-achievement-method
(first new-goalstack))
:args (list
new-goalstack
new-bindings
child-success-msg
lineage child-created-msg))))
(add-node-to-derivation-tree
new-child
lineage
*derivation-tree*)
(funcall child-created-msg new-child)
(print-process-created-msg new-child r lineage))))
;;; The function DEACTIVATE-BC-PROCESS deactivates the given
;;; backward chainer process.
(defun deactivate-bc-process (proc)
(deactivate-process proc)
(when *extended-text-trace*
(print (list 'deactivating proc))))
;;; The function MAKE-BINDINGS-FOR-MATCHING-FACT propagates
;;; instance bindings made when looking up a fact.
(defun make-bindings-for-matching-fact (instance bindings)
(propagate-bindings '() (append instance bindings)))
;;; The function MAKE-BINDINGS-FOR-MATCHING-RULE propagates match
;;; bindings made when looking up a rule.
(defun make-bindings-for-matching-rule
(rule-bindings-pair bindings)
(propagate-bindings '()
(cons (second rule-bindings-pair)
bindings)))
;;; The function MAKE-GOALSTACK-FOR-MATCHING-RULE collects
;;; premises and propagates bindings through them.
(defun make-goalstack-for-matching-rule (rule-bindings-pair
goalstack bindings)
(loop for g in (make-goalstack-for-rule-match
(first rule-bindings-pair) goalstack)
collect (fact-subst g bindings)))
;;; The function MAKE-GOALSTACK-FOR-MATCHING-FACT propagates
;;; instance bindings through the goal stack.
(defun make-goalstack-for-matching-fact (goalstack bindings)
(loop for g in goalstack
collect (fact-subst g bindings)))
;;; 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))
;;; GET-DISJUNCTS collects the disjuncts from the complete
;;; pattern.
(defun get-disjuncts (or-goal-pattern)
(loop for term in (cdr or-goal-pattern)
unless (numberp term)
collect term))
;;; The function ADD-NODE-TO-DERIVATION-TREE inserts the new
;;; backward chainer decision process into the proper location in
;;; the tree based on its lineage.
(defun add-node-to-derivation-tree (new-node lineage tree)
(setq lineage (reverse lineage))
(when (equal (car lineage) "root")
(pop lineage))
(let ((match (loop for sub in (cdr tree)
when (equal (car lineage) (car sub))
return sub)))
(if match
(add-node-to-derivation-tree new-node
(reverse (cdr lineage)) match)
(setf (cdr tree) (cons (list new-node) (cdr tree))))))
;;; The function DERIVATION-TREE displays the tree of backward
;;; chainer decision processes.
(defun derivation-tree ()
(pprint *derivation-tree*))
;;; The function PRINT-PROCESS-CREATED-MSG is used for debugging
;;; purposes to increase verbosity during process creation.
(defun print-process-created-msg (child match lineage)
(when *extended-text-trace*
(with-process-lock (*print-lock*)
(format t "~%*** creating ~a~% parent: ~a" child
(list *current-process* (process-active-p *current-process*)))
(format t
"~% goalstack: ~a~% match: ~a~% lineage:~a ***~%"
(car (process-initial-arguments child)) match lineage))))
;;; The function KILL-EXTRA-BC-PROCESSES is called when all of
;;; the required instances of the top-level goal have been found.
(defun kill-extra-bc-processes (victims)
(print (list (length victims) 'victims))
(loop for v in (reverse victims)
unless (eq v *current-process*)
do (print (list 'killing v ))
(kill-process v))
(print (list 'killing-self *current-process*))
(kill-process *current-process*))
;;; The function MAKE-GOALSTACK-FOR-RULE-MATCH appends rule
;;; premises onto the goal stack.
(defun make-goalstack-for-rule-match (rule goalstack)
(let ((premises (get-rule-premises rule)))
(append premises (list (list '*rule* rule)) goalstack)))
;;; The function GET-RULE returns the given rule.
(defun get-rule (rule-name)
(loop for r in *current-rule-sets*
when (eq (car r) rule-name)
return (second r)))
;;; The GET-RULE-PREMISES returns the premises of the given rule.
(defun get-rule-premises (rule-name)
(loop for clause in (cdr (get-rule rule-name))
until (eq clause 'then)
collect clause))
;;; The function GET-RULE-CONCLUSIONS returns the conclusions of
;;; the given rule.
(defun get-rule-conclusions (rule-name)
(loop for clauses on (get-rule rule-name)
when (eq (first clauses) 'then)
return (cdr clauses)))
;;; The function APPLY-RULE applies a rule whose premises were
;;; true with the given bindings. It then propagates bindings
;;; through the conclusions and adds the resulting facts to the
;;; database.
(defun apply-rule (rule bindings)
(let ((bindingslst (propagate-bindings nil bindings)))
(with-process-lock (*print-lock*)
(format t "~%applying rule ~a from ~a ~%"
rule
*current-process* )
(format t " Deduced facts added to database:~%")
(loop for clause in (get-rule-conclusions rule)
do (add-fact (fact-subst clause bindingslst))
(format t " ~a~%" (fact-subst clause
bindingslst))))))
;;; The function CLEAR-FACTS erases the database.
(defun clear-facts ()
(setq *fact-tree* (list 'root)))
;;; The function PROPAGATE-BINDINGS propagates the bindings found
;;; during premise or rule matching through the rest of that
;;; rule's premises or conclusions.
(defun propagate-bindings (knowns unknowns)
(push (first unknowns) knowns)
(pop unknowns)
(if unknowns
(propagate-bindings knowns (sublis knowns unknowns))
knowns))
Generated with Harlequin WebMaker