;;; -*- Syntax:Common-Lisp; Mode: LISP; Package: (TMS Lisp 1000.); Base: 10. -*- (in-package 'tms) "(c) Copyright 1986, 1987, 1988, 1989 Xerox Corporation. All rights reserved. Subject to the following conditions, permission is granted to use and copy this software and to prepare derivative works: Such use, copying or preparation of derivative works must be for non-commercial research or educational purposes; each copy or derivative work must include this copyright notice in full; a copy of each completed derivative work must be returned to: DEKLEER@XEROX.COM (Arpanet) or Johan de Kleer, Xerox PARC, 3333 Coyote Hill Road, Palo Alto, CA 94304. This software is made available AS IS, and Xerox Corporation makes no warranty about the software or its performance." (defvar *immediately* T) ; Run every consumer immediately. (eval-when (compile load eval) ; I'm not sure if this is needed but it can't hurt. ;;; The CONSUMER struct is included in all consumers so that their function can be uniformly ;;; accessed. DEFCONSUMER forms a new struct type for each consumer but they all have ;;; (:include consumer (function )). (defstruct consumer #+:IL il:function ; this is the same temporary Interlisp #-:IL function ; screw as in all the DEFS structures. family ) ) ; Close eval-when for defstruct ;;; This does three things. ;;; (1) defines a defstruct to be associated with every instance of this consumer. ;;; [Great, Johan... so that's 1! What are the other two?? -- Jeff] ;;; If there are no variables, this does not construct a defstruct for this. ;;; Note that family is meaningless for variabless consumers. (defmacro defconsumer (name antecedents variables &body body &aux function-name names structure-name structure-names constructor-macro) (let ((*evaled-variables* ()) (*set-variables* ())) (declare (special *evaled-variables* *set-variables*)) (#+:IL walk-form #-:IL walk::walk-form (cons 'PROGN body) :walk-function #'(lambda (form context) #+Symbolics (declare (sys:downward-function)) (and (symbolp form) (not (#-:IL walk::variable-lexical-p #+:IL variable-lexical-p form)) (memq form variables) (if (eq context ':EVAL) (pushnew form *evaled-variables*) (pushnew form *set-variables*))) form)) (setq names (string name) structure-names (concatenate 'STRING names "-STRUCTURE") structure-name (intern structure-names) function-name (intern (concatenate 'STRING names "-FUNCTION")) constructor-macro (intern (concatenate 'STRING names "-MACRO"))) ;; If there are variables things are hairiest (cond (variables `(progn (defstruct (,structure-name (:PRINT-FUNCTION print-consumer) (:INCLUDE CONSUMER (#+:IL il:function #-:IL function #',function-name))) ,@(remove 'FAMILY variables)) ;; This is all a kludge.*** ;; instantiate-consumer could unravel this as a mcaro. (defmacro ,constructor-macro (family &rest initial-variables) `(,',(intern (concatenate 'STRING "MAKE-" structure-names)) :FAMILY ,family ,@initial-variables)) (defun ,function-name (.consumer. ,@antecedents) .consumer. (let ,(append (mapcar #'(lambda (variable) `(,variable (,(intern (concatenate 'STRING structure-names "-" (string variable))) .consumer.))) *evaled-variables*) (mapcan #'(lambda (variable) (unless (memq variable *evaled-variables*) `((,variable ())))) *set-variables*)) ,@body ,@(mapcar #'(lambda (variable) `(SETF (,(intern (concatenate 'STRING structure-names "-" (string variable))) .consumer.) ,variable)) *set-variables*))))) ;; If there are no variables things are easiest. (T `(progn (defmacro ,constructor-macro (&rest ignore) '#',function-name) (defun ,function-name (.consumer. ,@antecedents) .consumer. ,@body)))))) (defun print-consumer (consumer stream depth) (declare (ignore depth)) (format stream "#" (consumer-function consumer))) ;;; Have one of these, or make create-consumer a macro which figures this out. ;(defun create-one-argument-consumer ;;; This purely creates an instance of a consumer. (defmacro instantiate-consumer (name family &rest variables) `(,(intern (format nil "~A-MACRO" name)) ,family ,@variables)) ;;;**** consumer-constructor-macro unnecessary.*** now. ;;; This creates an instance of the consumer and schedules its exection. (defmacro create-consumer (name arguments family &rest variables) `(schedule-consumer ,arguments (,(intern (format nil "~A-MACRO" name)) ,family ,@variables))) ;;; Go to great lengths to preserve the order. (defun schedule-consumer (arguments consumer) (if (listp arguments) (create-conjunctive-consumer arguments consumer) (create-singleton-consumer arguments consumer))) ;;; This could be optimized by turning it into a macro. (defun create-conjunctive-consumer (arguments consumer &aux count type-so-far type) (setq count 0) (dolist (argument arguments) (incf count) (setq type (if (eq (name-symbol-name-symbol argument) 'CLASS) 'CLASS 'NODE)) (cond ((null type-so-far) (setq type-so-far type)) ((eq type-so-far type)) (t (add-mixed-consumer consumer arguments) (return-from create-conjunctive-consumer)))) (cond ((= count 0) (error "A consumer must have more than one antecedent")) ;***** we could optimize greatly if the count = 1. (t (selectq type-so-far (NODE (add-conjunctive-node-consumer consumer arguments)) (CLASS (add-mixed-consumer consumer arguments)))))) (defun create-singleton-consumer (antecedent consumer) (if (eq (name-symbol-name-symbol antecedent) 'CLASS) (add-consumer-to-class consumer antecedent) (add-node-consumer-to-node consumer antecedent))) (defvar *node*) ;;; Call this in the consumer if the current antecedent set is contradictory. (defun consumer-contradiction (reason) (contradiction (cons reason *antecedents*))) ;;; Note the change, conjunctive class consumers are now applyied. ;;; This gets invoked when the node justifying (defvar *antecedents* nil) (defconsumer new-add-conjunctive-consumer-internal (*node* &aux consumer *antecedents*) () (setq consumer (caar (n-a-justifications *node*)) *antecedents* (cdar (n-a-justifications *node*))) ;;******* equivalent in commmon (apply (if (symbolp consumer) consumer (consumer-function consumer)) consumer *antecedents*) (reclaim-node *node*)) ;;; A conjunction of antecedents to trigger a rule. ;;; Gets called on (self node supporters). ;;; If we wanted to be efficient, we could cache the consumer variable in the informant. (defun add-conjunctive-node-consumer (consumer *antecedents*) (cond (*immediately* (apply (if (symbolp consumer) consumer (consumer-function consumer)) consumer *antecedents*)) (t (let ((consumer-node (create-node *temp-node-datum*))) (justify-node consumer-node (cons consumer *antecedents*) T) (create-consumer NEW-ADD-CONJUNCTIVE-CONSUMER-INTERNAL consumer-node nil))))) (defconsumer delayed-gratification (node &aux informant) () (setq informant (first (first (n-a-justifications node)))) (justify-node (second informant) (third informant)) ;; The following line is sometimes commented out. Why? (reclaim-node node) ) ;;; This may seem extremely stupid, but it is extremely clever. ;;; ****** well if it is not currently blocked, why go through this nonsense. (defun justify-node-consumer (node justification &aux temporary) (setq temporary (create-node *temp-node-datum*)) (justify-node temporary (cons (list 'DELAY node justification) (cdr justification))) (create-consumer DELAYED-GRATIFICATION temporary nil) nil) ;;; A consumer gets called with [self node]. ;;; The basic ATMS calls this when a node goes out. At the moment all this status ;;; is not really used for much so this call is pointless --- nodes are never ;;; dequeued. If this function ever takes significant resources it can be thrown ;;; away. (defun out-node (node) ; (if (= (n-a-unique node) 2246.) ; (format T "~% Out-node: ~A" node)) (setf (n-a-status node) (if (n-a-has-consumers? node) (selectq (n-a-status node) (IN (push node *going-nodes*) 'GOING-OUT) (GOING-IN 'STAYING-OUT) (STAYING-IN 'GOING-OUT) ((OUT GOING-OUT STAYING-OUT) (error "Node ~A with consumers has status ~A, so why the call to outnode?" node (n-a-status node))) (T (error "Node ~A with consumers has status ~A" node (n-a-status node)))) 'OUT)) ; (if (= (n-a-unique node) 2246.) ; (format T "~% Out-node status is now: ~A, ~A" node (n-a-status node))) ) ;;; Is this now right?*********** NO******* not if there are********************* not ;;; in new regime with defstruct consumers. ;(defun has-consumers? (node &aux result1 result2) ; (setq result1 ; (dolist (consumer (n-a-consumers node)) ; (cond ((null consumer)) ; ((listp consumer) (if (cdr consumer) (return T))) ; (t (return T)) ; )) ; result2 (n-a-has-consumers? node)) ; (unless (equal result1 result2) (error "Mismatch")) ; result1 ; ; ) ;;; This runs the consumer ***NOW*** if possible. (defun add-immediate-consumer-to-node (consumer node) (if (n-a-envs node) (funcall consumer consumer node) (add-node-consumer-to-node consumer node))) ;;; These are the consumers for nodes alone. Cons the new consumer on the node's ;;; consumer list, and enqueue the node if it isn't enqueued already. ;;; The consumers of a node look like a list of lists. The first list is ;;; the consumers of the node. The remainder the consumers of the classes. ;;; The list is designed so that its car is ignored. Thus nconcing to the ;;; class structure, automatically adds consumers to the nodes it has. (defun add-node-consumer-to-node (consumer node &aux old-consumers) (setq *consumers-exist* t) (setq old-consumers (n-a-consumers node)) (cond ((null old-consumers) (setf (n-a-consumers node) (list (list 'MY-CONSUMERS consumer)))) ((car old-consumers) (rplacd (car old-consumers) (cons consumer (cdar old-consumers)))) (t (rplaca old-consumers (list 'MY-CONSUMERS consumer)))) (setf (n-a-has-consumers node) 1) (if (n-a-envs node) (enqueue-node node))) (defun add-class-consumer-to-node (consumer node &aux old-consumers) (setq *consumers-exist* t) (setq old-consumers (n-a-consumers node)) (if old-consumers (rplacd old-consumers (cons consumer (cdr old-consumers))) (setf (n-a-consumers node) (list nil consumer))) (if (cdr consumer) (setf (n-a-has-consumers node) 1)) (if (n-a-envs node) (enqueue-node node))) ;;; Consumer gets called with [self node supporters]. ;;; Convention is node will get recycled unless the consumer changes its datum. ;;; Note that in many cases, the consumer can save work by using at least the label. ;;; This tried to be very clever and avoid consing. However, the associated ;;; agenda mechanism will probably have to cons anyway so its unclear its ;;; worth the effort. Converting to CommonLisp I flushed the efficiency ;;; hack. (defun add-consumer-to-class (consumer class &aux last-consumer old-consumers) (setq *consumers-exist* t) (setq old-consumers (class-consumers class)) ;; This tries to save minimal conses, by not wiring up the consumers until there ;; actually are consumers around to wire up. (cond ((null old-consumers) (setq old-consumers (list 'MYSELF consumer) last-consumer (cdr old-consumers)) (setf (class-consumers class) old-consumers) (setf (class-last-consumer class) last-consumer) (dolist (node (class-nodes class)) (add-class-consumer-to-node old-consumers node) (if (n-a-envs node) (enqueue-node node)))) (t (rplacd (class-last-consumer class) (setf (class-last-consumer class) (list consumer))) (dolist (node (class-nodes class)) (setf (n-a-has-consumers node) 1) (when (n-a-envs node) (enqueue-node node)))))) ;;; ******* I bet you this does not handle idnetical antecedent classes *********** ;;; x x -> y will never fire*** ;;; Ordering is totally screwey.**** ;;; Now it starts to get a little hairy. Again, this implementation is dumb, but simple. ;;; Someone please give me an efficient version. This is n^m, I'm sure you ;;; can do nm. This does a few obvious blocking optimization. ;;; Don't forget that we have to handle the case, that the same node may be in ;;; multiple antecedent classes. ;;; Gets called on (self node supporters). ;;; See BCW's comments in todo file. If the same class occurs twice, this ;;; is brain dead. ;;; If the same class occurs twice this is relatively inefficient now, as ;;; it treats each class/position distinct. (defconsumer ADD-MIXED-CONSUMER-INTERNAL (node) (slot user-consumer slots) (dolist (set (node-sets node slot slots)) (add-conjunctive-node-consumer user-consumer set)) (if (eq (car slot) 'NEW-NODE) (rplaca slot 'OLD-NODE) (rplacd slot (cons node (cdr slot))))) ;;; This doesn't do any of the pre-screening which can be efficient in many circumstances. ;;; This is the analog to add-^-class-consumer-1. **** This bad because the weave ;;; below will get done even if there is nothing at all to do at all. ;;; Notice that slots are kept in reverse order here so that node-sets returns them in ;;; the correct order. (defun add-mixed-consumer (consumer antecedents &optional family &aux slots) (dolist (antecedent antecedents) ;; Use a cons here, has this gets rplacd'ed. (push (if (eq (name-symbol-name-symbol antecedent) 'CLASS) (cons antecedent nil) (cons 'NEW-NODE (cons antecedent nil))) slots)) (dolist (antecedent slots) (create-consumer ADD-MIXED-CONSUMER-INTERNAL (if (eq (car antecedent) 'NEW-NODE) (cadr antecedent) (car antecedent)) (if (symbolp consumer) family (consumer-family consumer)) :SLOT antecedent :USER-CONSUMER consumer :SLOTS slots))) ;;; This returns all possible sets, forcing the membership of node-class argument. ;;; **** do this for all node-sets variants. ;(defun node-sets (node class nodes) ; ;; First quickly check if there will be no sets. ; ;; ****** This could be modified to return a class/node if one of them isn't in? ; ;; ****** This just does the intern check. ; (dolist (node nodes) ; (cond ((eq class node)) ; ((eq (car node) 'NEW-NODE) (return-from NODE-SETS nil)) ; ((cdr node)) ; (t (return-from NODE-SETS nil)))) ; (let ((*sets* nil)) ; (node-sets-1 node class nodes nil) ; *sets*)) ;;; Remember that the same class can occur twice. ;;; This doesn't optimize the case where there is exactly one node. This will ;;; happen in mixed consumers. ;(defun node-sets-1 (node class-slot nodes set) ; (cond ((null nodes) (push set *sets*)) ; ((eq class-slot (car nodes)) ; (node-sets-1 nil nil (cdr nodes) (cons node set))) ; ((eq (caar nodes) 'NEW-NODE)) ; (t (dolist (new-node (cdar nodes)) ; (node-sets-1 node class-slot (cdr nodes) (cons new-node set)))))) ;;; Many of the sets are singletons and should (defun node-sets (node class nodes) ; (if (null (cdr nodes)) (incf foo)) ;; First quickly check if there will be no sets. ;; ****** This could be modified to return a class/node if one of them isn't in? ;; ****** This just does the intern check. (dolist (node nodes) (cond ((eq class node)) ((eq (car node) 'NEW-NODE) (return-from NODE-SETS nil)) ((cdr node)) (t (return-from NODE-SETS nil)))) (let ((sets nil)) (dolist (slot nodes) (cond ((eq class slot) (if sets (do ((set sets (cdr set))) ((null set)) (rplaca set (cons node (car set)))) (setq sets (list (list node))))) (sets (do ((set sets (cdr set))) ((null set)) (dolist (new-node (cddr slot)) (push (cons new-node (car set)) sets)) (unless (cadr slot) (error "How can this be")) (rplaca set (cons (cadr slot) (car set))))) (t (dolist (new-node (cdr slot)) (push (list new-node) sets))))) sets)) ;;; A constraint consumer is a consumer that fires if all but one. It has a ;;; strong built in presumption about the symmetry. As usual this ;;; handles duplicates at great expense. This is similar, but far from ;;; identical to the conjunctive consumer. ;;; This also uses exponentially too much space. Some day fix if matters. Look at ;;; the summer constraint of old envision to get an idea for how to do it. ;;; ******* if the class types are unique!!************ then much more efficiency is ;;; possible. ;;; **** why can't the closed over variables be stored in the informant. ;;; ***** why isn't a closure a pair? ;;; Consumer will be called (f nodes informant). ;;; This used to use make-art-q-list and g-l-p, which I flushed as there seems ;;; no point in using it as an array. ;;;****** if the user constructed a consumer which remembered informant, this ;;;****** indirect would not be necessary. (defconsumer add-conditional-internal (&rest antecedents) (user-consumer consumer-family) (funcall user-consumer antecedents consumer-family)) (defun add-conditional-conjunctive-class-consumer (consumer classes family condition) (create-consumer ADD-CONDITIONAL-INTERNAL (cons condition classes) family :USER-CONSUMER consumer :CONSUMER-FAMILY family)) ;;; Consumer is called with (tnode single-unknown-class node-set-with-unknown-absent) ;;; The problem solver decides what to do about this. ;;; Constraint consumers: ;;; *** this could be haired up as the conjunctive one. (defun add-constraint-class-consumer (ignore consumer2 classes informant) (add-general-constraint consumer2 classes informant nil)) ;;; This constraint is only active if it is conjoined with a node. ;;; ****** condition ;;; ***** add consumer to condition to wait until it gets in.******* ;;; ***** this is rather inefficient. ;;; All these constraint consumers suffer from the problem that the same class may ;;; appear twice.****** ;;; Could optimize case where each class occurs once. ;;; Could optimize case where a node is in at most one class. (defun add-c-c-c-c (consumer classes informant condition) (add-general-constraint consumer classes informant condition)) (defconsumer add-general-constraint-internal (node) (slot constraint) (add-constraint-class-consumer-1 .consumer. slot constraint node)) (defun add-general-constraint (consumer classes informant condition &aux constraint list-classes) (setq list-classes (mapcar #'list classes) constraint (make-constraint :CONSUMER consumer :INFORMANT informant :CONDITION condition :CLASSES list-classes)) (dolist (slot list-classes) (create-consumer ADD-GENERAL-CONSTRAINT-INTERNAL slot (informant-family informant) :SLOT slot :CONSTRAINT constraint))) ;;; Remember this gets called when the node is added to the class which is part of ;;; a class constraint. ;;; *** cold also check that the cosntraint-informant is also in...... ;;; Look at old envision for efficiency hacks here.**** (defun add-constraint-class-consumer-1 (me class-slot constraint node &aux unknown-class) (declare (ignore me)) (unless (dolist (slot (constraint-classes constraint)) (cond ((cdr slot)) ((eq class-slot slot)) (unknown-class (return T)) (t (setq unknown-class slot)))) (if unknown-class (dolist (set (constraint-node-sets node class-slot constraint)) ;;; ************ save conses, put on end. (add-constraint-consumer (car unknown-class) constraint set)) (dolist (unknown-class (constraint-classes constraint)) (unless (eq unknown-class class-slot) (dolist (set (node-setsa node class-slot unknown-class constraint)) (add-constraint-consumer (car unknown-class) constraint set)))))) (rplacd class-slot (cons node (cdr class-slot)))) ;;; **constraints need to be consumers. (defconsumer add-constraint-consumer-internal (&rest antecedents) (constraint unknown-class) (invoke-constraint-consumer constraint antecedents unknown-class)) (defun invoke-constraint-consumer (constraint antecedents unknown-class) (funcall (constraint-consumer constraint) nil unknown-class antecedents (constraint-informant constraint))) ;;; Notice that here set will always be a set of nodes. (defun add-constraint-consumer (unknown-class constraint set) ;;; ************ save conses, put on end. (if (constraint-condition constraint) (push (constraint-condition constraint) set)) ;; The following test avoids creating a consumer. (if *immediately* (invoke-constraint-consumer constraint set unknown-class) (create-consumer ADD-CONSTRAINT-CONSUMER-INTERNAL set constraint :CONSTRAINT constraint :UNKNOWN-CLASS unknown-class))) ;;; Like other node sets but it forcibly excludes ignore-class. (defun node-setsa (node class-slot ignore-class-slot constraint &aux *sets*) (node-setsa-1 node class-slot ignore-class-slot (constraint-classes constraint) nil) ; (format T "~% Computed ~D node sets" (length *sets*)) *sets*) (defun node-setsa-1 (node class-slot ignore-class-slot nodes set) (cond ((null nodes) (push set *sets*)) ((eq class-slot (car nodes)) (node-setsa-1 nil nil ignore-class-slot (cdr nodes) (cons node set))) ((eq ignore-class-slot (car nodes)) (node-setsa-1 node class-slot nil (cdr nodes) set)) (t (dolist (new-node (cdar nodes)) (node-setsa-1 node class-slot ignore-class-slot (cdr nodes) (cons new-node set)))))) (defun constraint-node-sets (node class-slot constraint &aux *sets*) (constraint-node-sets-1 node class-slot (constraint-classes constraint) nil) *sets*) (defun constraint-node-sets-1 (node class-slot nodes set) (cond ((null nodes) (push set *sets*)) ((eq class-slot (car nodes)) (constraint-node-sets-1 nil nil (cdr nodes) (cons node set))) ((cdar nodes) (dolist (new-node (cdar nodes)) (constraint-node-sets-1 node class-slot (cdr nodes) (cons new-node set)))) (t (constraint-node-sets-1 node class-slot (cdr nodes) set)))) ;;; A conditional disjunctive constraint consumer, is a kind of constraint which gets ;;; get triggered when any one of its inputs gets a value AND the node it is ;;; conditional on holds. ;;; **************** make all callers to add-d-c-c-c take the two arguments class/condition. ;;;********* consumer is not called this way any more. ;;;***** informant can be dumped because its in family, but that requires changing model. (defconsumer class-condition (&rest supporters) (consumer informant) (funcall consumer supporters informant)) ;;; User invoked. (defun add-c-d-c-c-c (user-consumer classes informant condition &aux consumer) (setq consumer (instantiate-consumer CLASS-CONDITION (informant-family informant) :CONSUMER user-consumer :INFORMANT informant)) (dolist (class classes) (schedule-consumer (list class condition) consumer))) ;;; The new agenda mechanism is organized by the environment waiting to be run. ;;; Call this when a consumer first gets attached to a node, or when a new environment ;;; is added to a node. :AGENDA/:BLOCKED indicates which queue this node is currently on. ;;; This enqueues the node onto the current agenda or blocked nodes database. ;;; This gets called by the TMS whenever it thinks it has added an environment to a node. (defun enqueue-node (node) ; (if (= (n-a-unique node) 2246.) (format T "~% Trying to queue ~A" node)) (selectq (n-a-enqueued? node) ;; This used to call (insert-in-agenda node), but that should be redundant. ;; If the node is in the agenda right now, this action should have no effect. (:AGENDA) ;; If the node wasn't in the focus, it may become in the focus. (:NOT-IN-FOCUS (if (in-focus? node) (insert-in-agenda node))) (:BLOCKED (unless (fast-simple-blocked? node nil) ;;; Should be some other flag. Fast-simple-blocked? will remove this node ;;; from the queues if it just became unblocked. (insert-in-agenda node))) (T (cond ((blocked? node)) ((unfocussed? node)) (t (insert-in-agenda node))))) ; (when (= (n-a-unique node) 2246.) ; (format T "~% Status: ~A" (n-a-enqueued? node)) ; (if (subset-env? (hybrid-label node) *current-focus*) ; (error "Can't happen")) ) ;;; This is FIFO as we want. *agenda* consists of triples: (size last . envs) ;;; This does not check for blocking, however, I suspect that some of the functions ;;; that call this should because they might inadvertently schedule a consumer ;;; that should not be run. (defun insert-in-agenda (node &aux env size consumer-nodes nodes envs) ; (if (= (n-a-unique node) 2810.) (format T "~% Trying to insert ~A" node)) (setf (n-a-enqueued? node) :AGENDA) (setq env (shortest-env (n-a-envs node)) consumer-nodes (env-consumer-nodes env)) ;; If the env has consumers, then it already is on agenda. ;; Consumer-nodes should not have duplicates on it. (cond (consumer-nodes (setq nodes (ncons node)) (rplacd (car consumer-nodes) nodes) (rplaca consumer-nodes nodes) ) (t (setq nodes (ncons node)) (setf (env-consumer-nodes env) (cons nodes nodes)) (setq size (env-count env) envs (ncons env)) (do ((previous nil next) (next *agenda* (cdr next))) ((null next) (if previous (rplacd previous (ncons (cons size (cons envs envs)))) (setq *agenda* (ncons (cons size (cons envs envs)))))) (cond ((= size (caar next)) (rplacd (cadar next) envs) (rplaca (cdar next) envs) (return nil)) ((> (caar next) size) (if previous (rplacd previous (cons (cons size (cons envs envs)) next)) (setq *agenda* (cons (cons size (cons envs envs)) next))) (return nil))))))) ;;; It might be worth organizing labels so that the shortest environment was always ;;; first. (defun shortest-env (envs &aux size new-size new-env) (if (atom envs) (return-from shortest-env envs)) (dolist (env envs) (setq new-size (env-count env)) (if (or (null size) (< new-size size)) (setq size new-size new-env env))) new-env) ;;; We'll find these when we pop them off. (defun dequeue-node (node) ; (if (= (n-a-unique node) 2246.) (format T "~% Dequeueing ~A" node)) (setf (n-a-enqueued? node) nil)) ;;; Used in focussed modes only. (defun failing-run? (&aux *contradiction*) ; (if cl-gde::*new-contradictions* (error "Senseless call")) (run) ; (if *contradiction* (format T "~% Contradiction is at: ~A" (car *contradiction*))) ; (print (list 'end cl-gde::*new-contradictions*)) (or (env-contradictory *current-focus*) *contradiction*)) ;;; Remember a consumer is always a list of lists. (defun run (&aux node consumer consumer-nodes envs) ; (setq start-time (get-internal-run-time)) (do nil ((null *agenda*)) (when (and *current-context* *current-nogoods*) (dependency-directed-backtracking)) (when (eq *current-context* 'FAIL) (setq *agenda* nil) (return nil)) (setq envs (cddar *agenda*)) (cond ((null envs) (setq *agenda* (cdr *agenda*))) ((null (setq consumer-nodes (env-consumer-nodes (car envs)))) (cond ((null (cdr envs)) (setq *agenda* (cdr *agenda*))) (t (rplacd (cdar *agenda*) (cdr envs))))) ;;**** this is not true anymore. We have to check for blocked-envs all the time because ;; nothing updates their queuing status when current context changes.******* FIX. ;; so I uncommented out the commented out block-node? ; ((blocked-env? (car envs))) (t (setq node (cadr consumer-nodes)) (rplacd consumer-nodes (cddr consumer-nodes)) (unless (cdr consumer-nodes) (setq consumer-nodes nil) (setf (env-consumer-nodes (car envs)) nil)) (cond ((neq :AGENDA (n-a-enqueued? node))) ((i-out? node) (dequeue-node node)) ;; This line ***must be here*** ((blocked? node)) ;;;******?????Don't when inserted. ((unfocussed? node)) ((if (atom (n-a-envs node)) (neq (car envs) (n-a-envs node)) (not (memq (car envs) (n-a-envs node)))) (insert-in-agenda node)) (t (if *trace* (format T "~% Running consumers of ~A : ~A" node (n-a-consumers node))) (dequeue-node node) ;;**** isn't this wrong as a shorter environment may be entered??? ;; Every slot on consumers points to one before. I flushed locatives. (do nil (nil) (unless (n-a-envs node) (return nil)) (if (do ((consumers (n-a-consumers node) (cdr consumers))) ((null consumers) (setf (n-a-has-consumers node) 0) T) (setq consumer (cdar consumers)) (when consumer (rplaca consumers consumer) (invoke-consumer (car consumer) node) ;; ***** Here we should have some code that ;; aborts when the focus becomes empty./inconsistent. (when (or (eq *foci* :EMPTY) *contradiction*) ;; Processing the consumers must be an atomic operation ;; or we must requeue. (or (cdr consumers) (cdr consumer) (setf (n-a-has-consumers node) 0)) (if (n-a-envs node) (enqueue-node node)) (return-from run nil)) (update-atms) (process-queued-nogoods) (return nil))) (return nil)) (and *current-context* *current-nogoods* (return nil)))))))) ;(format T "~% Running time is:~D seconds" (time-taken start-time)) ) (defun invoke-consumer (consumer *node*) (incf *consumer-invokations*) (cond ((or (functionp consumer) (symbolp consumer)) (funcall consumer consumer *node*)) ((invoke-consumer? consumer *node*) (funcall (consumer-function consumer) consumer *node*)) (t (push consumer (n-a-justification-consumers *node*))))) ;;; If a family slot is provided, don't trigger the consumer unless it is justified ;;; somehow else. Notice this could be smarter and not trigger until that consumer ;;; provided support.****** THIS COULD BE A HELL OF A LOT SMARTER. (defun invoke-consumer? (consumer node &aux family informant) (or (null (setq family (consumer-family consumer))) (dolist (j (n-a-justifications node)) (setq informant (just-informant j)) (unless (and (not (symbolp informant)) (not (listp informant)) (eq family (informant-family informant))) (return T))) ;; Pclauses are probably obsolete. (dolist (c (n-a-pclauses node)) (unless (eq family (informant-family (clause-informant c))) (return T))) (if (n-a-neg node) (dolist (c (n-a-nclauses (n-a-neg node))) (unless (eq family (clause-informant c)) (return T)))) )) ;;; Worked out by Johan de Kleer and Brian Williams. (defun make-control-disjunction-node (assumptions) assumptions ) ;;; This is the stuff I promised not to do: dependency-directed backtracking. ;;; This version is simplistic: ;;; o Assumes each assumption (defvar *trace-ddb* nil) ;;; Control stack entries are now: (assumptions current-assumption previous-environment). (defun assert-control-disjunction (assumptions) (dolist (assumption assumptions) (setf (assumption-addb-index assumption) *addb-count*) (push assumptions (assumption-disjunctions assumption))) (push (list assumptions (car assumptions) (or *current-context* *empty-env*)) *control-stack*) (if *trace-ddb* (format T "~% Adding first assumption of a new control disjunction: ~A" (string-assumption (car assumptions)))) (setq *current-context* (fast-cons-env (or *current-context* *empty-env*) (car assumptions) T)) (incf *addb-check-count*) (unblock) ;; We really need to check whether anything is blocked now.***** ) (defvar *show-backtracks* nil) ;;; Assumes you don't like the current context anymore (it need not be nogood). ;;; Returns NIL on failure, in which case *current-context* is the atom FAIL. (defun dependency-directed-backtracking (&aux oldest-contra next-current-context) (if (eq *current-context* 'FAIL) (return-from DEPENDENCY-DIRECTED-BACKTRACKING nil)) ;; First search back to a point which avoids all known contradictions. (setq oldest-contra (unwind-stack)) ;; At this point oldest-contra points to the current stack position which is failing. ;; Here we've backtracked to the last contradiction, or else there is an ATMS bug somewhere. ;; We've backtracked to the last contradiction, pick a next assumption if we can. (setq next-current-context nil) (do nil (nil) (unless oldest-contra (return)) (when (dolist (next-assumption (cdr (memq (cadar oldest-contra) (caar oldest-contra)))) ;; If all are false, this should do more intelligent things.***** (incf *addb-check-count*) (cond ((i-false? next-assumption)) ((and (not (simple-envp (setq next-current-context (fast-cons-env *current-context* next-assumption T)))) (env-contradictory next-current-context)) (if *trace-ddb* (format T "~% Can't add next assumption: ~A" (string-assumption next-assumption)))) (t (if *trace-ddb* (format T "~% Adding next assumption: ~A" (string-assumption next-assumption))) (rplaca (cdar oldest-contra) next-assumption) (rplaca (cddar oldest-contra) *current-context*) (setq *current-context* next-current-context) (if (complete oldest-contra) (return T)) (setq *current-context* (caddar oldest-contra))))) (if (or *trace-ddb* *show-backtracks*) (format T "~% Backtracked to: ~A" *current-context*)) (unblock) (return-from DEPENDENCY-DIRECTED-BACKTRACKING T)) (if (and (or (eql *h4* 1) *resolve-by-labeling* *resolve-by-ordered-labeling*) *contradict-solutions*) (error "Can't happen")) (incf *exhaustions*) (if *trace-ddb* (format T "~% Exhausted the disjunction: ~A" (caar oldest-contra))) (setq oldest-contra (cdr oldest-contra) *current-context* (caddar oldest-contra))) (if *trace-ddb* (format T "~%Can't backtrack anymore --- no more consistent interpretations.")) (setq *current-context* 'FAIL) nil) ;;; This only bothers remembering those nogoods which are subsets of the current (defun signal-nogood (env) (and *current-context* (vector-subset (env-vector env) (generic-env-vector *current-context*)) (push env *current-nogoods*))) (defun backtrack (print) (dotimes (j 1000000.) (if print (format T "~% Solution ~D : ~A, Environments = ~D" j (string-env *current-context*) *env-counter*)) (if (and *contradict-solutions* (or (eql *h4* 1) *resolve-by-labeling* *resolve-by-ordered-labeling*)) (let (*going-nodes*) (contradictory-env (simple-to-env *current-context*) '(SPECIOUSNESS)) (process-changed-nodes) )) (process-queued-nogoods) (unless (dependency-directed-backtracking) (return nil)) (if (eq 'FAIL (catch 'CONTRADICTION (run))) (return nil)) (if (eq *current-context* 'FAIL) (return nil)) )) ;;; Simply unwind the stack until one element of every *current-nogoods* is removed. ;;; Leaves *current-context* pointing at a consistent context. oldest-contra at ;;; the next stack position. This assumes every nogood is a subset of the current ;;; context. If not this will either error out or produce bad results. (defun unwind-stack (&aux stack previous-stack) (setq stack *control-stack*) (if *trace-ddb* (format T "~% Backtracking because current context contains nogoods: ~A" *current-nogoods*)) (if *current-nogoods* (dolist (nogood *current-nogoods*) (do nil (nil) (cond ((vector-subset (env-vector nogood) (generic-env-vector *current-context*)) (if *trace-ddb* (format T "~% To avoid contradiction ~A, removing the assumption: ~A" (string-env nogood) (string-assumption (cadar stack)))) ; We should delete the singleton nogoods soon... ; (when (eq nogood (assumption-env (cadar stack))) ; (rplaca (car stack) (fdelq (cadar stack) (setq *current-context* (caddar stack) previous-stack stack stack (cdr stack)) ) (t (return nil))))) (setq *current-context* (caddar stack) previous-stack stack)) (setq *current-nogoods* nil) previous-stack) ;;; oldest-contra is points at the current point in the stack. (defun complete (oldest-contra &aux new-control-stack current-context) (setq current-context *current-context*) (cond ((eq oldest-contra *control-stack*)) (t (do ((cs *control-stack* (cdr cs))) ((eq cs oldest-contra)) (setq new-control-stack cs)) ;; *** the current context should be doubly linked. (dolist (assumption (caar new-control-stack)) (incf *addb-check-count*) (cond ((i-false? assumption) ;; Something should delete this assumption. But not here ) ((and (not (simple-envp (setq *current-context* (fast-cons-env *current-context* assumption T)))) (env-contradictory *current-context*)) (setq *current-context* current-context)) (t (rplaca (cdar new-control-stack) assumption) (rplaca (cddar new-control-stack) current-context) (cond ((complete new-control-stack) (return T)) (t (setq *current-context* current-context))))))))) ;;; There must be one environment whose disjuntion assumptions are all in current context. ;;; **** probably a flag necessry. ;;; **** also a node can become ublocked when an environment is added to it. ;;; **** this works but is inefficient has hell. ;;; **** also a node can be put here more than once. (May not matter). ;;; Note that the node is not considered queued after it is blocked. (defun blocked? (node) (when *current-context* (cond ((eq (n-a-enqueued? node) :BLOCKED)) ((not (fast-simple-blocked? node)) nil) (t (setf (n-a-enqueued? node) :BLOCKED) T)))) ;;; Returns T if the node isn't in current focus. (defun unfocussed? (node) (when *foci* (cond ((eq (n-a-enqueued? node) :NOT-IN-FOCUS)) ;; This checks every consumer execution for being in focus. ((not (in-focus? node)) ;; Could we optimize by having a node falg indicating it ;; was in *unfocussed-nodes*? (push node *unfocussed-nodes*) (setf (n-a-enqueued? node) :NOT-IN-FOCUS) T)))) ;;; This simply checks whether the given node is blocked ;;; BUG HERE? consistent with.********* ;;; Obsolete?**** (defun simple-blocked? (node &aux vector) (when *current-context* (setq vector (generic-env-vector *current-context*)) (not (dolist (e (n-a-envs node)) (unless (dolist (c (env-assumptions e)) (and (assumption-disjunctions c) (not (vector-member c vector)) (return T))) (return T)))))) ;;; This uses the first assumption as an index, if there are multiple environments ;;; with the same first index this does extra work. If this conses a lot ;;; we can save those too. If the node is now unblocked, this makes sure ;;; the node is removed from all blocked-node lists. Notice we can still ;;; sometimes get duplicates because envs get added and removed as problem solving ;;; progresses. Nothing takes the blocking off when an environment is removed from a node. ;;; Maybe we should??? ;;; The idea is that every environment of the label of a node should be blocked waiting ;;; for exactly one assumption. If needed-assumption is NIL, clean up the data structures. (defun fast-simple-blocked? (node &optional needed-assumption &aux vector blocked) (cond ((null *current-context*) nil) ((i-true? node) nil) (T (setq vector (generic-env-vector *current-context*)) (dolist (e (n-a-envs node)) (when (or (null needed-assumption) (memq needed-assumption (env-assumptions e))) (unless (dolist (c (env-assumptions e)) (when (and (assumption-disjunctions c) (not (vector-member c vector))) (pushnew c blocked) (return T))) ;; This is slightly overkill because the context might become inconsistent ;; This unblocks this node from all possible places. (unless needed-assumption (dolist (e (n-a-envs node)) (dolist (a (env-assumptions e)) (setf (assumption-blocked-nodes a) (fdelq1 node (assumption-blocked-nodes a)))))) (return-from FAST-SIMPLE-BLOCKED? nil)))) ;; It may not be worth the trouble detecting duplicates... (dolist (b blocked) (pushnew node (assumption-blocked-nodes b))) T))) ;;; This is non-standard actually: A consumer is run only if it has some ;;; environment whose every control assumption appears in the current context. ;;; We can recycle conses here if we need to. Or have an extra field in a consumer/node ;;; for threading. (defun unblock () (dolist (a (generic-env-assumptions *current-context*)) (dolist (b (assumption-blocked-nodes a)) (cond ((neq (n-a-enqueued? b) :BLOCKED)) ((fast-simple-blocked? b a)) (T (insert-in-agenda b)))) (setf (assumption-blocked-nodes a) nil))) ;;; New blocking code for run. ;;; An environment is blocked if all its control disjunctions don't appear in the ;;; current context. ***[unimplemented] it is consistent with *current-context* ;;; Envs point to nodes, so the following when implemented is much better. (defun simple-blocked-env? (env) (dolist (a (env-assumptions env)) (and (assumption-disjunctions a) (not (memq a (generic-env-assumptions *current-context*))) (return T)))) ;(defun enqueue-node-if-not-blocked (node known-blocked-env) ; known-blocked-env ;;; Finds the shortest environment among envs which is not blocked. (defun shortest-non-blocked-env (envs &aux size new-size new-env) (dolist (env envs) (setq new-size (env-count env)) (and (or (null size) (< new-size size)) (not (simple-blocked-env? env)) (setq size new-size new-env env))) new-env) ;;;****** THIS SHOULD GO IN ANOTHER FILE SOON. (defconsumer equality-consumer (from condition) (result informant predicate) (unless (and predicate (not (funcall predicate (n-a-datum from)))) (clobber result (n-a-datum from) (list informant from condition)))) ;;; This ensures the value on var1 will always be propagated to var2 as long as condition ;;; holds. (defun equality-constraint (var1 var2 condition informant &optional predicate) (create-consumer EQUALITY-CONSUMER (list var1 condition) (informant-family informant) :RESULT var2 :INFORMANT informant :PREDICATE predicate) (create-consumer EQUALITY-CONSUMER (list var2 condition) (informant-family informant) :RESULT var1 :INFORMANT informant :PREDICATE predicate))