(in-package "KPML")

;;; File: prettifying.lisp
;;;
;;; Contains functions that make results look more presentable...

(defun feature-pack (list-of-symbols)
  "takes a list of symbols and makes a new symbol out of them
   example: takes '(abc def ghi) and returns the interned symbol abc+def+ghi"
  (if (listp list-of-symbols)
      (let ((new-symbol-string (format nil "~a" (car list-of-symbols))))
	(dolist (item (cdr list-of-symbols))
	  (setq new-symbol-string (format nil "~a+~a" new-symbol-string item)))
	(intern new-symbol-string (find-package 'PENMAN)))
    list-of-symbols))

(defun function-pack (list-of-symbols)
  "takes a list of symbols and makes a new symbol out of them
   example: takes '(abc def ghi) and returns the STRING abc/def/ghi"
  (if (listp list-of-symbols)
      (let ((new-symbol-string (format nil "~a" (car list-of-symbols))))
	(dolist (item (cdr list-of-symbols))
	  (setq new-symbol-string (format nil "~a/~a" new-symbol-string item)))
	new-symbol-string)
    (string list-of-symbols)))

(defun justify-list-of-strings (line-length list-of-strings)
  (let ((justified-list '(" ")))
    (dolist (str list-of-strings)
      (setq justified-list (append justified-list (justify-string line-length str))))
    (cdr justified-list)))



;;; ----------------------------------------------------------------------
;;; Following moved out of KPML-I substrate to here so that they are
;;; always defined...
;;; ----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; Following function prints a single realization statement on
;;; standard output respecting systemic notation and upper/lower
;;; case conventions for features and microfunctions.
;;;
;;; 2.0.34
;;; The following two functions for printing realisation statements
;;; (one for ANSI compatible Lisps, the other for weaker implementations,
;;; particularly here ACL3.0) formerly put out single realisation
;;; statements on a single line, regardless of how long that realisation
;;; statement is. This can look ugly if we have very long, descriptive
;;; feature names (as in some example grammars), so this is changed to
;;; make it look prettier. Main problem is that the logical printing
;;; blocks don't inherit the set right margin lengths and so keep on
;;; going... The logical blocks also do not like to break up symbols
;;; (obviously, since they can't then be read). So we have to retreat
;;; here to some of the older methods used in Penman where the output
;;; formatting is done ourselves.
;;; ----------------------------------------------------------------------

(defun PPRINT-SINGLE-RS (rs)	
  "pretty prints a single realization statement (ANSI compatible)"
  (labels ((pp-rs (rs)
	     (let ((op (first rs))(args (rest rs)))
	       (case op
		 (*
		  (write-char #\*)
		  (pp-rs (cdr rs)))
		 (insert 
		  (pprint-logical-block 
		   (nil args)
		   (write-char #\+)
		   (loop 
		     (format t "~@(~A~)" (pprint-pop))
		     (pprint-exit-if-list-exhausted)
		     (write-char #\space))))
		 (preselect 
		  (format t "~@(~A~) :~(~{ ~A~}~)" (first args)(rest args)))
		 (conflate
		  (format t "~{~@(~A~)~@[/~]~}" args))
		 (order  
		  (format t "~{~@(~A~)~@[^~]~}" args))
		 (orderatfront
		  (format t "#^~@(~A~)" (first args)))
		 (orderatend
		  (format t "~@(~A~)^#" (first args)))
		 (partition 
		  (format t "~{~@(~A~)~@[ ... ~]~}" args))
		 (lexify 
		  (format t "~@(~A~) !~{ ~:(~A~)~}" (first args)(rest args)))
		 (inflectify 
		  (format t "~@(~A~) :::~(~{ ~A~}~)" (first args)(rest args)))
		 (classify 
		  (format t "~@(~A~) ::~{ ~(~A~)~}" (first args)(rest args)))
		 (outclassify
		  (format t "¬ ~@(~A~) ::~{ ~(~A~)~}" (first args)(rest args)))
		 (expand 
		  (format t "~@(~A~) (~{~@(~A~)~@[ ~]~})" 
			  (first args)(rest args)))
		 (agreement
		  ;; 2.0.40+2.0.52 agreement improvements
		  (cond ((consp (first args))
			 ;; 3.2 extension
			 (format t "~{~@(~A~)~@[~~~]~}" (first args))
			 (format t "~%")
			 (pprint-logical-block 
			  (nil (cdr args))
			  (write-char #\()
			  (format t "~5T~(~A~)->" (pprint-pop))
			  (loop 
			   (format t "~(~A~)" (pprint-pop))
			   (pprint-exit-if-list-exhausted)
			   (pprint-newline :fill)))
			 (write-char #\))
			 )
			(t
			 (format t "~@(~A~) ~~ ~@(~A~)" (first args)(second args))
			 (format t "~%")
			 (pprint-logical-block 
			  (nil (cddr args))
			  (write-char #\()
			  (loop 
			   (format t "~{~(~5T~A = ~A~@[ ~]~)~}" (pprint-pop))
			   (pprint-exit-if-list-exhausted)
			   (pprint-newline :fill)))
			 (write-char #\)))))
		 (otherwise (format t "~W" rs))))))
    (let ((output-string 
	   (with-output-to-string (stream)
	     (let ((*standard-output* stream))
	       (pp-rs rs)))))
      (loop for s in (indent-and-fill output-string 
				      :left-margin 3 
				      :right-margin *print-right-margin*
				      :right-margin-p T :except-first-p T)
	  as i from 0
	  when (eq i 0) do (format t "~A" s)
	  else do 
	       (pprint-newline :fill)
	       (format t "~A" s)
	     ))))


;;; ----------------------------------------------------------------------
;;; And a non-ansi duplicate... sigh...
;;; For at least Allegro PC ACL3.0, the format directives are
;;; weaker than in ANSI CL. We have to be cautious with some of
;;; the more complex combinations therefore. Particularly the
;;; [ construct appears insufficiently supported.
;;; ----------------------------------------------------------------------

(defun NONANSI-PPRINT-SINGLE-RS (rs)	
  "same as pprint-single-rs but for ANSI-weak Lisps"
  (labels ((pp-rs (rs)
	     (let ((op (first rs))(args (rest rs)))
	       (case op
		 (*
		  (write-char #\*)
		  (pp-rs (cdr rs)))
		 (insert 
		  (loop for arg in args
		      do
			(write-char #\+)
			(format t "~@(~A~)" arg)
			(write-char #\space)))
		 (preselect 
		  (format t "~@(~A~) :~(~{ ~A~}~)" (first args)(rest args)))
		 (conflate
		  (format t "~@(~A~)" (first args))
		  (loop for arg in (rest args)
		      do 
			(format t "/~@(~A~)" arg)))
		 (order  
		  (format t "~@(~A~)" (first args))
		  (loop for arg in (rest args)
		      do 
			(format t "^~@(~A~)" arg)))
		 (orderatfront
		  (format t "#^~@(~A~)" (first args)))
		 (orderatend
		  (format t "~@(~A~)^#" (first args)))
		 (partition 
		  (format t "~@(~A~)" (first args))
		  (loop for arg in (rest args)
		      do
			(format t "...~@(~A~)" arg)))
		 (lexify 
		  (format t "~@(~A~) !~{ ~:(~A~)~}" (first args)(rest args)))
		 (inflectify 
		  (format t "~@(~A~) :::~(~{ ~A~}~)" (first args)(rest args)))
		 (classify 
		  (format t "~@(~A~) ::~{ ~(~A~)~}" (first args)(rest args)))
		 (outclassify
		  (format t "¬ ~@(~A~) ::~{ ~(~A~)~}" (first args)(rest args)))
		 (expand 
		  (format t "~@(~A~) (~{~@(~A~) ~})" (first args)(rest args)))
		 (agreement
		  ;; 2.0.40+2.0.52 agreement improvments...
		  (cond ((consp (first args))
			 ;; 3.2 extension
			 (format t "~{~@(~A~)~@[~~~]~}" (first args))
			 (loop for a in (cdr args)
			       do
			       (format t "(~5T~(~A ->~{ ~A~}~))" (first a)(cdr a))))
			(t
			 (format t "~@(~A~) ~~ ~@(~A~) (~(~:{~5T~A=~A ~}~))"
				 (first args)(second args)(cddr args)))))
		 (otherwise (format t "~S" rs))))))
    (let ((output-string 
	   (with-output-to-string (stream)
	     (let ((*standard-output* stream))
	       (pp-rs rs)))))
      (loop for s in (indent-and-fill output-string 
				      :left-margin 3 
				      :right-margin *print-right-margin*
				      :right-margin-p T :except-first-p T)
	  as i from 0
	  when (eq i 0) do (format t "~A" s)
	  else do 
	       (format t "~%~A" s)
	       ))))

