(in-package "KPML")

;;; File: nonansi-pretty.lisp
;;; John, Edinburgh, 18 June 97.

;;; Allegro Common Lisp 3.0.2 and Harlequin Lispworks 4.0 (both for PCs) 
;;; do not support the
;;; ANSI-standard pretty printing. This provides a hack round
;;; this using the old Penman pretty printers... Following
;;; function should only be loaded when in ACL3.0.2 or Lispworks 4.0
;;; for the PC etc.

(defun NONANSI-PPRINT-LINGUISTIC-OBJECT-IN-LIST-FORM 
  (list language-set multilingual-mode)
  (declare (ignore language-set))
  (with-output-to-string (stream)
    (format stream "(")
    (let ((object-type (pop list))
	    (slot-type nil)
	    (slot-value nil)
	    (lg-restrictions (extract-lg-restrictions list)))
      (format stream "~S" object-type)
      (format stream "~%")
      (loop named L
	  while list
	  do (setf slot-type (pop list))
	     (setf slot-value (pop list))
	     (unless (or (null slot-value)
			 (and (stringp slot-value)(string= slot-value ""))
			 (equal slot-type :source-file)
			 (member slot-type *shadowed-slots*))
	  
	       (format stream "    ~S" slot-type)
	       (format stream "   ")
	       (case slot-type
		 (:name
		  (if *no-ml-conditionalization*
			(format stream "~S" (first (last slot-value)))
		      (format stream "~S" slot-value)))
		 (:preselectionguidance 
		  (format stream "~A"
			  (nonansi-pprint-preselection-guidance slot-value)))
		 ((:gloss :english)
		  (format stream "~A"
			  (nonansi-pprint-inquiry-gloss slot-value)))
		 (:logicalform
		  (format stream "~%~A"
			  (nonansi-pprint-spl-logical-form slot-value)))
		 (:semantics
		  (format stream "~A"
			  (nonansi-pprint-lexical-item-semantics slot-value)))
		 (:operatorcode
		  (if *file-writing*
		      (format stream "~A"
			      (nonansi-pprint-operatorcode
			       (if *no-ml-conditionalization* nil
				 multilingual-mode)
			       slot-value lg-restrictions))
		    (format stream "~S" slot-value)))
		 (otherwise
		  (format stream "~S" slot-value)))
	       (format stream "~%"))))
    (format stream ")")))

;;; ----------------------------------------------------------------------
;;; Support functions, hacked from their ansi counterparts...
;;; Important is that they all return strings and do not output
;;; anything directly to any stream.

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

(defun NONANSI-PPRINT-PRESELECTION-GUIDANCE (guidances)
  (let ((guidance nil))
    (with-output-to-string (stream)
      (format stream "(~%")
      (loop
	while guidances 
	  do
	    (setf guidance (pop guidances))
	    (typecase guidance
	      (symbol (format stream "~10T~S" guidance))
	      (preselection-guide
	       (format stream "~10T~S"
		       (if *file-writing*
			   (cons
			    (preselection-guide-selection guidance)
			    (preselection-guide-answer guidance))
			 (list (preselection-guide-selection guidance)
			       (preselection-guide-answer guidance))))))
	    (format stream "~%"))
      (format stream "~10T)"))))

  ;; ----------------------------------------------------------------------
  ;;  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 NONANSI-PPRINT-INQUIRY-GLOSS (inquiry-gloss)
  (let ((element nil))
    (with-output-to-string (stream)
      (format stream "(~%")
      (loop named L
	  while inquiry-gloss
	  do
	    (setf element (pop inquiry-gloss))
	    (write-char #\space stream)
	    (typecase element
	      (symbol 
	       (format stream "~10T~S~%" element))
	      (string
	       (if *file-writing*
		   (format t "~S" element)
		 (let ((strings 
			(justify-string (- *tty-right-margin* 24) element)))
		   (loop named gloss-parts
			 while strings
			 do (format stream "~10T~S~%" (pop strings))))))))
      (format stream "~10T)"))))


(defun NONANSI-PPRINT-LEXICAL-ITEM-SEMANTICS (concept-list)
  (format nil "~S"
	  (mapcar #'(lambda (element)
		      (cond ((or (lg-designator-p element)
				 (equal element '&))
			     element)
			    (t
			     (kb-getconceptname element))))
		  concept-list)))

(defun NONANSI-PPRINT-SPL-LOGICAL-FORM (lf)
  (if lf
      (subseq					  ;;; dump the newline
       (with-output-to-string (stream)
	 (pprint lf stream))
       1)
    ""))
  
;;; ----------------------------------------------------------------------
;;; Activate the above for KPML...

#+(or acl3.0 lispworks4.0)
(defun PPRINT-LINGUISTIC-OBJECT-IN-LIST-FORM 
    (list language-set multilingual-mode)
  (format T "~A"
	  (nonansi-pprint-linguistic-object-in-list-form 
	   list language-set multilingual-mode)))


