(in-package "KPML")

;;; File: generic-systemic-display.lisp
;;; KPML 0.8; John: IPSI: March 1995
;;;
;;; ----------------------------------------------------------------------
;;; This file contains updated general displaying of all the linguistic
;;; objects maintained within KPML. It replaces all previous Penman
;;; functions for such purposes with a uniformly implemented and applicable
;;; set of functions. (It now also relies on CLtL2 pretty printing
;;; capabilities as defined in pretty-printing.lisp.)
;;;
;;; The old Penman functions (print-system, print-chooser, etc.) are
;;; redefined to use new generic functions. The KPML options for
;;; various multilingual modes of displaying (i.e., monolingual,
;;; contrastive and multilingual) are built in as inherent
;;; components. This means that these definitions require at the very
;;; least the multilingual stubbs if KPML is not being used (i.e., the
;;; definitions for curlan, all_languages, and the ml functions). Note
;;; that this involves substantial rearrangment of the previous
;;; display functions, which had become distributed over different
;;; parts of the system and involved partial triplication of
;;; functionality; once this file has been loaded, none of the old
;;; functions are necessary (and they have hence been removed from
;;; KPML sources).  
;;; 
;;; Due to the occasionally dynamic construction of linguistic objects
;;; by selecting and merging resources for different languages (and
;;; these objects may not have any real independent existence), they
;;; are constructed as lists of slot-value pairs. These are then
;;; pretty printed. The low level pretty printing defined for all
;;; systemic objects in pretty-printing.lisp incorporates both.
;;;
;;; BEWARE: !!!!
;;; Finally, code below is
;;; still using 2 functions from display/pretty.lisp: justify-string
;;; print-chooser-to-string-list. THESE HAVE BEEN COPIED BELOW.
;;; 1.1 print-inquiry-to-window also lives there now.
;;; ----------------------------------------------------------------------
(defvar *ml-display-mode* :monolingual "the multilingual display options")
(defvar *kpml-emit-writing-points* NIL)
(defvar *displaying-patched-object* nil 
  "set T during the display of a patched object, can be used by the interface")

;;; ----------------------------------------------------------------------
;;; The main function is the following, which provides a single point
;;; of access for all display functionality. Only this function should
;;; be called when some form of a linguistic object is to be displayed
;;; on the screen, in some file, or in the window interface. It relies
;;; on the Common Lisp pretty printing.
;;;
;;; 4.0 add an output mode parameter for triggering XML...
;;;
(defun SYSTEMIC-DISPLAY (object &key 
				(object-type nil)
				(stream T)
				(display-mode *ml-display-mode*)
				(presentation-handler nil)
				(languages nil)
				(mode *object-output-mode*))
  ;;; establish default behavior...
  ;;;  stream: default(T)  - prints to the Lisp listener
  ;;;          :interface  - display on the window interface (if
  ;;;                        present, else to the Lisp listener)
  ;;;          nil         - display as strings
  ;;;          some stream - outputs to that stream
  ;;;  object-type: nil, guess the type of object (system, chooser,
  ;;;          inquiry, lexical-item, example)
  ;;;  languages: nil - in :monolingual mode, curlan
  ;;;                   otherwise, all_languages
  ;;;
  (unless object-type (setf object-type (guess-object-type object)))
  (unless object-type (return-from SYSTEMIC-DISPLAY nil))
  (when (eq display-mode :monolingual)(setf display-mode nil))
  (unless languages (setf languages 
			  (if display-mode 
			      (if *languages-in-focus*
				  *languages-in-focus*
				all_languages)
			    curlan)))
  (when (and (eq object-type :chooser)
	     (not (member object (list-choosers)))
	     (member object (list-systems)))
	(setf object (fetch-system-chooser object)))		  
  (unless (systemic-object-exists-p object object-type)
	  (return-from SYSTEMIC-DISPLAY nil))

  (when (and display-mode
	     (symbolp languages))
	(warning "Multilingual systemic display attempted for "
		 "the single language " languages)
	(setf languages (list languages)))
  
  (let ((defs-to-display (create-list-representations-of-object
			  object object-type languages display-mode))
	(*print-pretty* T))

    ;; 4.0 XML/ASCII mode parameter passed on here for stream and NIL...,
    ;;     i.e., has to be handled by the stream-display function
    ;;
    (cond ((streamp stream)
	   (stream-display stream defs-to-display languages display-mode mode))
	  ((null stream)
	   (stream-display NIL defs-to-display languages display-mode mode))
	  ((eq stream :interface)
	   (interface-display 
	    defs-to-display languages display-mode presentation-handler
	    object object-type))
	  (T
	   (tty-display defs-to-display languages display-mode)))))
	   


;;; ----------------------------------------------------------------------
;;; And something very similar for lists of objects plus a 
;;; conditionalization test...
;;;
;;; 4.0 add an output mode parameter for triggering XML...

(defun SYSTEMIC-DISPLAY-ITEMS (objects &key 
				      (object-type nil)
				      (stream T)
				      (display-mode *ml-display-mode*)
				      (presentation-handler nil)
				      (languages nil)
				      (test #'identity)
				      (sort T)
				      (mode *object-output-mode*))
  (let ((selected-objects 
	 (loop for object in objects
	       when (apply test (list object))
	       collect object)))

    (loop for object in (if sort (sort selected-objects #'string<)
			  selected-objects)
	  do
	  (when *kpml-emit-writing-points* (format *trace-output* "."))
	  (systemic-display object 
			    :object-type object-type
			    :stream stream
			    :display-mode display-mode
			    :presentation-handler presentation-handler
			    :languages languages
			    :mode mode))))

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

(defun GUESS-OBJECT-TYPE (object &optional &key (no-warning-p nil))
  (cond ((gethash object system-table)    :system)
	((gethash object choosers)        :chooser)
	((gethash object quiry-operators) :inquiry)
	((gethash object lexicon)         :lexeme)
	((gethash object penexamples)     :example)
	(t
	 (unless no-warning-p
		 (warning "Information requested for object " object 
			  " which is undefined.")))))


;;; Following function checks to see if the object exists as a
;;; systemic object of specified object-type. If no object-type
;;; is specified, sees if any object of the given name exists
;;; as any type of systemic object.
;;;
(defun SYSTEMIC-OBJECT-EXISTS-P (object &optional (object-type nil))
  (unless object-type 
	  (setf object-type (guess-object-type object :no-warning-p T)))

  (let ((exists?
	 (case object-type
	       (:system (gethash object system-table))
	       (:chooser (gethash object choosers))
	       (:inquiry (gethash object quiry-operators))
	       (:lexeme (gethash object lexicon))
	       (:example (gethash object penexamples))
	       (otherwise nil))))

    (unless exists?
	    (warning "There is no object " object " of type " object-type))

    exists?))


;;; ----------------------------------------------------------------------
;;; The following three functions are just copies of each other
;;; with the function call to display changed appropriately.

;;; ... but first make sure that the function for printing things
;;; to the terminal is there and stays there...

(unless (fboundp 'tty-printwindow)
	(setf (symbol-function 'tty-printwindow) #'printwindow)
	)


(defun TTY-DISPLAY (defs-to-display languages ml-mode)
  (cond ((eq (length defs-to-display) 1)
	 (tty-printwindow :display-pane
			   (format-linguistic-object-list
			    (first defs-to-display)
			    languages ml-mode)))
	(t
	 (loop for def in defs-to-display
	       as lg in languages
	       do
	       (tty-printwindow :display-pane
				 (format nil "Language: ~A" lg))
	       (tty-printwindow :display-pane 
				 (format-linguistic-object-list 
				  def languages ml-mode))))))


(defun INTERFACE-DISPLAY 
  (defs-to-display languages ml-mode presentation-handler object object-type)
  (let ((*tty-right-margin* *window-right-margin*)
	(old-slot-shadows *shadowed-slots*))
    (push :structure *shadowed-slots*)      ;; never want this in interface
    (cond ((eq (length defs-to-display) 1)
	   (setf *displaying-patched-object* 
	     (object-patch-status object object-type languages))
	   (apply presentation-handler 
		  (list (format-linguistic-object-list 
			 (first defs-to-display)
			 languages ml-mode)
			object-type))
	   (setf *displaying-patched-object* nil))
	  (t
	   (loop for def in defs-to-display
	       as lg in languages
	       do
		 (apply presentation-handler 
		      (list (concatenate 'string  "Language: " (string lg))
			    :string))
	       (setf *displaying-patched-object*
		 (object-patch-status object object-type (list lg)))
	       (apply presentation-handler
		      (list
		       (format-linguistic-object-list 
			def languages ml-mode)
		       object-type))
		 (setf *displaying-patched-object* nil))))
    (setf *shadowed-slots* old-slot-shadows)))


;; 4.0 output-mode added for XML/ASCII, but binds a mode special boolean flag
;;     for passing on to subsequent functions... 
;;
(defun STREAM-DISPLAY 
  (stream defs-to-display languages ml-mode 
	  &optional (output-mode *object-output-mode*))
  (let ((*xml-output-style-active* (equal output-mode :xml)))
    (declare (special *xml-output-style-active*))
    (cond ((eq (length defs-to-display) 1)
	   (format stream "~2%~A"
		   (format-linguistic-object-list 
		    (first defs-to-display)
		    languages ml-mode)))
	  (t
	   (loop for def in defs-to-display
		 as lg in languages
		 do
		 (format stream "~%;;; Language: ~S" lg)
		 (format stream "~%~A"
			 (format-linguistic-object-list 
			  def languages ml-mode)))))))


;;; Support function that creates a list of list representations of
;;; linguistic objects appropriate for the setting of the
;;; mode parameter. Only the :multilingual option is interesting,
;;; as it creates a multilingual instance on the fly consisting
;;; of the merge only of the languages that are being considered.
;;; Only for internal use.  
;;;
(defun CREATE-LIST-REPRESENTATIONS-OF-OBJECT 
  (object object-type languages mode)
  (case mode
	(:multilingual 
	 (cond ((set-equal languages all_languages) 
;; if all languages are requested, can simply return the object...
		(list (generic-object-to-list-multi-to-multi 
		       object object-type)))
	       (t
		(let* ((lg-instance-pairs
			(create-set-of-mono-lingual-instances 
			 object object-type))
		       (selected-pairs
			(loop for pair in lg-instance-pairs
			      when (member (first pair) languages)
			      collect pair)))
		  (list 
		   (generic-instance-to-list-multi-to-multi
		    (generic-merge-object selected-pairs object-type)
		    object-type))))))
	(:contrastive  
	 (loop for lg in languages collect 
	       (generic-object-to-list-multi-to-mono 
		object object-type lg)))
	(otherwise ;; monolingual...
	 (when (consp languages)
	       (warning 
		"Systemic display attempted monolingually for the "
		"list of languages " languages ": taking the first.")
	       (setf languages (first languages)))
	 (list
	  (generic-object-to-list-multi-to-mono 
	   object object-type languages)))))






;;; ----------------------------------------------------------------------
;;; Following functions simply provide generic function calls for
;;; the different merging and processing functions required for
;;; the different kinds of linguistic objects.

(defun GENERIC-MERGE-OBJECT (lg-instance-pairs object-type)
  (case object-type
	(:system (apply #'merge-system-instances (list lg-instance-pairs)))
	(:chooser (apply #'merge-chooser-instances (list lg-instance-pairs)))
	(:inquiry (apply #'merge-inquiry-instances (list lg-instance-pairs)))
	(:lexeme (apply #'merge-lexeme-instances (list lg-instance-pairs)))
	(:example (apply #'merge-example-instances (list lg-instance-pairs)))))


(defun GENERIC-OBJECT-TO-LIST-MULTI-TO-MONO (object object-type language)
  (case object-type
	(:system (system-to-list-multi-to-mono object language))
	(:chooser (chooser-to-list-multi-to-mono object language))
	(:inquiry (inquiry-to-list-multi-to-mono object language))
	(:lexeme (lexeme-to-list-multi-to-mono object language))
	(:example (example-to-list-multi-to-mono object language))))


(defun GENERIC-OBJECT-TO-LIST-MULTI-TO-MULTI (object object-type)
  (case object-type
	(:system (system-to-list-multi-to-multi object))
	(:chooser (chooser-to-list-multi-to-multi object))
	(:inquiry (inquiry-to-list-multi-to-multi object))
	(:lexeme (lexeme-to-list-multi-to-multi object))
	(:example (example-to-list-multi-to-multi object))))

(defun GENERIC-INSTANCE-TO-LIST-MULTI-TO-MULTI (object object-type)
  (case object-type
	(:system (system-instance-to-list-multi-to-multi object))
	(:chooser (chooser-instance-to-list-multi-to-multi object))
	(:inquiry (inquiry-instance-to-list-multi-to-multi object))
	(:lexeme (lexeme-instance-to-list-multi-to-multi object))
	(:example (example-instance-to-list-multi-to-multi object))))


;;; ----------------------------------------------------------------------
;;; And now the redefinitions of the Penman functions...
;;;

(defun PRINT-SYSTEM (name)
  (systemic-display name :object-type :system)
  (if (gethash name system-table)
      (unless (system-defined-for-lg-p name curlan)
	(warning "The system " name " is not defined for the language variety: " curlan)))
  t)


;;;
;;; what to do about informal versions of the inquiry?!?!?!
;;; (for present, use the old code...)

(defun PRINT-CHOOSER (&optional name (formal-flag :formal))
  "Prints the named chooser or if given a system name prints the chooser.  Options are :formal(default) :informal :both"
  (cond ((eq formal-flag :informal)
	 (printwindow :display-pane " ")
	 (printwindow :display-pane 
		      (print-chooser-to-string-list name formal-flag 120)))
	(t
	 (systemic-display name :object-type :chooser)))
  (let ((actual-name 
	  (cond ((loop for system in systems 
		       when (eq name (car system))
			 do (return t)
		     finally #-lispworks (return nil)  ;; 4.0+
			     #+lispworks (progn nil))
		 (fetch-system-chooser name))
		(t  name))))
    (unless (member curlan (fetch-chooser-info actual-name 'ls-set))
      (warning "The chooser " actual-name " is not defined for the language variety: " curlan)))
  t)

(defun PRINT-INQUIRY (name)
  (systemic-display name :object-type :inquiry)
  (unless (member curlan (fetch-inquiry-info name 'ls-set))
	  (warning "The inquiry " name " is not defined for the language variety: " curlan))
  t)


;;; ... and some others since they are now going for free...

(defun PRINT-LEXEME (name)
  (systemic-display name :object-type :lexeme))

(defun PRINT-EXAMPLE (name)
  (systemic-display name :object-type :example))

;;; ... one extra useful option is to print the full example record
;;; structure, with all selection expressions, kb- and tp-environments
;;; etc. This only makes sense to a file for the express purpose of
;;; reading it in again. Noone would want to see this information 
;;; displayed in its raw form, so it does not need to look so pretty.
;;; The following is taken from the old Penman object-description.lisp
;;; file and adjusted to our current needs. Note that these
;;; full example record printing are NOT multilingual.

(defun PRINT-FULL-EXAMPLE-RECORD (example-name stream)
  (let ((example-structure (gethash example-name penexamples)))
    (format stream "~%(example")
    (format stream "~% :name (~s ~s)" curlan example-name)
    (format stream "~% :targetform ~S" 
	    (fetch-example-info example-name 'targetform))
    (format stream "~% :logicalform  ")
    (pprint (fetch-example-info example-name 'logicalform) stream)
    (format stream "~%:rootnode ")
    (pprint (example-rootnode example-structure) stream)
    (format stream "~%:verbalizationgraph ")
    (pprint (example-verbalizationgraph example-structure ) stream )
    (format stream "~%:quantificationgraph ")
    (pprint (example-quantificationgraph example-structure ) stream )
    (format stream "~%:paragraph-theme ")
    (pprint (example-paragraph-theme example-structure ) stream )
    (format stream "~%:focus ")
    (pprint (example-focus example-structure ) stream )
    (format stream "~%:includedhubs ")
    (pprint (example-includedhubs example-structure ) stream )
    (format stream "~%:selectionexpressions ")
    (pprint (example-selectionexpressions example-structure ) stream )
    (format stream "~%:comments \"~a\"" (example-comments example-structure ))
    (format stream "~%:editor \"~a\"" (example-editor example-structure ))
    (format stream "~%:date \"~a\"" (example-date example-structure ))
    (format stream "~%:Structure ")
    (pprint (fetch-example-info example-name 'structure) stream)
    (format stream "~%:KBenvironment ")
    (pprint (example-kbenvironment example-structure) stream )
    (format stream "~%:TPenvironment "  )
    (pprint (example-tpenvironment example-structure) stream )
    (format stream "~%:discoursecontext ")
    (print-dc (example-discoursecontext example-structure) stream)
    (format stream ")~%")))

;; 3.2.37

(defun PPRINT-EXAMPLE-STRUCTURES (ex &optional (stream T))
  (let ((results (fetch-example-info ex 'structure)))
    (if results
	(if (consp results)
	    (loop for r in results
		  do (pprint-mouseable-structure r :stream stream))
	  (pprint-mouseable-structure results :stream stream)))))

;; 4.0  make this one into a method as it is conceivable that different
;;      languages might want to do it differently...

(defmethod PPRINT-INTERLINEAR (ex stream mode lg)
  (let ((results (fetch-example-info ex 'structure)))
    (if results
	(if (consp results)
	    (loop for r in results
		  do (format stream "~%~S"
			     (make-constituent-list-with-interlinears r)))
	  (format stream "~%~S"
		  (make-constituent-list-with-interlinears results))))))

;; and a version for HTML...

(defmethod PPRINT-INTERLINEAR (ex stream (mode (eql :html)) curlan)
  (let ((results (fetch-example-info ex 'structure)))
    (macrolet
     ((AS-TABLE (&body body)
		`(progn (format stream "~%<TABLE BORDER>") ,@body (format stream "~%</TABLE>")))
      (ELEMENT (&body body)
	       `(progn (format stream "~%<TD>") ,@body (format stream "~%</TD>")))
      (SMALLER (&body body)
	 `(progn (format stream "<FONT SIZE=-2>")
		 ,@body
		 (format stream "</FONT>")))
      (ROW (&body body)
	   `(progn (format stream "~%<TR VALIGN=TOP>") ,@body (format stream "~%</TR>"))))
     (labels 
      ((print-one-table 
	(x)
	(let ((f (flatten-till (make-constituent-list-with-interlinears x :terminal) :terminal))
	      (g (kpml::fetch-example-info ex 'kpml::gloss)))
	  (as-table ()
	    (row ()
		 (loop for x in (mapcar #'second f)
		       do (element () 
			   (format stream "~A" (if x x "--")))))   ;; row 1 - original
	    (row ()
		 (loop for x in (mapcar #'fourth f)
		       do (element () (format stream "~A" (if x x "--")))))   ;; row 3 - translit
	    (row ()
		 (loop for x in (mapcar #'third f)
		       do (element () 
				   (format stream "<em>~A</em>" 
					   (if x x "--")))))   ;; row 2 - gloss
	    )
	  (when g (smaller (format stream "<BR>~%<em>~A</em>" g)))
	  )))
      (if results
	  (if (consp results)
	      (loop for r in results do (print-one-table r))
	    (print-one-table results)))))))

;;; ----------------------------------------------------------------------
;;; Generic function for ascertaining patch status...

(defun OBJECT-PATCH-STATUS (object object-type lgs)
  (when (symbolp lgs) (setf lgs (list lgs)))
  (case object-type
    (:system (loop for l in lgs 
		 thereis (fetch-system-patch-status object l)))
    (:chooser (loop for l in lgs
		  thereis (fetch-chooser-info object 'patch-status l)))
    (:inquiry (loop for l in lgs
		  thereis (fetch-inquiry-info object 'patch-status l)))
    (otherwise nil)))

;;; ----------------------------------------------------------------------
;;; Old Penman functions for informal choosers...

(defun justify-string (line-length input-string)
  "Breaks input string into a list of strings not more than line-length where no word boundries are broken"
  (let ((next-word nil)
	(rest-of-string (string input-string))
	(current-line nil)
	(list-of-lines nil)
	)
    (loop
      (cond (rest-of-string
	     (multiple-value-setq (next-word rest-of-string) (get-next-word rest-of-string))
	     (cond ((< (+ (length current-line) (length next-word) 1) line-length)
		    #|(if (and current-line next-word)
			(setq current-line (concatenate 'string current-line " " next-word))
			(setq current-line (concatenate 'string current-line  next-word))))|#
		    (setq current-line (concatenate 'string current-line  next-word)))
		   (t(when current-line (push current-line list-of-lines))
		     (setq current-line (string-left-trim " " next-word)))))
	    (t (push current-line list-of-lines)
	       (return (reverse list-of-lines)))))))


(defun PRINT-CHOOSER-TO-STRING-LIST  
       (&OPTIONAL (Name message-sender) 
		  (Formal-Flag :formal) (line-length 55 line-length-p))
  ""
  (unless line-length-p
    (if window-interface-flag
	(setq line-length *window-right-margin*)
	(setq line-length *tty-right-margin*)))
  (prog (Chooser-Name Chooser-Definition string-for-scroll-window 
		      chooser-instance system-name)
	(cond (name
	       (cond((loop for system in systems 
			   when (eq  name (car system))
			     do (return t)
			 finally #+lispworks (progn nil)
				 #-lispworks (return nil))
		     (setq system-name name)
		     (setq chooser-name (fetch-system-chooser system-name)))
		    (t
		     (setq system-name nil)
		     (setq chooser-name name)))
	       (setq chooser-instance (gethash chooser-name choosers))
	       (setq chooser-definition 
		     (if chooser-instance (fetch-chooser-info chooser-name 'definition)
		       nil))
	       (cond 
		(chooser-Definition
		 (when system-name
		       (push (format nil "has chooser ~a."  chooser-name )  
			     string-for-scroll-window)
		       (push (format nil "The system ~a" name  )  
			     string-for-scroll-window)
		       (push " "   string-for-scroll-window))
		 (setq  string-for-scroll-window
			(append  string-for-scroll-window 
				 (list " " 
				       (format nil "The Chooser ~a is:" chooser-Name))))
		 (cond ((equal Formal-Flag :both)
			(setq string-for-scroll-window
			      (append  string-for-scroll-window
				       (pretty-with-header   
					Chooser-Definition "Formal: " 
					:right-margin line-length )))
			(setq string-for-scroll-window
			      (append string-for-scroll-window 
				      (pretty-with-header
				       (ask-identify-fix (copy-tree Chooser-Definition))
				       "Informal: " :right-margin line-length ))))
		       ((equal formal-flag :formal) 
			(setq string-for-scroll-window
			      (append  string-for-scroll-window
				       (pretty-with-header
					Chooser-Definition "Formal: " 
					:right-margin line-length ))))
		       (t 
			(setq string-for-scroll-window
			      (append string-for-scroll-window
				      (pretty-with-header
				       (ask-identify-fix (copy-tree Chooser-Definition))
				       "Informal: " :right-margin line-length ))))))
		(chooser-instance
		 (push (format nil "The chooser ~a exists but has no definition." Chooser-Name) string-for-scroll-window)
		 (return (values string-for-scroll-window)))
		((and system-name chooser-name)
		 (push (format nil "The system ~a says a chooser named ~a should exist but it does not."
			       system-name chooser-name)  string-for-scroll-window)
		 (return (values string-for-scroll-window)))
		(t (push (format nil "The chooser ~a does not exist" chooser-name)  string-for-scroll-window))))
	      (t (push (format nil "NIL given as a chooser name") string-for-scroll-window))) 
    (return (values  (justify-list-of-strings line-length string-for-scroll-window)))))

(DEFUN Print-Inquiry-To-Window (&OPTIONAL Inquiry Outer-Inquiry) 
  (let ((domain (fetch-inquiry-info (car inquiry) 'domain)))
    (when (or (not (boundp 'inquiry-domain-print-flag ))
	      (eq inquiry-domain-print-flag nil)
	      (eq inquiry-domain-print-flag 'all)
	      (eq inquiry-domain-print-flag domain))
      (cond (window-interface-flag 
	     (printwindow :inquiry-name-pane (car inquiry))
	     (printwindow :inquiry-question-pane  
			  (Make-English-Inquiry Inquiry Outer-Inquiry)))
	    (t
	     (printwindow
	       :display-pane
	       (indent-and-fill
		 (concatenate
		   'string
		   (format nil "~a: " (car inquiry))
		   (Make-English-Inquiry Inquiry Outer-Inquiry)) :left-margin 10)))))))
