(in-package "KPML")

;;; File: surveys.lisp
;;;
;;; A collection of survey functions for dealing with multilingual
;;; resources, preparing statistics, etc.
;;;
;;; Also some of the old original Penman functions for getting hold of
;;; survey information about loaded resources are tagged on the end.
;;;
;;; ----------------------------------------------------------------------
;;; The following functions prepare the overview statistics for sharing
;;; and incongruence in sets of multilingual resources. Tables are
;;; prepared according to regions... (as in the table presented in
;;; the Language Engineering paper (1997)).

;;; The basic user function is the following:

(defun MAKE-ML-GRAMMAR-STATS-TO-FILE (&key
				      (file "/tmp/ml-grammar-stats")
				      (regions (get-regions T))
				      (lgs all_languages)
				      (latex nil))
  (with-open-file (str file :direction :output
			     :if-exists :supersede)
    (make-ml-grammar-stats regions lgs str (if latex "&" "") latex)))

;;; 4.0 following will replace the following function definitions
;;;     as the preferred API sometime...

(defun SHOW-ML-GRAMMAR-STATS 
  (&key (regions (get-regions T))
	(lgs all_languages)
	(stream T)
	(separator "")
	(mode :text))
  (make-ml-grammar-stats regions lgs stream separator (case mode
							    (:text nil)
							    (:latex T)
							    (:html nil)
							    (otherwise
							     nil))))

   ;; --------------------------------------------------
   ;; The work is done by the following:
   ;; --------------------------------------------------

(defun MAKE-ML-GRAMMAR-STATS (all-regions &optional (lgs all_languages)
						    (stream T)
						    (sep "")
						    (latex nil))
  (let* ((results (make-array 
		   (list (length all-regions)
			 (length lgs))
		   :initial-element 0))
	 (in-lg-region-sums (make-array (length all-regions)))
	 (in-lg-sharing-quotient (make-array (length all-regions)))
	 (all-lg-region-sums (make-array (length all-regions))))

    (format *trace-output* "~%Compiling grammar stats...~% to do: ")
    (loop for r from 1 to (length all-regions) do (format *trace-output* "x"))
    (format *trace-output* "~%        ")
    (format stream "~%~35T~{~A   ~}" (mapcar #'(lambda (l) (subseq (string l) 0 3)) lgs))
    (loop for r in (sort all-regions #'string<)
	as nr from 0 
	do 
	  (let ((ml-total (length (systems-of-region-in-some-languages r lgs))))
	    (format *trace-output* ".")
	    (setf (aref all-lg-region-sums nr) ml-total)
	    (if latex
		(format stream "~%\\footnotesize \\sc ~30A~A  " 
			(string-downcase r) sep)
	      (format stream "~%~30A~A  " r sep))
	    (setf (aref in-lg-region-sums nr)
	      (loop for l in lgs
		  as nl from 0
		  summing 
		    (let ((value nil))
		      (setf curlan l)
		      (setf value (length (systems-of-region r nil nil)))
		      (setf (aref results nr nl) value)
		      (format stream "   ~3D~A" value sep)
		      value)))
	    (format stream "  :  ~4D~A" (aref in-lg-region-sums nr) sep)
	    (format stream "  :  ~4D~A" ml-total sep)
	    (format stream "  :  ~2,1,4,$~A~A" 
		    (if (> (aref in-lg-region-sums nr) 0)
			(* (/ ml-total (aref in-lg-region-sums nr))
			   100.00)
		      0)
		    (if latex "\\%" "%")
		    sep)
	    (format stream "  :  ~2,1,4,$" 
		    (if (> (aref in-lg-region-sums nr) 0)
			(/ (aref in-lg-region-sums nr) (* ml-total (length lgs)))
		      0))
	    (when latex (format stream "\\\\"))
	    ))
    (format stream "~2%~30T~A  " sep)
    (loop for l in lgs
	as nl from 0
	do (format stream "~6D~A" (loop for r in all-regions
				   as nr from 0
				   summing (aref results nr nl)) sep))
    (multiple-value-bind (region-sums ml-sums)
	(loop for r in all-regions as nr from 0
	    summing (aref in-lg-region-sums nr) into region-sums
	    summing (aref all-lg-region-sums nr) into ml-sums
	    finally (return (values region-sums ml-sums)))

      (format stream "  :  ~4D~A" region-sums sep)
      (format stream "  :  ~4D~A" ml-sums sep)
      (format stream "  :  ~2,1,4,$" (if (> region-sums 0)
					 (* (/ ml-sums region-sums) 100.00)
				       0)
	      )
      (format stream (if latex "\\% \\\\" "%"))
      )
    (format *trace-output* "~%Done.")))


;;; ----------------------------------------------------------------------
;;; 4.0 
;;;     The following functions (first redefined, second new) have been
;;;     made to use the multilingual access functions rather than playing
;;;     with the hashtables directly as before. This led to inaccuracies
;;;     as this was not catching examples where systems had been allocated
;;;     to different regions in different language varieties. Now this
;;;     is guaranteed: if a system does not belong to a region in its
;;;     variety, then it does not count here, even though it may belong
;;;     to that region in another variety.

(defun SYSTEMS-OF-REGION-IN-ANY-LANGUAGE (r)
  (systems-of-region r T nil))

(defun SYSTEMS-OF-REGION-IN-SOME-LANGUAGES (r varieties)
  (remove-duplicates
   (loop for curlan in varieties append (systems-of-region r nil nil))))

 ;; But the following really does look at the hashtable so that it
 ;; gets a first indication of overlap in the multilngual representation.
 ;; The above functions split out the systems and count more than
 ;; once. The two should actually aways give the same results,
 ;; but left here as a check...

(defun SYSTEMS-OF-REGION-IN-SOME-LANGUAGE (r varieties)
  (loop for s being each hash-value of system-table
      when (and (member r (if (consp (system-region s))
			      (system-region s)
		            (list (system-region s))))
                (intersection varieties (system-language-set s))
		)
      collect s))


;;; ----------------------------------------------------------------------
;;; 2.0
;;; Some comparison capabilities for helping in merging and comparing
;;; versions...
;;;
;;; Patched at 2.0.41
;;;
;;; 4.0 added a table that gathers the information while it is
;;;     being produced so that it can be displayed more usably
;;;     if one just wants an overview...
;;;
;;; ----------------------------------------------------------------------

(defvar *variety-comparison-counts* nil)

   ;; ----------------------------------------------------------------------
   ;; This utility compares language varieties V1 and V2 and compiles a
   ;; report of where they differ wrt systems, choosers, and inquiries.
   ;; ----------------------------------------------------------------------

(defun COMPARE-VARIETIES (V1 V2 &optional (details nil))
  (format t "~%Comparing language varieties ~A and ~A...~%" v1 v2)
  (let ((v1-systems (sort (list-systems v1) #'string<))
	(v2-systems (sort (list-systems v2) #'string<))
	(v1-choosers (sort (list-choosers v1) #'string<))
	(v2-choosers (sort (list-choosers v2) #'string<))
	(v1-inquiries (sort (list-inquiries v1) #'string<))
	(v2-inquiries (sort (list-inquiries v2) #'string<)))
    (compare-objects-of-type :system v1-systems v1 v2-systems v2 details)
    ;; 2.0.41
    (compare-features-of-varieties v1 v2 details)
    (compare-objects-of-type :chooser v1-choosers v1 v2-choosers v2 details)
    (compare-objects-of-type :inquiry v1-inquiries v1 v2-inquiries v2 details))
  (format t "~%... variety comparison completed."))

(defun COMPARE-OBJECTS-OF-TYPE (type v1-list v1 v2-list v2 details)
  ;; 2.0.41 extended and made a bit more informative...
  (flet ((normalize (s v type)
	   (format nil "~S" 
		   (flatten
		    ;; 2.0.41
		    (create-normed-list-representation-of-object s type v)))))
    (let ((v1-v2-diff (set-difference v1-list v2-list))
	  (v2-v1-diff (set-difference v2-list v1-list))
	  (v1-and-v2 (intersection v1-list v2-list))
	  (plural-stem (if (equal type :inquiry)
			   "inquirie"
			 (string-downcase (string type))))
	  (mismatches nil)
	  (mismatching-realizations nil)
	  (mismatching-outputs nil)
	  (lgpair (list v1 v2)))

      (format t "~% Comparing ~As..." plural-stem)
      (percentage-shared-messages v1 v2 plural-stem v1-list v2-list)

      (unless (set-equal v1-list v2-list)
	(format 
	 t 
	 "~%  There are differences in the ~As belonging to each variety."
	 plural-stem)
	(format t "~%  There are ~A ~As in ~A that are not in ~A"
		(length v1-v2-diff) plural-stem v1 v2)
	(format t "~%  and there are ~A ~As in ~A that are not in ~A."
		  (length v2-v1-diff) plural-stem v2 v1)
	(push `(,type ,v1 ,v2 
		      ,(length v1-v2-diff) ,(length v2-v1-diff))
	      *variety-comparison-counts*)

	(when details
	  (format t "~%  In ~A and not in ~A are: ~{~%     ~S~}~%"
		  v1 v2 v1-v2-diff)
	  (format t "~%  In ~A and not in ~A are: ~{~%     ~S~}~%"
		  v2 v1 v2-v1-diff)))

      (when (equal type :system)
	  (setf mismatching-outputs 
	    (sort
	     (compare-output-features v1-and-v2 lgpair)
	     #'string<))
	  (if mismatching-outputs
	      (format 
	       t 
	       "~%   following ~A common systems have nonmatching output features:~%      ~S" 
	       (length mismatching-outputs) mismatching-outputs)
	    (format 
	     t "~%   all shared systems have congruent output features."))
	  (setf mismatching-realizations
	    (sort
	     (compare-feature-realizations v1-and-v2 lgpair)
	     #'string<))
	  (if mismatching-realizations
	      (format 
	       t 
	       "~%   following ~A common features have nonmatching realizations:~%      ~S" 
	       (length mismatching-realizations) mismatching-realizations)
	      (format 
	       t "~%   all shared systems have congruent realizations.")))
      (loop for f in mismatching-realizations
	  do (pushnew (first (who-has-as-output f)) mismatching-outputs))
      (loop for s in v1-and-v2
	  as normed1 = (normalize s v1 type)
	  as normed2 = (normalize s v2 type)
	  when (and normed1 normed2 (not (equal normed1 normed2))
		    (not (member s mismatching-outputs)))
	  do (push s mismatches))
      (setf mismatches (sort mismatches #'string<))
      (when mismatches
	(format t "~%   There are also ~A incongruencies:" 
		(length mismatches))
	(loop for m in mismatches
	    do (format t "~%        *** Mismatch for ~A ~A" 
		       (string-downcase (string type)) m)))
      (when (and (equal type :system) mismatches)
	(format t "~%   The mismatches concerned regions : ~S"
		(sort 
		 (remove-duplicates
		  (mapcar 
		   #'(lambda (x) (fetch-system-region x v1)) mismatches))
		 #'string<)))
      )))

(defun CREATE-NORMED-LIST-REPRESENTATION-OF-OBJECT 
  (object object-type language)
  (let ((object (generic-object-to-list-multi-to-mono 
		 object object-type language)))
    (when (equal object-type :inquiry)
      (let ((gloss-pos (or (position :english object)
			   (position :gloss object))))
	(when gloss-pos
	  (setf (elt object (1+ gloss-pos))
	    (mapcar #'clean-up-final-string
		    (elt object (1+ gloss-pos)))))))
    (list object)))
	  
;;; ----------------------------------------------------------------------
;;; Compare systems in the syslist across the lg-pair for differences
;;; in output features only.
;;; ----------------------------------------------------------------------

(defun COMPARE-OUTPUT-FEATURES (syslist lg-pair)
  (loop for s in syslist
      for outs-in-l1 = (fetch-output-features s (first lg-pair))
      for outs-in-l2 = (fetch-output-features s (second lg-pair))
      unless (set-equal outs-in-l1 outs-in-l2)
      collect s))

;;; ----------------------------------------------------------------------
;;; Compare realization statements for the systems in the list...
;;; ----------------------------------------------------------------------

(defun COMPARE-FEATURE-REALIZATIONS (syslist lg-pair)
  (let ((features-with-different-realizations nil)
	(systems-with-different-realizations nil))
    (loop for s in syslist
	do 
	  (loop for f 
	      in (remove-duplicates
		  (append 
		   (fetch-output-features s (first lg-pair))
		   (fetch-output-features s (second lg-pair))))
	      unless (system-feature-realizations-eq s f lg-pair)
	      do (pushnew f features-with-different-realizations)
		 (pushnew s systems-with-different-realizations)))
    (values features-with-different-realizations
	    systems-with-different-realizations)))

(defun SYSTEM-FEATURE-REALIZATIONS-EQ (sys feature lg-pair)
  (let* ((outs1 (fetch-system-outputs sys (first lg-pair)))
	 (outs2 (fetch-system-outputs sys (second lg-pair)))
	 (r1 (loop for out in outs1
		 when (equal (second out) feature)
		 do (return (cddr out))))
	 (r2 (loop for out in outs2
		 when (equal (second out) feature)
		 do (return (cddr out)))))
    (set-equal (flatten r1) (flatten r2))))

;;; ----------------------------------------------------------------------
;;; Feature comparison summary...
;;; ----------------------------------------------------------------------

(defun COMPARE-FEATURES-OF-VARIETIES (v1 v2 &optional (details nil))
  (let* ((v1-list 
	  (let ((curlan v1))
	    (remove-duplicates
	     (loop for s in (list-systems v1)
		 append (fetch-output-features s)))))
	 (v2-list 
	  (let ((curlan v2))
	    (remove-duplicates
	     (loop for s in (list-systems v2)
		 append (fetch-output-features s)))))
	 (v1-v2-diff (set-difference v1-list v2-list))
	 (v2-v1-diff (set-difference v2-list v1-list))
	 (plural-stem "feature"))

      (format t "~% Comparing ~As..." plural-stem)
      (percentage-shared-messages v1 v2 plural-stem v1-list v2-list)
      (unless (set-equal v1-list v2-list)
	(format 
	 t 
	 "~%  There are differences in the ~As belonging to each variety."
	 plural-stem)
	(format t "~%  There are ~A ~As in ~A that are not in ~A"
		(length v1-v2-diff) plural-stem v1 v2)
	(format t "~%  and there are ~A ~As in ~A that are not in ~A."
		(length v2-v1-diff) plural-stem v2 v1)
	(push `(:feature ,v1 ,v2 ,(length v1-v2-diff) ,(length v2-v1-diff))
	      *variety-comparison-counts*)
	(when details
	  (format t "~%  In ~A and not in ~A are: ~{~%     ~S~}~%"
		  v1 v2 v1-v2-diff)
	  (format t "~%  In ~A and not in ~A are: ~{~%     ~S~}~%"
		  v2 v1 v2-v1-diff)))))

(defun PERCENTAGE-SHARED-MESSAGES (v1 v2 type v1-list v2-list)
  (let* ((sh (length (intersection v1-list v2-list)))
	 (total (length (union v1-list v2-list)))
	 (pc (* (/ sh total) 100.0)))
    (format t "~%  ~A has ~A ~As, ~A has ~A ~As." 
	    v1 (length v1-list) type
	    v2 (length v2-list) type)
    (format t "~%  ~A are shared (~A%: out of ~A)." 
	    sh pc total)
    (push `(,(if (string-equal type "inquirie")
		 :INQUIRY
	       (intern (string-upcase type) "KEYWORD"))
	    ,v1 ,(length v1-list) ,v2 ,(length v2-list) ,sh ,pc ,total)
	  *variety-comparison-counts*)))
	  

(defun SHOW-COMP-COUNTS (&optional (stream T))
  (format stream "~{~% ~{~10S ~}~}" (reverse *variety-comparison-counts*)))

;;; ----------------------------------------------------------------------
;;; 3.1+
;;; Cut down versions of the above that just gather statistics rather
;;; than giving messages. Should be merged at some point. Following
;;; compares values that give an absolute indication of difference
;;; between varieties. For systems two figures are returned, the
;;; first indicating paradigmatic differences, the second syntagmatic.
;;; ----------------------------------------------------------------------

(defun GATHER-COMPARISON-STATS-FOR-OBJECTS-OF-TYPE 
  (type v1-list v1 v2-list v2)
  (flet ((normalize 
	  (s v type)
	  (format nil "~S" 
		  (flatten
		   ;; 2.0.41
		   (create-normed-list-representation-of-object s type v)))))
    (let ((v1-v2-diff (set-difference v1-list v2-list))
	  (v2-v1-diff (set-difference v2-list v1-list))
	  (v1-and-v2 (intersection v1-list v2-list))
	  (diff-para 0)
	  (diff-synt 0)
	  (mismatching-realizations nil)
	  (mismatching-outputs nil)
	  (lgpair (list v1 v2)))

      (unless (set-equal v1-list v2-list) 
	;; There are differences in the ~As belonging to each variety.
	(setf diff-para (+ (length v1-v2-diff) (length v2-v1-diff))))
	
      (when (equal type :system)
	(setf mismatching-outputs 
	      (sort (compare-output-features v1-and-v2 lgpair) #'string<))
	(when mismatching-outputs
	  ;; following common systems have nonmatching output features... 
	  (setf diff-para (+ diff-para (length mismatching-outputs))))
	(setf mismatching-realizations
	      (sort (compare-feature-realizations v1-and-v2 lgpair) #'string<))
	  (when mismatching-realizations
	    ;; following common features have nonmatching realizations...
	    (setf diff-synt (length mismatching-realizations)))
	  (loop for f in mismatching-realizations
		do (pushnew (first (who-has-as-output f)) mismatching-outputs))
	  (setf diff-synt
		(+ diff-synt
		   ;; incongruencies in realisations of shared features...
		   (length
		    (loop for s in v1-and-v2
			  as normed1 = (normalize s v1 type)
			  as normed2 = (normalize s v2 type)
			  when (and normed1 normed2 
				    (not (equal normed1 normed2))
				    (not (member s mismatching-outputs)))
			  collect s)))))
      (list diff-para diff-synt))))

(defun GATHER-COMPARISON-STATS-FOR-VARIETIES (V1 V2)
  (let ((stats nil))
    (reset-network-if-necessary)
    (format 
     *trace-output* 
     "~%Gathering comparison stats for language varieties ~A and ~A...~%" 
     v1 v2)
    (let ((all-regions 
	   (union (let ((curlan v1))(get-regions))
		  (let ((curlan v2))(get-regions)))))
    (format *trace-output* "~% To do: ~10T")
    (loop for r from 1 to (length all-regions) do (format *trace-output* "x"))
    (format *trace-output* "~%~10T")
    (setf 
     stats
     (loop for r in all-regions
	   do (format *trace-output* ".")
	   collect
	   (list 
	    r
	    (let* 
		((curlan v1)
		 (v1-systems (systems-of-region+ r :no-warning-p t))
		 (v1-choosers (choosers-of-region r :no-warning-p t))
		 (v1-inquiries (inquiries-of-region r :no-warning-p t)))
	      (let* ((curlan v2)
		     (v2-systems (systems-of-region+ r :no-warning-p t))
		     (v2-choosers (choosers-of-region r :no-warning-p t))
		     (v2-inquiries (inquiries-of-region r :no-warning-p t)))
		(let*
		    ((sys-comp 
		      (gather-comparison-stats-for-objects-of-type 
		       :system v1-systems v1 v2-systems v2))
		     (para-sys-comp (first sys-comp))
		     (synt-sys-comp (second sys-comp))
		     ;; (compare-features-of-varieties v1 v2 details)
		     (ch-comp
		      (first
		       (gather-comparison-stats-for-objects-of-type 
			:chooser v1-choosers v1 v2-choosers v2)))
		     (inq-comp
		      (first (gather-comparison-stats-for-objects-of-type
			      :inquiry v1-inquiries v1 v2-inquiries v2))))
		  (list para-sys-comp
			synt-sys-comp
			ch-comp
			inq-comp)))))))
    (format t "~%... variety statistics comparison completed.")
    (cons 
     (loop for (r (para syn ch inq)) in stats
	   summing para into para-s
	   summing syn into syn-s
	   summing ch into ch-s
	   summing inq into inq-s
	   finally
	   ;; 4.0+ was:
	   ;; return (list :total (list para-s syn-s ch-s inq-s))
	   (return (list :total (list para-s syn-s ch-s inq-s)))
	   )
     stats))))

;;; ----------------------------------------------------------------------
;;; varieties is a list of language variety names
;;; stats-list is a list of the comparison stat lists as formed
;;;   by the functions above
;;; object is what kind of stats are required.
;;; ----------------------------------------------------------------------

(defun PREPARE-STATS-COMP-TABLE (varieties stats-list object)
  (let ((slice (case object
		     (:systems 0)
		     (:features 1)
		     (:choosers 2)
		     (:inquirys 3))))
    (format t "~%~31T~{~5A~}~30A" varieties object)
    (loop for r in (cons :total (get-regions t))
	  do 
	  (format t "~%~30A~{~5A~}"
		  r 
		  (loop for stats in stats-list
			collect
			(nth slice (second (assoc r stats))))))))

;;; ----------------------------------------------------------------------
;;; Old Penman functions...
;;; ----------------------------------------------------------------------

(defun COMPUTE-HASH-TABLE-OF-ALL-FUNCTIONS ()
  (dolist (system  (list-systems))
    (dolist (outputs (fetch-system-outputs system))
      (dolist (realization (cddr outputs))
	;(format *standard-output* "~%~s" realization)
	      (case (car realization)
	  (*)
	  ((lexify insert orderatend orderatfront preselect
		   inflectify  classify outclassify
;;> plus the morphology realizations...
		   preselect-substance weaken strengthen 
		   chop preselect-substance-as-stem
		   preselect-substance-as-property
		   )
	   (setf  (gethash (second realization) hash-table-of-all-functions)
		  (second realization)))
	  ((order conflate partition )
	   (setf  (gethash (second realization) hash-table-of-all-functions) 
		  (second realization))
	   (setf  (gethash (third realization) hash-table-of-all-functions) 
		  (third realization)))
	  (expand
	    (setf  (gethash (second realization) hash-table-of-all-functions) 
		   (second realization))
	    (setf  (gethash (third realization) hash-table-of-all-functions) 
		   (third realization))
	    (setf  (gethash (fourth realization) hash-table-of-all-functions) 
		   (fourth realization)))
;;; stratification realizations...
	  (register-insert
	   (push (cons (second realization) (second outputs)) 
		 *register-microfunction-inserts*))
	  (unless 
	   (member (car realization) *realization-operators*)
	   (warning "Unknown realization " realization " in system " 
		    system 
		    " -- unable to compute hash-table-of-all-functions")))))))


(defun lexical-and-grammatical-feature-survey ()
  (let ((features-from-lexicon (hashtable-to-list words-of-a-feature))
	(features-from-grammar nil))
    (dolist (x (who-can-classify))
      (dolist (y (second x))
	(push (third y) features-from-grammar)))
    (dolist (x (who-can-out-classify))
      (dolist (y (second x))
	(push (third y) features-from-grammar)))
    (dolist (x (who-can-inflectify))
      (dolist (y (second x))
	(push (third y) features-from-grammar)))
    (setq features-from-grammar (remove-duplicates features-from-grammar))
    (format t "~2%There are ~a features from the lexicon:" (length features-from-lexicon))
    (pprint (sort (copy-list features-from-lexicon) #'string<))
    (format t "~2%There are ~a features from the grammar:" (length features-from-grammar))
    (pprint  (sort (copy-list features-from-grammar) #'string<))
    (format t "~2%The following features only appear in the grammar:")
    (pprint (sort (copy-list (set-difference features-from-grammar features-from-lexicon)) #'string<))
    (format t "~2%The following features only appear in the lexicon:")
    (pprint (sort (copy-list (set-difference features-from-lexicon features-from-grammar)) #'string<))))

    
;;;-------------------------------------------------------------------
;;;
;;;   Goes through all the lexical items and collects the
;;;   lexicalfeatures used there... 

(defun CREATE-VALID-LEXICAL-FEATURE-LIST (&optional (lg nil))
  (setq valid-lexical-feature-list nil)
  (maphash #'(lambda (key val)
	       key
	       (let ((temp nil))
		 (cond ((setq temp 
			      (fetch-lexicon-info key 'features lg))
			(dolist (feature temp)
				(pushnew
				 feature  
				 valid-lexical-feature-list ))))))
	   lexicon))



