(in-package "KPML")

;;; File: basic-ttyio.lisp
;;;
;;; Contains those output functions that provide bottoming-out behaviour
;;; if there is nothing better available loaded (such as a window
;;; interface)... Are essentially the basic Penman functions occasionally
;;; altered lightly.
;;; 2.1 printwindow output suppressed in demo-mode.

(defun PRINTWINDOW (window-name &optional strings-to-print )
  "All output goes through here. It is expanded in the window interface."
  (unless *demo-mode*
    (when (symbolp strings-to-print)                      ;; 2.1 missed
      (setq strings-to-print (string strings-to-print)))  ;;     this case
    (when (stringp strings-to-print)
      (setq strings-to-print (list strings-to-print)))
    (case window-name
      ((:display-pane :realization-pane)
       (dolist (line  strings-to-print )
         (format *standard-output* "~%~a" line)))
      (otherwise
       (when strings-to-print                             ;; 2.1
         (dolist (line strings-to-print)                  ;; 1.1
	   (format *trace-output* "~%~a" line)))))))


(defun ASKWINDOW (type-of-ask strings-to-print &optional choices)
  (if window-interface-flag
      (askwindow-real-window type-of-ask strings-to-print  choices)   
      (askwindow-tty type-of-ask strings-to-print  choices)))

;This is redefined in the window interface to do something usefull.
(defun ASKWINDOW-REAL-WINDOW (type-of-ask strings-to-print  choices)
  type-of-ask strings-to-print choices
  nil)
  
(defun ASKWINDOW-TTY (type-of-ask strings-to-print &optional choices)
  (when (stringp strings-to-print)
    (setq strings-to-print (list strings-to-print)))
  (when example-runner-flag 
    (warning "Attempted to ask the user the following message: "  
	     strings-to-print )
    (throw 'erunner strings-to-print ))
  (case type-of-ask
    (:choice
     (unless choices (return-from ASKWINDOW-TTY nil)) ;; 2.0 was in wrong place
     (unless (>= (length choices) 2)
	(break "~%Asking for a choice with less than 2 choices does not make sense - choices: ~a" choices))
      (let ((number-of-choice nil))
	(tagbody
	  prompt-for-choice
	  (dolist (line  strings-to-print )
	    (format *standard-output* "~%~a" line))
	  (do ((count 1 (+ count 1))
	       (option choices (cdr option)))
	      ((null option))
	      (format  *standard-output* "~% ~s. ~a" count (car option)))
	  (format *standard-output* "~%Number Of Choice: ")
	  (setq number-of-choice (read *standard-input*))
	  (unless (and (numberp number-of-choice)
		       (>= number-of-choice 1)
		       (<= number-of-choice (length choices)))
	    (format *standard-output* 
		    "~%Please enter a number between 1 and ~a." 
		    (length choices))
	    (go prompt-for-choice)))
	(return-from askwindow-tty 
	  (nth (- number-of-choice 1) choices))))
    (:yes-or-no
     (dolist (line  strings-to-print )
       (format *standard-output* "~%~a" line))
     (return-from askwindow-tty (yes-or-no-p)))
    (:value
      (dolist (line  strings-to-print )
	(format *standard-output* "~%~a" line))
      (return-from askwindow-tty (read nil nil nil)))
    (:any-key-to-continue
      (dolist (line  strings-to-print )
	(format *standard-output* "~%~a" line))
      ;; 2.1 why is this using standard-output as an input stream?
      (read-char *standard-output* )	;any character to continue
      (return-from askwindow-tty ':continuing))
    (otherwise
     (break "~%Unknown type of user prompting - (askwindow ~a ~a)" 
	    type-of-ask strings-to-print)
     nil)))


;;; ----------------------------------------------------------------------
;;; Old functions from Penman's old-sgdisplay that are still used
;;; in some debugging cases... Print-fat updated so that it always
;;; uses that FAT separate window for display if it can...
;;; ----------------------------------------------------------------------

(defun PRINT-FAT ()
  (printwindow 
   (if window-interface-flag
       :function-association-table-pane
     :display-pane)
   (print-fat-to-string-list))
  T)

;;; (Following got forgotten in KPML 2.0, back again here!)

(defun PRINT-FAT-TO-STRING-LIST (&optional fat-data)
  (unless fat-data (setq fat-data associations))
  (let ((string-for-scroll-window '(" ")))
    (push (format nil  "Function Association Table")
	  string-for-scroll-window)
    (let ((terms nil)
	  (total-length nil))
      (dolist (item fat-data)
	(push (format nil   "Function: ~a" 
		      (function-association-function item))
	      string-for-scroll-window)
	(setq string-for-scroll-window
	  (append (reverse 
		   (pretty-with-header  
		    (function-association-concept item) "   Concept: "))
		  string-for-scroll-window))
	(setq string-for-scroll-window
	  (append (reverse 
		   (pretty-with-header
		    (function-association-presentation-spec item) 
		    "   Presentation-spec: " ))
		  string-for-scroll-window))
	(setq terms (function-association-term-set item))
	(setq total-length (length terms))
	(when (> total-length 20)
	  (setq terms (subseq terms 0 20))
	  (setq terms 
	    (append 
	     terms 
	     `(,(string (format 
			 nil "<Total length is ~a terms>" total-length))))))
	(setq string-for-scroll-window
	  (append (reverse (pretty-with-header  terms "   Terms: " ))
		  string-for-scroll-window))
	(push (format nil   "   Term: ~a" 
		      (function-association-term item)) 
	      string-for-scroll-window)))
    (reverse string-for-scroll-window)))


;;; ----------------------------------------------------------------------
;;; Following function should
;;; give a display of the entire structure of a generated
;;; sentence that is, however, suitable for tty output.
;;; Or we could make a general one which is both OK for
;;; mouse sensitive window display and for TTY. At present
;;; it merely does the old behavior, relying on the values
;;; placed in the global final-orderings. Fairly redundent
;;; wrt current KPML code I expect.
  
(defun DISPLAY-TTY-GENERATED-STRUCTURE ()
  (print-orderings)
  (values))

  
;;; Similarly wrt window behavior for the following... Maybe
;;; put them up in a popup window of something...
  
(defun DISPLAY-TTY-WARNING-REPORT (old-warning-count)
  (when (> Warning-Count Old-Warning-Count)
	(unless example-runner-flag 
		(askwindow 
		 :any-key-to-continue 
		 "Hit <END> key to display warnings"))
	(Report-Warnings 
	 (+ Old-Warning-Count 1) Warning-Count)))


;;; ----------------------------------------------------------------------
;;; Misc and old...
;;; ----------------------------------------------------------------------

(defun print-properties (property-list)
  (let((print-string ")" ))
    (dolist (one-property (reverse property-list))
      (setq print-string (format nil ")~a" print-string))
      (dolist (component (reverse one-property))
	(cond((stringp component)  
	      (setq print-string (format nil "\"~a\" ~a" component print-string)))
	     ((or (symbolp component) (numberp component))
	      (setq print-string (format nil "~a ~a" component print-string)))
	     (t
	      (warning T "The property list" T  property-list
                                       " is formated incorrectly."))))
      (setq print-string (format nil "(~a" print-string)))
    (setq print-string (format nil "(~a" print-string))))


(defun PRETTY-PRINT (object)
  (printwindow :display-pane (pretty object)))

(defun print-dc (instance stream)
  (format stream "(")
  (when (discourse-context-speaker instance)
    (format stream ":speaker ~a " (discourse-context-speaker instance)))
  (when (discourse-context-hearer instance)
    (format stream ":hearer ~a " (discourse-context-hearer instance)))
   (when (discourse-context-speaking-time instance)
    (format stream ":speaking-time ~a " (discourse-context-speaking-time instance)))
   (when (discourse-context-realm-of-speech instance)
    (format stream ":realm-of-speech ~a " (discourse-context-realm-of-speech instance)))
   (when (discourse-context-identifiables instance)
    (format stream ":identifiables ~a " (discourse-context-identifiables instance)))
   (when (discourse-context-priorrefs instance)
    (format stream ":priorrefs ~a " (discourse-context-priorrefs instance)))
   (format stream ")"))

