;;; -*- Mode:Common-Lisp; Package:Yes-Way; Base:10 -*-

;;; **********************************************************************
;;; Copyright (c) 1990 Stanford University.
;;; This code was written by James Rice.
;;; Copyright is held by Stanford University except where code has been
;;; modified from TI source code.  In these cases TI code is marked with
;;; a suitable comment.

;;; All Stanford Copyright code is in the public domain.  This code may be
;;; distributed and used without restriction as long as this copyright
;;; notice is included and no fee is charged.  This can be thought of as
;;; being equivalent to the Free Software Foundation's Copyleft policy.

;;; TI source code may only be distributed to users who hold valid TI
;;; software licenses.

;;; The development of this software was assisted by the following grants:
;;; Biomedical Research Technology Program of the National Institutes
;;; of Health under grant RR-00785
;;; Information Systems Technologies office of the Defense Advanced
;;; Research Projects Agency under contract N00039-86-C0033.

;;; **********************************************************************

;-------------------------------------------------------------------------------
;;; Definition of rule-sets.

(defflavor rule-set
  ((name (symbol-name (gentemp "NOT-NAMED-" 'user))) ; name of the rule set
   (documentation nil) ; string describing the rule set.
   (rules nil) ; a list of rules in the rule set.
   (precondition 'matches-event-types) ; a function to test the applicability
   (event-types-to-match *All-Event-Types*) ; a list of event types passed to
     ; precondition.
  )
  (sys:print-readably-mixin) ; include this because we fasl dump the rules.
  :Initable-Instance-Variables
  :Gettable-Instance-Variables
  :Settable-Instance-Variables
)


(defmethod (Rule-Set :delete-self) ()
"Removes all record of self from the rule base."
  (loop for Rule in *all-rules* do (send Rule :Remove-Rule-Set self))
  (setq *All-Rule-Sets* (remove self *All-Rule-Sets*))
)

(defmethod (rule-set :Fasd-Form) ()
"Knows how to dump self to a file so that it can be reconstituted again later."
 `(or (Rule-Set-Named ',name)
      (apply #'make-instance ',(type-of self)
	     ',(send self :reconstruction-init-plist)
      )
  )
)

(defun matches-event-types (Event event-types)
"Is true is EVENT matches (is a member of) the list of event types associated
 with this rule set.
"
  (member (string (event-type Event)) event-types :Test #'string-equal)
)

(defmethod (Rule-set :After :Init) (ignore)
"Makes sure that self is added to the rule base, deleting any preexisting
rule sets of the same name.
"
  (setq *all-rule-sets*
	(cons self (remove-if #'(lambda (x) (equal name (Rule-Set-Name x)))
			      *all-rule-sets*
                   )
        )
  )
)

(defmethod (Rule-Set :Remove-Rule) (Rule)
"Removes all rules with the same name as rule from self's rule list."
  (setq rules (remove-if #'(lambda (x) (equal (Rule-Name x) (Rule-Name rule)))
			 rules
	      )
  )
)

(defmethod (Rule-Set :Add-Rule) (Rule)
"Adds a rule to self, flushing out any old rules with the same name."
  (setq *rule-base-changed* t)
  (assert (typep Rule 'Rule) ())
  (setq rules
	(cons Rule
	      (remove-if #'(lambda (x)
			     (or (not (typep x 'Rule))
				 (equal (Rule-Name x) (Rule-Name rule))
			     )
			   )
			   rules
	      )
	)
  )
)

(defun Rule-Set-name (Rule-Set)
"The name of the rule set."
  (send Rule-Set :Name)
)

(defun rule-set-named (name)
"Finds a rule set with a given name.  Returns nil if there is no such."
  (find (string name) *all-rule-sets* :Test #'string-equal :Key #'rule-set-name)
)

(defmethod (Rule-Set :Print-Self) (stream &rest ignore)
"A simple print method for rule sets."
  (format stream "#<Rule-Set ~A>" name)
)

(defmethod (Rule-Set :Applicable-P) (to-event)
"Is true if self is applicable to the event To-Event."
  (let ((*mailer* (get-mail-control-window))
	(*disable-add-associated-filters* t)
       )
       (send self :Test-Precondition to-event)
  )
)

(defmethod (Rule-Set :apply-self) (to-event &optional (force-p nil))
"Applies the rules associated with Self in the context of To-Event.  This is
only done if the precondition is patched, unless Force-P is true.
"
  (let ((*mailer* (get-mail-control-window))
	(*disable-add-associated-filters* t)
       )
       (if (or force-p (send self :Test-Precondition to-event))
	   (loop for Rule in rules do (send Rule :apply-self to-event))
	   :not-run
       )
  )
)

(defmethod (Rule-Set :Test-Precondition) (event)
"Tests the precondition function to see whether we are applicable to the
event.  The precondition must be a function f(event, event-types-to-match).
"
  (or (not precondition) (funcall precondition Event event-types-to-match))
)

(defun edit-rule-set-1 (label)
"An internal function for the rule set editor.  All of the necessary slots
 in the rule set have already been bound to a bunch of specials so all
 this has to do is pop up a cvv menu.
"
  (condition-case nil
   (catch :Abort-Menu
     (tv:choose-variable-values
       `((*name* "Name" :String)
	 (*documentation* "Documentation" :String)
	 (*rules* "Rules" :Multiple-Menu
	  (loop for r in *all-rules* collect
		(list (send r :Name) :Value r :Documentation
		      (send r :Documentation)
		)
	  )
	 )
	 (*precondition* "Precondition Function" :Symbol)
	 (*event-types* "Event-Types to Match" :Multiple-Menu *all-event-types*)
	)
	:Label label
	:Superior tv:default-screen
	:Margin-Choices
	  (List (List "Abort [‘]" '(throw :Abort-Menu :Abort-Menu))
		"Do it [”]"
	  )
     )
     nil
   )
   (sys:abort :Abort-Menu)
  )
)

(defun edit-rule-set
       (&key (Rule-Set-to-edit nil) (label "Create a rule set"))
"Edits a rule set.  If Rule-Set-to-edit is supplied then this is edited,
 otherwise a new one is created.  Pops up a CVV menu to hack on the slots of the
 rule set.  Cleans up afterwards if we abort from the menu.
"
  (setq *rule-base-changed* t)
  (let ((Rule-Set (or Rule-Set-to-edit (make-instance 'Rule-Set))))
       (let ((*name* (send Rule-Set :Name))
	     (*documentation* (send Rule-Set :Documentation))
	     (*rules* (send Rule-Set :Rules))
	     (*precondition* (send Rule-Set :Precondition))
	     (*event-types* (send Rule-Set :Event-Types-To-Match))
	    )
	    (declare (special *name* *documentation* *rules* *precondition*
			      *event-types*
		     )
            )
	    (let ((result (edit-rule-set-1 label)))
	         (if (equal :Abort-Menu result)
		     (if rule-set-to-edit
			 nil
			 (send Rule-Set :delete-self)
		     )
		     (progn (send Rule-Set :Set-Name *name*)
			    (send Rule-Set :Set-Documentation *documentation*)
			    (send Rule-Set :Set-Rules *rules*)
			    (send Rule-Set :Set-Precondition *precondition*)
			    (send Rule-Set :Set-Event-Types-To-Match
				  *event-types*
			    )
		     )
		 )
	    )
       )
  )
)

;-------------------------------------------------------------------------------

;;; Definition of action parts.

(defflavor action-part
  ((action-specifiers '(""))  ;; a list of strings for the lines in the action.
   (parsed-actions nil) ;; action-specifiers after they have been parsed.
   (name "Then") ;; the name of the action part.
  )
  (sys:print-readably-mixin) ;; so that we can fasl dump.
  :Initable-Instance-Variables
  :Gettable-Instance-Variables
  :Settable-Instance-Variables
)

(defmethod (Action-Part :Fasd-Form) ()
"Fasl dumps self so that we can reconstruct ourselves on loading."
  (letf (((symeval-in-instance self 'parsed-actions) nil))
       `(apply #'make-instance ',(type-of self)
	       ',(send self :reconstruction-init-plist)
	)
  )
)

(defmethod (Action-Part :Parse-Actions)
	   (message-pattern-name message-pattern-sequence patterns)
"Is passed the name of the message pattern for the rule of which this is a part,
the message-sequence  that represents that pattern, e.g. MESSAGE and #<Seq 42>
and the list of patterns specified for this rule.  Causes the command strings
in action-specifiers to be parsed in the context of the above, delivering a
list of closures, one for each line.  These will be called later on.
"
  (let ((*named-sequence-alist*
	  (cons (list message-pattern-name message-pattern-sequence) patterns)
	)
       )
       (setq parsed-actions
	     (loop for action in action-specifiers
		   when (not (equal "" action))
		   collect
		     (typecase action
		       (string
			(funcall 'execute-command-from-string
				 action *mailer* 'read-and-execute-command nil
			)
		       )
		       (otherwise
			#'(lambda () (funcall action message-pattern-sequence))
		       )
		     )
	     )
       )
  )
)

(defun Binding-Mailbox-In-Sequences (sequences mailbox continuation)
"Calls the continuation function after it has bound the mailbox slot in each
of the sequences specified in Sequences to point to the mailstream Mailbox.
"
  (if sequences
      (if (second (first sequences))
	  (letf (((symeval-in-instance (second (first sequences)) 'mailbox)
		  mailbox
		 )
		)
		(Binding-Mailbox-In-Sequences
		  (rest sequences) mailbox continuation
		)
	  )
	  (Binding-Mailbox-In-Sequences (rest sequences) mailbox continuation)
      )
      (funcall continuation)
  )
)

(defmethod (Action-Part :apply-self) (to-event superior)
"Applies the actions in self in the context of to-event.  Superior is the rule
of which we are a part.  Has to do a certain amount of magic binding of slots
in the message sequences to make them appear concrete.
"
  (let ((message-pattern-name     (send superior :message-pattern-name))
	(message-pattern-sequence (send superior :message-pattern-sequence))
	(patterns                 (send superior :patterns))
       )
       (letf (((symeval-in-instance message-pattern-sequence
				    'sequence-specifier
               )
	       (list (Event-Message to-event))
	      )
	      ((symeval-in-instance message-pattern-sequence 'mailbox)
	       (Event-Mailbox to-event)
	      )
	     )
	     (send message-pattern-sequence :Canonicalise-Specifier t)
	     (Binding-Mailbox-In-Sequences patterns (Event-Mailbox to-event)
	       #'(lambda ()
		   (if (not parsed-actions)
		       (send self :Parse-Actions message-pattern-name
			     message-pattern-sequence patterns
		       )
		       nil
		   )
		   (loop for action in parsed-actions do (funcall action))
		 )
	     )
       )
  )
)


;-------------------------------------------------------------------------------
;;; Definition of rules.

(defflavor rule
  ((name (symbol-name (gentemp "NOT-NAMED-" 'user))) ;; name of the rule.
   (documentation "") ;; doc string for the rule.
   (patterns '((:Pattern nil) (:Pattern-2 nil) (:Pattern-3 nil))) ;; a Alist
     ;; of pattern-name & pattern pairs.  If the pattern is not nil then it is a
     ;; message-sequence whose sequence specifier defined the pattern.
   (message-pattern-name :Message) ;; the name of the patter to use for the
     ;; message that triggered this rule.
   (message-pattern-sequence (simple-disembodied-sequence 0))
     ;; the message sequence that is used to denote the message that
     ;; triggered the rule.
   (condition 'matches-patterns) ;; The condition part of the rule, which
     ;; typically will test to see whether the patterns match.
   (action-selector 'apply-all-actions)
     ;; The function that selects the action parts of the rule.  The default
     ;; invokes all of the actions in the list of actions.  It could, however
     ;; do a then/else or a case type test easily.  Actions can then be
     ;; selected on the basis of their names.
   (actions (list (make-instance 'Action-Part)
		  (make-instance 'Action-Part)
		  (make-instance 'Action-Part)
		  (make-instance 'Action-Part)
		  (make-instance 'Action-Part)
		  (make-instance 'Action-Part)
	    )
     ;; The actions to perform (a list of them).
   )
   (rule-sets (list (Rule-Set-Named "Default"))) ;; The rule sets of which this
     ;;  rule is a member.
  )
  (sys:print-readably-mixin) ;; we want to fasl dump.
  :Initable-Instance-Variables
  :Gettable-Instance-Variables
  :Settable-Instance-Variables
)

(defun apply-all-actions (actions event rule)
"The default action part selector function.  Applies all of the action parts in
Actions, which belong to Rule, to the event Event.
"
  (loop for action in actions do (send action :Apply-Self event rule))
)

(defmethod (rule :Fasd-Form) ()
"Dumps a rule to a file so that it can be read back in again.  Adds itself
to the rule base as appropriate and connects itself to its parent rule sets.
"
 `(or (Rule-Named ',name)
      (let ((Rule (apply #'make-instance ',(type-of self)
			 ',(send self :reconstruction-init-plist)
		  )
	    )
	    (*rule-base-changed* nil)
	   )
	   (loop for set in (send Rule :Rule-Sets) do
		 (send set :Add-Rule Rule)
	   )
	   rule
      )
  )
)

(defun rule-name (Rule)
"The name of the rule."
  (send Rule :name)
)

(defun rule-named (name)
"Finds a rule named Name or returns nil."
  (find (string name) *all-rules* :Test #'string-equal :Key #'rule-name)
)

(defun matches-patterns (Event patterns)
"Is true if the event Event matches all of the patterns in Patterns.  This
means that the message number specified by the event passes the
:accept-message-p predicate for each of the non null patterns
in the pattern list.
"
  (loop for (sequence-name sequence) in patterns always
	(or (not sequence)
	    (letf (((symeval-in-instance sequence 'mailbox)
		    (event-mailbox event)
		   )
		   ((symeval-in-instance sequence 'owner) *mailer*)
		   ((symeval-in-instance sequence 'computed-order)
		    :undefined
		   )
		  )
		  (send sequence :Accept-Message-P (event-message event))
	    )
	)
  )
)

(defmethod (Rule :apply-self) (event)
"Applies self to the Event.  If the condition part passes then the action part
selector is called to invoke the appropriate action parts.
"
  (letf (((symeval-in-instance *mailer* 'current-mailbox)
	  (Event-Mailbox event)
	 )
	)
        (let ((*mailer* (get-mail-control-window)))
	     (if (funcall condition Event patterns)
		 (funcall action-selector actions event self)
		 :if-part-failed
	     )
	)
  )
)

(defmethod (Rule :Print-Self) (stream &rest ignore)
"A simple print method for rules."
  (format stream "#<Rule ~A>" name)
)

(defmethod (Rule :After :Init) (ignore)
"Adds self to the rule base."
  (pushnew self *all-rules*)
)

(defmethod (Rule :delete-self) ()
"Removes all record of self from the rule base and disconnects self from
the rule-sets that own it.
"
  (loop for Rule-Set in rule-sets do (send Rule-Set :remove-rule self))
  (setq *All-Rules* (remove self *All-Rules*))
)

(defmethod (Rule :remove-rule-set) (rule-set)
"Removes a rule set from the list of rule sets that own this rule."
  (setq rule-sets
	(remove-if
	  #'(lambda (x) (equal (Rule-Set-Name x) (rule-set-name Rule-Set)))
	  rule-sets
	)
  )
)

(defun edit-rule-with-menu-2 (label)
"An internal function for the rule editor.  All of the necessary slots
 in the rule have already been bound to a bunch of specials so all
 this has to do is pop up a cvv menu.
"
  (declare (special *actions*))
  (condition-case nil
   (catch :Abort-Menu
     (tv:choose-variable-values
     `((*name* "Rule Name" :String)
       (*documentation* "Documentation" :String)
       (*rule-sets* "Add to rule sets"
	:Multiple-Menu (loop for rs in *all-rule-sets* collect
			     (list (send rs :Name) :Value rs :Documentation
				   (send rs :Documentation)
			     )
		       )
       )
       (*pattern-name* "Name for matching message" :Princed-Symbol)
       ""
       "Condition Part"
       (*condition* "Condition Function" :Capitalized-Symbol)
       (*patterns*
	(0 "Pattern name" :princed-Symbol)
	(1 "Pattern" :Sequence)
       )
       (*action-selector* "Action Selector Function" :Capitalized-Symbol)
       ""
       "Action Part"
       (*actions*
	(0 "Name" :String)
	(1 "Action" :Action)
       )
      )
      :Label label
;      :Width (min 600 (send tv:default-screen :Width))
      :Superior tv:default-screen
      :Margin-Choices
	(List (List "Abort [‘]"
		    '(throw :Abort-Menu :Abort-Menu)
	      )
	      "Do it [”]"
	)
     )
   )
   (sys:abort :Abort-Menu)
  )
)

(defun edit-rule-with-menu-1 (Rule label)
"Edits a rule.  Pops up a CVV menu to hack on the slots of the
 rule.  Cleans up afterwards if we abort from the menu.  Label is the label to
 use on the menu.
"
  (declare (special *actions*))
  (let ((*name* (send Rule :Name))
	(*documentation* (send Rule :Documentation))
	(*rule-sets* (send Rule :Rule-Sets))
	(*pattern-name* (send Rule :Message-Pattern-Name))
	(*condition* (send Rule :Condition))
	(*patterns* (send Rule :Patterns))
	(*action-selector* (send Rule :Action-Selector))
	(*actions*
	  (loop for action in (send Rule :Actions) collect
		(list (send action :Name)
		      (send action :Action-Specifiers)
		)
	  )
	)
       )
       (declare (special *name* *documentation* *rule-sets* *pattern-name*
			 *condition* *patterns* *action-selector* *actions*
		)
       )
       (let ((result (Edit-rule-with-menu-2 label)))
	    (if (equal :Abort-Menu result)
		result
		(progn (send Rule :Set-Name *name*)
		       (send Rule :Set-Documentation *documentation*)
		       (send Rule :Set-Rule-Sets *rule-sets*)
		       (send Rule :Set-Message-Pattern-Name *pattern-name*)
		       (send Rule :Set-Condition *condition*)
		       (send Rule :Set-Patterns *patterns*)
		       (send Rule :Set-Action-Selector *action-selector*)
		       (loop for action in (send Rule :Actions)
			     for (name specs) in *actions* do
			     (send action :Set-Name name)
			     (send action :Set-Action-Specifiers specs)
		       )
		       nil
		)
	    )
       )
  )
)

(defun checking-named-sequences (thing accessor)
"Checks to see whether Thing is the name of a named sequence.  If it is then
it uses the accessor to build a closure that will return the correct field
from the message in question when needed later.  If it is not one of the
named sequences then the thing is simply returned.  The closure created
gets embedded in a message sequence object.  The message sequence code
knows how to concretify this when needed later.
"
  (let ((entry
	  (assoc (if (stringp thing)
		     thing
		     (format nil "~A" thing)
		 )
		 *named-sequence-alist* :Test #'string-equal
	  )
	)
       )
       (if entry
	 #'(lambda ()
	     (let ((stream (if (boundp-in-instance (second entry) 'mailbox)
			       (send (second entry) :Mailstream)
			       (ferror nil "Mailbox is unset in ~S."
				       (second entry)
			       )
			   )
		   )
		  )
		  (funcall accessor stream
			   (send (second entry) :Numberise-Messages)
                  )
	     )
	   )
	   thing
       )
  )
)

(Defun edit-rule-with-menu
       (&key (label "Define a rule") (Rule-to-edit nil) (name nil))
"Edits a rule.  If Rule-to-Edit is specified then this is edited, otherwise a
new one is created with the name Name if it is provided.  It edits the rule by
popping up a cvv menu.
"
  (assert (not (and rule-to-edit name)) ())
  (setq *rule-base-changed* t)
  (let ((*mailer* (get-mail-control-window)))
       (let ((Rule (or Rule-to-edit (make-instance 'Rule)))
	     (*make-sequence-with-no-mailbox-ok-p* t)
	    )
	    (let ((*named-sequence-alist*
		    (list (list (send Rule :Message-Pattern-Name)
				(send Rule :message-pattern-sequence)
			  )
		    )
		  )
		 )
	         (declare (special *actions*))
		 (loop for action in (send Rule :Actions) do
		       (send action :Set-Parsed-Actions nil)
		 )
		 (if name (send Rule :Set-Name name))
		 (let ((result (edit-rule-with-menu-1 Rule label)))
		      (loop for Rule-Set
			    in (set-difference *All-Rule-Sets*
					       (Send Rule :Rule-Sets)
			       )
			    do (send Rule-Set :Remove-Rule Rule)
		      )
		      (if (and (equal :Abort-Menu result)
			       (not rule-to-edit)
			  )
			  (send Rule :Delete-Self)
			  (loop for Rule-Set in (Send Rule :Rule-Sets)
				do (send Rule-Set :Add-Rule Rule)
			  )
		      )
		 )
		 Rule
	    )
       )
  )
)

;-------------------------------------------------------------------------------
;;; Define CVV type for symbol and for princed symbol.

(defun cvv-read-symbol (stream)
  "Read in and validate a symbol."
  (let ((*package* (find-package 'user)))
       (let ((symbol (read stream t)))
	    (if (symbolp symbol) symbol (ferror () "A Symbol is required."))
       )
  )
)

(defun capitalize-princ (thing stream)
"Princs thing with print case set to :capitalize."
  (let ((*print-case* :Capitalize))
       (princ thing stream)
  )
)

(defun capitalize-prin1 (thing stream)
"Prin1s thing with print case set to :capitalize."
  (let ((*print-case* :Capitalize))
       (prin1 thing stream)
  )
)

;;; Define some new CVV types.
(setf (get :Symbol 'tv:choose-variable-values-keyword) '(prin1 Cvv-Read-Symbol))
(setf (get :Capitalized-Symbol 'tv:choose-variable-values-keyword)
      '(capitalize-prin1 Cvv-Read-Symbol)
)
(setf (get :Princed-Symbol 'tv:choose-variable-values-keyword)
      '(capitalize-princ Cvv-Read-Symbol)
)

;-------------------------------------------------------------------------------

;;; Define CVV type to read an action.

;;; Add the CVV type.
(setf (get :action 'tv:choose-variable-values-keyword-function)
      'choose-variable-values-decode-action
)

(defun choose-variable-values-decode-action (kwd-and-args)
"Cribbed from :menu."
  (let ((action (and (consp kwd-and-args) (second kwd-and-args))))
       (declare (special action))
       (values (closure '(action) 'choose-variable-values-action-print)
	       nil nil nil
	       (closure '(action) 'choose-variable-values-action)
	       "Click left to select a new value for this action"
       )
  )
)

(defun choose-variable-values-action (value)
"Edits an action part by putting it into a popup zmacs."
  (declare (special action))
  (let ((new-value
	  (let ((full-string
		  (if (stringp value) value (format nil "~{~A~^~%~}" value))
		)
	       )
	       (remove-if #'(lambda (x) (equal "" x))
		 (split-into-lines
		   (or (zwei:pop-up-edstring
			 full-string
			 '(:Mouse) nil
			 (min 500 (send tv:default-screen :Width))
			 (min 400 (send tv:default-screen :Height))
		       )
		       full-string
		   )
		   0
		 )
	       )
	  )
	)
       )
       (if new-value new-value value)
  )
)


(defun choose-variable-values-action-print (value stream)
"Prints out Value all on one line with s where the newlines would be."
  (declare (special action))
  (format stream "~{~A~^~}" (list-if-not (or value '"")))
)


;-------------------------------------------------------------------------------

;;; Define CVV type to read sequences.

;;; Add the CVV type.
(setf (get :sequence 'tv:choose-variable-values-keyword-function)
      'choose-variable-values-decode-sequence
)

(defun choose-variable-values-decode-sequence (kwd-and-args)
"Cribbed from :Menu."
  (let ((sequence (and (consp kwd-and-args) (second kwd-and-args))))
       (declare (special sequence))
       (values (closure '(sequence) 'choose-variable-values-sequence-print)
	       nil nil nil
	       (closure '(sequence) 'choose-variable-values-sequence)
	       "Click left to select a new value for this sequence"
       )
  )
)

(defun choose-variable-values-sequence (value)
"Edits a sequence using a CVV menu."
  (declare (special sequence))
  (let ((window self))
       (let ((new-value
	       (Read-Sequence-With-Menu
		 :Just-Specifier-P nil :Label "Specify a pattern"
	       )
	     )
	    )
	    (send window :Mouse-Select)
	    (if new-value new-value value)
       )
  )
)

(defun choose-variable-values-sequence-print (value stream)
"Princs out a sequence in a simple form."
  (declare (special sequence))
  (if value
      (princ (make-label-from-filter value) stream)
      (princ "" stream)
  )
)


;-------------------------------------------------------------------------------

;-------------------------------------------------------------------------------

(defun print-agenda (process-window)
"Prints statistics about the current agenda into the process status window."
  (declare (special *rule-processor*))
  (let ((agenda (send *rule-processor* :Agenda))
	(events (send *rule-processor* :Event-List))
       )
       (if (and *all-rules* (or agenda events))
	   (princ (format nil "Rules: ~D:~D, "
			  (length events) (length agenda)
		  )
		  process-window
           )
	   nil
       )
  )
)

;;; Adds print-agenda to the list of things to do in the process status window.
(if (not (member 'print-agenda *other-things-to-do-in-status-window*))
    (setq *other-things-to-do-in-status-window*
	  (append *other-things-to-do-in-status-window*
		  (list 'print-agenda)
	  )
    )
    nil
)