(in-package "KPML")

;;; File: regions.lisp
;;;
;;; Contains all management code that is based on functional regions.
;;; 3.1 cleared of clisp.

;;; FUNCTIONS FOR INCREASING THE UTILITY OF REGIONS FOR MANIPULATING
;;; INFORMATION MULTILINGUALLY.
;;; 
;;; FUNCTIONS DEFINED INCLUDE:
;;;
;;;   in-region (macro)
;;;   in-language (macro)
;;;
;;;   end-region (macro)
;;;   clear-region-and-language-defaults (equivalent function)
;;;
;;; In addition some old functions are updated to be compatible
;;; with the multilingual enviroment...
;;;   e.g. get-regions, etc.
;;;
;;;--------------------------------------------------------------------

(defvar *current-default-region* nil)

;;; ----------------------------------------------------------------------
;;; 2.0.43 It is not
;;; always beneficial to hide the gates so parameterize this according
;;; to the global flag... 
;;; ----------------------------------------------------------------------

(defvar *INCLUDE-GATES-IN-REGION-OVERVIEWS-P* T)
(defvar *GRAPHIC-EXTENSION* "pdf")  ;; 4.0

;;; ----------------------------------------------------------------------
;;; Following declaration should be placed at the beginning of each
;;; file where linguistic resources are defined.
;;;
;;;   (in-region :name Region-name :languages L)
;;;
;;; or
;;;
;;;   (in-region :name Region-name :languages (L1 L2 l3 ... L4))
;;;   
;;; When resources so labelled are loaded into the multilingual
;;; environment, then they are automatically conditionalized for
;;; the specified languages and region specifications are checked
;;; for compatibility. The result of loading such a region is
;;; a set of linguistic entities that are only valid for the
;;; specified languages. (Note: IF THE RESOURCES LOADED ALREADY
;;; CONDITIONALIZE THEMSELVES EXPLICITLY, THEN THIS INFORMATION
;;; OVERRIDES THE INFORMATION GIVEN IN THE IN-REGION SPEC.)
;;;  ----------------------------------------------------------------------

(defmacro IN-REGION (&key (name nil)(languages nil))
  `(setf *in-ml-region*                 t
	 *current-default-region*       (quote ,name)
	 *current-default-languages* 
	 (approve-languages
	  (if (listp (quote ,languages))
	      (mapcar #'(lambda (x) (intern (string x) :keyword))
		      (quote ,languages))
	   (list (intern (string (quote ,languages)) :keyword))))))


;;; For when region identity is not critical, there is also the
;;; declaration
;;;
;;;   (in-language :languages L) etc.
;;;

;;; 0.9.21 
;;; Following did not activate the language conditionalization 
;;; appropriately...

(defmacro IN-LANGUAGE (&key (languages nil))
  `(setf *in-ml-region* T ;; 0.9.21
	 *current-default-languages* 
	 (approve-languages
	  (remove-duplicates
	   (if (listp (quote ,languages))
	       (mapcar #'(lambda (x)
			   (intern (string x)
				   :keyword))
		       (quote ,languages))
	     (list (intern (string (quote ,languages)) :keyword)))))))


(defun APPROVE-LANGUAGES (lg-list)
  (let ((rejects '()))
    (loop for lg in lg-list
	  unless (member lg all_languages)
	  do
	  (warning "KPML is not already configured for requested language: " 
		   lg)
	  (cond ((askwindow 
		  :yes-or-no 
		  "Add language to configuration and accept these resources?")
		 (push lg all_languages))
		(t
		 (if (askwindow
		      :yes-or-no
		      "Remove language from specification and accept these resources?")
		     (push lg rejects)
		   (throw 'loading-tag nil)))))
    (set-difference lg-list rejects)))


;;; Also allow the region to be explicitly ended, although this is
;;; also done implicitly by a superceding call to in-region...

(defmacro END-REGION ()
  `(setf *in-ml-region* nil
	 *current-default-region* nil
	 *current-default-languages* nil))


(defun CLEAR-REGION-AND-LANGUAGE-DEFAULTS () 
  (setf *in-ml-region* nil
	*current-default-region* nil
	*current-default-languages* nil)
  )




;;;-------------------------------------------------------------------
;;; OLD FUNCTIONS UPDATED FOR MULTILINGUALITY:

;;; following sensitive to the changed structure of the list of systems...
;;; *** AND to the fact that some of the objects may not be relevant for
;;;         the current language!! (John:Hiddensee:Sep94).
;;;         All these functions now take an optional argument that forces
;;;         the old behaviour, else they just give an image of the
;;;         current language.
;;; 0.7.31 still wasnt quite right, since for all languages need to get
;;;         hold of all the region definitions for each language...
;;;  

(defun GET-REGIONS (&optional (all-languages nil))
  (let ((all-regions-no-duplicates nil))
    (cond (all-languages
	   (dolist (x (list-systems))
		   (loop for lg in all_languages do
			 (pushnew (fetch-system-region x lg)
				  all-regions-no-duplicates))))
	  (t
	   (dolist (x (list-systems))
		   (when (system-defined-for-lg-p x curlan)
			 (pushnew (fetch-system-region x) 
				  all-regions-no-duplicates)))))
    (sort all-regions-no-duplicates #'string-lessp)))


;;; Following also was not handling the all-languages case correctly...
;;; 4.0 it certainly was not... was in fact absolute garbage: but
;;;     for how long has it been so?!
;;;
(defun SYSTEMS-OF-REGION (region &optional (all-languages nil)(warning-p T))
  (let ((regions (get-regions all-languages))
	(monolingual-systems (mapcar #'first systems)))
    (cond ((not (member region regions))
	   (when warning-p
             (format 
              t 
	      "Requested region: ~A does not have any systems in it.~%" 
	      region))
	   nil)
	  (t
	   (sort (remove-duplicates
		  (cond (all-languages
			 (loop for system in monolingual-systems 
			       append
			       (loop for lg in all_languages
				     when (and (system-defined-for-lg-p system lg)
					       (eq (fetch-system-region system lg)
						   region))
				     collect system)))
			(t
			 (loop for system in monolingual-systems
			       when (and (system-defined-for-lg-p system curlan)
					 (eq (fetch-system-region system) region))
			       collect system))))
		 #'string-lessp)))))


;; 3.1+ second parameter made optional and default valued as 
;;      in the previous function
(defun SYSTEMS-OF-REGION-NO-WARNINGS (region &optional (all-languages nil))
  (let ((regions (get-regions all-languages))
	(monolingual-systems (mapcar #'first systems)))
    (cond ((not (member region regions))
	   nil)
	  (t
	   (sort (remove-duplicates
		  (cond (all-languages
			 (loop for system in monolingual-systems
			       append
			       (loop for lg in all_languages
				    when (and (system-defined-for-lg-p system lg)
					      (eq (fetch-system-region system lg)
						  region))
				    collect system)))
			(t
			 (loop for system in monolingual-systems
			       when (and (system-defined-for-lg-p system curlan)
					 (eq (fetch-system-region system) region))
			       collect system))))
		 #'string-lessp)))))


;;; ----------------------------------------------------------------------
;;; 3.1+
;;; provided for consistency but with a slightly different name
;;; so as not to affect code relying on the old functions above...
;;; ----------------------------------------------------------------------

(defun SYSTEMS-OF-REGION+ (region &key (no-warning-p nil))
  (if no-warning-p
      (systems-of-region-no-warnings region nil)
    (systems-of-region region nil)))

;;; ----------------------------------------------------------------------
;;; extracted from Renate's selex.lisp...

(defun INPUTS-OF-REGION (region)
  (let ((input-features 
	 (remove-duplicates 
	  (remove 
	   'and 
	   (remove 'or 
		   (flatten (mapcar #'(lambda (system)  
					(fetch-system-inputs system))
				    (systems-of-region region)))))))
	(features-of-region (features-of-region region)))
    (remove nil (mapcar #'(lambda (in) 
			    (if (not (member in features-of-region)) in))
			input-features))))
    

(defun FEATURES-OF-REGION (region)
  (features-of-systems (systems-of-region region)))

(defun FEATURES-OF-SYSTEMS (list)
  (cond ((null list) nil)
	(t (append (fetch-output-features (car list))
		   (features-of-systems (cdr list))))))

(defun COLLECT-ALL-REGIONS ()
  ;; maphash over all systems
  (dolist (system (list-systems))
    (let ((region (fetch-system-region system)))
      (when region
	(pushnew region regions))))
  regions)

;;; KPML 0.8; no warnings flag added.
(defun CHOOSERS-OF-REGION (region &optional &key (no-warning-p nil))
  (let ((systems-of-interest 
	 (if no-warning-p (systems-of-region-no-warnings region nil)
	   (systems-of-region region))))
    (remove 
      nil
      (sort 
	(remove-duplicates (mapcar #'fetch-system-chooser systems-of-interest))
	#'string-lessp))))

(defun ASK-INQUIRIES-OF-REGION (region &optional &key (no-warning-p nil))
  (reset-network-if-necessary)
  (let* ((choosers-of-interest (choosers-of-region region
						   :no-warning-p no-warning-p))
	 (ask-inquiries (mapcar 
			  #'(lambda (chooser)
			      (assoc 'asks (cdr (assoc chooser (ml-chooser-db)))))
			  choosers-of-interest))
	 (inquiry-list 
	   (mapcar 
	     #'(lambda (ask)
		 (cond
		   ((null ask) nil)
		   (t
		    (mapcar #'car (cdr ask)))))
	     ask-inquiries)))
    (sort
      (remove-duplicates (flatten inquiry-list))
      #'string-lessp)))


(defun IDENTIFY-INQUIRIES-OF-REGION (region &optional &key (no-warning-p nil))
  (reset-network-if-necessary)
  (let* ((choosers-of-interest (choosers-of-region region 
						   :no-warning-p no-warning-p))
	 (identify-inquiries (mapcar 
			  #'(lambda (chooser)
			      (assoc 'identifies (cdr (assoc chooser (ml-chooser-db)))))
			  choosers-of-interest))
	 (ID-inquiry-list 
	   (mapcar 
	     #'(lambda (identify)
		 (cond
		   ((null identify) nil)
		   (t
		    (mapcar #'caadr (cdr identify)))))
	     identify-inquiries)))
    (sort
      (remove-duplicates (flatten ID-inquiry-list))
      #'string-lessp)))

;;; ----------------------------------------------------------------------
;;; 3.1+ why this is missing I do not know
;;; ----------------------------------------------------------------------

(defun INQUIRIES-OF-REGION (region &optional &key (no-warning-p nil))
  (sort
   (union
    (identify-inquiries-of-region region :no-warning-p no-warning-p)
    (ask-inquiries-of-region region :no-warning-p no-warning-p))
   #'string-lessp))

;;; ----------------------------------------------------------------------
;;; 2.0 following used to be in kpml-i/substrate, no reason for that...

;;;   For any region, returns the dependent regions, number of systems, 
;;;   number of input features, and output features (i.e., features
;;;   leading from/to other regions)
;;;   N.B. note that X output features can of course lead on to some
;;;        number greater than X of systems.
;;;
;;; 2.0.43 added gate inclusion flag
;;; ----------------------------------------------------------------------

(defun OUTPUTS-OF-REGION (region)
  (let ((systems-of-region (systems-of-region region))
	(O nil))
    (values
     (remove-duplicates
      (flatten
       (loop for s in systems-of-region
	   collect
	     (loop for f in (fetch-output-features s)
		 collect
		   (loop for i in (who-has-as-input f)
		       when (and 
			     (not (eq (fetch-system-region i) region))
			     (or *include-gates-in-region-overviews-p*
				 (not (gate-p i))))
		       collect (fetch-system-region i) 
		       and do (pushnew f O))))))
     (length systems-of-region)
     (length (inputs-of-region region))
     (length O)
     )))

(defun OUTPUTS-OF-REGION-WITH-SYSTEMS (region)
    (let ((systems-of-region (systems-of-region region)))
      (loop for s in systems-of-region
	  collect
	    (loop for f in (fetch-output-features s)
	       collect
		 (loop for i in (who-has-as-input f)
		     when (and 
			   (not (eq (fetch-system-region i) region))
			   (or *include-gates-in-region-overviews-p*
			       (not (gate-p i))))
		     collect 
		       (cons (fetch-system-region i) i))))))

(defun OUTPUT-FEATURES-OF-REGION (region)
    (let ((systems-of-region (systems-of-region region)))
      (loop for s in systems-of-region
	  append
	    (loop for f in (fetch-output-features s)
		unless
		  (loop for i in (who-has-as-input f)
		      always (or (eq (fetch-system-region i) region)
				 (gate-p i)))
		collect f))))

;;; ----------------------------------------------------------------------
;;; 2.1
;;;
(defun PATCHED-SYSTEMS-OF-REGION (region)
  (let ((systems-of-region (systems-of-region region)))
    (loop for s in systems-of-region
          when (fetch-system-patch-status s)
          collect s)))


(defun COUNT-PATCHED-SYSTEMS-OF-REGION (region)
  (length (patched-systems-of-region region)))

;;; ----------------------------------------------------------------------
;;; 2.0 region report... puts the connectivity information out to a file
;;;                      in a couple of formats...

(defun MAKE-TEXT-REGION-REPORT (regions &optional (stream *standard-output*))
  (loop for r in regions
      as inputs = (sort (inputs-of-region r) #'string<)
      as outputs = (sort (output-features-of-region r) #'string<)
      do
	(format stream "~2%Region: ~A (~A systems)"
		r (length (systems-of-region r)))
	(if inputs
	    (progn
	      (format stream "~%  Inputs:")
	      (loop for f in inputs
		  do (format 
		      stream "~%     ~(~30A~)~10T~20A" f
		      (fetch-system-region (first (who-has-as-output f))))))
	  (format stream "~%  No inputs."))
	(if outputs
	    (progn
	      (format stream "~%  Outputs:")
	      (loop for f in outputs
		  do (format 
		      stream "~%     ~(~30A~)~10T~20A" f 
		      (sort
		       (remove-duplicates
			(loop for s in (who-has-as-input f)
			    as r2 = (fetch-system-region s)
			    unless (equal r2 r)
			    collect r2))
		       #'string<))))
	  (format stream "~%  No outputs.")))
  (format stream "~%Region report done."))

(defun MAKE-HTML-REGION-REPORT (regions 
                                &optional 
                                (with-networks nil)           ;; 4.0
                                (with-dependencies nil)       ;; 4.0
                                (stream *standard-output*))
  (macrolet 
      (
       ;; some headers...
       (COL-HEADER (header)
	 `(format stream 
		  "~%<CENTER><TABLE BORDER COLS=1 WIDTH=\"100%\" BGCOLOR=\"#99FF99\"><TR><TD><B><FONT COLOR=\"#993366\" SIZE=+1> ~A </FONT></B></TD></TR></TABLE></CENTER>~%&nbsp;" ,header))

       (FEATURES-REGIONS-ROW ()
	 `(format stream "~%  <TR><TD><B><FONT COLOR=\"#993366\">Features</FONT></B></TD><TD><B><FONT COLOR=\"#993366\">Regions</FONT></B></TD></TR>"))

       ;; following make sure things balance...
       (AS-TABLE ((cols size) &body body)
	 (let 
	   ((start-table-def 
	     "~%<CENTER><TABLE BORDER COLS=~A WIDTH=~S BGCOLOR=\"#FFFFCC\">"))
	   `(progn
	      (format stream ,start-table-def ,cols ,size)
	      ,@body
	      (format stream "~%</TABLE></CENTER>"))))

       (ELEMENT (&body body)
	 `(progn (format stream "~%<TD>") ,@body (format stream "~%</TD>")))
       
       (ROW (&body body)
	 `(progn (format stream "~%<TR VALIGN=TOP>") 
		 ,@body (format stream "~%</TR>")))
       
       (REGION-HEADER (region n)
	 `(format stream 
		  "~2%<HR SIZE=4 WIDTH=\"100%\">
<BR><B><FONT FACE=\"Garamond\">
<A NAME=\"region-~A\"><FONT SIZE=+2>Region: ~A</FONT></A>
(~A systems)</FONT></B>

" ,region ,region ,n))
       
       (NETWORK-LINK (region)
         `(when with-networks
                (format stream
                  "<DIV ALIGN=right><B><I><FONT FACE=\"Garamond\"><FONT SIZE=+2><A href=\"networks/~A.~A\">System Network</A></FONT></FONT></I></B></DIV>" ,region *graphic-extension*)))

       (DEPGRAPH-LINK (region)
         `(when with-dependencies
            (format stream 
              "<DIV ALIGN=right>&nbsp;<B><I><FONT FACE=\"Garamond\"><A href=\"deps/~A.~A\"><FONT SIZE=+1><I>Dependency Graph</FONT></A></FONT></I></B></DIV>" ,region *graphic-extension*)))

       (REGION-CLOSER ()
	 `(format stream "<div ALIGN=right><A href=\"#top\"><font size=-2><em>top</em></font></A></div><P>"))
       )

   (language-variety-overview stream)
   (loop for r in regions
	as inputs = (sort (inputs-of-region r) #'string<)
	as outputs = (sort (output-features-of-region r) #'string<)
	do
	  (region-header r (length (systems-of-region r)))
          (network-link r)
	  (as-table (2 "91%")
	    (row
	     (if inputs
		 (progn
		   (element
		    (col-header "Input features for the region")
		    (as-table (2 "100%")
		      (features-regions-row)
		      (loop for f in inputs
			  as r = (fetch-system-region
				  (first (who-has-as-output f)))
			  do (format 
			      stream 
			      "~%     <TR><TD>~(~A~)</TD>
         <TD><A HREF=\"#region-~A\">~A</A></TD></TR>" f r r)))
		    (format stream "~%&nbsp;")))
	       (element (format stream "No inputs.")))
	     (element
	      (col-header "Output features for the region")
	      (if outputs
		  (as-table (2 "100%")
		      (features-regions-row)
		      (loop for f in outputs
			  as r-set = (sort
				      (remove-duplicates
				       (loop for s in (who-has-as-input f)
					   as r2 = (fetch-system-region s)
					   unless (equal r2 r)
					   collect r2))
				      #'string<)
			  do 
			    (row
			     (element (format stream "~(~A~)" f))
			     (element
			      (loop for r in r-set
				  do (format stream 
				     "<A HREF=\"#region-~A\">~A</A> " r r))))))
		(format stream "~%No outputs.")))))
          (depgraph-link r)
	  (region-closer)
	  )
    (format stream "~%<BR><TT>Region report done.</TT></BODY></HTML>~%")))


  ;; ----------------------------------------------------------------------
  ;; 4.0 extra options added...
  ;; ----------------------------------------------------------------------

(defun REGION-REPORT-TO-FILE 
    (regions  &key (style :html)
		   (in-directory 
		    ;;         ---------- 4.0 -----------
		    ;;  by default bounce the entire report down a directory...
		    ;;
		    (coerce-directory
		     (merge-pathnames 
		      common-lisp-user::*root-of-resources* (string kpml::curlan))
		     ))
		   (with-networks NIL)
		   (with-dependencies NIL))
  (format *trace-output* "~%;;; Preparing region report...")
  (with-open-file (*standard-output*
		   (merge-pathnames 
		    (pathname (concatenate 'string 
					   "region-report-" (string curlan)
					   "." (string style) ;; 4.0
					   ))
		    (pathname in-directory)
		    )
		   :direction :output
		   :if-exists :new-version)
    (when (eq style :html) 
      (make-html-header "Region report"))
    (region-report-line style)
    (case style
      (:html (make-html-region-report regions with-networks with-dependencies))
      (:text (make-text-region-report regions)))
      (format *trace-output* "...Done.")))

(defun MAKE-HTML-HEADER (title)
  (format t 
	  "<HTML>
<HEAD>
   <META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=iso-8859-1\">
   <META NAME=\"Author\" CONTENT=\"unknown\">
   <TITLE>~A</TITLE>
</HEAD>
<BODY>"
 title))

(defun REGION-REPORT-LINE (style)
  (when (eq style :html) 
    (format t "<FONT SIZE=+2>"))
  (format t "Region overview for language variety: ~A." curlan)
  (when (eq style :html)
    (format t "</FONT><BR><TT>"))
  (format t 
	  "~%Report created automatically on: ~A at: ~A"
	  (time-stamp) (get-penman-feature :site))
  (when (eq style :html) (format T "</TT><BR><BR>"))
  )
    
(defun LANGUAGE-VARIETY-OVERVIEW (stream) 
  (let ((r-set (collect-all-regions)))
    (format 
     stream "~%<A name=\"top\"><BR>This language variety contains ~A regions.
               <BR>They are:<CENTER><TABLE COLS=1 WIDTH=\"58%\">" 
     (length r-set))
    (loop for r in (sort r-set #'string<)
	do (format stream "<TR><TD><FONT SIZE=-2>
<A HREF=\"#region-~A\">~A</A></FONT></TD></TR>"
		   r r))
    (format stream "</TABLE></CENTER><BR><BR>")
    ))
