;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Schema -*-

;;;; The running routines that make up the schema mechanism.
;;;; This was originally the last 40% of SCHEMA.LISP.

;;; [This file was inspired by Ramstad's implementation of Drescher's
;;; system, but Ramstad's version has by now been 80% or more rewritten.]

(in-package :schema)

;;; The reason that these are expressed as two separate macros is because the
;;; structure of some of the updaters (currently, SCHEMA-UPDATE-EXT-ITEM-STATS,
;;; SCHEMA-UPDATE-EXT-CONJ-STATS, and NEW-SCHEMA-UPDATE-EXT-ITEM-STATS)
;;; don't quite fit the model assumed by WITH-UPDATE-FRAMEWORK.  Hence, we break
;;; things out so I can still use some of the modularization below.  The reason for the
;;; little IFFER macros is because NEW-SCHEMA-UPDATE-EXT-ITEM-STATS basically can't
;;; take advantage of any of this stuff anyway, because it's based on iterators.
(defmacro UPDATE-FRAMEWORK-IFFER (what iteration-variable)
  (let ((iffer (intern-format "~A-if" what)))
    `(,iffer (fix= 0 (rem ,iteration-variable 2))
      (safe-format *output-stream* "~35T")	; !SF!
      (format *output-stream* "~%"))))

(defmacro WITH-UPDATE-FRAMEWORK-INNARDS (what
					 (iteration-variable iteration-limit)
					 (individual-variable individual-accessor)
					 (format-string &rest format-args)
					 &body body)
  (let ((formatter (intern-format "~A-format" what)))
    ;; The original code, in most cases, used DOTIMES instead of LOOP.
    ;; However, I had to change to LOOP in the case of SCHEMA-UPDATE-EXT-CONJ-STATS
    ;; for what I can only think is a Genera compiler bug, so I'll use LOOP for all the rest, too.
    `(loop for ,iteration-variable from 0 below ,iteration-limit
	   do (let ((,individual-variable (,individual-accessor ,iteration-variable)))
		,@body
		(when ,format-string  ; Allow turning it off.  (It'd be cleaner to do this at compile-time, not runtime, but this is easy & not too slow.)
		  (,formatter ,format-string ,@format-args)))
	      (update-framework-iffer ,what ,iteration-variable))))

(defmacro WITH-UPDATE-FRAMEWORK ((what pretty-what)
				 (iteration-variable iteration-limit)
				 (individual-variable individual-accessor)
				 (format-string &rest format-args)
				 &body body)
  (let ((formatter (intern-format "~A-format" what)))
    `(progn
       (,formatter (format nil "updating ~A~%" ,pretty-what))
       (with-update-framework-innards ,what
				      (,iteration-variable ,iteration-limit)
				      (,individual-variable ,individual-accessor)
				      (,format-string ,@format-args)

	 ,@body)
       (,formatter "~%"))))

;;; It turns out that all the callers of the above three macros, now that they're properly broken out,
;;; always do so when they're mapping over schema (not items, conjs, or whatever), and they always
;;; name their iteration variables the same, too.  So package up this common idiom and make life easier.
(defmacro WITH-SCHEMA-UPDATE-FRAMEWORK-INNARDS (what
						(format-string &rest format-args)
						&body body)

  `(with-update-framework-innards ,what
				  (schema-index *schema-number*)
				  (schema get-schema)
				  (,format-string ,@format-args)
     ,@body))

(defmacro WITH-SCHEMA-UPDATE-FRAMEWORK (what
					(format-string &rest format-args)
					&body body)
  `(with-update-framework ,what
			  (schema-index *schema-number*)
			  (schema get-schema)
			  (,format-string ,@format-args)
     ,@body))
  
(defmacro SCHEMA-UPDATE-FRAMEWORK-IFFER (what)
  `(update-framework-iffer ,what schema-index))

;;;; Major function:  SCHEMA-UPDATE-APPLICABLE.

(defmacro CONTEXT-SATISFIED-P (array)
  `(state-array-included-p *microworld-state* ,array *microworld-state-size*))

(defmacro CONJ-SATISFIED-P (conj-index)
  `(state-on-p (conj-current-state
                (get-conj ,conj-index))))

;;; For each schema with satisfied context, mark it as applicable.
;;; An empty context is always satisfied, otherwise, it is satisfied if
;;; a) the context has been made into a conj and the conj is ON
;;; b) each state in the context is matched by the microworld state.

;;; Broken out so I can debug some applicability probems with goals.
(defsubst COMPUTE-SCHEMA-APPLICABLE (schema)
  (or (schema-context-empty-p schema)
      (if (schema-context-conj-p schema)
	  (conj-satisfied-p
	    (schema-context-item schema))
	  (context-satisfied-p
	    (schema-context-array schema)))))

(defun SCHEMA-UPDATE-APPLICABLE ()
  (with-schema-update-framework (applicable "applicable")
				("~4D ~25A~A"
				 schema-index
				 (schema-print-name schema)
				 (flag-unparse (schema-applicable schema)))
    (setf (schema-applicable schema)
	  (flag-parse
	    (compute-schema-applicable schema)))))

;;; *** start update accessibility / create goal-directed actions ***

;;; NOTE:  The MIT Press version of Drescher's algorithm doesn't use
;;; any of this code, rather, goal-directed actions are created for
;;; each unique result which is included in a schema.

;;; This code updates accessibility for items and conjunctions and
;;; makes goal-directed-actions for those which are highly accessible.
;;; Must be called *after* schemas have been marked applicable.

;;; The following two functions (ACCESSIBLE-KEY and ACCESSIBLE-TEST) are
;;; used via ASSOC by the main UPDATE-ACCESSIBILITY routine -- they
;;; should only be used by that routine (they are fairly specifically
;;; designed for that routine only).

;;; ACCESSIBLE-TEST assumes that RESULT-SCHEMA has a non-NIL result
;;; (obviously not interesting), and that CONTEXT-SCHEMA has a non-NIL
;;; context (as the first pass in the main UPDATE-ACCESSIBILITY insures
;;; that these are all dealt with).

;;; When calling via ASSOC, RESULT-SCHEMA is bound to the result of
;;; evaluating the key for the given car of the ASSOC pair 
;;; (in the case of the UPDATE-ACCESSIBILITY routine, the CAR is a
;;; schema-index, and the ACCESSIBLE-KEY function gives us the actual
;;; schema).
;;; CONTEXT-SCHEMA is bound to the argument that ASSOC is looking for
;;; (in the UPDATE-ACCESSIBILITY routine, it is the schema for which we
;;; are attempting to find a result which chains to its context).
;;; Returns T when result of RESULT-SCHEMA implies context of
;;;   CONTEXT-SCHEMA.

(defun ACCESSIBLE-KEY (y)
  (get-schema y))

(defun ACCESSIBLE-TEST (context-schema result-schema)
  ;; RESULT must be non-NIL to satisfy anything.
  (let ((result-data (schema-data result-schema))
        (context-data (schema-data context-schema)))
    (if (schema-data-result-conj-p result-data)
        ;; If result conjunction, check to see if context
        ;; is conjunction too.
        (if (schema-data-context-conj-p context-data)
            ;; If so, entry in the result conjunction inclusion
            ;; array set correctly implies context satisfied.
            (flag-truep
	      (flag-array-get-flag
		(conj-inclusion-array
		  (get-conj (schema-result-item result-schema)))
		(schema-context-item context-schema)))
	    ;; If context not conjunction, check array directly.
	    (state-array-included-p
	      (conj-item-array
		(get-conj (schema-result-item result-schema)))
	      (schema-context-array context-schema)
	      *fixna-required-to-hold-all-item-states*))
	;; Otherwise, context must be single, and stuff match up
	;; (return the value t or nil as appropriate).
	(and (schema-data-context-single-p context-data)
	     (state-eq (if (schema-data-result-negated-p result-data)
			   (make-state-off)
			   (make-state-on))
		       (state-array-get-state
			 (schema-context-array context-schema)
			 (schema-result-item result-schema)))))))

;;; To speed up computation in ASSOC.
;;; &&& ---> I'll bet that making this just expand into > for Genera (and eliminating a function call!)
;;; would be a major win.  Try this out at some point.  E.g., #+Genera (deff 'truefloat> #'>) or something...
;;; [Gee, I take it back---#'> probably runs slower, given its disassembly---it has to handle a &rest arg,
;;; whereas the > in truefloat> is a single instruction, because the compiler can tell how many args it's getting...]
(defun TRUEFLOAT> (x y)
  (> (the short-float x)
     (the short-float y)))

(defvar *ACCESSIBLE-ITEM-POS*
	(make-flag-array *fixna-required-to-hold-all-item-flags*))

(defvar *ACCESSIBLE-ITEM-NEG*
	(make-flag-array *fixna-required-to-hold-all-item-flags*))

(defvar *ACCESSIBLE-CONJ-POS*
	(make-flag-array *fixna-required-to-hold-all-conj-flags*))

;;; Description of UPDATE-ACCESSIBILITY algorithm:
;;; When a schema is reached through any path, mark it.
;;; For the first round, form a list of all applicable schemas with
;;; medium reliability and non-nil results.
;;; For every round, keep a list of schemas reached on the previous
;;; round, with corresponding reliability, sorted from highest to
;;; lowest.
;;; To form the next round of schemas, go through all schemas,
;;; using FIND to see if any members of the last round list
;;; have a result which chains to the context of the current schema.
;;; If a schema is found which can be chained to,
;;; if marked as visited previously, and reliability higher, then
;;; update old value and put on next round list -- otherwise ignore.
;;; If not visited previously and above threshold, put on next round
;;; list .
;;; In this fashion, every reachable schema through a path of
;;; accessible schemas can be found and marked.
;;; The result item or conjunction for each marked schema is then
;;; marked -- and then each item and conjunction has its accessibility
;;; updated.

;;; Note:  current behavior of program has conjunctive result ->
;;; conjunctive context -- but if a conjunction *includes* another one,
;;; that conjunction isn't marked explicitly accessible (unless it is
;;; accessible through some other path).

;;; Accessibility in the negative direction for conjunctions is
;;; definitely not important -- a negated conjunction is a disjunction,
;;; and a disjunctive goal makes no sense within the context of this
;;; mechanism.

;;; To avoid unnecessary proliferation of fairly useless goal-directed
;;; actions, this routine was modified to as to not have negated items
;;; as goals either -- this departure from the original paper can be
;;; undone by carefully removing commented out code below and in the
;;; definition of the item datatype.

;;; Major function:  UPDATE-ACCESSIBILITY.

(defparameter *UPDATE-ACCESSIBILITY-NUMBER-OF-PASSES* 5)	; [This was originally part of a hardcoded (DOTIMES (Y 4) ...) sort of thing.]

(defun UPDATE-ACCESSIBILITY ()
  (flag-array-clear *accessible-item-pos* *fixna-required-to-hold-all-item-flags*)
  #+gd-actions-negative
  (flag-array-clear *accessible-item-neg* *fixna-required-to-hold-all-item-flags*)
  (flag-array-clear *accessible-conj-pos* *fixna-required-to-hold-all-conj-flags*)
  (let ((visited nil)
        (old-visited nil))
    (dotimes (x *schema-number*)
      (let* ((schema (get-schema x))
	     (data (schema-data schema)))
	(cond ((and (schema-data-applicable-p data)
		    (flag-falsep (schema-data-result-empty data))
		    (weighted-rate-medium-p (schema-reliability schema)))
	       (setf (schema-marked schema) (make-flag-true))
	       (setq visited (acons x (schema-reliability schema) visited)))
	      (t
	       (setf (schema-marked schema) (make-flag-false))))))
    (setq visited (sort visited  #'truefloat> :key #'cdr))
    (setq old-visited (copy-alist visited))
    (accessibility-format "initial visited ~A~%" visited)
    (dotimes (y (1- *update-accessibility-number-of-passes*))
      (let ((new-visited nil))
	y					; In case ACCESSIBILITY-FORMAT is compiled not to do anything.
	(accessibility-format "pass ~D~%" y)
	(accessibility-format "old-visited ~A~%" old-visited)
	(dotimes (x *schema-number*)
	  (let* ((schema (get-schema x))
		 (data (schema-data schema))
		 (reliability (schema-reliability schema)))
	    (declare (short-float reliability))
	    ;; If empty result, not interesting, and must also have high
	    ;; enough reliability (otherwise anything found returned
	    ;; would be too low to have new-reliability above the threshold).
	    (when (and (flag-falsep (schema-data-result-empty data))
		       (weighted-rate-medium-p reliability))
	      ;; The obscure [in Ramsta'd opinion, anyway--- Foner] ASSOC
	      ;; command sends the result of applying ACCESSIBLE-KEY to
	      ;; each element of OLD-VISITED, along with SCHEMA, to
	      ;; ACCESSIBLE-TEST -- ACCESSIBLE-TEST is expected to
	      ;; return T if one is found where the schema in question
	      ;; has a result which includes the context of SCHEMA.
	      (let* ((found (assoc schema old-visited
				   :key #'accessible-key
				   :test #'accessible-test)))
		(when found
		  (let ((new-reliability
			  (weighted-rate* reliability (cdr found))))
		    (declare (short-float new-reliability))
		    (accessibility-format
		      "schema ~D reliability ~6,4F prior-reliability ~6,4F ~
                        new-reliability ~6,4F~%"
		      x reliability (cdr found) new-reliability)
		    ;; if already marked
		    (if (schema-marked-p schema)
			;; Check to see if this is a more reliable path.
			(when (float> new-reliability (cdr (assoc x visited)))
			  ;; If so, replace the old value with the new
			  ;; one, and add it to the new-visited array
			  ;; (as the new value may allow certain
			  ;; children which didn't succeed before to
			  ;; succeed this time).
			  ;; &&& Can I store the assoc value instead of recomputing?  Or would I need a locative?
			  (rplacd (assoc x visited) new-reliability)
			  (setq new-visited
				(acons x new-reliability new-visited)))
			;; Otherwise not marked, so mark and add to
			;; new-visited array if greater than threshold.
			(when (weighted-rate-medium-p new-reliability)
			  (setf (schema-marked schema) (make-flag-true))
			  (setq new-visited
				(acons x new-reliability new-visited)
				visited
				(acons x new-reliability visited))))))))))
	(unless new-visited
	  (return))
	;; At this point, NEW-VISITED has what should be used for
	;; old-visited on the next iteration.
	(setq new-visited (sort new-visited #'truefloat> :key #'cdr))
	(setq old-visited new-visited)
	(accessibility-format "visited ~A~%" visited))))
  ;; At this point, all "accessible" schemas should be marked, so go
  ;; through them, if result conjunctive, mark the included
  ;; conjunctions (which includes the result conjunction).
  ;; If not, just mark the item(s).
  (dotimes (x *schema-number*)
    (let* ((schema (get-schema x))
	   (data (schema-data schema)))
      (when (and (schema-data-marked-p data)
		 (flag-falsep (schema-data-result-negated data)))
	(let ((result-item (schema-result-item schema)))
	  (if (schema-data-result-conj-p data)
	      (flag-array-ior (conj-inclusion-array
				(get-conj result-item))
			      *accessible-conj-pos*
			      *fixna-required-to-hold-all-conj-flags*)
	      (setf (flag-array-get-flag
		      *accessible-item-pos*
		      result-item)
		    (make-flag-true)))))))
  ;; Old version for negated results (note: doesn't do inclusive
  ;; conjunctions right).
  #+gd-actions-negative
  (dotimes (x *schema-number*)
    (let* ((schema (get-schema x))
	   (data (schema-data schema)))
      (when (schema-data-marked-p data)
	(let ((result-item (schema-result-item schema)))
	  (if (schema-data-result-conj-p data)
	      (if (flag-falsep (schema-data-result-negated data))
		  (setf (flag-array-get-flag
			  *accessible-conj-pos*
			  result-item)
			(make-flag-true)))
	      (setf (flag-array-get-flag
		      (if (flag-truep (schema-result-negated schema))
			  *accessible-item-neg*
			  *accessible-item-pos*)
		      result-item)
		    (make-flag-true)))))))
  ;; Actually modify the accessibility numbers for the items and conjunctions.
  ;; For each marked conjunction, increase accessibility and mark the
  ;; included (positive) items.
  (accessibility-format "updating accessibility~%")
  ;; In the usual (original) case, *FIXNA-REQUIRED-TO-HOLD-ALL-ITEM-FLAGS*
  ;; (and hence the length of *RELIABLE-ITEM-POS*) is smaller than
  ;; *FIXNA-REQUIRED-TO-HOLD-ALL-CONJ-FLAGS* (and hence the length of
  ;; (CONJ-xxx-FLAG-ARRAY ...)).  However, in the case where I've boosted
  ;; the maximum number of conj's from 300 to 3000, this is no longer the case.
  ;; [This reasoning stolen from SYN-ITEM-UPDATE-PHASE-THREE.]
  (let ((minimal-length (min *fixna-required-to-hold-all-conj-flags*
			     *fixna-required-to-hold-all-item-flags*)))
    (dotimes (x *conj-number*)
      (let ((conj (get-conj x)))
	(cond ((flag-truep (flag-array-get-flag *accessible-conj-pos* x))
	       (conj-acc-pos-update conj t)
	       (flag-array-ior (conj-pos-flag-array conj)
			       *accessible-item-pos*
;                              *fixna-required-to-hold-all-conj-flags*)	; CONJ, not ITEM, because the first arg to the IOR is only CONJ long.
			       minimal-length)
	       (accessibility-format "~A~%" conj)
	       (when (and (flag-falsep (conj-gd-pos-created conj))
			  (conj-acc-pos-high-p conj))
		 (setf (conj-gd-pos-created conj) (make-flag-true))
		 (make-gd-action-conj-pos x)))
	      (t
	       (conj-acc-pos-update conj nil)
	       (accessibility-format "~A~%" conj))))))
  (dotimes (x *item-number*)
    (let ((item (get-item x)))
      (item-acc-pos-update
	item
	(flag-truep (flag-array-get-flag *accessible-item-pos* x)))
      #+gd-actions-negative
      (item-acc-neg-update
	item
	(flag-truep (flag-array-get-flag *accessible-item-neg* x)))
      (accessibility-format "~A~%" item)
      (when (and (flag-falsep (item-gd-pos-created item))
		 (item-acc-pos-high-p item))
	(setf (item-gd-pos-created item) (make-flag-true))
	(make-gd-action-item-pos x))
      #+gd-actions-negative
      (when (and (flag-falsep (item-gd-neg-created item))
		 (item-acc-neg-high-p item))
	(setf (item-gd-neg-created item) (make-flag-true))
	(make-gd-action-item-neg x))
      )))

;;;; Create goal-directed action functions.

(defun MAKE-GD-ACTION-ITEM-POS (item-index)
  (main-format "~5D goal-directed-action-item-pos-created ~D ~A~%"
               *clock-tick*
               item-index
               (item-print-name (get-item item-index))))

#+gd-actions-negative
(defun MAKE-GD-ACTION-ITEM-NEG (item-index)
  (main-format "~5D goal-directed-action-item-neg-created ~D ~A~%"
	       *clock-tick*
	       item-index
	       (item-print-name (get-item item-index))))

(defun MAKE-GD-ACTION-CONJ-POS (conj-index)
  (main-format "~5D goal-directed-action-conj-pos-created ~D ~A~%"
               *clock-tick*
               conj-index
               (conj-print-name (get-conj conj-index))))

;;; *** end update accessibility / create goal-directed actions code ***

;;;; Major functions:  ITEM-UPDATE-STATE and CONJ-UPDATE-STATE.

(defun ITEM-UPDATE-STATE ()
  (dotimes (x *item-number*)
    (let ((current-item (get-item x)))
      (if (item-syn-item-p current-item)
	  (setf
	    ;; Last state (post) = current state (pre).
	    (item-last-state current-item) (item-current-state current-item)
	    ;; Put "both" into current-state and microworld-state.
	    ;; "Both" is 11 and inclusive ORs with anything.
	    ;; Written into each synthetic item state while determining
	    ;; the state of the primitive items.
	    (item-current-state current-item) (make-state-both)
	    (get-microworld-state x) (make-state-both))
	  (let ((new-state (state-parse (funcall (item-code current-item)))))
	    (setf
	      ;; Last state (post) = current state (pre).
	      (item-last-state current-item) (item-current-state current-item)
	      ;; Current state (post) = result of calling code.
	      (item-current-state current-item) new-state
	      (get-microworld-state x) new-state)
	    ;; Update generality -- increment rate if state is ON.
	    (item-generality-update current-item (state-on-p new-state)))))))

(defun CONJ-UPDATE-STATE ()
  (dotimes (x *conj-number*)
    (let* ((current-conj (get-conj x))
	   (new-state (state-parse
			(context-satisfied-p
			  (conj-item-array current-conj)))))
      (setf
	;; Last state (post) = current state (pre).
	(conj-last-state current-conj) (conj-current-state current-conj)
	;; Current state (post) = result of calling code.
	(conj-current-state current-conj) new-state))))

;;;; Major function:  SCHEMA-UPDATE-ACTIVATED.

;;; If schema has same action, is not a goal-directed-action schema,
;;; and is applicable (i.e. context-satisfied) then is activated.
;;; Otherwise, if goal-directed-action and result satisfied, mark activated.

(defun SCHEMA-UPDATE-ACTIVATED (action-index)
  (with-schema-update-framework (activated "activated")
				("~4D ~25A~A"
				 schema-index
				 (schema-print-name schema)
				 (flag-unparse (schema-activated schema)))
    (setf (schema-activated schema)
	  (flag-parse
	    (and (fix= (schema-action-item schema) action-index)
		 (if (schema-action-gd-p schema)
		     (schema-result-satisfied-p schema)
		     (schema-applicable-p schema)))))))

;;;; Major function:  SYN-ITEM-UPDATE-STATE.

(defvar *RELIABLE-ITEM-POS* (make-flag-array *fixna-required-to-hold-all-item-flags*))
(defvar *RELIABLE-ITEM-NEG* (make-flag-array *fixna-required-to-hold-all-item-flags*))
(defvar *RELIABLE-CONJ*     (make-flag-array *fixna-required-to-hold-all-conj-flags*))

(defun SCHEMA-NOT-CONTEXT-OVERRIDDEN-P (schema)
  (let ((record-offset 0)
        (array-index 0)
        (ext-context (schema-extended-context schema)))
    ;; Iterate through all items.
    (dotimes (x *item-number* t)
      ;; For each, check to see if the counter value is 13 or higher.
      (if (fix< 12
		(counter-array-value
		  ext-context array-index record-offset))
	  ;; If so, check to see if counter positive and item OFF
	  ;; or counter negative and item ON.
	  ;; If either is true, overridden.
	  (if (flag-truep
		(counter-array-pos
		  ext-context array-index record-offset))
	      (if (state-off-p (get-microworld-state x))
		  (return nil))
	      (if (state-on-p (get-microworld-state x))
		  (return nil))))
      (if (fix= *counter-record-max-offset* record-offset)
	  (setq record-offset 0
		array-index (fix1+ array-index))
	  (setq record-offset (fix+ *counter-bits* record-offset))))))

;;; When the current state is KNOWN, put in current-state.
;;; When it is just guessed, put in maybe-state.
;;; SET-TIME is updated when current-state is changed, this can easily
;;; be used to check and make sure an earlier (higher precedent) value
;;; isn't being clobbered.

(defun SYN-ITEM-UPDATE-STATE ()
  (dotimes (x *syn-item-number*)
    (setf (syn-item-maybe-state (get-syn-item x))
	  (make-state-unknown)))
  (schema-update-host-results)
  (syn-item-update-phase-one)
  (syn-item-update-phase-two-a)
  (syn-item-update-phase-three)
  (syn-item-update-phase-two-b)
  (syn-item-update-phase-four)
  (syn-item-update-phase-five))

(defun SCHEMA-UPDATE-HOST-RESULTS ()
  (with-schema-update-framework (result "host schema results")
				("~4D ~25A~A"
				 schema-index
				 (schema-print-name schema)
				 (flag-unparse (schema-result-satisfied schema)))
    (when (schema-syn-item-p schema)
      (setf (schema-result-satisfied schema)
	    (flag-parse
	      (or (schema-result-empty-p schema)
		  (if (schema-result-conj-p schema)
		      (conj-satisfied-p
			(schema-result-item schema))
		      (or (state-eq
			    (if (schema-result-negated-p schema)
				(make-state-off)
				(make-state-on))
			    (get-microworld-state
			      (schema-result-item schema)))
			  (state-eq
			    (make-state-both)
			    (get-microworld-state
			      (schema-result-item schema)))))))))))

(defun SYN-ITEM-UPDATE-PHASE-ONE ()
  ;; PHASE ONE
  ;; If host schema activated and not overridden,
  ;; Result obtains/does not obtain -> On/Off.
  ;; These go into CURRENT-STATE as they are not to be overridden.
  ;; (For efficiency, part of phase two is also done: if host is
  ;; overridden, put OFF as MAYBE-STATE).
  (dotimes (x *syn-item-number*)
    (let* ((syn (get-syn-item x))
	   (schema (get-schema (syn-item-host-schema syn))))
      (when (schema-activated-p schema)
	(if (schema-not-context-overridden-p schema)
	    (if (schema-result-satisfied-p schema)
		(setf (syn-item-current-state syn) (make-state-on)
		      (syn-item-unknown-time syn)  (fix+ *clock-tick*
							 (average-value
							   (syn-item-on-duration syn)))
		      (syn-item-set-time syn)      *clock-tick*)
		(setf (syn-item-current-state syn) (make-state-off)
		      (syn-item-unknown-time syn)  (fix+ *clock-tick*
							 (average-value
							   (syn-item-off-duration syn)))
		      (syn-item-set-time syn)      *clock-tick*))
	    (setf (syn-item-maybe-state syn) (make-state-off)))))))

(defun SYN-ITEM-UPDATE-PHASE-TWO-A ()
  ;; NOTE: the accidental clobbering of phase one values can be
  ;; prevented now by checking set-time --> if equal to *clock-tick*,
  ;; it has already been set and should not be further modified.
  ;; PHASE TWO
  ;; Overriden host schema -> Off in maybe-state (done in phase one).
  ;; Not overridden host schema with reliable applicable child
  ;;    gives ON in MAYBE-STATE (unless MAYBE-STATE set in phase one).
  (dotimes (x *schema-number*)
    (let* ((schema (get-schema x))
	   (data (schema-data schema)))
      (when (flag-falsep (schema-data-result-empty data))
	(let ((parent (get-schema (schema-parent schema))))
	  (when (and (schema-syn-item-p parent)
		     (schema-data-applicable-p data)
		     (weighted-rate-high-p (schema-reliability schema))
		     (state-unknown-p
		       (syn-item-maybe-state (schema-reifier parent)))
		     (schema-not-context-overridden-p schema))
	    (setf (syn-item-maybe-state (schema-reifier parent))
		  (make-state-on))))))))

(defun SYN-ITEM-UPDATE-PHASE-THREE ()
  ;; PHASE THREE
  ;; Reliable activated schemas with synthetic items in the result
  ;; indicate that the item should be turned ON/OFF.
  ;; Move phase two and phase three results up into current-state
  ;; if not blocked by already being set this time around.
  (dotimes (x *schema-number*)
    (let* ((schema (get-schema x))
	   (data (schema-data schema)))
      (when (and (schema-data-activated-p data)
		 (weighted-rate-high-p (schema-reliability schema))
		 (flag-falsep (schema-data-result-empty data)))
	(let ((result-item (schema-result-item schema)))
	  (if (schema-data-result-conj-p data)
	      (flag-array-ior (conj-inclusion-array
				(get-conj result-item))
			      *reliable-conj*
			      *fixna-required-to-hold-all-conj-flags*)
	      (setf (flag-array-get-flag
		      (if (schema-data-result-negated-p data)
			  *reliable-item-neg*
			  *reliable-item-pos*)
		      result-item)
		    (make-flag-true)))))))
  (dotimes (x *conj-number*)
    (when (flag-truep (flag-array-get-flag *reliable-conj* x))
      (let ((conj (get-conj x)))
	;; In the usual (original) case, *FIXNA-REQUIRED-TO-HOLD-ALL-ITEM-FLAGS*
	;; (and hence the length of *RELIABLE-ITEM-POS*) is smaller than
	;; *FIXNA-REQUIRED-TO-HOLD-ALL-CONJ-FLAGS* (and hence the length of
	;; (CONJ-xxx-FLAG-ARRAY ...)).  However, in the case where I've boosted
	;; the maximum number of conj's from 300 to 3000, this is no longer the case.
	(let ((minimal-length (min *fixna-required-to-hold-all-conj-flags*
				   *fixna-required-to-hold-all-item-flags*)))
	  (flag-array-ior (conj-pos-flag-array conj)
			  *reliable-item-pos*
			  minimal-length)
	  (flag-array-ior (conj-neg-flag-array conj)
			  *reliable-item-neg*
			  minimal-length)))))
  (dotimes (x *item-number*)
    (let* ((item (get-item x))
	   (data (item-data item)))
      (when (item-data-syn-item-p data)
	(let ((neg (flag-array-get-flag *reliable-item-neg* x))
	      (pos (flag-array-get-flag *reliable-item-pos* x))
	      (syn (get-syn-item (item-syn-item-index item))))
	  (when (fix/= *clock-tick* (syn-item-set-time syn))
	    (if (flag-truep neg)
		(if (flag-truep pos)
		    ;; If both are true, set unknown.
		    (setf (syn-item-current-state syn)
			  (make-state-unknown)
			  (syn-item-set-time syn)
			  *clock-tick*)
		    ;; Neg true, pos false, if not marked in phase
		    ;; two, set OFF.
		    (if (state-unknown-p (syn-item-maybe-state syn))
			(setf (syn-item-current-state syn)
			      (make-state-off)
			      (syn-item-unknown-time syn)
			      (fix+ *clock-tick*
				    (average-value
				      (syn-item-off-duration syn)))
			      (syn-item-set-time syn)
			      *clock-tick*)
			;; Marked in phase two, set UNKNOWN.
			(setf (syn-item-current-state syn)
			      (make-state-unknown)
			      (syn-item-set-time syn)
			      *clock-tick*)))
		;; Neg false.
		(if (flag-truep pos)
		    ;; Neg false, pos true, if not marked in phase
		    ;; two, set ON.
		    (if (state-unknown-p (syn-item-maybe-state syn))
			(setf (syn-item-current-state syn)
			      (make-state-on)
			      (syn-item-unknown-time syn)
			      (fix+ *clock-tick*
				    (average-value
				      (syn-item-on-duration syn)))
			      (syn-item-set-time syn)
			      *clock-tick*)
			;; Marked in phase two, set unknown.
			(setf (syn-item-current-state syn)
			      (make-state-unknown)
			      (syn-item-set-time syn)
			      *clock-tick*))))))))))

(defun SYN-ITEM-UPDATE-PHASE-TWO-B ()
  ;; PHASE TWO REVISITED
  ;; If phase two and three conflicted, the current-state was set to
  ;; unknown -- any synthetic item which hasn't been set this cycle
  ;; and has a non-unknown MAYBE-STATE should use the MAYBE-STATE to
  ;; update current-state.
  (dotimes (x *syn-item-number*)
    (let ((syn (get-syn-item x)))
      (when (and (fix/= *clock-tick* (syn-item-set-time syn))
		 (state-noteq (make-state-unknown)
			      (syn-item-maybe-state syn)))
	(setf (syn-item-current-state syn) (syn-item-maybe-state syn)
	      (syn-item-unknown-time syn)  (fix+ *clock-tick*
						 (average-value
						   (if (state-on-p
							 (syn-item-maybe-state syn))
						       (syn-item-on-duration syn)
						       (syn-item-off-duration syn))))
	      (syn-item-set-time syn)      *clock-tick*)))))

(defun SYN-ITEM-UPDATE-PHASE-FOUR ()
  ;; PHASE FOUR
  ;; Timeouts.
  (dotimes (x *syn-item-number*)
    (let ((syn (get-syn-item x)))
      (when (and (fix/= *clock-tick* (syn-item-set-time syn))
		 (fix= *clock-tick* (syn-item-unknown-time syn)))
	(setf (syn-item-current-state syn) (make-state-unknown)
	      (syn-item-set-time syn)      *clock-tick*)))))

(defun SYN-ITEM-UPDATE-PHASE-FIVE ()
  ;; PHASE FIVE
  ;; Update the items and microworld-state array with the newly
  ;; calculated information -- also update generality for the
  ;; synthetic items.
  (dotimes (x *item-number*)
    (let ((current-item (get-item x)))
      (when (item-syn-item-p current-item)
	(let ((new-state
                (syn-item-current-state
		  (get-syn-item (item-syn-item-index current-item)))))
	  (setf (item-current-state current-item) new-state
		(get-microworld-state x)          new-state)
	  (item-generality-update current-item (state-on-p new-state)))))))

;;;; Major functions:  SCHEMA-UPDATE-ALL-RESULTS and SCHEMA-UPDATE-RELIABILITY.

(defun SCHEMA-UPDATE-ALL-RESULTS ()
  (with-schema-update-framework (result "all results")
				("~4D ~25A~A"
				 schema-index
				 (schema-print-name schema)
				 (flag-unparse (schema-result-satisfied schema)))
    (setf (schema-result-satisfied schema)
	  (flag-parse
	    (or (schema-result-empty-p schema)
		(if (schema-result-conj-p schema)
		    (conj-satisfied-p
		      (schema-result-item schema))
		    (state-eq
		      (if (schema-result-negated-p schema)
			  (make-state-off)
			  (make-state-on))
		      (get-microworld-state (schema-result-item schema)))))))))

(defun SCHEMA-UPDATE-RELIABILITY ()
  (without-floating-underflow-traps		; New:  This bombed out once due to extremely tiny reliability...
    (with-schema-update-framework (reliability "reliability")
				  ("~4D ~6,4F"
				   schema-index
				   (schema-reliability schema))
      (when (schema-activated-p schema)
	(weighted-rate-update (schema-reliability schema)
			      (schema-result-satisfied-p schema))))))

;;;; Predicted-results definitions.

(deflimit *PREDICTED-RESULTS-SIZE*       *fixna-required-to-hold-all-item-states* 25)
(deflimit *PREDICTED-RESULTS-CONJS-SIZE* *fixna-required-to-hold-all-conj-states* 20)

(defvar *PREDICTED-RESULTS*
	(make-state-array *predicted-results-size*))

(defvar *PREDICTED-RESULT-CONJS*
	(make-state-array *predicted-results-conjs-size*))

(defmacro PREDICTED-RESULT (item)
  `(state-noteq (make-state-unknown)
                (state-array-get-state *predicted-results* ,item)))

(defmacro PREDICTED-RESULT-CONJ (conj)
  `(state-noteq (make-state-unknown)
                (state-array-get-state *predicted-result-conjs*
                                       ,conj)))

;;;; major functions:  UPDATE-PREDICTED-RESULTS and PRINT-PREDICTED-RESULTS.

(defun UPDATE-PREDICTED-RESULTS ()
  (state-array-clear *predicted-results* *predicted-results-size*)
  (state-array-clear *predicted-result-conjs* *predicted-results-conjs-size*)
  (dotimes (schema-index *schema-number*)
    (let ((schema (get-schema schema-index)))
      (when (and (flag-falsep (schema-result-empty schema))
		 (weighted-rate-high-p (schema-reliability schema))
		 (schema-activated-p schema)
		 (schema-result-satisfied-p schema))
	(cond ((schema-result-conj-p schema)
	       (setf (state-array-get-state *predicted-result-conjs*
					    (schema-result-item schema))
		     (if (schema-result-negated-p schema)
			 (make-state-off)
			 (make-state-on)))
	       (state-array-ior
		 (conj-item-array
		   (get-conj (schema-result-item schema)))
		 *predicted-results*
		 *predicted-results-size*))
	      (t
	       (setf (state-array-get-state *predicted-results*
					    (schema-result-item schema))
		     (if (schema-result-negated-p schema)
			 (make-state-off)
			 (make-state-on)))))))))

(defun PRINT-PREDICTED-RESULTS-ENABLED ()
  (predicted-results-format "predicted-results~%")
  (dotimes (x *item-number*)
    (let ((foo (state-array-get-state *predicted-results* x)))
      (cond ((state-unknown-p foo)		; $OPT:  UNLESS might be clearer.
	     nil)
	    (t
	     (predicted-results-format
	       "~A~%"
	       (item-print-name (get-item x)))))))
  (predicted-results-format "predicted-result-conjunctions~%")
  (dotimes (x *conj-number*)
    (let ((foo (state-array-get-state *predicted-result-conjs* x)))
      (cond ((state-unknown-p foo)		; $OPT:  UNLESS might be clearer.
	     nil)
	    (t
	     (predicted-results-format
	       "~A~%"
	       (conj-print-name (get-conj x))))))))

;;;; Major function:  SCHEMA-UPDATE-EXT-ITEM-STATS.

(defun SCHEMA-UPDATE-EXT-ITEM-STATS ()
  (dotimes (item-index *item-number*)
    (let ((current-item (get-item item-index))
	  (record-offset 0))
      (multiple-value-bind (array-index record-position)
	  (get-counter-array-index item-index)
        (setq record-offset (counter-record-offset record-position))
        (item-format "~A~%" current-item)
	(with-schema-update-framework-innards ext-stats
					      (nil)
	  (cond ((schema-result-empty-p schema)
		 (let ((activated (schema-activated schema))
		       (positive (schema-extended-result-pos schema))
		       (negative (schema-extended-result-neg schema))
		       (current-state (item-current-state current-item))
		       (last-state (item-last-state current-item)))
		   (ext-stats-format "~4D res " schema-index)
		     ;;; Do positive transition -- activation matches and old is off.
		   (cond ((and (state-off-p last-state)
			       (not (and
				      (flag-falsep activated)
				      (predicted-result item-index)))
			       (flag-eq
				 (counter-array-toggle
				   positive array-index record-offset)
				 activated))
			  (ext-stats-format "+t ")
			    ;;; Check to see if new is on.
			  (cond ((state-on-p current-state)
				 (ext-stats-format "~A->"
						   (counter-unparse-from-array
						     positive array-index record-offset))
				 (counter-array-toggle-toggle
				   positive array-index record-offset)
				 (counter-array-modify-value
				   positive array-index record-offset activated)
				 (ext-stats-format "~A"
						   (counter-unparse-from-array
						     positive array-index record-offset)))
				(t
				 (ext-stats-format "~A->"
						   (counter-unparse-from-array
						     positive array-index record-offset))
				 (counter-array-toggle-toggle
				   positive array-index record-offset)
				 (ext-stats-format "~A"
						   (counter-unparse-from-array
						     positive array-index record-offset)))))
			   ;;; Do negative transition -- old is on.
			 ((and (state-on-p last-state)
			       (not (and (flag-falsep activated)
					 (predicted-result item-index)))
			       (flag-eq
				 (counter-array-toggle
				   negative array-index record-offset)
				 activated))
			  (ext-stats-format "-t ")
			    ;;; Check to see if new is off.
			  (cond ((state-off-p current-state)
				 (ext-stats-format "~A->"
						   (counter-unparse-from-array
						     negative array-index record-offset))
				 (counter-array-toggle-toggle
				   negative array-index record-offset)
				 (counter-array-modify-value
				   negative array-index record-offset activated)
				 (ext-stats-format "~A"
						   (counter-unparse-from-array
						     negative array-index record-offset)))
				(t
				 (ext-stats-format "~A->"
						   (counter-unparse-from-array
						     negative array-index record-offset))
				 (counter-array-toggle-toggle
				   negative array-index record-offset)
				 (ext-stats-format "~A"
						   (counter-unparse-from-array
						     negative array-index record-offset)))))
			 (t
			  (ext-stats-format "no ")))))
		(t
		 ;; Non-empty result so update extended-context.
		 (ext-stats-format "~4D con " schema-index)
		 (cond ((and (schema-activated-p schema)
			     (or
			       (state-unknown-p
				 (state-array-get-state
				   (schema-context-children schema) item-index))
			       (state-noteq
				 (state-array-get-state
				   (schema-context-children schema) item-index)
				 (item-last-state current-item))))
			(let* ((ext-context (schema-extended-context schema))
			       (last-state (item-last-state current-item))
			       (toggle (counter-array-toggle
					 ext-context array-index record-offset)))
			  (cond ((or (and (flag-truep toggle)
					  (state-on-p last-state))
				     (and (flag-falsep toggle)
					  (state-off-p last-state)))
				 (ext-stats-if
				   (state-on-p last-state)
				   (ext-stats-format "+t ")
				   (ext-stats-format "-t "))
				 (ext-stats-format
				   "~A->"
				   (counter-unparse-from-array
				     ext-context array-index record-offset))
				 (counter-array-toggle-toggle
				   ext-context array-index record-offset)
				 (if (schema-result-satisfied-p schema)
				     (counter-array-modify-value
				       ext-context array-index record-offset
				       (flag-parse (state-on-p last-state))))
				 (ext-stats-format
				   "~A "
				   (counter-unparse-from-array
				     ext-context array-index record-offset)))
				(t
				 (ext-stats-format "no match state/toggle")))))
		       (t
			(ext-stats-format "not activated or deferred"))))))
	(ext-stats-format "~%")))))

;;;; Major function:  SCHEMA-UPDATE-EXT-CONJ-STATS.

(defun SCHEMA-UPDATE-EXT-CONJ-STATS ()
  (loop for conj-index from 0 below *conj-number* do	; Changed from DOTIMES due to weird Genera compiler bug w/DOTIMES & FORMAT???
    (let* ((current-conj (get-conj conj-index))
	   (record-offset 0)
	   (current-state (conj-current-state current-conj))
	   (last-state (conj-last-state current-conj)))
      (multiple-value-bind (array-index record-position)
	  (get-counter-array-index conj-index)
	(setq record-offset (counter-record-offset record-position))
	(conj-format "~A~%" current-conj)
	(with-schema-update-framework-innards ext-conj-stats
					      (nil)
	  (ext-conj-stats-format "~4D res conj " schema-index)
	  (cond ((schema-result-empty-p schema)
		 (let ((activated (schema-activated schema))
		       (positive (schema-extended-result-conj-pos schema)))
		     ;;; Do positive transition -- activation matches and old is off.
		   (cond ((and (state-off-p last-state)
			       (not (and
				      (flag-falsep activated)
				      (predicted-result-conj conj-index)))
			       (flag-eq
				 (counter-array-toggle
				   positive array-index record-offset)
				 activated))
			  (ext-conj-stats-format "+t ")
                      ;;; check to see if new is on
			  (cond ((state-on-p current-state)
				 (ext-conj-stats-format
				   "~A->" (counter-unparse-from-array
					    positive array-index record-offset))
				 (counter-array-toggle-toggle
				   positive array-index record-offset)
				 (counter-array-modify-value
				   positive array-index record-offset activated)
				 (ext-conj-stats-format
				   "~A" (counter-unparse-from-array
					  positive array-index record-offset)))
				(t
				 (ext-conj-stats-format
				   "~A->" (counter-unparse-from-array
					    positive array-index record-offset))
				 (counter-array-toggle-toggle
				   positive array-index record-offset)
				 (ext-conj-stats-format
				   "~A" (counter-unparse-from-array
					  positive array-index record-offset)))))
			 (t (ext-conj-stats-format "no ")))))
		(t
		 (ext-conj-stats-format "-- res non-empty"))))))
    (ext-conj-stats-format "~%")))

;;;; Major function:  MAYBE-SPINOFF-SCHEMA.
     
(defun MAYBE-SPINOFF-SCHEMA ()
  (dotimes (schema-index *schema-number*)
    (when ; Returns 'MAYBE-SPINOFF-SCHEMA-FINISHED if clause true.  What's the point?
      (let ((schema (get-schema schema-index))
	    (array-index 0)
	    (record-offset 0))
	(if (schema-result-empty-p schema)
	    (let ((result-pos
		    (schema-extended-result-pos schema))
		  (result-neg
		    (schema-extended-result-neg schema))
		  (result-pos-conj
		    (schema-extended-result-conj-pos schema))
		  (children (schema-result-children schema))
		  (conj-children (schema-result-conj-children schema)))
	      (dotimes (item-index *item-number* nil)
		(if (state-unknown-p
		      (state-array-get-state children item-index))
		    (cond ((and (fix= *counter-maximum*
				      (counter-array-value
					result-pos array-index record-offset))
				(flag-truep
				  (counter-array-pos
				    result-pos array-index record-offset)))
			   (return
			     (make-spinoff-result schema-index
						  item-index
						  (make-state-on))))
			  ((and (fix= *counter-maximum*
				      (counter-array-value
					result-neg array-index record-offset))
				(flag-truep
				  (counter-array-pos
				    result-neg array-index record-offset)))
			   (return
			     (make-spinoff-result schema-index
						  item-index
						  (make-state-off))))
			  (t nil)))
		(if (and (fix< item-index *conj-number*)
			 (flag-falsep
			   (flag-array-get-flag conj-children item-index)))
		    (cond ((and (fix= *counter-maximum*
				      (counter-array-value
					result-pos-conj array-index record-offset))
				(flag-truep
				  (counter-array-pos
				    result-pos-conj array-index record-offset)))
			   (return
			     (make-spinoff-result-conj
			       schema-index
			       item-index)))
			  (t nil)))
		(if (fix= *counter-record-max-offset* record-offset)
		    (setq record-offset 0
			  array-index (fix1+ array-index))
		    (setq record-offset (fix+ *counter-bits* record-offset)))))
	    ;; Non-empty result so check for context spinoffs.
	    (let ((context (schema-extended-context schema))
		  (children (schema-context-children schema))
		  (current-item -1)
		  (current-state (make-state-unknown)))
	      (dotimes (item-index *item-number*
				   (if (state-noteq (make-state-unknown) current-state)
				       (make-spinoff-context schema-index
							     current-item
							     current-state)
				       nil))
		(if (and (state-unknown-p
			   (state-array-get-state children item-index))
			 (fix= *counter-maximum*
			       (counter-array-value
				 context array-index record-offset))
			 (or (state-unknown-p current-state)
			     (item-generality-< (get-item item-index)
						(get-item current-item))))
		    (setq current-state
			  (if (flag-truep
				(counter-array-pos
				  context array-index record-offset))
			      (make-state-on)
			      (make-state-off))
			  current-item item-index))
		(if (fix= *counter-record-max-offset* record-offset)
		    (setq record-offset 0
			  array-index (fix1+ array-index))
		    (setq record-offset (fix+ *counter-bits* record-offset)))))))
      (return 'maybe-spinoff-schema-finished))))

;;; Major function:  MAKE-SPINOFF-RESULT.

;;; As result spinoffs can only occur from empty-result schemas, and
;;; empty result schemas must necessarily have empty contexts, this
;;; routine does not have to deal with anything but spinning off from
;;; "blank" schemas -- i.e. those which do not have any context or
;;; result -- remember, all flags are false by default.

(defun MAKE-SPINOFF-RESULT (schema item state)	; SCHEMA and ITEM are really indices, not actual objects...
  (let* ((parent-schema (get-schema schema))
         (spinoff-schema (make-action-schema
			   (schema-action-item parent-schema))))
    (setf (schema-result-item spinoff-schema)   item
          (schema-context-empty spinoff-schema) (make-flag-true)
          (schema-parent spinoff-schema)        schema)
    (when (state-off-p state)
      (setf (schema-result-negated spinoff-schema)
	    (make-flag-true)))
    (setf (bit (item-result-dependent-schemas (get-item item))	; Note that this item now has a schema which uses it in its result.
	       (1- *schema-number*))		; The schema is the NEW schema, _not_ the (bare) schema index in SCHEMA!
	  1)
    (schema-update-print-name spinoff-schema)
    (main-format "~5D spinoff-result  ~A~6A ~A -> ~A~%"
                 *clock-tick*
                 (state-unparse state)
                 (item-print-name (get-item item))
                 (schema-print-name parent-schema)
                 (schema-print-name spinoff-schema))
    (setf (state-array-get-state
	    (schema-result-children parent-schema) item)
	  state)
    spinoff-schema))

;;;; Major Function:  MAKE-SPINOFF-RESULT-CONJ.

(defun CHECK-ITEM-RESULTS ()			; DBG.
  (loop for index from 0 below *item-number*
	for item = (get-item index)
	  for r = (item-result-dependent-schemas item)
	  do (format t "~&~3D  ~S~&"
		     index
		     (enumerate-bit-vector r)))
  (values))

(defun CHECK-ITEM-CONTEXTS ()			; DBG.
  (loop for index from 0 below *item-number*
	for item = (get-item index)
	  for c = (item-context-dependent-schemas item)
	  do (format t "~&~3D  ~S~&"
		     index
		     (enumerate-bit-vector c)))
  (values))

(defmacro TELLING-ITEMS-ABOUT-SCHEMA (item-dependency-array item-state-array schema-index)
  ;; For each item in the state-array whose state is not unknown (e.g., positively or negatively included),
  ;; mark each such item with the schema, so the item knows the schema is dependent upon it.
  `(loop for state-index from 0 below *item-number*
	 do (unless (state-unknown-p (state-array-get-state ,item-state-array state-index))
	      ;; The item number represented by STATE-INDEX is included (either positively or negatively) in this conj.
	      ;; This means that we must tell the item that SCHEMA is referencing it.
	      (setf (bit (,item-dependency-array (get-item state-index)) ,schema-index) 1))))

(defun TELL-ITEMS-ABOUT-SCHEMA-RESULT-DEPENDENCY (item-state-array schema-index)
  (telling-items-about-schema item-result-dependent-schemas  item-state-array schema-index))

(defun TELL-ITEMS-ABOUT-SCHEMA-CONTEXT-DEPENDENCY (item-state-array schema-index)
  (telling-items-about-schema item-context-dependent-schemas item-state-array schema-index))

(defun MAKE-SPINOFF-RESULT-CONJ (schema conj)	; SCHEMA and CONJ are really indices, not actual objects...
  (let* ((parent-schema (get-schema schema))
         (spinoff-schema (make-action-schema
			   (schema-action-item parent-schema))))
    (setf (schema-result-item   spinoff-schema) conj
          (schema-result-conj   spinoff-schema) (make-flag-true)
          (schema-context-empty spinoff-schema) (make-flag-true)
          (schema-parent        spinoff-schema) schema)
    (tell-items-about-schema-result-dependency	; Note that these items now have schemas which use them in their results.
      (conj-item-array (get-conj conj))
      (1- *schema-number*))			; The schema is the NEW schema, _not_ the (bare) schema index in SCHEMA!
    (schema-update-print-name spinoff-schema)
    (main-format "~5D spinoff-result-conjunction  ~A~6A ~A -> ~A~%"
                 *clock-tick*
                 (state-unparse (make-state-on))
                 (conj-print-name (get-conj conj))
                 (schema-print-name parent-schema)
                 (schema-print-name spinoff-schema))
    (setf (flag-array-get-flag
	    (schema-result-conj-children parent-schema) conj)
	  (make-flag-true))
    spinoff-schema))

;;;; Major function:  MAKE-SPINOFF-CONTEXT.

;;; A context spinoff has same context as its parent, but with a new
;;; item added -- note that this invalidates any conjunction
;;; information, so this isn't copied (by default context-conjunction
;;; is false, and context-item is -1).
;;; RESULT and ACTION are direct copies from the parent.
;;; The EXTENDED-CONTEXT counters for the parent schema are also reset
;;;   (as required for deferring to a more specific schema).
;;; To inhibit context spinoffs of items which are already in the
;;; context, the CONTEXT-ARRAY is copied to the CONTEXT-CHILDREN array.
    
(defun MAKE-SPINOFF-CONTEXT (schema item state)	; SCHEMA and ITEM are really indices, not actual objects...
  (let* ((parent-schema (get-schema schema))	; The schema that already exists, from which we are spinning off a new one.
         (spinoff-schema (make-action-schema	; The new, spinoff schema (a real object, not an index).
			   (schema-action-item parent-schema)))
         (parent-schema-data (schema-data parent-schema)))
    (if (schema-data-context-empty-p parent-schema-data)
        (setf (schema-context-single spinoff-schema) (make-flag-true))
	(state-array-copy (schema-context-array parent-schema)
			  (schema-context-array spinoff-schema)
			  *fixna-required-to-hold-all-item-states*))
    (setf (state-array-get-state (schema-context-array spinoff-schema) item) state
          (schema-parent spinoff-schema) schema)
    (state-array-copy (schema-context-array spinoff-schema)
                      (schema-context-children spinoff-schema)
                      *fixna-required-to-hold-all-item-states*)
    (if (schema-data-result-empty-p parent-schema-data)
        (setf (schema-result-empty spinoff-schema)   (make-flag-true))
	(setf (schema-result-item spinoff-schema)    (schema-result-item parent-schema)
	      (schema-result-conj spinoff-schema)    (schema-data-result-conj parent-schema-data)
	      (schema-result-negated spinoff-schema) (schema-data-result-negated parent-schema-data)))
    (setf (state-array-get-state (schema-context-children parent-schema) item) state
          (schema-extended-context parent-schema)        (make-counter-array *fixna-required-to-hold-all-item-counters*))
    (when (schema-data-action-gd-p parent-schema-data)
      (setf (schema-extended-context-post parent-schema) (make-counter-array *fixna-required-to-hold-all-item-counters*)))
    (let ((spinoff-schema-index (1- *schema-number*)))	; The index of the newly-created schema (*SCHEMA-NUMBER* always points to first UNUSED index).
      ;; Note that these items now have schemas which use them in their contexts (from the parent schema).
      (tell-items-about-schema-context-dependency
	(schema-context-array parent-schema)
	spinoff-schema-index)
      ;; ALSO, add the NEW context item (from the spinoff schema).
      (setf (bit (item-context-dependent-schemas (get-item item))
		 spinoff-schema-index) 1)
      ;; ALSO, note that the items in the new schema's RESULT are dependents of it!
      (cond ((schema-result-conj-p spinoff-schema)	; Schema is a result-conj, so update for each item in the conj.
	     (let* ((conj-index (schema-result-item spinoff-schema))
		    (conj (get-conj conj-index))
		    (conj-item-state-array (conj-item-array conj)))
	       (tell-items-about-schema-result-dependency
		 conj-item-state-array spinoff-schema-index)))
	    (t					; Schema is ordinary result, so update for the single item.
	     (setf (bit (item-result-dependent-schemas (get-item (schema-result-item spinoff-schema)))
			spinoff-schema-index)
		   1))))
    (schema-update-print-name spinoff-schema)
    (main-format "~5D spinoff-context  ~A~6A ~A -> ~A~%"
                 *clock-tick*
                 (state-unparse state)		; * for ON, . for OFF
                 (item-print-name (get-item item))	; E.g., VF34.
                 (schema-print-name parent-schema)	; E.g., -VF04/EYEF/VF33.
                 (schema-print-name spinoff-schema))	; E.g., -VF04&VF34/EYEF/VF33.
    spinoff-schema))

;;;; Major function:  MAYBE-MAKE-CONJS.

(defun MAYBE-MAKE-CONJS ()
  (conj-format "making necessary conjunctions...~%")
  (dotimes (x *schema-number*)
    (let* ((schema (get-schema x))
	   (data (schema-data schema)))
      (when (and (flag-falsep (schema-data-context-single data))
		 (flag-falsep (schema-data-context-empty data))
		 (weighted-rate-high-p (schema-reliability schema))
		 (flag-falsep (schema-data-context-conj data)))
	(setf (schema-context-item schema) (make-conj (schema-context-array schema))
	      (schema-context-conj schema) (make-flag-true))
	(schema-update-print-name schema)
	(conj-format "modifying ~4D ~A conj ~D~%"
		     x
		     (schema-print-name schema)
		     (schema-context-item schema)))))
  (dotimes (x *conj-number*)
    x   ; Ignore this to avoid a compiler warning, in case CONJ-FORMAT is expanding to NIL.  (I had to say (IGNORE X) instead of just X.  Why???)
    (conj-format "~A~%" (get-conj x))))

;;;; Major function:  MAYBE-MAKE-SYN-ITEMS.

;;; A schema succeeds if, when activated, its result obtains.
;;; Initially, a schema updates the LC-CONSY rate, if it
;;; succeeded this time -- then check to see if succeeded last time
;;; and update rate accordingly.
;;; When highly lcly-cons and not reliable, stop updating
;;; lc-cons and start updating durations.
;;; ON-DURATION:  the duration from the first successful execution to
;;; the first unsuccessful one.
;;; OFF-DURATION:  the duration from the first unsuccessful execution to
;;; the first successful one.

(defun MAYBE-MAKE-SYN-ITEMS ()
  (syn-item-format
    "making synthetic items and updating duration/consistency...~%")
  (loop for schema-index from 0 below *schema-number*	; Changed from DOTIMES due to weird Genera compiler bug w/DOTIMES & FORMAT???
	do					; [ ... but _this_ one wasn't required until 18-Aug-93, long after all the rest!  ...and just after ...
    (syn-item-format "~4D " schema-index)	;   ... I macro-ized all of the microworld stuff, but before fixing the *SCHEMA-NUMBER* = 0 bug... Hmm...]
    (let ((schema (get-schema schema-index)))
      (cond ((schema-lcly-cons-p schema)
	     (if (schema-activated-p schema)
		 (cond ((and (schema-result-satisfied-p schema)
			     (not (schema-succeeded-last-p schema)))
			(syn-item-format "syn update off-duration before ~3D "
					 (average-value
					   (syn-item-off-duration
					     (get-syn-item
					       (schema-reifier schema)))))
			(average-update
			  (syn-item-off-duration
			    (get-syn-item (schema-reifier schema)))
			  (fix- *clock-tick* (schema-first-tick schema)))
			(syn-item-format "after ~3D "
					 (average-value
					   (syn-item-off-duration
					     (get-syn-item
					       (schema-reifier schema)))))
			(syn-item-format "first-tick set ~5D" *clock-tick*)
			(setf (schema-first-tick schema) *clock-tick*))
		       (t
			(when (and (not (schema-result-satisfied-p schema))
				   (schema-succeeded-last-p schema))
			  (syn-item-format "syn update on-duration before ~3D "
					   (average-value
					     (syn-item-on-duration
					       (get-syn-item
						 (schema-reifier schema)))))
			  (average-update
			    (syn-item-on-duration
			      (get-syn-item (schema-reifier schema)))
			    (fix- *clock-tick* (schema-first-tick schema)))
			  (syn-item-format "after ~3D "
					   (average-value
					     (syn-item-on-duration
					       (get-syn-item
						 (schema-reifier schema)))))
			  (syn-item-format "first-tick set ~5D" *clock-tick*)
			  (setf (schema-first-tick schema) *clock-tick*))))
		 (syn-item-format "syn not activated ")))
	    (t
	     ;; Not locally consistent.
	     (cond ((and (schema-activated-p schema)
			 (flag-falsep (schema-result-empty schema))
			 (schema-result-satisfied-p schema))
		    (syn-item-format "no syn update consistency before ~A "
				     (schema-lc-consy-unparse schema))
		    (schema-lc-consy-update
		      schema (schema-succeeded-last-p schema))
		    (syn-item-format "after ~A "
				     (schema-lc-consy-unparse schema))
		    (when (and (schema-lc-consy-high-p schema)
			       (weighted-rate-low-p (schema-reliability schema)))
		      (setf (schema-lcly-cons schema) (make-flag-true)
			    (schema-reifier schema)   (make-syn-item schema-index))))
		   (t
		    (syn-item-format
		      "no syn not activated or no non-empty satisfied result")))))
      (syn-item-format "~%")
      (when (schema-activated-p schema)
	(setf (schema-succeeded-last schema)
	      (schema-result-satisfied schema))))))

;;;; Summary reporting.

;;; SHOW-RELIABLE-SCHEMAS is used by RUN-MICROWORLD, but the other definitions
;;; might be useful elsewhere, so we'll define them here.  I'm using substs instead
;;; of macros so they can be used functionally, too.  Note that I haven't covered the
;;; entire set, but merely partitioned it into those whose reliability is above
;;; *WEIGHTED-RATE-HIGH* and those below.  There are other ranges between high
;;; and medium, and between medium and low, and below low, that could conceivably
;;; be useful as well.

(defsubst RELIABLE-SCHEMA? (schema)
  (weighted-rate-high-p (schema-reliability schema)))

(defsubst RELIABLE-SCHEMA-INDEX? (schema-index)
  (reliable-schema? (get-schema schema-index)))

;;; What the name says:  not reliable.  Could be semireliable or totally worthless. 
(defsubst UNRELIABLE-SCHEMA? (schema)
  (not (reliable-schema? schema)))

(defsubst UNRELIABLE-SCHEMA-INDEX? (schema-index)	; Ditto.
  (not (reliable-schema-index? schema-index)))

(defun COUNT-RELIABLE-SCHEMAS (&optional (from 0) (below *schema-number*))
  (loop for index from from below below
	count (reliable-schema-index? index)))

;;; Used by the iteration logging code.
(defun SHOW-RELIABLE-SCHEMAS (&optional iteration dont-list-em (from 0) (below *schema-number*))
  ;; If ITERATION is supplied, we'll talk about what iteration this is.
  ;; If DONT-LIST-EM is supplied, we won't bother listing exactly what
  ;; the reliable schemas are, though.
  (main-format "~A~:[~;Iteration ~:*~D.  ~]~D total schema~:P, ~D reliable schema~:P~
                ~:[ in the range from ~D below ~D~;~2*~]~:[:~;.~]~&"
	       (emit-date-prefix nil nil)
	       iteration
	       *schema-number*
	       (count-reliable-schemas from below)
	       (and (= from 0) (= below *schema-number*))
	       from below
	       dont-list-em)
  (unless dont-list-em
    (loop with printed-counter = 0
	  for index from from below below
	  when (reliable-schema-index? index)
	    do (when (and (zerop (mod printed-counter 25))	; 25 schemas per line.
			  (not (zerop printed-counter)))	; If no reliable schemas yet, don't do a zillion newlines!
		 (main-format "~%")
		 (setf printed-counter 0))
	       (main-format "~D " index)	; No point in forcing wide columns...
	       (incf printed-counter))
    (main-format "~%")))

;;; For exploration.  Not designed to be particularly efficient...
(defun ALL-RELIABLE-SCHEMA-NUMBERS (&optional (from 0) (below *schema-number*) unreliable-instead)
  (loop for index from from below below
	when (or (and (not unreliable-instead)
		      (reliable-schema-index? index))
		 (and unreliable-instead
		      (not (reliable-schema-index? index))))
	  collect index))

;;; For exploration.  Not designed to be particularly efficient...
(defun ALL-RELIABLE-SCHEMAS (&optional (from 0) (below *schema-number*) unreliable-instead)
  (loop for index from from below below
	when (or (and (not unreliable-instead)
		      (reliable-schema-index? index))
		 (and unreliable-instead
		      (not (reliable-schema-index? index))))
	  collect (get-schema index)))

;;; For exploration.  Not used by the iteration logging code.
(defun SHOW-RELIABLE-SCHEMAS-IN-TABLE (&optional (from 0) (below *schema-number*) unreliable-instead)
  (let ((schemas (all-reliable-schemas from below unreliable-instead)))
    (loop for schema in schemas
	  do (format t "~&~A~&" schema)))
  (values))

;;;; Initialization of the schema mechanism.

;;; "Makes" all the items.  Many item functions have been defined, but this stuffs
;;; their names and function cells into the data structure that's actually examined by
;;; the schema mechanism, by calling MAKE-ITEM for each item.  We take care to do
;;; this in the order in which the DEFITEMs were originally compiled, because certain
;;; debugging functions (EYEHAND-SHOW-ITEMS-ENABLED, Ramstad's original function
;;; renamed from his name of SHOW-ITEMS, being the major offender) "know" which
;;; item number is which, and item numbers are assigned sequentially by MAKE-ITEM
;;; each time it's called.  (*sigh* Really, of course, we now have the information in
;;; *primitive-items* to make such functions look the information up instead.  The
;;; first time I need this functionality in a microworld whose dimensions are
;;; different from Ramstad's original microworld, I'll implement it.)
;;;
;;; ITEMS should be the given microworld's *PRIMITIVE-ITEMS* list, as generated by
;;; DEFITEM.  Returns the number of items.
(defun MAKE-ALL-ITEMS (items pkg)
  (setf *item-number* 0)
  (setf *syn-item-number* 0)
  (loop for name in (reverse items)
	do (make-item
	     (string-downcase (symbol-name name))
	     (symbol-function name)
	     pkg))
  *item-number*)

;;; Same as above, but for actions.
(defun MAKE-ALL-ACTIONS (actions pkg)
  (setf *action-number* 0)
  (loop for name in (reverse actions)
	do (make-blank-action-schema
	     (make-action (format nil "/~(~A~)/" (symbol-name name))
			  (symbol-function name)
			  pkg)))
  *action-number*)

;;; Clears various crucial counters that aren't cleared by more specific initialization
;;; routines.  Note that this has to run _before_ MAKE-ALL-ITEMS and _especially_
;;; MAKE-ALL-ACTIONS, because MAKE-ALL-ACTIONS also increments *SCHEMA-NUMBER*
;;; when it defines the bare action schemas.
(defun CLEAR-SOME-MECHANISM-COUNTERS ()
  (setf *clock-tick*    0)
  (setf *schema-number* 0)
  (setf *conj-number*   0)
  (values))

;;; End of file.