(in-package "KPML")

;;; File: pretty-printing.lisp
;;; John:IPSI:Apr95

;;; The lowest level pretty printing functions for all systemic objects are
;;; collected here. These are used internally in systemic generic
;;; display.
;;; 
;;; Patches:
;;;   0.8.15 adds in unconditionalized resource writing.
;;;   0.9    adds in the ability to shadow slots
;;;   4.0    XML branch added in for lexicons


(declaim (special *file-writing*))

(defvar *no-ml-conditionalization* nil)
(defvar *shadowed-slots* '(:patch-status))

(defun FORMAT-LINGUISTIC-OBJECT-LIST (list languages ml-mode)
  (declare (special *xml-output-style-active*))
  (with-output-to-string 
    (stream)
    (let ((*standard-output* stream)
	  (cl:*print-right-margin* *tty-right-margin*))
      ;;
      ;; 4.0 XML branch here...
      ;;
      (if *xml-output-style-active*
	  (print-xml-linguistic-object list languages ml-mode)
	(pprint-linguistic-object-in-list-form list languages ml-mode)))))


;;; Following interprets those list-versions of object definitions
;;; and uses the CLtL2 pretty printing facilities...
;;; Takes over pretty printing of all objects. Exceptions / special
;;; cases are handled slotwise. E.g.  Inquiry
;;; definitions have two complications, (i) the operatorcode
;;; should be allocatable to specified Lisp packages, (ii)
;;; preselection guidance is an unwieldy structure... Both
;;; are unravelled below.

;;; (Note that an alternative is provided for PC-ACL3.0 and
;;; other nonconformant lisps in nonansi-pretty)
#-(or lispworks4.0 acl3.0)
(defun PPRINT-LINGUISTIC-OBJECT-IN-LIST-FORM 
  (list language-set multilingual-mode)
  (declare (ignore language-set))
  (cl:pprint-logical-block 
   (nil list :prefix "(" :suffix ")")
   (let ((object-type (cl:pprint-pop))
	 (slot-type nil)
	 (slot-value nil)
	 (lg-restrictions (extract-lg-restrictions list)))
     (cl:pprint-indent :block 4)
     (cl:write object-type) ;; type of object
     (cl:pprint-newline :mandatory)
     (loop (cl:pprint-exit-if-list-exhausted)
	   (setf slot-type (cl:pprint-pop))
	   (setf slot-value (cl:pprint-pop))
	   (unless (or (null slot-value)
		       (and (stringp slot-value)(string= slot-value ""))
		       (equal slot-type :source-file)
		       (member slot-type *shadowed-slots*))

	     (cl:write slot-type)
	     (cl:pprint-tab :section 24 8)
	     
	     (case slot-type
	       (:name
		(if *no-ml-conditionalization*
		    (cl::write (first (last slot-value)))
		  (cl::write slot-value)))
	       (:preselectionguidance 
		(pprint-preselection-guidance slot-value))
	       ((:gloss :english)
		(pprint-inquiry-gloss slot-value))
	       (:logicalform
		(cl:pprint-newline :mandatory)
		(pprint-spl-logical-form slot-value))
	       (:semantics
		(pprint-lexical-item-semantics slot-value))
	       (:operatorcode
		(if *file-writing*
		    (pprint-operatorcode
		     (if *no-ml-conditionalization* nil
		       multilingual-mode)
		     slot-value lg-restrictions)
		  (cl:write slot-value)))
	       (otherwise
		(cl:write slot-value)))
       (cl:pprint-newline :mandatory))))))

(defun PPRINT-PRESELECTION-GUIDANCE (guidances)
  (let ((guidance nil))
    (cl:pprint-logical-block 
     (nil guidances :prefix "(" :suffix ")")
     (loop (cl:pprint-exit-if-list-exhausted)
	   (setf guidance (cl:pprint-pop))
	   (typecase guidance
		     (symbol (cl:write guidance))
		     (preselection-guide
		      (cl:write 
		       (if *file-writing*
			   (cons
			    (preselection-guide-selection guidance)
			    (preselection-guide-answer guidance))
			 (list (preselection-guide-selection guidance)
			       (preselection-guide-answer guidance))))))
	   (cl:pprint-newline :mandatory)))))

  ;; ----------------------------------------------------------------------
  ;;  The following was spacing out and formatting comments nicely, but
  ;;  this is no good if we are writing to a file to be read in at some
  ;;  later stage! Conditionalize. 
  ;;  Note also that need to be explict that only one gloss is allowed.
  ;;  This is not good, already there are more than one in the Czech glosses.
  ;; ----------------------------------------------------------------------

(defun PPRINT-INQUIRY-GLOSS (inquiry-gloss)
  (let ((element nil))
    (cl:pprint-logical-block
     (nil inquiry-gloss :prefix "(" :suffix ")")
     (loop (cl:pprint-exit-if-list-exhausted)
	   (setf element (cl:pprint-pop))
	   (write-char #\space)
	   (typecase element
		     (symbol 
		      (cl:write element)
		      (cl:pprint-newline :fill))
		     (string
		      (if *file-writing*
			  (format t "~S" element)
			(cl:pprint-logical-block
			 (nil (justify-string (- *tty-right-margin* 24) element))
			 (loop (cl:pprint-exit-if-list-exhausted)
			       (cl:write (cl:pprint-pop))
			       (cl:pprint-newline :fill))))))))))


(defun PPRINT-LEXICAL-ITEM-SEMANTICS (concept-list)
  (cl:write
   (mapcar #'(lambda (element)
	       (cond ((or (lg-designator-p element)
			  (equal element '&))
		      element)
		     (t
		      (kb-getconceptname element))))
	   concept-list)))


(defun PPRINT-SPL-LOGICAL-FORM (lf)
  (let ((element nil))
    (cl:pprint-logical-block
     (nil lf :prefix "(" :suffix ")")
     (loop (cl:pprint-exit-if-list-exhausted)
	   (cl:pprint-indent :block 4)
	   (setf element (cl:pprint-pop))
	   (cond ((consp element) 
		  (pprint-spl-logical-form element))
		 ((keywordp element)
		  (cl:pprint-newline :mandatory)
		  (cl:write element))
		 (t
		  (cl:write element)))
	   (cl:write-char #\space)
	   (cl:pprint-newline :fill)))))


(defun PPRINT-OPERATORCODE (multilingual-mode slot-value lg-restrictions)
  (format *standard-output* "~A"
	  (if multilingual-mode
	      (in-ml-inquiry-packages slot-value lg-restrictions)
	    (in-inquiry-package slot-value))))

(defun EXTRACT-LG-RESTRICTIONS (list)
  (loop for element in list
	as next-element in (cdr list)
	when
	(eq element :name)
	do
	(return-from extract-lg-restrictions
		     (typecase next-element
			       (cons
				(remove-if #'(lambda (x)
					       (not (keywordp x)))
					   next-element))
			       (symbol next-element)))))



(defun PPRINT-CONSTITUENT-STRUCTURE-AS-LIST (constit &optional (indent 0))
  (fresh-line)
  (format t "~VT[~{~S~^/~}]" indent (first constit))
  (cond ((stringp (second constit))
	 (format t "~40,0T = ~S"  (second constit))
	 (fresh-line))
	(t
	 (loop for sub in (cdr constit) do
		(setf indent (+ indent 4))
		(pprint-constituent-structure-as-list sub indent)
		(setf indent (- indent 4))
		(fresh-line)))))



;;; ----------------------------------------------------------------------
;;; 2.0.34 width of realization boxes made flexible and controllable...
;;; 2.0.40 agreement message improvements included...
;;; 2.0.52 more of the same.
;;;
;;; Minor extension to use these in the graphing code for system networks,
;;; since logical printing blocks don't know how wide they are in the
;;; environment of the grapher...
;;; ----------------------------------------------------------------------

(defun INDENT-LIST-OF-STRINGS 
    (indentation list-of-strings 
     ;; 2.0.34
     &key (except-first-p nil)
	  ;; 2.1
	  (indent-string nil))
  (let ((used-indent-string
	 (if indent-string 
	     indent-string
	   (make-string 
	    indentation :initial-element #\Space))))
    (cons
     (if except-first-p 
	 (first list-of-strings)
       (concatenate 'string used-indent-string (first list-of-strings)))
     (loop for string in (cdr list-of-strings)
	 collect (concatenate 'string used-indent-string string)))))

;;; ----------------------------------------------------------------------
;;; 0.9.37 this was an old bug!... parameter list was illformed.
;;; 2.0.34, 2.1 extended.
;;; ----------------------------------------------------------------------

(defun INDENT-AND-FILL
    (list-of-strings  &key  (left-margin 0) (right-margin 55)
			    (right-margin-p nil)
			    ;; 2.0.34
			    (except-first-p nil)
			    ;; 2.1
			    (indent-string nil)
			    )
  (unless right-margin-p
    (if window-interface-flag
	(setq right-margin *window-right-margin*)
	(setq right-margin *tty-right-margin*)))
  (let ((input-string ""))
    (if (stringp list-of-strings)
	(setq input-string list-of-strings)
	(dolist (x list-of-strings)
	  (setq input-string (concatenate 'string input-string x))))
    (indent-list-of-strings 
     left-margin 
     (justify-string (- right-margin left-margin) input-string)
     :except-first-p except-first-p
     :indent-string indent-string)))

;;; ----------------------------------------------------------------------
;;; These remaining very old Penman pretty printing routines are still used in
;;; miscellaneous bits of code scattered around...
;;; ----------------------------------------------------------------------

(defun pretty-with-header (object header &key  (right-margin 55) (left-margin 0))
  (let* ((list-of-strings (pretty object :right-margin right-margin  :left-margin (+ (length header) left-margin)))
	 (top-string (pop list-of-strings)))
    (setf (subseq top-string   0 (+ (length header) left-margin)) header)
    (push top-string list-of-strings)
    list-of-strings))

(defun pretty (object &key (right-margin 55 right-margin-p) (left-margin 0))
  (unless right-margin-p
    (if window-interface-flag
      (setq right-margin *window-right-margin*)
      (setq right-margin *tty-right-margin*)))
  (let* ((old-pp-line-length *print-length*)
         (*print-length* (- right-margin left-margin))
         (string-list nil)
         (output-string-list nil)
         (indent-string (make-string left-margin :initial-element #\space))
         (item nil))
    (with-input-from-string (s (string (with-output-to-string (x) 
                                         (pprint object x))))
      (loop
       (setq item (read-line s nil :eof))
       (if (equal item :eof)
         (return )
         (push item string-list))))
    (dolist (x string-list)  ;add in the left margin
      (push (format nil "~a~a" indent-string x) output-string-list))
    (setq *print-length* old-pp-line-length)
    output-string-list))

(defun get-next-word ( input-string)
  "Returns the first word in input-string, leading blanks are part of a word, trailing blanks are ignored."
  (when (or (not input-string)
	    (equal input-string ""))
    (return-from get-next-word (values nil nil)))	        ;if empty or nil return nil
  (let ((first-non-blank (search " " input-string :test-not #'equal)))
    (unless first-non-blank
      (return-from get-next-word  (values nil nil)))	;if all blanks return nil
    (let* ((leading-white-space (subseq input-string 0 first-non-blank))
	   (string-without-leading-blanks (subseq input-string first-non-blank))
	   (next-blank-or-end (or (search " " string-without-leading-blanks )
				  (length string-without-leading-blanks )))
	   (rest-of-string (subseq string-without-leading-blanks next-blank-or-end))
	   (first-word (concatenate 'string
				    leading-white-space 
				    (subseq string-without-leading-blanks 0 next-blank-or-end ))))
      (when (equal rest-of-string "")
	(setq rest-of-string nil))
      (return-from get-next-word  (values first-word rest-of-string)))))




