(in-package "KPML")

;;; File: traversal.lisp
;;;
;;; Basic network traversal...
;;;
;;; 2.1, April 1999. Cleared of Penman's use CLISP.
;;;
;;; ----------------------------------------------------------------------
;;; Locks...

(defun say-entry-control ()
  (setq say-lock t))

(defun say-exit-control ()
  (setq say-lock nil))

(defun express-entry-control ()
  (setq express-lock t))

(defun express-exit-control ()
  (setq express-lock nil))

;;; ----------------------------------------------------------------------
;;; Note that where-am-i-id, and its implementation whereamiidcode,
;;; should always be available... Here's a safe version of it...
;;; ----------------------------------------------------------------------

(defun INTERNAL-WHEREAMIIDCODE (&optional dummy)
  "always implemented, gives unique id used by modification-specification-id"
  dummy
  (let ((result nil))
    (dolist (x  alias-function-stack)
      (let ((item (symbol-name x)))
	(setq result (concatenate 'string (subseq item 0 (position #\# item)) "-" result))))
    (intern result (find-package "KPML"))))


;;; ----------------------------------------------------------------------
;;; Allows mixture of systemically and non-systemically defined features
;;; as used in the genre experiments...
;;; ----------------------------------------------------------------------

(defun AUGMENT-BY-EXTERNAL-FEATURES ()
  (dolist (f current-preselections)
	  (when (member f *input-features-of-intergates*)
		(push f feature-selections)
		(dremove f current-preselections))))

;;; ----------------------------------------------------------------------
;;; 2.0 traversal augmented so that provision is made for the KPML coder
;;;     and grammar explorer directly. Activation is by means of the
;;;     global flag *coding-mode*.
;;;     Traverse-grammar is called by constituent1 in structures.lisp, 
;;;     when all-parts has decided we need to grow some structure.
;;; ----------------------------------------------------------------------

(defun TRAVERSE-GRAMMAR (first-feature message-sender-param)
  ;; traverse grammar traverses the loaded grammar starting from the
  ;; feature First-feature as selected in the system Message-sending-param.

  ;; message-sender is used globally during generation (CHECK)
  (setq message-sender message-sender-param)  
  
  (let (Current-System)
    (push First-Feature Feature-Selections)
    
    ;; add all features that are preselected and which belong to the external
    ;; inputs of intergates automatically without further ado to the selection
    ;; expression...
    (when *stratification?* (augment-by-external-features))
    
    ;; activate the selection
    (send-message First-Feature)

    ;; basic loop (with possibility of coding intervening)...
    (while (setq Current-System (find-next-system Enterable-Systems))
     do 
     (cond (*coding-mode*
	    ;; enterable-systems holds all systems currently enterable,
	    ;; so bring up a page menu for the features of those systems
	    (setf enterable-systems
	      (remove-duplicates
	       (let* ((selections
		       (get-codings-for-systems enterable-systems))
		     (previous-enterable-systems enterable-systems)
		      (nonconsumed-enterable-systems nil))
		(setf enterable-systems nil)
		(setf nonconsumed-enterable-systems
		  (loop for sys in previous-enterable-systems
		      for choice in selections
		      when choice 
		      do (pre-evaluated-system sys choice)
		      else collect sys))
		(append enterable-systems nonconsumed-enterable-systems)))))
	   (T
	    (setq Enterable-Systems (Dremove Current-System Enterable-Systems))
	    (when (member (first feature-selections) *coding-roots*)
	      (setf *coding-mode* T))
	    (Evaluate-System Current-System))))

    (when Enterable-Systems 
      (Warning "Entry dependency cycle in the following systems: " 
	       Enterable-Systems))))


;;; ----------------------------------------------------------------------
;;; Check whether a system may be entered...

(defun SYSTEM-INPUTS-SATISFIED (Input-Clause)
  (if (listp input-clause)
      (Case (CAR Input-Clause)
	    (And (loop for elt in (CDR Input-Clause) 
		     always (System-Inputs-Satisfied elt)))
	    (Or (loop for elt in (CDR Input-Clause) 
		    thereis (System-Inputs-Satisfied elt)))
	    (otherwise 
	     (Warning "Illegal input expression: " Input-Clause 
		      " one system downstream of  " Message-Sender ".")))
    (member Input-Clause Feature-Selections)))

;;; ----------------------------------------------------------------------
;;; Do the actions associated with entering and choosing within a
;;; system...
;;;
(defun EVALUATE-SYSTEM (Message-Sender-param)
  (setq message-sender message-sender-param) ;; old specvar message-sender
  (Push  Message-Sender Used-Systems)
  (if (fetch-Disabled-system Message-Sender)
      (when *show-disabled-systems-flag*
	(printwindow :display-pane " ")
	(printwindow 
	 :display-pane 
	 (indent-and-fill 
	  (format nil 
		  "Disabled System ~a -- entry conditions satisfied." 
		  Message-sender ))))
    (let ((Feature-To-Call-From 
	   (Select-Major (fetch-System-Outputs Message-Sender))))
      (when Feature-To-Call-From 
	(incf System-Entry-Count)
	(Send-Message Feature-To-Call-From)))))

;;; A slight variation for when coding or doing breadth first selection
;;; in the systems that may be entered with realizations being done as
;;; required...

(defun PRE-EVALUATED-SYSTEM (Message-Sender-param choice)
  (setq message-sender message-sender-param) 
  (Push  Message-Sender Used-Systems)
  ;; do the realizations, * and *p is comment...
  (Push choice Feature-Selections)
  (when *perform-realizations*
    (loop for Minor 
	in (loop for o in (fetch-System-Outputs Message-Sender)
	       when (equal choice (second o))
	       return (cddr o))
	unless (member (car minor) '(* *p) :test #'eq)	
	do (apply (car Minor)(cdr minor))))

  (incf System-Entry-Count)
  (send-message Choice))

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

(defun FIND-NEXT-SYSTEM (Sys-List)
  (unless fast-flag
    (setq sys-list (sort (copy-list Sys-List) #'String-lessp)))	;slow
  (dolist (s Sys-List)
    (unless (enter-another-first? s sys-list)
      ;(intersection sys-list (fetch-System-Enter-First-associations s))
      (when Show-Dependency-Choices
	(printwindow :display-pane " ")
	(printwindow :display-pane (indent-and-fill (format nil "Possible Systems: ~a" sys-list)))
	(printwindow :display-pane (indent-and-fill (format nil "Entering: ~a" s ))))
      (when (and english-trace-flag window-interface-flag)
	(printwindow :system-name-pane (format nil "~a" s)))
      (when (or (eq *cumulate-chooser-activity* :all)
		(and (eq *cumulate-chooser-activity* :traced)
		     (or (member s *traced-systems*)
			 (member (fetch-system-chooser s) 
				 *traced-chooser-inquiries* :key #'car)
			 (intersection *traced-inquiries*
				       (inquiries-of-chooser
					(fetch-system-chooser s))))))
	(record-system-in-history s))
      (RETURN s))))

(defun ENTER-ANOTHER-FIRST? (system-to-enter others-ready-for-entering)
  (dolist (x (fetch-System-Enter-First-associations system-to-enter))
    (when (member x  others-ready-for-entering)
      (return-from enter-another-first? t)))
  nil)

(DEFUN Reset-Systems ()
    (SETQ Used-Systems NIL)
    (SETQ Conflate-Demons NIL)
    (when *monitor-feature-use*
      (loop for f in feature-selections 
	  do (pushnew f *cumulative-features-used*)))
    (SETQ Feature-Selections NIL)
    (SETQ Ordering-Relations NIL)
    (SETQ No-Function-Realization NIL)
    (SETQ Blackboard NIL)
    (SETQ Brownboard NIL)
    (SETQ Whiteboard NIL)
    (SETQ Pledges NIL)
    (setq associations nil)		;added this -rna 8-24-88
;speed-patch:  The (clrhash ...) below supercedes the (setq ...) above;
;the latter can probably be removed. (John Wilkinson)
    (clrhash *associations-table*)
    (setq enterable-systems nil)  ;In Interlisp this was reset whenever you escaped from the scope of
                                  ;the (DECLARE specvars enterable-systems)! Now must explicitly reset.
    
    t)

(DEFUN Select-Preselected (Output Preselected)
    (incf Preselection-Count)
    (setq Current-Preselections (Remove Preselected Current-Preselections ))
    (cdr (loop for Out in Output 
	     when (Eq Preselected (Second Out))
	     return out)))

(DEFUN Check-Derived-Data NIL
  (Make-Paths-Valid)
  (when (Not System-Dependencies-Valid)
    (Compute-System-Dependencies)
    (SETQ System-Dependencies-Valid T))
  (setq *all-regions* (sort (collect-all-regions) #'string-lessp)))

(DEFUN Make-Paths-Valid NIL
  (when (Not Paths-Valid)
    (Compute-Paths)
    (Compute-Void-Features)
    (compute-hash-table-of-all-functions)
    (SETQ Paths-Valid T)))

(defun Expression-contains-fn (expression fn)
  (when (listp expression)
    (cond((equal (car expression) fn)
	  expression)
	 (t (loop for elt in (cdr expression) 
		as result = (expression-contains-fn elt fn)
		when result
		return result)))))

;;; ----------------------------------------------------------------------
;;; Compute-paths.
;;; From ML-Penman: ml-penman-patch-allparts.lisp
;;;
;;; Original function commented by Steve, 1982, so please don't ask
;;; me for justifications! :-) (John).
;;;   Notes: Path-Features is a global set in fn: feature-path 
;;;          (allparts.lisp).
;;; ----------------------------------------------------------------------

(defun COMPUTE-PATHS ()
  
  ;initialization (changed not to hardwire rank as starting system
  ;                John: Budapest: Sep94)

  ;; 0.7.39: a list of systems can have the start entry condition...
  (setf (fetch-exact-feature-def-field 'waiting 'start ) 
	(primitive-find-input 'start))
  (loop for F in Path-Features
      do 
	(setf (fetch-exact-feature-def-field 'Preselection-Features F)  NIL)
	)
  (SETQ Path-Features NIL)					
  (setq loop-errors nil)

  ;
  ; First, compute all paths rooted at the start of the network
  ;
		
  (loop for S in (fetch-exact-feature-def-field 'Waiting 'Start) 
      do 
	(Compute-Paths1 S  (list 'Start) nil))
  
  ;
  ;Then, compute all paths disrupted by an intervening 
  ;Or, hence not completely preselectable back to start.
  ;S takes the format (sys-name LS1 ... Lsn), we have to
  ;extract sys-name if Curlan applies.
  ;
  	
  (loop for S in Systems
      when 
	(and (member Curlan (cdr S))
	     (Expression-Contains-Fn (fetch-system-inputs (car S)) 'Or))
      do 
	(loop for Feature in (fetch-output-features (car S))
            do 
	      (Feature-Path Feature nil nil))
       )

  )

;;; ----------------------------------------------------------------------
;;; 2.0.39 John. Nov98. Brigitte found that loading some system definition
;;;                     into a multilingual loaded resource (English, German)
;;;                     caused generation to fail thereafter, even though
;;;                     the system definitions would work fine if only a
;;;                     single language had been loaded. Generation was
;;;                     failing because preselection augmentation paths
;;;                     were no longer being worked out accurately. The
;;;                     following function follows paths through the grammar
;;;                     stopping whenever it hits a disjunctive entry
;;;                     condition. Previously it also contained a stop
;;;                     condition which would prevent paths being followed
;;;                     further whenever the current effort no longer added
;;;                     anything new to the path being collected. This
;;;                     was however calculated on the basis of 
;;;                     (set-difference Current-Path Old-Path), where
;;;                     old-path is the previous preselection path and
;;;                     current-path is the feature path to the current
;;;                     effort. Stopping would be ok, if we were sure that
;;;                     this meant that we've been this way before and have
;;;                     already picked up everything more delicate. Perhaps
;;;                     this condition was met accidentally in the monolingual
;;;                     resource case and now fails. The precise cause of
;;;                     this change of behaviour is not at the moment clear
;;;                     to me, but removing this stop condition certainly
;;;                     guarantees that we always get all of the preselection
;;;                     paths set. This may take a bit longer to work out
;;;                     but doesn't seem to be particularly noticeable on
;;;                     current day machines. The original code seems to
;;;                     have been dated 1982 so maybe this was more of an
;;;                     issue then.
;;;
;;; 2.0.46  wasn't quite good enough, missed a trick and so lost some
;;;         paths... fixed.
;;; ----------------------------------------------------------------------

(defun COMPUTE-PATHS1 (System Current-Path Visited-Systems)
  (let ((Out-Feats (fetch-output-features System))
	Old-Path New-Path)
    (cond
     ((Not (fetch-Disabled-system System))
      (setq Old-Path 
	(fetch-exact-feature-def-field 'Preselection-Features (CAR Out-Feats)))
      (cond
       ((Not (Expression-Contains-Fn (fetch-system-inputs System) 'Or))
	(let ((increment (set-difference Current-Path Old-Path)))
	  (setf New-Path
	    ;; 2.0.46
	    (if increment (append increment Old-Path) old-path))
	  (loop for Feature in Out-Feats 
	      do (Feature-Path Feature New-Path Visited-Systems)))))))))


(DEFUN Feature-Path (&OPTIONAL Feature Path Visited-Systems )
  (PushNew  Feature Path-Features)
  (setf (fetch-exact-Feature-def-field 'Preselection-Features Feature)  Path)
  (let ((new (cons feature path)))
    (dolist (s  (fetch-exact-feature-def-field 'Waiting Feature)) 
      (cond
	((member S Visited-Systems)
	 (cond
	   ((Not (member (cons S  Feature ) Loop-Errors))
	    (Push (cons S  Feature ) loop-errors)
	    (Warning "GRAMMAR LOOP: System " S " is waiting on feature " Feature ", " 
		     "causing (or participating) in the loop "
		     (append (member S (Reverse Visited-Systems)) (list S))))))	
	((And (Not Path)
	      (member Feature (fetch-exact-Feature-def-field 'Preselection-Features (CAR (fetch-output-features
										     S)))))
	 NIL)
	(T (Compute-Paths1 S New  (cons S  Visited-Systems )))))))

(DEFUN Compute-Void-Features ()
  (loop for F in Path-Features 
      do (setf (fetch-exact-feature-def-field 'Voidness F)  NIL))
  (SETQ All-Void-Features NIL)
  (loop for F in Path-Features 
      as v = (Voidness F)
      when v
      do (setf (fetch-exact-feature-def-field 'Voidness F)  V)
	 (PushNew F All-Void-Features ))
  All-Void-Features)

(DEFUN Voidness (Node)
    (And (Not (Who-Has-As-Input Node))
	 (Not (Active-P Node))))

(DEFUN Active-P (Node)
  (loop for System in (Who-has-as-output Node) 
      thereis
	(loop for Expression in (Get-Node-Expression System Node) 
	    when (member (CAR Expression) Operators)
	    return expression)))

(DEFUN Get-Node-Expression (System Feature)
  (CDDR (loop for Out in (fetch-System-Outputs System) 
	    when  (Equal (Second Out) Feature)
	    return out)))

(DEFUN Generate-System-Dependencies-Closure-List 
    (First-List Second-List Closure-List)
  (loop for Sys2 in Second-List
      as This-Closure = (cond
			 ((assoc Sys2 Closure-List))
			 (T 
			  (SETQ Closure-List (cons (list Sys2) Closure-List)) 
			  (CAR Closure-List)))
      do (loop for Sys1 in First-List
	     do (PushNew Sys1 (cdr This-Closure))))
  ;;(closure-element-reachablefns This-Closure)
  Closure-List)

(DEFUN Create-Computable-Dependencies ()
  "Computes all declared dependencies"
  (let ((Dep-Classify-DB
	 (Who-Can-Classify-Any 
	  (remove-Duplicates 
	   (loop for Dec in Computable-Dependency-Declarations
	       collect (car Dec)) 
	   :test #'equal))))
    (SETQ Computable-Dependencies 
	  (loop for Dec in Computable-Dependency-Declarations
	      collect (Create-Computable-Dependency-Set Dec Dep-Classify-DB))))
  )


(DEFUN Create-Computable-Dependency-Set (Dep-Dec Dep-Classify-DB)
  "Given a dependency declaration consisting of a function and a 
          system, computes all of the dependencies required to classify the 
          function before the given system is entered"
  (let ((Classifiers
	 (loop for C in Dep-Classify-DB
	     when (loop for cc in (second C)
		      thereis (Equal (Second cc) (car dep-Dec) ))
	     collect (CAR C))))
    ;;	(format t "~%Classifiers are: ~%~s" classifiers)
    (LIST 
     (remove-Duplicates 
      (UNION Classifiers
	     (loop for S in Classifiers
		 nconc (Up-Stream-Systems S))) :test #'equal)
     (cdr Dep-Dec))))

(DEFUN Up-Stream-Systems (Given-System)
  (setq known-up-stream-systems nil)
  (Up-Stream-Systems0 Given-System)
  known-up-stream-systems)


(DEFUN Up-Stream-Systems0 (Given-System)
  (let ((Immediates 
	 (loop for F 
	     in (Compute-System-Input-Features 
		 (fetch-system-inputs Given-System ))
	     as got-output = (Who-has-as-output F)
	     when got-output
	     collect (CAR Got-Output))))
    ;;	(format t "~%immediates: ~a" immediates)
    (loop for I in Immediates
	when (Not (member I Known-Up-Stream-Systems))
	do (PushNew I Known-Up-Stream-Systems )
	   (Up-Stream-Systems0 I)
	   )))

(defun random-choice (chosen-words)
  (if (equal (length chosen-words) 1)
      chosen-words
      (nth (random (- (length chosen-words) 1)) chosen-words)))


;;; ----------------------------------------------------------------------
;;; The following  function is changed    to make preselections   take
;;; effect in the light of no contradicting evidence...
;;; Also, (KPML 0.8) changed so that non-existent realization operators, etc.
;;; are warned against and ignored, rather than bombing.
;;; 0.9: tracing systems also reports which feature was chosen.

(DEFUN Select-Major (Majors)
  (PROG (Preselections  Selector-Result Chosen-Feature temp)
	(SETQ Preselections
	      (remove-duplicates 
		(intersection Current-Preselections (fetch-output-features Message-Sender))))
	(SETQ Preselection 
	      (cond
		(Preselections 
		 (cond
		   ((> (LENGTH Preselections)
		       1)
		    (Warning "Multiple Preselection error: " Preselections)
		    (make-whiteboard-elt :realization (cons 'conflict  preselections))
		    NIL)
		   (T (CAR Preselections))))
		(T NIL)))
	;;;Provides for declaration of particular selectors associated with 
	;;;the system, but defaults to the Default-Selector. 
	
	(SETQ Selector-Result 
	      (cond

;;;> John; 16Dec91: IPSI add a don't bother to ask user if the preselections already
;;;> make it clear! 
		((and 
		   Preselection
		   (not (fetch-system-chooser Message-Sender)))
		 (Select-Preselected Majors Preselection)
		 (CDR (clisp::for O in Majors thereis (Eq (Second O) Preselection))))
		((setq temp (fetch-System-Selector-associations Message-Sender))
;;; 0.8: 
		 (cond ((fboundp temp)
			(funcall temp Majors Preselection))
		       (t
			(warning "System " message-sender " references an undefined choice selection method; default used instead.")
			(funcall Default-Selector Majors Preselection))))

		(T (funcall Default-Selector Majors Preselection))))

	(unless selector-result
	  (warning "System " message-sender " entered but no choice could be made."))
	
	(cond
	  ((And Preselection (not (equal Preselection (CAR Selector-Result))))
	   (Warning "Under " Message-Sender ", " (CAR Selector-Result)
		    " was chosen despite a preselection of " Preselection ".")
	   (RETURN NIL))
	  (T (SETQ Chosen-Feature (CAR Selector-Result))
	     (update-old-feature-selection message-sender chosen-feature) ;; 4.1
	     ;; 0.9
	     (when (member message-sender *traced-systems*)
	       (printwindow :display-pane " ")
	       (printwindow :display-pane
			    (indent-and-fill 
			     (format nil "System selects ~a" chosen-feature))))
	
	     (when (or (eq *cumulate-chooser-activity* :all)
		       (and 
			(eq *cumulate-chooser-activity* :traced)
			(or (member message-sender *traced-systems*)
			    (member (fetch-system-chooser message-sender) 
				    *traced-chooser-inquiries* :key #'car)
			    (intersection *traced-inquiries*
					  (inquiries-of-chooser
					   (fetch-system-chooser 
					    message-sender))))))
	       (record-feature-in-history chosen-feature))

	     (Push  Chosen-Feature Feature-Selections)
	     (when (and Show-Immediate-Realizations-Flag (CDR Selector-Result))
		    (printwindow :display-pane " "))
	     (loop for Minor in (CDR Selector-Result)
		  do
		  (when Show-Immediate-Realizations-Flag
		    (printwindow :display-pane
				 (indent-and-fill (format nil "      In ~a, Realizing: ~a" Message-sender Minor))))
;*'s are comment operators for realizations
		  (unless (member (car minor) '(* *p) :test #'eq)	
;;; 0.8: make sure defined...
			  (cond ((fboundp (car Minor))
;this does the realization
				 (apply (car Minor)(cdr minor)))
				(t
				 (warning "In " message-sender
					  " undefined realization operator: "
					  (car minor) " -- ignoring.")))))
	     (RETURN Chosen-Feature)))))


;;; ----------------------------------------------------------------------
;;; The following now gives improved error diagnostics --- which
;;; may be quite significant for the ML environment, since the network is changing
;;; quasi-dynamically...

(defun send-message (feature)
  "For each system that has FEATURE in its entry condition, see if the input features are satisfied."
  (dolist (system (fetch-exact-feature-def-field 'waiting feature))
    (when (And (Not (member System Used-Systems))
	       (let ((input-expression (fetch-system-inputs System)))
		 (unless input-expression
		   (Warning "System: " System " probably has no possible entry condition
specified for the current language. Check the following:" 
			    (system-inputs (gethash system system-table))))
		 (System-Inputs-Satisfied (fetch-system-inputs System))))
      (push system enterable-systems)
      (when (Or show-why-system-is-firing-flag
		(member System *traced-systems*))
	(printwindow :display-pane " ")
	(printwindow :display-pane
		     (indent-and-fill (format nil "System ~a is firing from system ~a" system message-sender)))
	(printwindow :display-pane
		     (indent-and-fill (format nil "because of the feature ~a." feature)))))))

(DEFUN Compute-System-Dependencies NIL
  (loop for sys in Systems 
      do (setf (fetch-system-enter-first-associations sys) NIL))
  (let ((*print-pretty* t))
    (Create-Computable-Dependencies)
    (loop for order 
	  in (append (ml-system-dependencies) Computable-Dependencies)
	  with totalclosure
	  do (loop for elt1 in order
		   as elt2 in (CDR order)
		   do (SETQ totalclosure
			    (Generate-System-Dependencies-Closure-List
			     (cond
			      ((value-if-listp elt1))
			      (T (deref-dependency-set elt1)))
			     (cond
			      ((value-if-listp elt2))
			      (T (deref-dependency-set elt2)))
			     totalclosure)))
	  finally
	  (loop for closure in totalclosure
		do (Complete-Closure (first closure) ;(closure-element-head closure)
				     totalclosure))
	  (loop for elt in totalclosure
		do (cond
		    ((member (first elt)	;(closure-element-head closure)
			     (cdr elt))	;(closure-element-reachablefns  elt)
		     (Warning "The system " (first elt) ;(closure-element-head  elt)
			      " is in a System Dependency loop with systems "
			      (cdr elt))))	;(closure-element-reachablefns   elt)
		(setf (fetch-system-enter-first-associations (first elt)) 
		      ;;(closure-element-head  elt)
		      (CDR elt))))))



;;; Following replaces a simple call to eval. The argument is
;;; either nil or the name of a dependency set. Now all dependency
;;; sets should have been defined by define-dependency-set.
;;; The result returned is the dependency set for the current
;;; language.

(defun DEREF-DEPENDENCY-SET (elt)
  (let* ((dependency-sets
	  (cdr (assoc elt *system-dependency-sets*))))
    (second (assoc curlan dependency-sets))))

