(in-package "KPML")

;;; File: history-cumulation.lisp
;;; John:Feb 20 '96:IPSI
;;;
;;; Support for the detailed chooser and inquiry tracing supplied
;;; with KPML 0.9.
;;; 1.1 adds information of what example is being processed as it
;;;     is possible/likely to accumulate information over several
;;;     examples...
;;; 2.1 adds information about the source of an inquiry response and
;;;     also records for what constituent system information is being
;;;     recorded for...

(defvar *gh-table* '() "Table for the cumulative system and chooser activity")
(defvar *temp-inquiry-cache* nil)

(defstruct GH-HISTORY 
  (system nil)
  (constituent nil)
  (feature nil)
  (inquiries nil)
  (example nil))

(defun RESET-GENERATION-HISTORY ()
  (setf *temp-inquiry-cache* nil)
  (setf *gh-table* nil))
		     
;;; ----------------------------------------------------------------------
;;; The following can be called (since the user can click anytime)
;;; before the expected response to an inquiry has been pushed onto
;;; the temporary inquiry cache. This means that this list is out
;;; of step wrt the structure expected. This can be recognized by
;;; the length of the list, which normally should be an even number.
;;; So, we only work on the longest list that is an even number
;;; starting from the back!
;;;
;;; 2.0.10
;;; It was possible for the aborting generation to cause certain problems
;;; for the history cumulation code. Certain data structures were not
;;; preserved well. But we don't want to clobber all the information
;;; that was there when we abort, because most likely we want to inspect
;;; what was going wrong...
;;;
;;; In particular, it was possible for the following code to be
;;; made to fall over, if generation was previously aborted in the middle. 
;;; So we make this now emphatically robust. If it breaks in the middle
;;; then we clear out the history and say sorry. If not, then it delivers
;;; the goods as usual. When there's an error, call 
;;; RESET-GENERATION-HISTORY and redo without trapping errors.
;;; ----------------------------------------------------------------------

(defun FINALIZE-PENDING-ENTRIES ()
  (flet ((try-and-finalize ()
	   (let ((current-element (first (last *gh-table*)))
		 (cache-complete? (evenp (length *temp-inquiry-cache*))))
	     (setf (gh-history-inquiries current-element)
	       (reverse (loop for ((resp . source) inq) 
			    on (if cache-complete?
				   *temp-inquiry-cache*
				 (cdr *temp-inquiry-cache*))
			    by #'cddr
			    collect (list (first inq) (cdr inq) resp source))))
	     (setf *gh-table*
	       (append (butlast *gh-table* 1) (list current-element)))
	     (setf *temp-inquiry-cache* 
	       (if cache-complete?
		   nil
		 (list (car *temp-inquiry-cache*)))))))
    (when *temp-inquiry-cache*
      (handler-case 
	  (try-and-finalize)
	(error (c) 
	  (declare (ignore c))
	  (reset-generation-history)
	  ;; one more chance...
	  (try-and-finalize))))))


;;; 1.1 current example name added...
;;; 2.1 current constituent added...
(defun RECORD-SYSTEM-IN-HISTORY (system)
  (finalize-pending-entries)
  (setf *gh-table*
    (append *gh-table*
	    (list (make-gh-history 
		   :system system :example *most-recent-example*
                   :constituent (first alias-function-stack))))))

;;; This is overwritten when the interface is loaded...
(defun RECORD-FEATURE-IN-HISTORY (feature)
  (let ((current-element (first (last *gh-table*))))
    (setf (gh-history-feature current-element) feature)
    (setf *gh-table*
      (append (butlast *gh-table* 1)
	      (list current-element)))))

(defun RECORD-INQUIRY-TO-HISTORY (parameters actual)
  (let ((filled-in-inq 
	 (cons (first parameters)
	       (loop for p in (cdr parameters)
		   as a in (cdr actual)
		   collect (cons p a)))))
    (push filled-in-inq *temp-inquiry-cache*)))

(defun RECORD-INQUIRY-RESPONSE-TO-HISTORY (resp inq)
  (declare (ignore inq))
  (push (cons resp *current-inquiry-answer-source*) *temp-inquiry-cache*)
  )

;;; Following uses the old Penman global current-chooser.

(defun TRACE-INQUIRY-P (inq-op)
  (or (member inq-op *traced-inquiries*)
      (loop for (c . i) in *traced-chooser-inquiries*
	  thereis (and (equal inq-op i)
		       (equal current-chooser c)))))



