(in-package "KPML")

;;; File: tests.lisp
;;; ----------------

;;; Current version overseen by: John Bateman, IPSI
;;;                              0 version; Hiddensee, Sep94
;;;                              1 version; Darmstadt, Nov94
;;;                          KPML 1.1: updates incorporated.
;;;                              3.1 updated for selective use from interface
;;;                                  clisp cleaned out.  Prag->Bremen, Feb00
;;;
;;;   This file takes the Penman file of the same name as a
;;; basis and starts tidying up and expanding the functionality so
;;; that it is both compatible with the Multilingual environment and
;;; also more useful. Many of the functions seem to have fallen into
;;; disuse in using Penman, however for KPML they should be seen as
;;; regular tests that are applied whenever grammar changing takes
;;; place. 
;;;
;;; Original function definitions lost in the mists of history but
;;; certainly developed partly under  National Science Foundation 
;;; Grant IST-8408726, Federal Contract numbers MDA903-81-C-0335, 
;;; MDA903-87-C-0641, F49620-84-C-0100, and F49620-87-C-0005, and the
;;; U.S. Government holds license rights under DAR 7-104.9 (a)(c)(1).
;;; (These are the inherited Penman acknowledgements.)
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;KPML Development history 
;;;
;;; John:Hiddensee:Sep94
;;;
;;;  changes, alterations and  general  tidying up  for  compatibility
;;;  with  the  ML-environment   begun. Changes   are   such that  all
;;;  functions should work  as before if  there is no  ML-environment,
;;;  however  additional  keyword   arguments influence their  further
;;;  behavior. Comments have been added where checks have been made.
;;;  Some of the function names have been changed; but only of functions
;;;  that were not used anywhere else automatically anyway.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar all-out-classified-functions nil)
(defvar db nil "used in analyze choosers")

;;; Little addition to make a quick survey of the number of features
;;; that have been used so far by generated examples...
(defvar *quick-feature-survey* nil)

(defvar *upper-model-present* nil 
  "nil until someone loads an upper model")

(defvar *flag-chooser-feature-error* nil)

;;;
;;; Function: PERFORM-STATIC-CONSISTENCY-CHECKS
;;;  -- replaces print-test-whole and test-whole;
;;;  -- is the central point where consistency checks are
;;;     fired up;
;;;  -- precise behaviour is controlled by keywords as follows:
;;;          :to-file "file-name" : results placed in file in
;;;                                 user's home directory
;;;          :lg-restricted       : when T only checks for
;;;                                 current language

(defun PERFORM-STATIC-CONSISTENCY-CHECKS
  (&key (to-file nil)(lg-restricted nil))

  (cond (to-file
	 (unwind-protect
	     (let ((file-name (merge-pathnames 
			       (pathname (string to-file))
			       (user-homedir-pathname))))
	       (with-open-file 
		(output-stream  file-name  
				:direction :output
				:if-exists :new-version)
		(let ((*standard-output* output-stream))
		  (static-consistency-checks
		   :lg-restricted lg-restricted))))))
	(t (static-consistency-checks
	    :lg-restricted lg-restricted))))

	  
;;; ----------------------------------------------------------------------
;;; 3.2.66
;;;  messages cleaned up to be more readable, that's all...
;;; ----------------------------------------------------------------------

(defun STATIC-CONSISTENCY-CHECKS (&key (lg-restricted nil))
  (cond ((or lg-restricted (not (ml-p)))
	 (let ((cur-disabled-systems 
		(loop for (sys lg) in *disabled-systems*             ;; 3.2.66
		      when (equal lg curlan)
		      collect sys)))
	   (when cur-disabled-systems 
	     (format t "Note: following systems are disabled! Should they be? ~%  ~A" 
		     cur-disabled-systems)))
	 (Check-Derived-Data)
	 (Compute-Wholistic-Tests)
	 (Analyze-Choosers))
	(t
	 (unless (ml-p)
		 (format *trace-output*
			 "~%Cannot restrict language in non-multilingual system!")
		 (return-from static-consistency-checks nil))
	 (when *disabled-systems*                                    ;; 3.2.66
	   (format t "Note: following systems are disabled! Should they be? ~%  ~A" 
		   *disabled-systems*))
	 (dolist (curlan all_languages)
		 (format t "~2% Consistency checks for: ~A~%" curlan)
		 (Check-Derived-Data)
		 (Compute-Wholistic-Tests)
		 (Analyze-Choosers)))))


(defun COMPUTE-WHOLISTIC-TESTS ()
  (create-valid-lexical-feature-list curlan)
  (create-list-of-test-alls)
    
  ;; Network connectivity tests...
  (paradigmatic-tests)

  ;; Syntagmatic constraints tests...
  (syntagmatic-tests)

    ;; Surveys...
    (format t "~2%.... resource surveys...~2%")
    (chooser-definition-survey)
    (inquiry-implementations-unbound-check)
    (inquiry-definition-survey)
    (operator-implementation-survey)
    )


(defun PARADIGMATIC-TESTS ()
  (format t "~2%.... paradigmatic tests...~%")
  (Unreachable-Inputs-Test)
  (Unreachable-Outputs-Test)
;;  (Excess-Void-Feature-Test)  ;; 3.1 this was here, wrongly?
  (Excess-Void-Features-Test))

(defun SYNTAGMATIC-TESTS ()
  (format t "~2%.... syntagmatic tests...~%")
  (Expand-Classify-Test)
  (Expand-Conflate-Test)
  (Expand-Lexify-Test)
  (Expand-Out-Classify-Test)
  (Expand-Preselect-Test)
;  (Duplicate-System-Number-Test)  ;; not used anymore
  (Default-Ordering-Loops-Test))
  

(defun KPML-STATUS-TESTS ()
  (unless *upper-model-present*
	  (format t "~2%;;; !!WARNING!!: no upper model present!! "))
  (unless paths-valid
	  (format t "~2%;;; !!WARNING!!: network connectivity not up to date!! "))
  )



;;;--------------------------------------------------------------------
;;;    NETWORK CONNECTIVITY...
;;;
;;;     the network has one distinguished feature, [start], its root.
;;;
;;; 3.1 was returning  (sort (remove-Duplicates (copy-list Feats) :test #'equal) #'String<=)
;;;     where feats was was each feature where there was a problem:
;;;     (setq feats (append feats each) )
;;;  No idea why...
;;;  Although probably so that a user can use the information gathered in some way other than
;;;  just editing the report file. Sounds reasonable, so return something useful...

(defun UNREACHABLE-INPUTS-TEST ()
  (let ((list-of-output-features 
	 (cons 'start (hashtable-to-list all-output-features))))
    (format t "~%~10TTesting for undefined input features...")
    (loop for S in (list-systems Curlan)
	  as Each = (set-difference (fetch-input-features s) list-of-output-features)
          when each collect (list  (remove-Duplicates Each :test #'equal) s) into bad
          finally 
          (if Bad 
              (progn
                (format t "~%~10T!! There were input features not recognized as outputs of any systems.")
                (format t "~{~%~12T!! ~{~S in system: ~S~}~} " (Dreverse Bad))
                (return-from UNREACHABLE-INPUTS-TEST bad))
            (format t "~%         OK.")
            ))
    nil))

(defun UNREACHABLE-OUTPUTS-TEST ()
  (let ((UO (set-difference 
             (hashtable-to-list All-Output-Features) Path-Features)))
    (format t "~%~10TTesting for undefined output features...")
    (if uo
        (format t "~%~12T!! The following Output Features of systems are not reachable from entry features: ~A"
                uo)
      (format t "~%          OK."))
    uo))

(defun EXCESS-VOID-FEATURE-TEST (Sys)
  (let* ((Outs (fetch-output-features Sys))
         (Voids (remove-duplicates (intersection Outs All-Void-Features))))
    (cond
     ((> (LENGTH Outs) 1)
      (cond ((> (LENGTH Voids) 1)
             (format t "~%~12T!! Too many void features on System ~A: ~S" Sys Voids)
             T)
            (t nil)))
     (T (cond (Voids 
               (format t "~%~12T!! Void output ~A on gate ~A" (CAR Voids) sys)
               T)
              (t nil))))))


(defun EXCESS-VOID-FEATURES-TEST ()
  (format t "~%~10TTesting for terminal features without realisations...")
  (loop for S in (list-systems Curlan) do (Excess-Void-Feature-Test S)))

;;;
;;; Syntagmatic tests...
;;;

(defun EXPAND-CLASSIFY-TEST ()
  (cond
    ((List-Systems Curlan) 
     (PROG (Classify-Features Classifys Out-Classify-Features Out-Classifys Errors Both-Features)
       (SETQ Classifys (Expand-Operator-Test 'Classifys))
       (SETQ Classify-Features (loop for C in Classifys nconc (copy-tree (CDDR C))))
       (SETQ Out-Classifys (Expand-Operator-Test 'Out-Classifys))
       (SETQ Out-Classify-Features (loop for C in Out-Classifys nconc (copy-tree (CDDR C))))
       (SETQ Both-Features (UNION Classify-Features Out-Classify-Features))
       (cond
        ((SETQ Errors (set-difference Valid-Lexical-Feature-List Both-Features))
         (format t  "~%!! Lexical features not called for by any Out-Classify or Classify: ~S" 
                 Errors)))
       (cond
        ((SETQ Errors (set-difference Terminal-Lexical-Feature-List Both-Features))
         (format t  "~%!! TERMINAL lexical features not called for by any Out-Classify or Classify: ~S"
	         Errors)))
       (cond
        ((SETQ Errors (set-difference Both-Features Valid-Lexical-Feature-List))
         (format 
          t "~%!! Features demanded by Out-Classifies or Classifies, but not present in the Lexicon: ~A"
          Errors)))
       (SETQ All-Out-Classified-Functions 
             (sort (Remove-duplicates 
                    (loop for C in Out-Classifys
                          collect (Second C)) :test #'equal)
                   #'String<=))
       (SETQ All-Classified-Functions 
             (sort (Remove-duplicates 
                    (loop for C in Classifys
                          collect (Second C)) :test #'equal)
                   #'String<=))
       errors))))


(defun EXPAND-CONFLATE-TEST ()
  (let ((error nil))
    (loop for C in All-Conflates
          do 
          (cond
           ((member (CAR C) All-Expanded-Functions)
            (setf error T)
            (format t "~%!! The function ~A is both expanded and conflated in ~A"  (CAR C) C)))
          (cond
	   ((member (Second C) All-Expanded-Functions)
            (setf error T)
	    (format t "~%!! The function ~A is both expanded and conflated in ~A"  (Second C) C))))
    error))

(defun EXPAND-LEXIFY-TEST ()
  ;; 3.2.66 replaces a simple list of failing lexemes by a list of the systems
  ;;        that are guilty too...
    (PROG (Lexify-Words Lexifys Errors)
      (SETQ Lexifys (Expand-Operator-Test 'Lexifys))
      (SETQ Lexify-Words (loop for C in Lexifys collect (Third C)))
      (cond
       ((SETQ Errors (sort 
		      (remove-duplicates
		       (set-difference Lexify-Words (Words-List))
		       :test #'equal)         ;; 4.0
		      #'string<))             ;;   paren/param error here
        (format t "~%!! Words demanded by Lexifies, but not present in the Lexicon: ~A~%" Errors)
	(loop for e in errors
	      do (format t "~%~10T~A in: ~A" e (mapcar #'car (who-can-lexify e))))

	(SETQ All-Lexified-Functions 
	      (sort (Remove-duplicates (loop for C in Lexifys collect (Second C)) :test #'equal)
		    #'String<=))
        nil))))

(defun EXPAND-OPERATOR-TEST (Op-Name)
;this needs to be fixed to check for expand and (or classify lexify out-classify preselect) 
;on the same path through the grammar.
  (PROG (Temp-List)
    (SETQ Temp-List (loop for S in (List-Systems Curlan) nconc (Get-System-Info S Op-Name)))
    #|(for Sub-List in Temp-List bind func when (member (SETQ func (Second Sub-List))
                                                        All-Expanded-Functions)
           do (format t "~%!! The function ~A has been both expanded and ~A in ~A" func 
                      (Case Op-Name  (Lexifys "lexified ")
                        (Out-Classifys "Out-Classified ")
                        (Classifys "classified ")
                        (Preselections "preselected ")
                        (otherwise "something weird"))
                      Sub-List))|#
    (RETURN Temp-List)))

(DEFUN Expand-Out-Classify-Test NIL
  (cond
    ((List-Systems Curlan) 
     (PROG (Out-Classify-Features Out-Classifys Errors)
       (SETQ Out-Classifys (Expand-Operator-Test 'Out-Classifys))
       (SETQ Out-Classify-Features (loop for C in Out-Classifys nconc (copy-tree (CDDR C))))
       (cond
        ((SETQ Errors (set-difference Valid-Lexical-Feature-List Out-Classify-Features))
         (format t "~%!! Lexical features not called for by any Out-Classify: ~A" Errors)))
       (cond
        ((SETQ Errors (set-difference Terminal-Lexical-Feature-List Out-Classify-Features))
         (format t "~%!! TERMINAL lexical features not called for by any Out-Classify: ~A" 
                 Errors)))
       (cond
        ((SETQ Errors (set-difference Out-Classify-Features Valid-Lexical-Feature-List))
         (format t "~%!! Features demanded by Out-Classifies, but not present in the Lexicon: ~A"
                 Errors)))
       (if errors
           (SETQ All-Out-Classified-Functions 
                 (sort (Remove-duplicates (loop for C in Out-Classifys
                                                collect (Second C)) :test #'equal)
                       #'String<=))
         nil)))))


(DEFUN Expand-Preselect-Test NIL
  (PROG (Preselect-Features Preselects Errors)
    (SETQ Preselects (Expand-Operator-Test 'Preselections))
    (SETQ Preselect-Features (loop for C in Preselects nconc (copy-tree (CDDR C))))
    (cond
     ((SETQ Errors (set-difference Preselect-Features Path-Features))
      (format t "~%!! Features demanded by Preselects, but not chosen in the Grammar: ~A" Errors)))
    (if errors
        (SETQ All-Preselected-Functions (sort (Remove-duplicates (loop for C in Preselects collect
                                                                       (Second C)) :test #'equal)
                                              #'String<=))
      nil)))


;;; Following function not used in KPML... content removed.
(DEFUN Duplicate-System-Number-Test NIL
  #+ignore(let ((table (make-hash-table)))
            (dolist ( Sys  (List-Systems Curlan))
              (push sys (gethash (fetch-system-system-number sys) table)))
            (maphash #'(lambda (key val)
		         (cond((and (> (length val) 1) (< (length val) 5))
		               (warning "The systems " val " have the same system number " key))
		              ((> (length val) 4)
		               (warning (length val) " systems have the same system number " key))))
	             table))
  nil)



;;;------------------------------------------------------------------------
;;; Chooser analysis used multilingually also. Flag added to restrict
;;; tests to those systems that are relevant for the current language
;;; only. Old behaviour obtained by leaving flag out or specifying
;;; nil.
;;;                                                         John:Sep94
;;;         (John:Nov94: flag no longer needed due to language
;;;                      sensitivity of the list-systems function.)

(defun ANALYZE-CHOOSERS (&OPTIONAL Clearing-Flag &key (ml-p nil))
  (declare (ignore ml-p))
  (let ((list-of-systems (list-systems curlan)))
    (format t "~%~10TChecking choosers for feature usage...")
    (cond (Clearing-Flag 
	   (setq Chooser-DB NIL)
	   (printwindow :display-pane "Chooser Data Base Cleared." ))
	  (T 
           (setf *flag-chooser-feature-error* nil)
           (setq Chooser-DB 
		   (PROG 
		    ((Sys-List (loop for s in list-of-systems 
				    when (fetch-system-chooser s)
				    collect s)))
		    (RETURN 
		     (loop for sys in Sys-List
                           as ch = (fetch-system-chooser sys)
                           as def = (Get-Chooser-Def (fetch-system-chooser sys))
			   when def
			   collect (Cons ch (Analyze-Chooser def sys ch))))))
             ;; 0.9 multilingual chooser-db...
             (update-multilingual-chooser-db chooser-db)
             ;; now collect list of all grammatical functions.
	     (setq  list-of-all-grammatical-functions nil)
             ;; first do those mentioned in system outputs.
	     (dolist (system list-of-systems)
               (dolist (output (fetch-system-outputs system))
                 (dolist (item-in-output output)
                   (when (and (listp item-in-output) 
                              (atom (second item-in-output)))
                     (pushnew (second item-in-output) 
                              list-of-all-grammatical-functions)))))
             ;;;now do those mentioned in choosers
	     (dolist (chooser (list-choosers) )
               (setq   list-of-all-grammatical-functions
                       (append   list-of-all-grammatical-functions 
                                 (fetch-chooser-db-elt 'functions chooser))))
	     (setq list-of-all-grammatical-functions 
		   (remove-duplicates list-of-all-grammatical-functions ))
	     (printwindow :display-pane "Chooser Data Base Computed." )
             *flag-chooser-feature-error*
             ))))

;;; ----------------------------------------------------------------------
;;; 3.0 was missing a defaultchoose check...
;;; 4.0 downgraded the situation where a system has a superset of the
;;;     features mentioned in the chooser to a caution.
;;; ----------------------------------------------------------------------

(defun ANALYZE-CHOOSER (&optional Chooser-Def System-Name Chooser-Name )
  ;; 3.2.66 formatting of messages improved...
  (labels ((s (list) (sort list #'string<)))
    (PROG (All-Choices Analysis System-Choices defaultchoice flag-error)
	(setq db nil)
        (setf flag-error nil)
	(setq Analysis
	      (loop for clause in Chooser-Def 
		   do
		   (Analyze-Chooser-Clause clause chooser-name)
		   finally (RETURN (Dremove NIL DB))))
	(setq All-Choices (CDR (assoc 'Choices Analysis)))
        (setq defaultchoice (cdr (assoc 'defaultchoose analysis)))
	(setq All-Choices (Remove-duplicates (Dremove NIL All-Choices) :test #'equal))
	(setq System-Choices (fetch-output-features System-Name))

	(cond ((set-equality All-Choices System-Choices))
              (defaultchoice
		(unless (subsetp defaultchoice system-choices)
		  (format t "~%2!! The system ~A [~A] ~%    uses chooser ~A, 
~%     defaultchooses ~S  whereas the system defines features ~S." 
			  System-name 
			  (fetch-system-region system-name) 
			  chooser-name defaultchoice 
			  (s system-choices))
		  (setf flag-error T)))
	      ((subsetp All-Choices System-Choices)
	       ;; 4.0 downgraded...
	       ;;
	       (let 
		   ((message 
		     (format 
		      nil 
		      "~%!! The system ~A [~A] uses chooser ~A which chooses: ~A whereas the system defines: ~A."
		      System-name 			  
		      (fetch-system-region system-name) 
		      chooser-name (s all-choices) (s system-choices))))
		 (caution message)
		 #+ignore(setf flag-error T)
		 ))
	       (t
	       (format t "~%2!! The system ~A [~A] uses chooser ~A 
~%      which chooses ~%      : ~A~%      whereas the system only defines features~%      : ~A."
		       System-name (fetch-system-region system-name) Chooser-Name 
		       (s All-Choices)
		       (s System-Choices))
               (setf flag-error T)))
        (setf *flag-chooser-feature-error* flag-error)
	(RETURN analysis))))


;;; KPML 0.8; curiously, it was not previously possible to track which
;;; functions are receiving associations where! Who-can-identify in
;;; the Penman interpretation worked on identifying inquiries, not
;;; functions, and copyhubs were not being recorded at all as 
;;; association effecting in the chooser-db. This is now changed
;;; with an extra entry in the chooser-db and a change in the
;;; semantics of who-can-identify.  (John:IPSI:April 95)

(defun ANALYZE-CHOOSER-CLAUSE (clause chooser-name)
  (when (value-if-listp Clause)
    (let ((arg (second clause)))
      (Case (CAR Clause)
        (CopyHub (Add-Atoms-To-ASSOC 'Copies arg DB)
		 (Add-Atoms-To-ASSOC 'Functions arg DB)
		 (Add-Atoms-To-ASSOC 'Functions (Third Clause) DB)
		 (Add-Atoms-To-ASSOC 'Identified-by-copyhub (Third Clause) DB))
        (Pledge (Add-Atoms-To-ASSOC 'Functions arg DB)
	        (Add-Atoms-To-ASSOC 'Pledges arg DB))
        (TermPledge (Add-Atoms-To-ASSOC 'Functions arg DB)
                    (Add-Atoms-To-ASSOC 'TermPledges arg DB))
        (Choose (Add-Atoms-To-ASSOC 'Choices arg DB))
        (Identify (Add-Atoms-To-ASSOC 'Functions arg DB)
		  (Add-Atoms-To-ASSOC 'Functions (CDR (Third Clause)) DB)
		  (Add-List-To-ASSOC 'Identifies (CDR Clause) DB))
        (Ask (Add-List-To-ASSOC 'Asks arg DB)
	     (Add-Atoms-To-ASSOC 'Functions  (CDADR Clause) DB)
	     (loop for c in (CDDR Clause)
		   do 
		   (cond ((consp c)
		          (loop for cc in (CDR c) do (Analyze-Chooser-Clause cc chooser-name)))
		         (t
		          (warning 
			   "Misformed chooser definition: " 
			   chooser-name "; " c " should be an inquiry response -- ignoring.")
                          (setf *flag-chooser-feature-error* T)))))
        (defaultchoose (Add-Atoms-To-ASSOC 'defaultchoose arg DB)
                       (Add-Atoms-To-ASSOC 'Choices arg DB))
        (otherwise (when (Not (member (CAR Clause) Legal-Extension))
                     (setf *flag-chooser-feature-error* T)
                     (warning "In chooser: " chooser-name ", unknown chooser operator: " Clause)))))))
  


;;;--------------------------------------------------------------------
;;;  RESOURCE SURVEYS...
;;;
;;;  John: Sep04 a few trivial extra figures, returns the same information
;;;        as before though...

(defun OPERATOR-IMPLEMENTATION-SURVEY ()
  (let ((unimps nil)(trivs nil))
    ;; (i)
    (format t "~%!! Listing inquiry operators that only use trivial defaults: ")
    (format t "~%!! ~{~%~20T~A~}" 
	    (pretty 
	     (sort (setq trivs
			 (loop for op in Inquiry-Operators 
			       when (equal (fetch-inquiry-info op 'operatorcode) 'trivialdefaultcode)
			       collect op
			       ))
		   #'string<=)
	     :right-margin 50))
    (format t "~%~10T!! which is a total of ~a out of ~a (~A%)." 
	    (LENGTH trivs) (LENGTH Inquiry-Operators)
	    (* (/ (length trivs)(LENGTH Inquiry-Operators)) 100.0 ))
    (inquiry-metafunction-spread trivs)
    
    ;; (ii) this was the old case...
    (format t "~%!! Listing inquiry operators that do not use inquiry implementations: ")
    (format t "~%!! ~{~%~20T~A~}" 
	    (pretty 
	     (sort (setq unimps 
			 (loop for op in Inquiry-Operators 
			       unless (fetch-inquiry-info op 'operatorcode)
			       collect op
			       ))
		   #'string<=)
	     :right-margin 50))
    (format t "~%~10T!! which is a total of ~a out of ~a (~A%)" 
	    (LENGTH unimps) (LENGTH Inquiry-Operators)
	    (* (/ (length unimps)(LENGTH Inquiry-Operators)) 100.0 ))
    (inquiry-metafunction-spread unimps)

    
    (format t "~%~10T!! and so ~A inquiries are not actively semantically controlled."
	    (+ (length unimps)(length trivs)))
    (format t "~%~10T!! i.e., ~A% of the total."
	    (* (/ (+ (length unimps)(length trivs))(LENGTH Inquiry-Operators)) 100.0 ))
    unimps))

;;; 3.1 for Jiri

(defun INQUIRY-IMPLEMENTATIONS-UNBOUND-CHECK ()
  (let ((unbound (loop for inq in (list-inquiries)
                       as op = (fetch-inquiry-info inq 'operatorcode)
                       when (and op
                                 (not (fboundp op)))
                       append (list op inq))))
    (format t "~%~10T!! Checking for inquiries operators used but not defined...")
    (if unbound 
        (progn
          (format t "~%~12T Following operator codes are undefined:")
          (format t " ~{~%~15TOperator ~S, in inquiry ~S.~}" unbound))
      (format t "~%~10TOK."))
    unbound))

(defun INQUIRY-DEFINITION-SURVEY ()
  (let ((undefined-inquiries nil))
    (format t "~%!! Checking for inquiries used in choosers but not defined...")
    (loop for system in (list-systems curlan)
	  when (fetch-system-chooser system)
	  do
	  (setf inquiries-used-in-chooser
		(append
		 (fetch-chooser-db-elt 
		  (fetch-system-chooser system) 'asks)
		 (fetch-chooser-db-elt 
		  (fetch-system-chooser system) 'identifies)))
	  (loop for inq 
		in (mapcar #'first inquiries-used-in-chooser)
		unless (member inq inquiry-operators)
		do (push inq undefined-inquiries)))
    (if undefined-inquiries
        (format t "~%~10T!! Following are not defined: ~A" undefined-inquiries)
      (format t "~%~10TOK."))
    undefined-inquiries))
	

(defun CHOOSER-DEFINITION-SURVEY ()
  (let ((undefined-choosers nil))
    (format t "~%!! Checking for choosers used in systems but not defined...")
    (loop for system in (list-systems curlan)
	  do
	  (if (fetch-system-chooser system)
	      (unless (gethash (fetch-system-chooser system)
			       choosers)
		      (push (fetch-system-chooser system)
			    undefined-choosers))))
    (if undefined-choosers
        (progn
          (format t "~%!! Following choosers used in systems but not defined:")
          (format t "~%!! ~A" undefined-choosers))
      (format t "~%          All choosers used in systems are defined."))
    undefined-choosers))

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

(defun FEATURE-SURVEY (&optional (brief nil))
;;; KPML 0.8: example list updated and some small bugs out...
;;; 3.0       output to standard output not to a display window...
  (let* ((Chosen  (All-Example-Choices))
	 (all-output-features-list
	  (remove-duplicates (hashtable-to-list All-Output-Features )))
	 (Residue 
	  (SORT 
	   (set-DIFFERENCE All-Output-Features-list Chosen) #'string-lessp)))
	(cond ((and *quick-feature-survey* (not brief))
               (format t "~%  Features selected in examples: ~A (out of ~A)"
                       (LENGTH Chosen)(LENGTH All-Output-Features-list)))
	      ((not brief)
               (format t "~%  The following examples are loaded: ~A..."
                       (sort (list-of-examples) #'string<=) )
               (format t "~%  Out of  ~a grammatical features, these ~a are chosen in examples: ~A"
                       (LENGTH All-Output-Features-list) (LENGTH Chosen)
                       (sort chosen #'string<=))
               (format t "~%    while these ~a are not chosen: ~A. " 
				    (LENGTH Residue)(sort residue #'string<=))))
        residue))



;;; ----------------------------------------------------------------------
;;; Little thing for showing how examples add to the features
;;; that have been selected. A good example set should probably
;;; have rather linear cumulation of features used.
;;; ----------------------------------------------------------------------

(defun CUMULATIVE-EXAMPLE-FEATURE-USE (&optional (examples (list-of-examples)))
  (let* ((*demo-mode* T)
	 (*quick-feature-survey* T)
	 (prev (feature-survey T))
	 (N 0))
  (loop for ex in examples 
      do (progn
	   (say ex)
	   (setf N (feature-survey T))
	   (format t "~% ~A ~10T ~A ~10T ~A"
		   ex N (- N prev))
	   (setf prev N)))))


(defun GENERATED-FEATURE-USE (ex)
  (let* ((*demo-mode* T)
	 (*accumulate-used-features* T)
	 (prev (length *features-used*))
	 (N 0))
    (say ex)
    (setf N (length *features-used*))
    (format t "~% ~A ~10T ~A ~10T ~A"
	    ex N (- N prev))))

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

(defun All-Example-Choices ()
       (remove-Duplicates (loop for ex in (List-Of-Examples) nconc (Choices-Of-Example ex))))

(defun Choices-Of-Example (Example-Symbol)
;;; KPML 0.8; example structure reference updated.
  (PROG ((Selection-Expressions
	   (fetch-example-info example-symbol 'selectionexpressions))
	   Collections)
	 (setq Collections (loop for SE in Selection-Expressions nconc (COPY-list (CDR SE))))
	 (RETURN (remove-Duplicates Collections))))


(defun LEXICON-SURVEY (&optional (lex lexicon))
  "lists all the lexical items with the same set of lexical features"
  (let ((features-to-words (make-hash-table :test #'equal))
	(features-to-words-list nil))
    (maphash #'(lambda (key val)
		 (let ((new-key  
                        (sort (remove-duplicates (copy-list (lexical-item-features val))) #'string<)))
		   (push key (gethash new-key features-to-words))))
	     lex)
    (setq features-to-words-list (sort (hashtable-to-list features-to-words) #'string<
				       :key #'(lambda (x)
						(format nil "~a" x)))) ;this is slow
    (format t "~2%Survey of Lexicon ~a" lex)
    (format t "~%Length = ~a  Number of Catagories = ~a" 
            (hash-table-count lex) (hash-table-count features-to-words))
    (dolist (x features-to-words-list)
      (format t "~2%Features:")
      (pprint x)
      (format t "~%Lexical Items:")
      (pprint (sort (gethash x features-to-words) #'string<)))
    nil))

(defun grammatical-system-p (x)
  (cond ((atom x)
	 (unless (gethash x system-table)
	   (warning x " is not a system.")))
	((consp x)
	 (dolist (xx x)
	   (grammatical-system-p xx))))t)





;;;================================================================================
;;;
;;; ... Additional new tests; John:IPSI:March 94
;;;
;;;--------------------------------------------------------------------------------
;;;
;;; 1) enforce some consistency such that system names and
;;;    feature names are distinct unless they belong to
;;;    a gate... 
;;; (note: Feb00: this is not used, as it is only necessary in 
;;;        rather odd circumstances, such as, e.g., when we are
;;;        converting to some other representation language.
;;;        Not for normal users therefore and so left here as
;;;        a Lisp function only not accessible from the GUI)

(defun SYSTEM-FEATURE-NAME-CLASH-TEST ()
  (let ((list-of-features (list-grammatical-features))
	(list-of-systems (list-systems))
	(list-of-clashes nil))
    (dolist (c (intersection list-of-features list-of-systems))
      (unless (gate-p c)
	(push c list-of-clashes)))
    list-of-clashes))

(defun SORT-FEATURES-BY-REGION (list)
  (let ((region-feature-list nil))
    (dolist (l list)
      (push (cons (fetch-system-region 
		   (first 
		    (who-has-as-output l)))
		  l)
	    region-feature-list))
    (sort region-feature-list 
	  #'string<
	  :key #'car)))


;;; ----------------------------------------------------------------------
;;; 3.1 a check to see whether the systems allocated to regions are
;;;     consistent. Not absolutely sure that they need to be however...
;;; ----------------------------------------------------------------------

(defun REGION-ASSIGNMENT-SURVEY ()
  "checks to see if the systems of regions use metafunctions consistently"
  (loop for region in (get-regions)
        as syss = (systems-of-region region)
        as mfs = (remove-duplicates (mapcar #'fetch-system-metafunction syss))
        when (> (length mfs) 1)
        do
        (format t "~%  !! Region: ~A has multiple metafunction assignments involving ~A"
                region mfs)
        and collect (cons region mfs)))

;;;
;;; Utilities...
;;;

(defun SET-EQUALITY (a b)
  (not (or (set-difference a b)
	   (set-difference b a))))



(defun WORDS-LIST (&optional (lg nil))
  (if lg
      (loop for word in words
	    when (member lg (cdr word))
	    collect word)
    (mapcar #'first words)))

;;; 3.1 broken out from function at front for re-use...

(defun CREATE-LIST-OF-TEST-ALLS ()
  (let ((list-of-systems (list-systems curlan)))
    (declare (special All-Conflates All-Expansions All-Expanded-Functions))
  (SETQ All-Conflates 
        (loop for C in 
	        (loop for S in list-of-systems 
		      nconc (Get-System-Output-Fields S 'Conflate))
	        collect (CDR C)))
    (SETQ All-Expansions 
	  (loop for E in (loop for S in list-of-systems 
		              nconc (Get-System-Output-Fields S 'Expand))
	        collect (CDR E)))
    (SETQ All-Expanded-Functions 
	  (remove-Duplicates 
	   (loop for E in All-Expansions collect (CAR E)) :test #'equal))))
