(in-package "KPML")

;;; File: ml-who-can-what.lisp
;;;
;;; Significant KPML updates. Reliance on CLISP out. File tidied up.
;;; Who-can results have been restructured to include the feature
;;; where something happens.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Who can do what functions ;;;;;;;; Modified for ML-environment ;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; 0.9 was still relying on a monolingual chooser-db after all this time!
;;;     changed. John:IPSI:Jan96.
;;;     Unlike default orders and the like, only the multilingual option
;;;     is supported. Structure of *ml-chooser-db* is a list of pairs
;;;     with the car identifying the language.

;;; 1.0.19
;;; Experimental update of who-can-... in progress. Done here
;;; for -insert only to see if there are any preferences.
;;; 2.0
;;; The update is clearly better, espeically when filtered against
;;; the currently generated example so that the developer can pinpoint
;;; exactly which systems/realization statements were responsible for
;;; a given aspect of the realization. Imposed on all who-can-
;;; functions to give a new set kpml-who-can-X. The old functions
;;; are maintained at the end of this file in case there is any
;;; code still relying on them. John:May98.
;;; ======================================================================

(defun ML-CHOOSER-DB ()
  (rest (assoc curlan *ml-chooser-db*)))

(defun UPDATE-MULTILINGUAL-CHOOSER-DB (chooser-db &optional (lg curlan))
  (let ((modified-chooser-dbs nil)
	(consumed nil))
    (loop for lg-chooser-db in *ml-chooser-db*
	do
	  (cond ((eq (car lg-chooser-db) lg)
		 (push (cons lg chooser-db) modified-chooser-dbs)
		 (warning "Chooser DB for language " lg " being updated.")
		 (setf consumed t))
		(t
		 (push lg-chooser-db modified-chooser-dbs))))
    (unless consumed (push (cons lg chooser-db) modified-chooser-dbs))
    (setf *ml-chooser-db* modified-chooser-dbs)))

(defun RELATIVIZE-TO-LANGUAGE (list-of-systems)
  (loop for system-spec in list-of-systems
      when (member curlan (cdr system-spec))
      collect (first system-spec)))

;;; ----------------------------------------------------------------------
;;; 2.0 Presume this was for one of the old attempts
;;; at providing online documentation in Penman....
;;; In any case the old functionp is replaced here by fboundp and
;;; a loop introduced. 
;;; ----------------------------------------------------------------------

(defun WHO? ()
  (printwindow 
   :display-pane 
   (indent-and-fill 
    (format nil "~a" 
	    (loop for x in (apropos-list "WHO" "KPML") 
		when (fboundp x) collect x))))
  t)

;;; ----------------------------------------------------------------------
;;; Old Penman general formatter for who-can results...
;;;  returns the results and lists of system name and relevant realization
;;;  statement. Actually what is more useful is generally the feature
;;;  to which the realization statement belongs. This is handled in the
;;;  KPML replacement of this function defined below.
;;; ----------------------------------------------------------------------

(defun WHO-FORMAT (what-items which-field compare-function)
  (let ((item-list (MKLIST what-items))
	(local-list nil))
    (loop for system in (relativize-to-language systems)
	when (setq local-list (loop for x 
				  in (get-system-info system which-field)
				  when (funcall compare-function item-list x)
				  collect x))
	collect (list system local-list))))

;;; ----------------------------------------------------------------------
;;; Update of function (who-format) above.
;;; Specialized for now to inserts. Can update the others next release
;;; sometime, or as users express some preference.
;;;
;;; 2.0 Done.
;;;
;;; Difference can be seen in the following:
;;;  (who-can-insert 'actor)
;;;    => ((ACTOR-INSERT ((INSERT ACTOR))))
;;;  (kpml-who-can-insert 'actor)
;;;    => ((ACTOR-INSERT (ACTOR-INSERTED (INSERT ACTOR))))
;;;
;;; The extra information can then be used to good effect, for example
;;; in the window interface...
;;; ----------------------------------------------------------------------

(defun WHO-FORMAT-FEATURE (what-items which-field compare-function)
  (let ((item-list (MKLIST what-items))
	(local-list nil)
	(local-list2 nil))
    (loop for system in (relativize-to-language systems)
	when (setq local-list 
	       (loop for (feature x) 
		   in (get-system-output-field-features system which-field)
		   when (setf local-list2
			  (loop for y in x
			      when (funcall compare-function item-list y)
			      collect y))
			collect (cons feature local-list2)))
	collect (cons system local-list))))

;;; ----------------------------------------
;;; Based on  allparts.lisp: GET-SYSTEM-OUTPUT-FIELD.
;;;   which was previously used by all of the fields for
;;;   get-system-info, thereby throwing away the
;;;   feature info.
;;; ----------------------------------------

(defun GET-SYSTEM-OUTPUT-FIELD-FEATURES (sys field)
  (let ((ans nil))
    (loop for Out in (fetch-System-Outputs sys)
	do (setf ans (loop for Each in (CDDR Out)
			 when (Eq (CAR Each) field)
			 collect each))
	when ans
	collect (list (second out) ans))))

;;; ----------------------------------------
;;; This all then supports...
;;; ----------------------------------------

(defun KPML-WHO-CAN-INSERT (&optional what-items) 
  (who-format-feature what-items 'insert #'intersection-using-equal-test))

(defun KPML-WHO-CAN-CONFLATE (&optional what-items)
  (Who-Format-feature what-items 'conflate #'subsetp))

(defun KPML-WHO-CAN-EXPAND (&optional Lst )
  (Who-Format-feature Lst 'Expand 'subsetp))

(defun KPML-WHO-CAN-LEXIFY (&optional Lst )
  (Who-Format-feature Lst 'Lexify 'subsetp))

(defun KPML-WHO-CAN-INFLECTIFY (&optional lst)
  (who-format-feature lst 'inflectify 'subsetp))

(defun KPML-WHO-CAN-ORDER (&optional Lst )
  (append
   (who-format-feature lst 'order 'subsetp)
   (who-format-feature lst 'orderatfront 'subsetp)
   (who-format-feature lst 'orderatend 'subsetp)
   (who-format-feature lst 'partition 'subsetp)))

(defun KPML-WHO-CAN-PRESELECT (&OPTIONAL Lst )
    (Who-Format-feature Lst 'Preselect 'subsetp))

;;; ----------------------------------------
;;; new KPML lexical feature who-cans...
;;; ----------------------------------------

(defun KPML-WHO-CAN-OUT-CLASSIFY (&OPTIONAL Lst )
    (Who-Format-feature Lst 'Outclassify 'subsetp))

(defun KPML-WHO-CAN-CLASSIFY-ANY (&OPTIONAL Lst )
  (Who-Format-feature lst 'Classify #'intersection-using-equal-test))

(defun KPML-WHO-CAN-CLASSIFY (&OPTIONAL Lst )
  (Who-Format-feature Lst 'Classify 'subsetp))

;;; ----------------------------------------
;;; Behaviour of this one is different, returns
;;; two values, explicit partitions in the
;;; grammar and those entailed by default order
;;; lists.
;;; ----------------------------------------

(defun KPML-WHO-CAN-PARTITION (&OPTIONAL One Other )
  (let ((local-list nil)
	(local-list2 nil))
    (setf one (if other (LIST One Other) (list One)))
    (values
     (loop for system in (relativize-to-language systems)
	 when (setq local-list 
		(loop for (feature x) 
		    in (get-system-output-field-features system 'partition)
		    when (setf local-list2
			   (loop for y in x
			       when (or (equal one '(nil))(subsetp one y))
			       collect y))
		    collect (cons feature local-list2)))
	 collect (cons system local-list))
     
     ;; KPML 0.8; multilingual default orderings...
     (loop for Order-List in (ml-default-orderings)
	 when (or (equal one '(nil)) (SUBSETP One Order-List))
	 collect (Cons 'Default-Sublist Order-List)))))

;;; ----------------------------------------------------------------------
;;; The remainder of the old functions can be kept for the time being
;;; since they do not need to provide so much information to be
;;; complete...
;;; ----------------------------------------------------------------------

;;; ----------------------------------------
;;; grammatical features: network connectivity
;;; ----------------------------------------

(defun WHO-HAS-AS-INPUT (input-feature)
  (fetch-exact-feature-def-field 'waiting input-feature))

(defun WHO-HAS-AS-OUTPUT (feature)
  (fetch-exact-feature-def-field 'chosen-by feature))


;;; ---------------------------------------
;;; systems: connectivity...
;;; ---------------------------------------

(defun WHO-CAN-CALL-DIRECTLY (&rest Lst)
  (loop for System in (Relativize-To-Language Systems)
      when (loop for x in (Get-System-Info System 'Calls)
	       thereis (member x  Lst))
      collect System))

;;; ----------------------------------------
;;; Grammatical functions
;;; ----------------------------------------

(DEFUN Who-Uses-Function (&OPTIONAL fn )
  (unless (Ml-Chooser-Db)
    (printwindow :display-pane "No Choosers analyzed." ))
  (let ((total nil)(refs nil)(ch nil))
    (dolist (chooser  (Ml-Chooser-Db))
      (setq ch (car chooser))
      (when (member fn (fetch-chooser-db-elt 'functions ch))
	(setq refs nil)
	(dolist (inq (fetch-chooser-db-elt 'asks ch))
	  (when (member fn inq)
	    (push `(asks ,inq) refs)))
	(dolist (inq (fetch-chooser-db-elt 'identifies ch))
	  (when (or (member fn  (cdr (second inq)))	;inputfunctions
		    (equal fn (first inq)))	;outputfunction
	    (push `(identify ,inq) refs)))
	(when (member fn  (fetch-chooser-db-elt 'pledges ch))
	  (push `(pledge ,fn) refs))
	(when refs (push (list ch refs)
			 total))))
    (sort total #'string-lessp :key #'car)))

;;; ----------------------------------------
;;; realizations: an overview function
;;;
;;; this old one could be quite useful if taken
;;; over and made interface accessible sometime.
;;; ----------------------------------------

(DEFUN Who-Can-Realize (&OPTIONAL Functions )
  (PROG (Who-Set)
	(when (SETQ Who-Set (Who-Can-Lexify Functions))
	  (printwindow :display-pane  "Lexify : " ) (pretty-print  who-set))
	(when (SETQ Who-Set (Who-Can-Classify Functions))
	  (printwindow :display-pane  "Classify : " ) (pretty-print  who-set))
	(when (SETQ Who-Set (Who-Can-Out-Classify Functions))
	  (printwindow :display-pane  "Out-Classify : " ) (pretty-print  who-set))
	(when (SETQ Who-Set (Who-Can-Preselect Functions))
	  (printwindow :display-pane  "Preselect : " ) (pretty-print  who-set))
	(when (SETQ Who-Set (Who-Can-Order Functions))
	  (printwindow :display-pane  "The Order Operator : " ) (pretty-print  who-set))
	(when (SETQ Who-Set (Who-Can-Partition Functions))
	  (printwindow :display-pane  "Partition : " ) (pretty-print  who-set))
	(when (SETQ Who-Set (Who-Can-Insert Functions))
	  (printwindow :display-pane  "Insert : " ) (pretty-print  who-set))
	(when (SETQ Who-Set (Who-Can-Expand Functions))
	  (printwindow :display-pane  "Expand : " ) (pretty-print  who-set))
	(when (SETQ Who-Set (Who-Can-Conflate Functions))
	  (printwindow :display-pane  "Conflate : " ) (pretty-print  who-set))
	(when (SETQ Who-Set (Who-Can-Pledge Functions))
	  (printwindow :display-pane  "Pledge : " ) (pretty-print  who-set))
	))

;;; ----------------------------------------
;;; choosers
;;; ----------------------------------------

(defun WHO-USES-CHOOSER (chooser)
  (let ((temp (loop for x 
		  in (relativize-to-language systems) 
		  when (equal chooser (fetch-system-chooser x)) 
		  collect x)))
    (printwindow :display-pane (format nil "~a" temp))
    temp))

;;; ----------------------------------------
;;; chooser operators
;;; ----------------------------------------

(defun who-can-choose (&optional fn)
  (chooser-operator-info 'choices fn))
(defun who-can-copy-hub (&optional fn)
  (chooser-operator-info 'copies fn))
(defun who-can-pledge (&optional  fn)
  (chooser-operator-info 'pledges fn))
(defun who-can-term-pledge (&optional fn)
  (chooser-operator-info 'termpledges fn))
(defun who-can-default-choose (&optional fn)
  (chooser-operator-info 'defaultchoose fn))

(defun CHOOSER-OPERATOR-INFO (operator-name &optional function-name)
  (let ((refs nil))
    (cond (function-name
	   (dolist (chooser-info (ml-chooser-db))
	     (dolist (operator-info (cdr chooser-info))
	       (when (equal operator-name (car operator-info))
		 (when (member function-name (cdr operator-info))
		   (push (car chooser-info) refs))))))
	  (t
	   (dolist (chooser-info (ml-chooser-db))
	     (dolist (operator-info (cdr chooser-info))
	       (when (equal operator-name (car operator-info))
		 (push (car chooser-info) refs))))))
    (sort (remove-duplicates refs) #'string-lessp)))

;;; ----------------------------------------
;;; Inquiries
;;; ----------------------------------------

;;; ----------------------------------------
;;; The following was the old Penman who-can-identify function, but
;;; this name is very misleading: here changed to something more
;;; transparent. Label also changed in interface accordingly and
;;; a function that does what who-can-identify sounds like (i.e.,
;;; to return those choosers where a given grammatical function
;;; is identified) is added.
;;; ----------------------------------------

(defun WHO-CAN-POSE-IDENTIFYING-INQUIRY  (&optional inquiry-name)
  (let((refs nil))
    (cond (inquiry-name
	   (dolist (chooser (ml-chooser-db))
	     (dolist (op (cdr chooser))
	       (when (equal (car op) 'identifies )
		 (dolist (x (cdr op))
		   (when (equal (car (second x)) inquiry-name)
		     (push (car chooser) refs))))))
	   (sort refs #'string-lessp ))
	  (t
	   (dolist (chooser (ml-chooser-db))
	     (dolist (op (cdr chooser))
	       (when (equal (car op) 'identifies )
		 (push (car chooser) refs))))
	   (sort (remove-duplicates refs) #'string-lessp)))))

(defun WHO-CAN-IDENTIFY (function-name)
  (let ((refs nil))
    (dolist (chooser (ml-chooser-db))
	    (dolist (op (cdr chooser))
		    (cond ((equal (car op) 'identifies)
			   (dolist (x (cdr op))
				   (when (equal (first x) function-name)
					 (pushnew (car chooser) refs))))
			  ((equal (car op) 'identified-by-copyhub)
			   (dolist (x (cdr op))
				   (when (equal x function-name)
					 (pushnew (car chooser) refs)))))))
    (sort refs #'string-lessp)))
			   
(defun WHO-CAN-ASK (&optional  inquiry-name)
  (let((refs nil))
    (cond (inquiry-name
	   (dolist (chooser (ml-chooser-db))
	     (dolist (op (cdr chooser))
	       (when (equal (car op) 'asks )
		 (dolist (x (cdr op))
		   (when (equal (car  x) inquiry-name)
		     (push (car chooser) refs))))))
	   (sort refs #'string-lessp ))
	  (t
	   (dolist (chooser (ml-chooser-db))
	     (dolist (op (cdr chooser))
	       (when (equal (car op) 'asks )
		 (push (car chooser) refs))))
	   (sort (remove-duplicates refs) #'string-lessp)))))

(defun WHO-CAN-INQUIRE (&optional inq)
  (sort (append 
	 (who-can-pose-identifying-inquiry inq) 
	 (who-can-ask inq)) 
	#'string-lessp))

;;; ----------------------------------------------------------------------
;;; Find an object by giving a substring, returns the list of objects found
;;; ----------------------------------------------------------------------

(defun FIND-ANYTHING-LIKE (substr)
  "Finds any symbol in package KPML which contains substring"
  (apropos-list substr (find-package "KPML")))

(defun FIND-SYSTEM-LIKE (substr)
  (sort (loop for sys in  (relativize-to-language systems)
	    when (search (string-downcase substr) 
			 (string-downcase (format nil "~a" sys)))
	    collect sys) 
	#'string-lessp))

(defun FIND-CHOOSER-LIKE (substr)
  (let ((result-list nil))
    (maphash #'(lambda (key val)
		 val
		 (when (search (string-downcase substr)
			       (string-downcase (format nil "~a" key)))
		   (push key result-list)))
	     choosers)
    result-list))

(defun FIND-INQUIRY-LIKE (substr)
  (let ((result-list nil))
    (maphash #'(lambda (key val)
		 val
		 (when (search (string-downcase substr)
			       (string-downcase (format nil "~a" key)))
		   (push key result-list)))
	     quiry-operators)
    result-list))

(defun FIND-GRAMMATICAL-FUNCTION-LIKE (substr)
  (if list-of-all-grammatical-functions
      (let ((result-list nil))	
	(dolist (func list-of-all-grammatical-functions)
	  (when (search (string-downcase substr)
			(string-downcase (format nil "~a" func)))
	    (push func result-list)))
	(sort result-list #'string-lessp))
    (printwindow 
     :display-pane 
     "Run analyze-choosers to generate list of all grammatical functions first"
     )))

(defun FIND-GRAMMATICAL-FEATURE-LIKE (substr)
  (let ((result-list nil))
    (maphash #'(lambda (key val)
		 val
		 (when (search (string-downcase substr)
			       (string-downcase (format nil "~a" key)))
		   (push key result-list)))
	     all-output-features)
    result-list))

;;; ----------------------------------------------------------------------
;;; Old who-can- functions from Penman are kept here for the time being...
;;; ----------------------------------------------------------------------

(defun WHO-CAN-INSERT (&optional lst)
  (Who-Format Lst 'inserts 'intersection-using-equal-test))

(defun WHO-CAN-CONFLATE (&optional Lst  )
    (Who-Format Lst 'Conflations 'subsetp))

(defun WHO-CAN-EXPAND (&optional Lst )
  (Who-Format Lst 'Expansions 'subsetp))

(defun WHO-CAN-LEXIFY (&optional Lst )
    (Who-Format Lst 'Lexifys 'subsetp))

(defun who-can-inflectify (&optional lst)
  (who-format lst 'inflectifys 'subsetp))

(defun WHO-CAN-ORDER (&optional Lst )
  (Who-Format Lst 'Orderings 'subsetp))

(defun WHO-CAN-PRESELECT (&OPTIONAL Lst )
    (Who-Format Lst 'Preselections 'subsetp))

(defun WHO-CAN-PARTITION (&OPTIONAL One Other )
  (if Other
      (SETQ One (LIST One Other))
    (SETQ One (list One)))
  (Nconc (loop for System in (Relativize-To-Language Systems) 
	     with t0
	     when (loop for P 
		      in (SETQ t0 (Get-System-Output-Fields System 'Partition))
		      thereis (or (equal one '(nil)) (SUBSETP One P)))
	     collect (Cons System t0))
;;; KPML 0.8; multilingual default orderings...
	 (loop for Order-List in (ml-default-orderings)
	     when (or (equal one '(nil)) (SUBSETP One Order-List))
	     collect (Cons 'Default-Sublist Order-List))))

;;; ----------------------------------------
;;; old Penman lexical feature who-cans...
;;; ----------------------------------------

(DEFUN Who-Can-Out-Classify (&OPTIONAL Lst )
    (Who-Format Lst 'Out-Classifys 'subsetp))

(DEFUN Who-Can-Classify-Any (&OPTIONAL Lst )
    (Who-Format Lst 'Classifys (function intersection-using-equal-test)))

(DEFUN What-Systems-Can-Classify (FUNCTIONNE)
  (remove-Duplicates 
   (loop for Pair 
       in (Who-Can-Classify FUNCTIONNE) collect (car pair))
   :test #'equal))

(DEFUN Who-Can-Classify (&OPTIONAL Lst )
    (Who-Format Lst 'Classifys 'subsetp))

