;; $Id: assistance.lsp,v 1.10 2001/03/21 20:50:34 moltmans Exp $
;; test-rules.lsp -- 
;; Author: Michael Oltmans <moltmans@ai.mit.edu> 
;; Created: <Wed Jan 24 21:10:54 2001> 
;; Time-stamp: <2001-03-18 13:46:24 moltmans> 

(in-package :COMMON-LISP-USER)
(require :jlinker)
(defpackage :javatools.jlinker (:nicknames :jl))

(defparameter *assistance-files*
  '("answer"
    "assistance"
    "load-lisp"))

(defvar *assistance-rule-file* "rules")
(defvar *assistance-debug-flags* nil)
(defvar *assistance-notebook* nil)
(defvar *assistance-solutions* nil)
(defvar *best-solution* nil)
(defvar *num-solutions* 0)

(defun compile-assistance ()
  (bps-load-files (make-BPS-path *BPS-path*)
		  *assistance-files* :action :compile)
  (unless (and (boundp '*ltre*)
               (not (null *ltre*)))
    (load-bps-system "ltms" "ltre" "load-ltre")
    (create-ltre "DUMMY"))
  (bps-load-files (make-BPS-path *BPS-path*)
		  *assistance-rule-file* :action :compile))

(defun make-assistance-tms ()
  (let ((ltre (create-ltre "ASSISTANCE-TMS")))
    (setq *assistance-debug-flags*
	  '(:MAIN :FIND-CHOICES :COMPOSITE-SETS :JAVA)) ;:FIND-CAUSES
    (in-ltre ltre)
;    (pushnew 'assert-moves *macros-to-expand*)
;     (push 'user-contradicts-world-handler
; 	  (ltms-contradiction-handlers (ltre-ltms ltre)))
    (push 'event-CWA-Contradiction-Handler
	  (ltms-contradiction-handlers (ltre-ltms ltre)))

;    (change-ltms (ltre-ltms ltre)
;		 :contradiction-handler #'assistance-contradiction-handler)
;    (bps-load-file *bps-path* *assistance-rule-file*))
    ;; load the rules that support cwa's
    (bps-load-file *ltre-path* *set-rule-file*)))

(defun run ()
  (debugging-assistance
   :MAIN "~%==================================================")
  (debugging-assistance
   :MAIN "~%Processing Current State of the World:~%")

  (run-rules)
  (debugging-assistance :MAIN "~%Finding default motions...")
  (default-motions)
  (run-rules)
  (debugging-assistance :MAIN "~%Building event equivalence classes...")
  (build-event-equivalence-classes)
  (run-rules)
  (close-event-sets-and-set-times)
;  (run-rules)
;  (build-composite-events)
  (run-rules)
  (close-composite-events)
  (find-causes)
  (setq *best-solution* nil)
  (cond ((cdr *assistance-solutions*)
	 (debugging-assistance :MAIN "~%Multiple (~D) solutions: ~%    ~A"
			       (length *assistance-solutions*)
			       *assistance-solutions*)
	 (prune-solutions *assistance-solutions*))
	(t
	 (setq *best-solution* (first *assistance-solutions*))))
  (dolist (soln *assistance-solutions*)
    (format t "~%==================================================")
    (format t "~%Solution: ")
    (print-causal-chains (build-causal-chains soln)))
  (format t "~%==================================================")
  (format t "~%Best Solution: ")
  (print-causal-chains (build-causal-chains *best-solution*))
  (adjust-parameters)
  )

;;; If there are multiple solutions put together one that follows the
;;; description order
(defun prune-solutions (solns)
  ;;; these are the solutions everyone agrees on
  (let* (;;; All the possible
	 (possibles (assemble-possible-causes solns))
	 (best-solution (remove nil
				(mapcar #'(lambda (poss)
					    (when (null (cddr poss))
					      (second poss)))
					possibles)))
	 (assumptions nil))
    (setq possibles (remove-if #'(lambda (poss)
				   (null (cddr poss)))
			       possibles))
    (format t "~%====================")
    (format t "~%Possibles:   ~A" possibles)
;    (format t "~%Best: ~A" best-solution)
    (assuming best-solution *LTRE*
      (dolist (possible possibles)
	(let* ((this-time (get-event-time (car possible)))
	       (cause (find-if
		       #'(lambda (cause)
			   (let ((time (get-event-time (second cause))))
			     (and (< time this-time)
				  (>= time 0))))
		       (cdr possible))))
	  (when (null cause)
	    (setq cause (find-if
			 #'(lambda (cause)
			     (let ((time (get-event-time (second cause))))
			       (< time this-time)))
			 (cdr possible))))
	  (if cause
	      (setq assumptions (push cause assumptions))
	    (format t
		    "~%WARNING:  There should be at least one cause: ~A"
		    possible))))
      (format
       t
       "~%Trying to find best solution by trying these assumptions:~%  ~A"
       assumptions)
      (try-assumptions assumptions))))

(defun try-assumptions (soln)
  (if (null soln)
      (setq *best-solution* (find-if #'(lambda (soln)
					 (every #'true? soln))
				     *assistance-solutions*))
    (assuming (list (car soln)) *LTRE*
      (try-assumptions (remove-if-not #'unknown? soln)))))

  
;;; collect the causes from each solution into a set of possible
;;; causes for each event.  This sounds like what we do in the first
;;; step of the whole algorithm by finding possible causal links but
;;; these are only the possible solutions that are part of a possible
;;; complete causal structure.
(defun assemble-possible-causes (solns)
  ;;; sort the events by earliest description time and if there are
  ;;; more than one cause for an event pick the earliest described
  ;;; cause.  (Sort in reverse order since we push elements onto the
  ;;; list and thus reverse it...)
  (let ((events (sort (fetch-event-sets) #'> :key #'get-event-time))
	possibles)
    (dolist (event events)
      (let ((causes nil))
	(dolist (soln solns)
	  (let ((cause (find event soln :key #'third :test #'equal)))
	    (pushnew cause causes)))
	(push (cons event causes) possibles)))
    possibles))
	

(defun find-causes (&optional debug)
  (setq *assistance-solutions* nil)
  (setq *num-solutions* 0)
  (let ((*debug-dds* debug)
	(choices (build-causal-choice-sets)))
    (debugging-assistance :FIND-EVENTS "~%    Events: ~A" (fetch-event-sets))
    (debugging-assistance :FIND-CHOICES "~%    Choices: ~A" choices)
    (tracking-dd-search choices
			#'assistance-add-solution))
  (format t "~%Found ~D solutions" *num-solutions*))


;;; this really shouldn't be here.  it really should just do the same
;;; thing done by talk about causality...
(defun build-causal-chains (choice-sets)
  (let ((answer nil)
	(chains (remove 'exogenous-cause choice-sets
			:key #'caadr :test-not #'eq)))
;     (dolist (choice choice-set)
;       (when (eq (car (second choice)) 'exogenous-cause)
; 	(push (list (third choice)) chains)))

; 			(mapcar #'(lambda (choice)
; 				     (if (eq (car (second choice))
; 					     'exogenous-cause)
; 					 (list (third choice))
; 				       nil))
; 				 choice-set))))
;    (format t "~%Roots ~A" chains)
    (dolist (chain (mapcar #'cddr chains) answer)
;      (format t "~%chain: ~A" chain)
      (do ((effect (find (first chain) choice-sets
			 :key #'second :test #'equal)
		   (find (third effect) choice-sets
			 :key #'second :test #'equal))
	   (result (list (first chain))
		   (cons (third effect) result)))
	  ((null effect) (push (reverse result) answer))))))


(defun assistance-add-solution (choices)
  (incf *num-solutions*)
  ;; delete any solutions that are less general than this one
  (setq *assistance-solutions*
	(remove-if #'(lambda (option)
		       (super-assumption-p choices option))
		   *assistance-solutions*))
  ;; if it is more general than some other option add it to the list
  (cond ((not (find-if #'(lambda (option)
			   (super-assumption-p option choices))
		       *assistance-solutions*))
	 (push choices *assistance-solutions*)
	 (debugging-assistance :FIND-CAUSES
			       "~%  Adding solution:~%    ~A" choices))
	(t
	 (debugging-assistance
	  :FIND-CAUSES
	  "~%  More general solutions exist:~%    ~A" choices))))

(defun super-assumption-p (sup sub)
  (every #'(lambda (c1 c2)
	     (or (equal c1 c2)
		 (equal (car (second c2)) 'exogenous-cause)))
	 sup sub))




(defmacro debugging-assistance (key msg &rest args)
  `(when (member ,key *assistance-debug-flags*)
     (format t ,msg ,@ args)))

(defmacro with-solution (&rest body)
  `(cond ((null *best-solution*)
	  (error "~%There was no solution, cannot proceed"))
	 (t
	  (assuming *best-solution* *LTRE*
	    ,@ body))))

(defun build-causal-choice-sets ()
  (let ((events (fetch-event-sets))
	(choices nil))
    (dolist (event events choices)
      (let* ((causes (mapcar #'solidify-can-cause
			     (fetch-possible-causes-of event)))
	     (true (find-if #'(lambda (cause)
				;; this may not be necessary: why are
				;; exogenous causes special in this
				;; case?  if the utterance is "when
				;; one moves the stopper..." it is
				;; clear that the cause is exogenous so
				;; we should believe a causes.
				(and (not (eq (car (second cause))
					      'exogenous-cause))
				     (true? cause)))
			    causes)))
	;; this makes sure that we don't try other opttions if we
	;; already know the cause
; 	(format t "~%event = ~A" event)
; 	(format t "~%causes = ~A" causes)
; 	(format t "~%true = ~A" true)
	(if true
	    (setq choices (cons (list true) choices))
	  (setq choices (cons causes choices)))
;	(format t "~%choices = ~A" choices)
	))))
	  

;   (let ((events (fetch-event-sets)))
;     (mapcar #'solidify-can-cause
; 	    (mapcar #'fetch-possible-causes-of events))))

(defun solidify-can-cause (can-cause)
  "Replace (can-cause ?a ?b) with (causes ?a ?b)"
  (subst 'causes 'can-cause can-cause))

(defun fetch-possible-causes-of (event &optional (status nil))
  (cond-fetch `(can-cause ?event ,event) status))

(defun find-causes-of (event &optional (status :TRUE))
  (mapcar #'second (cond-fetch `(causes ?event ,event) status)))

(defun fetch-possible-effects-of (event &optional (status nil))
  (cond-fetch `(can-cause ,event ?event) status))

(defun find-effects-of (event &optional (status :TRUE))
  (mapcar #'third (cond-fetch `(causes ,event ?event) status)))

(defun find-subject-of (event &optional (status :TRUE))
  (dolist (id (set-members event))
    (let ((move (cond-fetch `(moves ?body ,id) status)))
      (when move
	(return (second (first move)))))))

(defun find-cannonical-event (event &optional (status :TRUE))
  (let ((cannonicals (cond-fetch `((event ?id) has-member ,event)
				status)))
    (when (cdr cannonicals)
      (error "Event ~A has multiple cannonical reps:~%   ~A"
	     event cannonicals))
    (first (first cannonicals))))

(defun find-body-name (body &optional (status :TRUE))
  (let ((names (cond-fetch `(name ?name ,body) status)))
    (when (cdr names)
      (error "Body ~A has multiple names:~%   ~A"
	     body names))
    (second (first names))))

(defun find-english-name (item &optional (status :TRUE))
  (if (eq (first item) 'exogenous-cause)
      "exogenous force"
    (find-body-name item status)))

(defun find-body-by-name (name &optional (status :TRUE))
  (let ((bodies (cond-fetch `(name ,name ?body) status)))
    (when (cdr bodies)
      (error "~A represents several entities:~%   ~A"
	     body bodies))
    (third (first bodies))))


(defun print-causal-chains (chains)
  (dolist (chain chains)
    (format t "~%Causes: ")
    (dolist (event chain)
      (format t "~%        ~A" event))))

; (defun user-contradicts-world-handler (clauses ltre)
;   (let ((body (moving-the-unmoveable clauses)))
;     (when body
;       (report-error-to-java "~A cannot move" (find-body-name body)))))

; (defun moving-the-unmoveable? (clauses)
;   (let ((moves (fetch-cond
;   (let ((moves (remove 'moves clauses :key #'car :test-not #'eq))
; 	(can-moves (remove 'can-moves clauses :key #'car :test-not #'eq)))
;     (dolist (m moves)
;       (when (find (second m) can-moves :key #'second)
; 	(return-from moving-the-unmoveable (second m))))))
	     
(defun report-error-to-java (message &rest args)
  (format t "~%")
  (apply #'format t message args))
	

;;; This does not make any provisions for which of a set of possible
;;; assumptions is chosen only that it will pick one consistant set
;;; ex: a, b, c wher ab and bc are contradictions if they are tested
;;; as a, b, c then a and c will be in but if they are tested as b, c,
;;; a then b will be the only believed node...
(defun default-motions (&optional (ltre *LTRE*))
  (let ((num-assertions 0))
    (with-contradiction-check
     (ltre-ltms ltre)
     (with-contradiction-handler
      (ltre-ltms ltre)
      #'(lambda (clauses ltms)
	  (throw 'BAD-DEFAULT 'bad-default-assumption))
      (dolist (assumption
	       (remove-if-not #'unknown?
			      (append (fetch '(can-rotate ?fact))
				      (fetch '(can-translate ?fact)))))
	(incf num-assertions)
	(let ((answer (catch 'BAD-DEFAULT (assume! assumption :DEFAULT))))
	  (when (eq answer 'bad-default-assumption)
	    (decf num-assertions)
	    (retract-assumption assumption))))))
    num-assertions))


(defun add-exogenous-causes (choice-sets)
  "Add an option to each set that says that an external event caused the event."
  (mapcar #'(lambda (choice-set)
	      (let ((event (third (first choice-set))))
		(append choice-set `((exogenous-cause ,event)))))
	  choice-sets))


(defun add-no-choice-needed (choice-sets)
  "Add an option to each set that says that no choice needs to be made"
  (mapcar #'(lambda (choice-set)
	      (append choice-set '((no-choice-needed))))
	  choice-sets))


; (defun build-event-sets ()
;   (let ((sets nil))
;     (dolist (event (fetch '(moves ?body ?id)))
;       (dolist (same (fetch `(same-event ?event ,(third event))))
; 	(setq sets (add-pair-to-sets (third event) (second same) sets))))

;     (dolist (set sets)
;       ;; sort by annotation time to have a consistent set name
;       (sort set #'< :key #'get-event-time)
;       (assert! `(set (event ,(car set))) :set-def)
;       (dolist (member set)
; 	(assert! `((event ,(car set)) has-member ,member) :same-events)))))

(defun get-event-time (event)
  (let ((facts (cond-fetch `(time ,event ?time) :TRUE)))
    (cond ((cdr facts)
	   (error "Shouldn't have more than one time for event: ~A" facts))
	  ((and (listp event)
		(eq (car event) 'exogenous-cause))
	   -1)
	  (t
	   (third (car facts))))))

(defun add-pair-to-sets (x1 x2 foos)
  (format t "~%Pair ~A ~A" x1 x2)
  (do ((beg nil (append beg (list elmt)))
       (s (cdr foos) (cdr s))
       (elmt (car foos) (car s)))
      ((null elmt) (cons (list x1 x2) foos))
    (cond ((member x1 elmt)
	   (return-from add-pair-to-sets
	     (append beg (pushnew x2 elmt) s)))
	  ((member x2 elmt)
	   (return-from add-pair-to-sets
	     (append beg (pushnew x1 elmt) s))))))


(defun cond-fetch (form &optional (status nil)
			&aux matches)
  "fetch conditionally according to status :TRUE :FALSE :KNOWN :UNKOWN nil"
  (setq matches (fetch form))
  (case status
    (:TRUE (remove-if-not #'true? matches))
    (:FALSE (remove-if-not #'false? matches))
    (:KNOWN (remove-if-not #'known? matches))
    (:UNKNOWN (remove-if-not #'unknown? matches))
    (t matches)))

(defun fetch-event-sets ()
  (mapcar #'second (cond-fetch '(set (event ?id)) :TRUE)))


; ;; this may be even easier since we assert same-event facts right
; ;; away.  we start with no cwa sets and create them as we go.  if
; ;; there is no acative cwa set for any items in a set make a new cwa
; ;; set.

; ;; QUESTION: do we need to retract first?  i think not since
; ;; has-member's that are invalid will take themselves out because the
; ;; only way to go out is to take away the same-event fact.

; ;; if any event in a set allready has a cwa set assume that the event
; ;; is a member of it.  this will cause all events that are same-event
; ;; to it to fall in place as well (due to the rule that puts events in
; ;; the same set if they are same-event of one another).  If there is
; ;; no cwa for any of the elements of the set then make a new (event
; ;; id) cwa set and put the first element of set in it.
 
; ;; the only time we have a real problem is when there are two sets
; ;; and then they need to be merged.  this will spark a
; ;; contradiction.  where should the handler be?  top level?

;   ;; make sure we start fresh by retracting any assumed has-member
;   ;; statements
;   (retract-set-assumptions) 
;   (dolist (set (build-event-sets))
;     (let ((currents (fetch `((event ?id ?
;       (assume! `((,(car set)

;; make sure we have all current same-event facts enabled and
(defun build-event-equivalence-classes ()

  ;; if we get contradictions in event sets it will be because there
  ;; are two sets and then a same-event will be asserted w/events from
  ;; both sets...
  (run-rules)
  (let ((events (mapcar #'second
			(cond-fetch '(event ?event) :TRUE))))
    (dolist (event (remove-if-not #'true? events))
      ;; if there is no cwa that includes this event then make one
      ;(debugging-assistance :EVENT-SETS "~%    For event: ~A" event)
      (cond ((not
	      (find-if #'true?
		       (fetch `((event ?id) has-member ,(third event)))))
	     (let ((set `(set (event ,(new-event-id "event"
						    (second event))))))
	       (debugging-assistance :EVENT-SETS
				     "~%    Making new event-set: ~A" set)
	       (debugging-assistance :EVENT-SETS
				     "~%               With seed: ~A" event)
	       (assume! set :cwa-for-new-event)
	       (assume! `(,(second set) has-member ,(third event))
			:seed-set-member)
	       ;; need to pull in the rest of the members so run rules
	       (run-rules)
;	       (close-set-if-needed (second set))
	       ))
	    (t
	     (debugging-assistance :EVENT-SETS
				   "~%    Set exists for: ~A" event))))))


(defun build-composite-events ()
  "Build cwa for (describes ?note ?event) when there's several events per note"
  (run-rules)
  (let ((descs (cond-fetch '(describes ?note ?id) :TRUE)))
    (dolist (desc descs)
      ;; if there is no cwa that includes this description then make one
      (debugging-assistance :COMPOSITE-SETS
			    "~%    For description: ~A" desc)
      (cond ((find-if
	      #'true?
	      (fetch `((describes ?id) has-member ,(third desc))))
	     (debugging-assistance :COMPOSITE-SETS
				   "~%    Description exists for: ~A" desc))
	    (t
	     (let ((set `(set (describes ,(second desc)))))
	       (debugging-assistance :COMPOSITE-SETS
				     "~%    Making new description-set: ~A"
				     set)
	       (debugging-assistance :COMPOSITE-SETS
				     "~%               With seed: ~A" desc)
	       (assume! set :CWA-FOR-NEW-COMPOSITE-EVENT)
	       (assume! `(,(second set) has-member ,(third desc))
			:seed-set-member)
	       ;; need to pull in the rest of the members so run rules
	       (run-rules)
;	       (close-set-if-needed (second set))
	       ))))))

(defun fetch-composite-events ()
  (mapcar #'second (cond-fetch '(set (describes ?note)) :TRUE)))

(defun close-composite-events ()
  (let ((composites (fetch-composite-events)))
    (mapcar #'close-set-if-needed composites)))


(defun close-event-sets-and-set-times ()
  (let ((events (fetch-event-sets))
	(updates nil))
    ;; first cloe the sets
    (dolist (event events)
      (multiple-value-bind (m-ignore cwa work?)
	  (close-set-if-needed event)
	(when work?
	  (push cwa updates)
	  (debugging-assistance :EVENT-SETS
				"~%    Updating set for: ~A" event))))

    ;; update the earliest explanation time for each event
    (dolist (cwa updates)
      (let ((time (apply #'min (mapcar #'get-event-time (third cwa)))))
	(assert! `(:IMPLIES ,cwa (time ,(car cwa) ,time))
		 :EVENT-TIME-IS-FIRST-DESCRIPTION-TIME)))))

(defun process-new-input ()
  (run)
  )

(defun show-defaults ()
  (dolist (default (fetch '(default ?a)))
    (dolist (value (fetch `(,(second default) ?a)))
      (format t "~%~A: ~A" value (label-of value)))))

		
	

; (defun assistance-contradiction-handler (jtms contradictions)
;   (let* ((cnode (first contradictions))
; 	 (datum (tms-node-datum cnode))
; 	 (form (datum-lisp-form datum)))
;     (cond ((not (listp form))
; 	   (error "~%Exepected a list in contradiction: ~A" form))
; 	  ((eq (car form) 'violated-default)
; 	   (format t "~%Violated default: ~A" form)
; 	   (format t "~%retract: ~A" (second form))
; 	   (format t "~%reason: ~A" (datum-assumption? (referent (second form))))
; 	   (retract! (second form)
; 		     (datum-assumption? (referent (second form)))))
; 	  ((eq (car form) 'valueless-default)
; 	   (format t "~%Violated default: ~A" form)
; 	   (format t "~%assume: ~A" (second form))
; 	   (assume! (second form) :default))
; 	  (t
; 	   (error "~%I only know about default assumptions: ~A" form)))
;     ;(check-for-contradictions jtms)
;     ))
	   

(defun query-java (query assertion reason)
  (when (jl:jcall (jl:jmeth "rec.annotate.rules.Notebook"
			    "doJavaQuery" "java.util.LinkedList")
		  *assistance-notebook* (make-java-list query))
    (assert! assertion reason)))


(defun assert-causal-taxonomy (causes effects pre &aux results)
  (dolist (cause causes)
    (dolist (effect effects)
      (push `(causes ,cause ,effect) results)))
  (let ((tax `(:IMPLIES (:AND ,@ pre) (:TAXONOMY ,@results))))
;    (format t "~%TAXONOMY: ~A" results)
;    (format t "~%TAXONOMY: ~A" tax)
    (assert! tax
	     :ONE-OF-THE-CAUSES-MUST-CAUSE-ONE-OF-THE-EFFECTS)))

(defun assert-moves! (body source pre reason &optional body-name)
;  (format t "~%~A Moves when ~A ~%  because: ~A" body pre reason)
  (let ((id (new-event-id "moves" body-name)))
    (assert! `(:implies (:AND ,@pre)
			(:AND (moves ,body ,id)
			      (describes ,source ,id)))
	     reason)))

(defun new-event-id (&rest names)
  (gensym (substitute #\- #\SPACE
		      (reduce #'(lambda (str1 str2)
				  (concatenate 'string str1 "-" str2))
			      (mapcar #'princ-to-string
				      (append names '("")))))))

(defun get-assistance-object (obj)
  (jl:jcall (jl:jmeth "rec.annotate.rules.Notebook"
		      "lookupSymbol" "java.lang.String")
	    *assistance-notebook* (symbol-name obj)))
  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utiltities for debugging/inspecting etc...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun gather-rec-assumptions (&aux assumptions)
  (map-dbclass
   #'(lambda (dbclass)
       (dolist (datum (dbclass-facts dbclass))
	 (when (eq (datum-assumption? datum)
		   :REC-SYSTEM)
	   (push `(assume! ',(datum-lisp-form datum)
			   ',(datum-assumption? datum))
		 assumptions)))))
  assumptions)

(defun reset ()
  (let ((assumptions (gather-rec-assumptions)))
    (bps-load-file (make-BPS-path ".") "assistance")
    (bps-load-file (make-BPS-path ".") "answer")
    (make-assistance-tms)
    (bps-load-file (make-BPS-path ".") "rules")
    (mapcar #'eval assumptions)
    (format t "~%Done reloading assumptions into new LTRE")))

(defun save-rec-assumptions (&optional (file "saved-assumptions.lsp"))
  (let ((assumptions (gather-assumptions)))
    (with-open-file (stream file
		     :direction :output
		     :if-exists :supersede
		     :if-does-not-exist :create)
      (mapcar
       #'(lambda (form)
	   (print form stream))
       assumptions))))

(defun fetch-class (class)
  (mapcar #'datum-lisp-form (dbclass-facts (get-dbclass class))))
		   
(defun show-important (&optional (*LTRE* *LTRE*)
				 (stream *standard-output*))
  (let ((counter 0))
    (dolist (type '(moves can-cause causes before same-event (event ?id)))
      (dolist (fact (fetch `(,type . ?rest)))
	(format stream "~%~A: ~A" fact (label-of fact))
	(incf counter)))
    (format stream 
	    "~%~D facts total." counter)
    counter))


(defun fetch-n (fact &optional (n 0))
  (nth n (fetch fact)))

(defun event-CWA-contradiction-handler (contradictions ltms)
  ;; Retracts all invalid CWA's for equivalent event sets implicated in
  ;; each contradiction.  If all cleared, proceed with computation
  (debugging-assistance :EVENT-SETS
			"~%      EVENT-SETS: Active Contradictions = ~A."
			contradictions)
  (dolist (contradiction contradictions)
    (when (violated-clause? contradiction)
      (dolist (asn (assumptions-of-clause contradiction))
	(let ((form (view-node asn)))
	  (when (and (cwa-form? form)
		     (listp (car form))
		     (eq (caar form) 'event)
		     (CWA-invalid? form))
	    (debugging-assistance :EVENT-SETS
				  "~%      EVENT-SETS: Retracting ~A."
				  form)
	    (retract-CWA form))))))
  (debugging-assistance
   :EVENT-SETS
   "~%      EVENT-SETS: Contradictions still active: ~A."
   (remove-if-not #'(lambda (c) (violated-clause? c))
		  contradictions))
  (not (some #'(lambda (c) (violated-clause? c))
	     contradictions)))

(defun tracking-DD-Search (choice-sets end
				 &optional current-choices
				 &aux answer marker choices)
  "Just like standard DDS but record our current set of choices."
;   (format t "~%    DDS: current-choices: ~A"
; 	  (mapcar #'(lambda (c)
; 		      (if (equal c '(no-choice-needed))
; 			  'x 'o))
; 		  current-choices))
  (when (null choice-sets)
    (debug-dds "~%    DDS: Found solution.")
    (funcall end current-choices)
    (return-from tracking-DD-Search nil))
  (setq marker (list 'DDS (car choice-sets)))
  (setq choices (car choice-sets))
  (dolist (choice choices)
    (debug-dds "~%    DDS: Considering ~A..." choice)
    (cond ((false? choice) ;skip if known loser
	   (debug-dds "~%    DDS: ~A already known nogood." choice))
	  ((true? choice) ;continue if known
	   (debug-dds "~%    DDS: ~A true by implication." choice)
	   (tracking-DD-Search (cdr choice-sets) end (cons choice current-choices))
	   (return nil))
          (t (debug-dds "~%    DDS: Assuming ~A." choice)
             (with-Contradiction-Handler (ltre-ltms *ltre*)
              #'(lambda (clauses ltms &aux asns)
                   (debug-dds "~%    DDS: Entering handler for ~A with ~A~A."
                    choice clauses
                    (mapcar #'(lambda (c) (violated-clause? c))
                       clauses))
                   (dolist (cl clauses)
                      (setq asns (assumptions-of-clause cl))
                      (debug-dds "~%    DDS: Assumptions are: ~A"
                        asns)
                      (dolist (asn asns)
                         (when (or (equal choice (view-node asn))
                                   (and (listp choice) (eq (car choice) :NOT)
                                        (equal (cadr choice) (view-node asn))))
                            (throw marker
                               (cons :LOSERS ;; Assign labels before any retraction
                                  ;; Failure to do so can result in incorrect nogoods.
                                  (mapcar #'signed-view-node
                                     (delete asn asns))))))))
              (setq answer (catch marker
			     (Assuming (list choice) *ltre*
			       (run-rules *ltre*)
			       (tracking-DD-Search (cdr choice-sets) end
					     (cons choice current-choices)))))
              (when (and (listp answer)
                         (eq (car answer) :LOSERS))
                 (debug-dds "~%    DDS: ~A inconsistent with:~%   ~A."
                  choice (cdr answer))
		 (format t "~%DDS: ~A inconsistent with:~%   ~A."
			 choice (cdr answer))
                 (assert! `(:NOT (:AND ,choice
                                  ,@ (cdr answer)))
                  :DD-SEARCH-NOGOOD)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Parameter adjustment stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun adjust-parameters ()
  ;; should reset all parameters to default first to avoid retracted
  ;; values being used in the simulation
  (with-solution
   (adjust-springs)))

(defun adjust-springs ()
  (let ((springs (cond-fetch '(spring-state ?spring ?state) :TRUE)))
    (dolist (spring springs)
      (set-java-spring-length (second spring)
			      (spring-length-percent (third spring))))))

(defun spring-length-percent (state)
  (ecase state
    (in-compression 1.2)
    (in-tension 0.8)
    (at-rest 1.0)))
		 
(defun set-java-spring-length (spring ratio)
  (let ((s (get-assistance-object spring)))
    (jl:jcall (jl:jmeth "rec.simulate.widgets.WSimSpring"
			"adjustSpringRestLength" "double")
	      s ratio)))
		 
(defun get-spring-constraint (spring body arrow)
  (let ((s (get-assistance-object spring))
	(b (get-assistance-object body))
	(a (get-assistance-object arrow)))
    (debugging-assistance :JAVA
			  "~%(get-spring-constraint ~A ~A ~A) => "
			  spring body arrow)
    (let ((compression 
	   (jl:jstatic "getCompression"
		       "rec.annotate.rules.SpringAdjuster"
		       s b a)))
      (debugging-assistance :JAVA "~A" compression)
      (cond ((= compression 1)
	     `(spring-state ,spring in-compression))
	    ((= compression 0)
	     `(spring-state ,spring at-rest))
	    ((= compression -1)
	     `(spring-state ,spring in-tension))
	    (nil nil)))))