;;------------------------------------------------------------------;;
;;                       HELP DIALOG                                ;;
;;                                                                  ;;
;;  Luca Scrucca                                                    ;;
;;  Department of Statistics                                        ;;
;;  University of Perugia, Italy                                    ;;
;;  luca@stat.unipg.it                                              ;;
;;                                                                  ;;
;;------------------------------------------------------------------;;

;;  v. 1.0, May 1999                                                
;;  v. 1.1, Feb 2000 added text-window (based on display-window, thanks to Forrest Young)

(provide "helpdlg")

;; The file displayw.lsp is required to show the help in a text window, 
;; otherwise is sent to the listener
(require "displayw")
(if (position "displayw" *modules* :test #'equal)
    (setf helpdlg-has-displayw t)
    (setf helpdlg-has-displayw nil))

(defparameter *helpdlg-text-window* nil 
    "This global variable contains the object address of the current help dialog text window, nil otherwise.")


(defun has-documentation (x)
"Args: (x)
Returns T if symbol or list of symbols in x has documentation, NIL otherwise.
It also returns T if a symbol is an object."
  (unless (listp x) (setf x (list x)))
  (mapcar #'(lambda(s) 
                   (cond ((documentation s 'function) t)
                         ((documentation s 'variable) t)
                         ((documentation s 'type)     t)
                         ((documentation s 'setf)     t)
                         ((boundp s)  (if (objectp (eval s)) t nil))
                         (t                        nil)))
             x))

#|
(defun get-documentation (x)
  (unless (listp x) (setf x (list x)))
  (mapcar #'(lambda (s) 
            (cond ((documentation s 'function) 
                   (format nil "~a~%~a" s (documentation s 'function)))
                  ((documentation s 'variable) 
                   (format nil "~a~%~a" s (documentation s 'variable)))
                  ((documentation s 'type)     
                   (format nil "~a~%~a" s (documentation s 'type)))
                  ((documentation s 'setf)     
                   (format nil "~a~%~a" s (documentation s 'setf)))
                  (t                        nil)))
             x))
|#

(defun get-documentation (x)
  (unless (listp x) (setf x (list x)))
  (let* ((stdout *standard-output*)
         (out nil)
        )
    (setf *standard-output* (make-string-output-stream))
    (mapcar #'(lambda (s) (help s)) x)
    (def out (get-output-stream-string *standard-output*))
    (def *standard-output*  stdout)
    out
))

(defun help* (&optional (x nil))
"Arg: 'SYMBOL
Shows the documentation associated with those symbols whose names
contain SYMBOL as substring. 
A dialog with scrolling bar is presented, and is possible to display
the desired items in the list by pushing the Display button or double-
clicking on the the item. If the item is the name of a defined object,
 then the function (display-help* <item>) is called.
Without argument the function shows the About XLISP-STAT dialog.
Example:
(help* 'regr)"

  (unless x (ABOUT-XLISP-STAT)
            (return-from help* (values)))

  (let* ((show (apropos-list x))
	     (has-doc (has-documentation show))
    	 (show (if (and has-doc (which has-doc)) (select show (which has-doc))))
	     (show (mapcar #'string-downcase (mapcar #'symbol-name show)))
	  	 (show (remove x show :test #'equal))  ;; remove the variable we couldn't find
         (lista nil) (display nil) (help-string nil) (dialog nil) (close nil) (help nil)
         (row-pix (round (* 1.3 (+ (send graph-proto :text-ascent) 
                                   (send graph-proto :text-descent)))))
         (obj nil)
         (sep (make-string 40 :initial-element #\-))
         (window-w (list (round (* (send display-window-proto2 :text-width 
                                     (strcat (repeat " " XLISP::*LINE-LENGTH*))) 1.1)) 300))
	    )
    (when (not show) 
          (message-dialog (format nil "No help available for substring: ~a" x))
          (return-from help* (values)))
    (setf lista (send list-item-proto :new (select show (order show))
		                              :size (list 190 (* row-pix (min 12 (length show))))
                                      :action #'(lambda (x) 
                    (when x 
              	(let* ((kk (send self :selection))
                       (tt (string-to-symbol 
                       (select (send self :slot-value 'list-data) kk)))
                       (doc nil)
                      )
                  (if (boundp tt) 
                      (if (objectp (eval tt))
                          (display-help* tt)))
                  (setf doc (format nil "~&~a~%" (get-documentation tt)))
                  (cond (helpdlg-has-displayw
                        (cond ((null *helpdlg-text-window*)
                               (setf *helpdlg-text-window*
                                    (display-window doc :title "Help" 
                                                        :size window-w :show t))
                               (defmeth *helpdlg-text-window* :close ()
                                  (call-next-method)
                                  (setf *helpdlg-text-window* nil)))
                              (t (send *helpdlg-text-window* :add-text doc 
                                                             :show t :scroll t))))
                        (t (format t "~a" doc))))
                    ))))
    (setf print (send button-item-proto :new "Print"
                                        :action #'(lambda()
              		 (let* ((kk (send lista :selection))
              		        (tt (string-to-symbol (if kk 
                                (select (send lista :slot-value 'list-data) kk))))
                             (doc nil)
                            )
      			     (cond (tt  (format t "~&~a~%" (get-documentation tt)))
                           (t   (message-dialog "Please make a selection.")))
			        ))))
    (setf close (send button-item-proto :new "Close" 
                                        :action #'(lambda () (send dialog :close))
;                                                  (send (slot-value 'dialog) :close))
                 ))
    (setf help  (send button-item-proto :new "Help" 
                                        :action #'help*-dialog))
    (setf help-string (format nil "(help* '~a).
Please select one argument:" x))
    (setf dialog (send dialog-proto :new (list help-string 
                                               (list lista 
                                                     (list print " " help close)))
                               :default-button display :title "Help dialog"))
    (values)
 )
)

(defun display-help* (object &optional (return-object nil))
"Arg: 'SYMBOL
Display the documentation associated with the methods own by the prototype
called SYMBOL.
A dialog with scrolling bar is presented, and is possible to display
the documentation for the desired items in the list by pushing the 
Display button or double-clicking on a item. 
Example:
(display-help* 'glim-proto)"

  (unless (boundp object) 
          (message-dialog (format nil "Sorry, object not defined!"))
          (return-from display-help* (values)))
  (setf object (eval object))
  (unless (objectp object) 
          (message-dialog (format nil "Sorry, not an object !"))
          (return-from display-help* (values)))
  
   (let* ((methods  (qsort (remove-duplicates (send object :own-methods) :test #'equal)))
	      (show     (mapcar #'string-downcase (mapcar #'symbol-name methods)))
          (prec-obj (mapcar #'(lambda (p) (string-downcase 
                              (format nil "~a" (send p :slot-value 'proto-name))))
                    (send object :precedence-list)))
          (prec-obj (remove-duplicates prec-obj :test #'equal))
          (prec-list (cons (list "Precedence list:") 
                           (select prec-obj (iseq (length prec-obj)))))
          (lista nil) (lista2 nil) (display nil) (help-string nil) 
          (dialog nil) (close nil) (help nil)
          (sep (make-string 40 :initial-element #\-))
          (window-w (list (round (* (send display-window-proto2 :text-width 
                                     (strcat (repeat " " XLISP::*LINE-LENGTH*))) 1.1)) 400))
          (row-pix (round (* 1.3 (+ (send graph-proto :text-ascent) 
                                   (send graph-proto :text-descent)))))
	  	)
   (setf lista (send list-item-proto :new show
                                  :size (list 190 (* row-pix (min 12 (length show))))
	                              :action #'(lambda (x)
                 (when x 
                  (let* ((kk (send self :selection))
                         (tt (elt (send self :slot-value 'list-data) kk))
                         (pos (position tt show :test #'equal))
                         (doc nil)
                        )
                  (setf doc (format nil "~&~a :~a~%~a~%~%" 
                                (send object :slot-value 'proto-name)
                                (select methods pos) 
                                (send object :documentation (select methods pos))))
                  (cond (helpdlg-has-displayw
                        (cond ((null *helpdlg-text-window*)
                               (setf *helpdlg-text-window*
                                    (display-window doc :title "Help" 
                                                        :size window-w :show t))
                               (defmeth *helpdlg-text-window* :close ()
                                  (call-next-method)
                                  (setf *helpdlg-text-window* nil)))
                              (t (send *helpdlg-text-window* doc :show t :scroll t))))
                        (t (format t "~a" doc)))
                   )))))
   (setf lista2 (send list-item-proto :new prec-obj
                                  :size (list 160 (* row-pix (min 12 (length prec-obj))))
	                              :action #'(lambda (x)
                  (if x (let* ((kk (send self :selection))
                  		       (tt (elt (send self :slot-value 'list-data) kk))
                              )
                        (display-help* (string-to-symbol tt))))) ) )
   (setf print (send button-item-proto :new "Print"
                                       :action #'(lambda()
                    (let* ((kk (send lista :selection))
                	       (tt (if kk (elt (send lista :slot-value 'list-data) kk)))
                           (pos (position tt show :test #'equal))
                           (doc nil)
                          )
                    (cond (tt (format t "~&~a :~a~%~a~%~%"
                                       (send object :slot-value 'proto-name)
                                       (select methods pos) 
                                       (send object :documentation (select methods pos))))
                          (t (message-dialog "Please make a selection.")))
                     ))))
   (setf close (send button-item-proto :new "Close" 
                                        :action #'(lambda () (send dialog :close))))
   (setf help  (send button-item-proto :new "Help" 
                                        :action #'display-help*-dialog))

   (setf help-string (format nil "(display-help* '~a).
Please select one argument:" (send object :slot-value 'proto-name)))
   (setf dialog (send dialog-proto 
                  :new (list help-string 
                         (list (list "Methods:" lista)
                               (list "Precedence list:" lista2)
                               (list " " " " " " print " " help close)))
                  :type 'modeless
                  :default-button display :title "Help dialog"))

   (if return-object dialog (values))
  )
)

(defmeth *object* :help* ()
    (display-help* 'self))

;;------------------------;;
;;    Functions needed    ;;
;;------------------------;;

(defun eval-string (aString)
"Arg: (aString)
Returns a list of the expressions obtained 
on evaluation of the characters in aString"  
  (let ((st (make-string-input-stream aString))   
        (result nil)   
        (expr nil))  
    (loop (setq expr (read st nil 'eof))  
          (when (eql expr 'eof)    
                (return (reverse result)))  
          (setf result (cons expr result)))))

(defun string-to-symbol (string)
"Arg: (string)
From a string (or list of strings) the function returns a symbol (or a list
of symbols), i.e. removes the \"\" from each element of the input list.
Es:
> (string-to-symbol \"help\")
HELP
> (string-to-symbol (list \"a\" \"b\" \"c\" \"b\"))
(A B C B)"
  (cond ((stringp string)  (car (eval-string string)))
        (t (let ((pos (map-elements #'equal (map-elements #'type-of string) 'string)))
              (cond ((all-nil pos) string)
                    ((all-t   pos) (combine (map-elements #'eval-string 
                                                          (select string (which pos)))))
                    (t             (setf (select string (which pos))
                                         (map-elements #'eval-string (select string (which pos))))
                                   (combine string))
               )
          ))
    )
)


(defun qsort (x &rest args)
"Function args (x)
Alphabetizes the elements of x, even if they are numbers, strings or symbols,
with numbers first."
 (let ((x (copy-seq x)))
 (flet ((qcvx (a b)
     (cond ((and (numberp a) (numberp b)) (< a b))
           ((numberp a) t)
           ((numberp b) nil)
           (t (string-lessp (string-upcase a) (string-upcase b))))))
  (sort x #'qcvx))))

;;------------------------;;
;;    Help dialogs        ;;
;;------------------------;;

(defun help*-dialog ()
  (let* ((text
"The function (help* 'SYMBOL) shows the documentation associated
with those symbols whose names contain SYMBOL as substring. 
A dialog with scrolling bar is presented, and is possible to display
the desired items in the list by pushing the Display button or 
double-clicking on the item. 
If the item is the name of a defined object, a double-click call 
the function (display-help* <item>), which allows to display the 
documentation for the methods of an object.
If the function is called without argument, it shows the 
About XLISP-STAT dialog.

"
        ))
   (message-dialog text)))

(defun display-help*-dialog ()
  (let* ((text
"
The function (display-help* 'SYMBOL) shows the documentation 
associated with the methods own by the prototype called SYMBOL.
A dialog with scrolling bar is presented, and it is possible
to display the documentation for the desired items in the list 
by pushing the Display button or double-clicking on a item.

"
        ))
   (message-dialog text)))


;;------------------------------------------------------------------;;
;; If the problem is finding the appropriate method or slot when    ;;
;; you're not sure what it's called, you can try something like     ;;
;; this -- an :apropos method for objects that's a sort of parallel ;; 
;; to the apropos function:                                         ;;
;; es. > ( send histogram-proto :apropos "point" )                  ;;
;;                                                                  ;;
;; Steven D. Majewski (804-982-0831) <sdm7g@Virginia.EDU>           ;;
;; Department of Molecular Physiology and Biological Physics        ;;
;; University of Virginia             Health Sciences Center        ;;
;; P.O. Box 10011            Charlottesville, VA  22906-0011        ;;
;;------------------------------------------------------------------;;
( defmeth *object* :apropos ( str &key (help t) )
  ( dolist 
    ( name ( send self :doc-topics ))
    ( when (string-search  str (symbol-name name)) 
           ( if help 
                ( progn ( send self :help name ) (terpri))
                (format t "~s~%" name ))))
  ( format t "~a : ~a SLOTS:~%" ( slot-value 'proto-name ) self )
  ( dolist 
    ( name ( send self :slot-names ))
    ( when (string-search str (symbol-name name))
           ( format t "~s : ~a~%" name ( slot-value name )))))

;;------------------------------------------------------------------------;;
;;                                                                        ;;
;;                         DISPLAY WINDOW                                 ;;
;;                                                                        ;;
;; display542.lsp                                                         ;;
;; Copyright (c) 1997 by Forrest W. Young                                 ;;
;; Creates a window for displaying text. Extends the Mac-only             ;;
;; display window (Tierney, p. 360) to work on all platforms.             ;;
;; distributed as displayw.lsp with version 5.4.2                         ;;
;;                                                                        ;;
;; Modified by Luca Scrucca, luca@stat.unipg.it                 Feb. 2000 ;;
;;                                                                        ;;
;;------------------------------------------------------------------------;;

;(provide "displayw")

;; WINDOW CONSTRUCTOR FUNCTION

(defun display-window (text &key (title "TextWindow") (size '(475 280)) 
                                 (location '(10 20)) (show t) fit)
"------------------------------------------------------------------------
                         DISPLAY WINDOW                                 
------------------------------------------------------------------------

Args: (text &key (title \"TextWindow\") (size '(475 280)) 
                 (location '(10 20)) (show t) fit)

Displays a window containing TEXT, a required argument. Window is fit to
text when FIT is T. LOCATION and SIZE provide location and size of the
window. If SHOW is T then the window is shown.
Returns the object from the display-window-proto2.
Extends the Mac-only display window (Tierney, p. 360) to work on all 
platforms. 
More text can be added sending the message :add-text new-text.

------------
Copyright (c) 1997 by Forrest W. Young
Modified by Luca Scrucca, luca@stat.unipg.it, Feb. 2000"

  (let* ((w (send display-window-proto2 :new :title title :size size
                  :location location :show nil)) 
         (window-height (second (send w :size)))
         (window-width (first (send w :size)))
         (line-height (send w :line-height))
         (page-increment (* line-height 
                            (floor (/ (- window-height line-height) 
                                      line-height))))
         (maxrow-width (max (map-elements #'send graph-proto :text-width 
                                    (split-string-at text #\newline))))
        )

    (when (> (+ maxrow-width 50) window-width)
          (send w :size (+ maxrow-width 50) window-height)
          (send w :line-width maxrow-width))

    (send w :paste-string text)

    (cond (fit (when show (send w :show-window))
               (send w :fit-window-to-text))
          (t   (when show (send w :show-window))))
    (setf *current-text-window* w)
    w))

;; Method for adding a text to a window



;;########################################################################
;;
;; WINDOW OBJECT CODE
;;
;;########################################################################


(defproto display-window-proto2 
  '(x y nstrings strings nlines lines line-height line-width write-now
      default-window-height fit-window-to-text-height nowrap noformat
      v-scroll-value x-list y-list reformatting)
  () graph-window-proto)

(defmeth display-window-proto2 :isnew 
  (&key (title "TextWindow") (size '(475 280)) (location '(10 20)) (show t))
  (call-next-method :title title :size size :show nil)
  (apply #'send self :location location)
  (send self :default-window-height (second size))
  (send self :flush-window)
  (send self :line-height (+ (send self :text-ascent)
                             (send self :text-descent)))
  (let* ((window-width (first (send self :size)))
         (window-height (second (send self :size)))
         (line-height (send self :line-height))
         (text-menu (send menu-proto :new title))
         (text-window self)
         (v-page-increment (* line-height 
                            (floor (/ (- window-height line-height) 
                                      line-height))))
         (save-text-menu-item
          (send menu-item-proto :new "Save Text ..." :enabled t
                :action (lambda () (send self :save-text t nil))))
         (text-to-listener-menu-item
          (send menu-item-proto :new "Send Text to Listener" :enabled t
                :action (lambda () (send self :save-text nil t))))
         (refresh-text-menu-item
          (send menu-item-proto :new "Refresh Text" :enabled t
                :action (lambda () (send self :redraw))))
         (fit-text-menu-item
          (send menu-item-proto :new "Fit Window to Text" :enabled t
                :action (lambda () (send self :fit-window-to-text))))
         )
    (send self :menu text-menu)
    (send text-menu :append-items
          save-text-menu-item
          text-to-listener-menu-item
          (send dash-item-proto :new)
          refresh-text-menu-item
          fit-text-menu-item)
    (defmeth text-menu :install ()
            (setf *current-text-window* text-window)
            (call-next-method)
            )
    (send self :has-v-scroll t) 
    (send self :v-scroll-incs line-height v-page-increment)
    (send self :has-h-scroll t)
    (send self :h-scroll-incs 
          (floor (/ window-width 20)) (floor (/ window-width 2)))
    ) 
  (when show (send self :show-window))
  (setf *current-text-window* self)
  t)

(defmeth display-window-proto2 :x (&optional (number nil set))
  (if set (setf (slot-value 'x) number))
  (slot-value 'x))

(defmeth display-window-proto2 :y (&optional (number nil set))
  (if set (setf (slot-value 'y) number))
  (slot-value 'y))

(defmeth display-window-proto2 :x-list (&optional (list-of-nums nil set))
  (if set (setf (slot-value 'x-list) list-of-nums))
  (slot-value 'x-list))

(defmeth display-window-proto2 :y-list (&optional (list-of-nums nil set))
  (if set (setf (slot-value 'y-list) list-of-nums))
  (slot-value 'y-list))

(defmeth display-window-proto2 :nstrings (&optional (number nil set))
  (if set (setf (slot-value 'nstrings) number))
  (slot-value 'nstrings))

(defmeth display-window-proto2 :strings (&optional (list-of-strings nil set))
  (if set (setf (slot-value 'strings) list-of-strings))
  (slot-value 'strings))

(defmeth display-window-proto2 :nlines (&optional (number nil set))
  (if set (setf (slot-value 'nlines) number))
  (slot-value 'nlines))

(defmeth display-window-proto2 :lines (&optional (list-of-strings nil set))
  (if set (setf (slot-value 'lines) list-of-strings))
  (slot-value 'lines))

(defmeth display-window-proto2 :line-height (&optional (number nil set))
  (if set (setf (slot-value 'line-height) number))
  (slot-value 'line-height))

(defmeth display-window-proto2 :line-width (&optional (number nil set))
  (if set (setf (slot-value 'line-width) number))
  (slot-value 'line-width))

(defmeth display-window-proto2 :write-now  (&optional (logical nil set))
  (if set (setf (slot-value 'write-now) logical))
  (slot-value 'write-now))

(defmeth display-window-proto2 :fit-window-to-text-height 
  (&optional (logical nil set))
  (if set (setf (slot-value 'fit-window-to-text-height) logical))
  (slot-value 'fit-window-to-text-height))

(defmeth display-window-proto2 :reformatting (&optional (logical nil set))
  (if set (setf (slot-value 'reformatting) logical))
  (slot-value 'reformatting))

(defmeth display-window-proto2 :default-window-height 
  (&optional (number nil set))
  (if set (setf (slot-value 'default-window-height) number))
  (slot-value 'default-window-height))

(defmeth display-window-proto2 :nowrap  (&optional (logical nil set))
  (if set (setf (slot-value 'nowrap) logical))
  (slot-value 'nowrap))

(defmeth display-window-proto2 :noformat  (&optional (logical nil set))
  (if set (setf (slot-value 'noformat) logical))
  (slot-value 'noformat))

(defmeth display-window-proto2 :v-scroll-value (&optional (number nil set))
  (if set (setf (slot-value 'v-scroll-value) number))
  (slot-value 'v-scroll-value))

(defmeth display-window-proto2 :do-click (x y m1 m2) 
  (when (not (equal *current-text-window* self))
        (setf *current-text-window* self)))

(defmeth display-window-proto2 :paste-stream (stream)
  (let ((string nil))
    (loop
     (setf string (read-line stream nil))
     (when (not string) (return))
     (setf string (strcat string (string #\newline)))
     (send self :paste-string string))
    ))

(defmeth display-window-proto2 :paste-string (string)
  (let* ((last-char nil)
         (string-piece string)
         (string-max string-piece)
         (string-length nil)
         (more nil)
         (split-loc 0)
         (max-char 100))
    (cond 
      ((send self :noformat)
       (loop 
        (setf string-piece string)
        (setf split-loc (position #\newline string-piece))
        (cond
          (split-loc
           (when (> split-loc 0)
                 (setf string-piece (select string-piece (iseq split-loc)))
                 (send self :lines 
                       (add-element-to-list (send self :lines) string-piece))
                 (setf string-length (send self :text-width string-piece))
                 (send self :strings 
                       (add-element-to-list (send self :strings) string-PIECE))
                 (send self :write-line-to-window 
                       string (send self :x) (send self :y) string-length))
           (send self :new-line (send self :y))
           (send self :strings (add-element-to-list (send self :strings)
                                                  (string #\newline)))
           (when (> (1+ split-loc) (1- (length string))) (return))
           (setf string (select string 
                                 (iseq (1+ split-loc) (1- (length string))))))
          (t
           (send self :lines 
                 (add-element-to-list (send self :lines) string-piece))
           (setf string-length (send self :text-width string-piece))
           (send self :write-line-to-window 
                 string (send self :x) (send self :y) string-length)
           (send self :strings 
                 (add-element-to-list (send self :strings) string-PIECE))
           (send self :nstrings (1+ (send self :nstrings)))
           (return)))))
      ( (> (length string) 0)
          (setf last-char (select (reverse string) 0))
          (when (and (not (equal last-char #\ ))
                     (not (equal last-char #\newline)))
                (setf string (strcat string " "))
                (setf string-piece string)
                (setf string-max string-piece))
          (loop (setf more nil)
                (setf string-length (length string-piece))
                (when (> string-length max-char)
                      (setf string-max 
                            (reverse (select string-piece (iseq max-char))))
                      (setf split-loc (- max-char (position #\  string-max)))
                      (setf string-max 
                            (select (reverse string-max) (iseq split-loc)))
                      (setf more t)
                      )
                (send self :strings 
                      (add-element-to-list (send self :strings) string-max))
                (send self :nstrings (1+ (send self :nstrings)))
                
                (when (> (length string-max) 0) 
                      (send self :write-string-to-window string-max))
                (when more
                      (setf max-char 
                            (min max-char (- string-length split-loc)))
                      (setf string-piece 
                            (select string-piece 
                                     (iseq split-loc (- string-length 1))))
                      (setf string-max string-piece)
                   )
                (when (not more) (return)))))
  t))

(defmeth display-window-proto2 :write-string-to-window (string)
  (let ((x (send self :x))
        (y (send self :y))
        (string-width (send self :text-width string))
        (line-width (send self :line-width))
        (line-width-remaining nil)
        (old-line-remaining string)
        (pieces nil)
        (piece-width nil)
        (splitable string)
        (vr (send self :view-rect))
        )
    (when (not line-width)
          (if (= 0 (send self :canvas-width))
              (send self :line-width 400)
              (send self :line-width (- (send self :canvas-width) 20)))
          (setf line-width (send self :line-width)))
    (setf line-width-remaining (- (send self :line-width) x))
    (loop 
     (setf pieces (send self :split-line splitable x line-width-remaining))
     (when (and (equal (third pieces) old-line-remaining)
                (not (position #\  (third pieces)))
                (<= (send self :line-width)
                    (send self :text-width (third pieces))))
           (setf line-width-remaining (send self :line-width))
           (setf piece-width (send self :text-width (third pieces)))
           (send self :lines 
                 (add-element-to-list (send self :lines) (third pieces)))
           (send self :write-line-to-window (third pieces) x y piece-width)
           (setf splitable nil)
           (return)
           )
     (setf old-line-remaining (third pieces))
     (when (first pieces)
           (setf piece-width (send self :text-width (first pieces)))
           (send self :lines 
                 (add-element-to-list (send self :lines) (first pieces)))
           (send self :write-line-to-window (first pieces) x y piece-width))
     (when (<= (send self :line-width) (send self :x)))
     (when (equal (second pieces) "NL")(send self :new-line y))
     (cond 
       ((third pieces) 
        (when (not (equal (second pieces) "NL"))(send self :new-line y))
        (setf x (send self :x))
        (setf y (send self :y))
        (setf line-width-remaining (send self :line-width))
        (setf splitable (third pieces)))
       (t (return))))))

(defmeth display-window-proto2 :split-line (string x line-width)
  (let* ((string-length (length string))
         (nowrap (send self :nowrap))
         (margins 0)
         (real-line-width (- line-width margins))
         (first-newline-loc nil)
         (last-space-loc nil)
         (split-loc nil)
         (print-string string)
         (previous-print-string string)
         (print-string-width (send self :text-width print-string))
         (print-string-length (length print-string))
         (remaining-string nil)
         (print-string-backwards nil)
         (last-space-loc nil)
         (last-nl-loc nil)
         )

    (when (<= real-line-width 0) (setf real-line-width 20))

 ;loop finds longest acceptable string - skip if nowrap

    (when (not nowrap)
    (loop
     (when (< print-string-width real-line-width) 
           (setf print-string previous-print-string)
           (setf print-string-length (length print-string))
           (setf print-string-width (send self :text-width print-string))
           (loop
            (when (< print-string-width real-line-width) (return))
            (setf print-string-length (- print-string-length 1))
            (setf print-string (select string (iseq print-string-length))) 
            (setf print-string-width (send self :text-width print-string)))
           (return))
     (setf previous-print-string print-string)
     (setf print-string-backwards (reverse print-string))
     (setf last-space-loc (position #\  print-string-backwards))
     (setf last-nl-loc (position #\newline  print-string-backwards))
     (when (and (not last-space-loc) (not last-nl-loc)) (return))
     (when (not last-space-loc) (setf last-space-loc print-string-length))
     (when (not last-nl-loc) (setf last-nl-loc print-string-length))
     (setf print-string-length 
           (- print-string-length (min last-space-loc last-nl-loc) 1))
     (setf print-string (select string (iseq print-string-length))) 
     (if print-string
         (setf print-string-width (send self :text-width print-string))
         (setf print-string-width 0))
     ))

    ;now look for first newline in that string

    (setf first-newline-loc (position #\newline print-string))
 
    ;if no newline, look for last space in that string

    (if first-newline-loc
        (setf split-loc (+ 1 first-newline-loc))
        (if (position #\  (reverse print-string))
            (setf split-loc 
                  (- print-string-length 
                     (position #\  (reverse print-string))))
            (setf split-loc 0))) 
    ;sometimes strips off spaces that are not to be stripped!
    ;remaining string from after (not including) split-loc to end of string
    (if (= split-loc string-length);sometimes print-string-length
        (setf remaining-string nil)
        (setf remaining-string 
              (select string ;sometimes print-string 
                      (iseq split-loc (- string-length 1)))))
    ;above sometimes print-string-length
    ;make print-string the string up to (not incuding) split-loc
    (if (= split-loc 0)
        (setf print-string nil)
        (setf print-string 
              (strcat " " (select print-string (iseq (- split-loc 1))))))
    (setf break-char (if first-newline-loc "NL" "SP"))
    (list print-string break-char remaining-string)))

(defmeth display-window-proto2 :write-line-to-window (string x y st-width)
  (when (send self :write-now) 
        (let ((vr (send self :view-rect)))
          (when (<= (second vr) y (+ (second vr) (fourth vr)))
                 (send self :draw-text string x y 0 1)
                 ))
        )
  (send self :x-list (add-element-to-list (send self :x-list) x))
  (send self :y-list (add-element-to-list (send self :y-list) y))
  (send self :x (+ (send self :x) st-width)))

(defmeth display-window-proto2 :new-line (y)
  (send self :nlines (1+ (send self :nlines)))
  (send self :y (+ (send self :y) (send self :line-height)))
  (send self :x 10)
  (send self :y))

(defmeth display-window-proto2 :redraw ()
  (when (not (send self :reformatting))
  (when t 
        (send self :erase-window)
        (let* ((y-top (second (send self :view-rect)))
               (y-now nil)
               (y-bot (+ y-top (fourth (send self :view-rect)))))
          (dotimes (i (length (send self :y-list)))
                   (setf y-now (select (send self :y-list) i))
                   (cond
                     ((<= y-top y-now y-bot)
                      (send self :draw-text 
                            (select (send self :lines) i)
                            (select (send self :x-list) i) y-now 0 1))
                     ((> y-now y-bot)
                      (return)))))
        )))


(defmeth display-window-proto2 :reformat ()
  (when t 
        (let ((write-before (send self :write-now)))
          (send self :write-now t)
          (send self :reformatting t)
          (when (not write-before) (send self :start-buffering))

;; check if horizontal scroll is needed
          (let* ((window-width (first (send self :size)))
                 (row-maxwidth (max (map-elements #'send self :text-width (send self :lines))))
                ) 
            (cond
              ((> row-maxwidth (- window-width 30))
               (send self :has-h-scroll t)
               (send self :h-scroll-incs
                    (floor (/ window-width 20)) (floor (/ window-width 2))))
              (t
               (send self :has-h-scroll nil)))
            )
;; check if vertical scroll is needed
          (let* ((window-height (second (send self :size)))
                 (line-height (send self :line-height))
                 (content-height (* line-height (1+ (send self :nlines))))
                 (page-increment (* line-height 
                                    (floor (/ (- window-height line-height) 
                                              line-height))))) 
            (cond
              ((> content-height (second (send self :size)))
               (send self :v-scroll-incs line-height page-increment)
               (send self :has-v-scroll content-height))
              (t
               (send self :has-v-scroll nil)))
            )

          (cond 
            ((> (first (send self :size)) 200)
             (let ((nstrings (send self :nstrings))
                   (strings (send self :strings))
                   )
               (send self :erase-window)
               (send self :x 10)
               (send self :y 0)
               (send self :nlines 0)
               (send self :lines nil)
               (send self :x-list nil)
               (send self :y-list nil)
               (when nstrings
                     (dotimes (i nstrings)
                              (send self :write-string-to-window 
                                    (select strings i))))))
            (t (send self :size 201 (second (send self :size)))))
          (send self :write-now write-before)
          
          (send self :reformatting nil)
          (when (not write-before) (send self :buffer-to-screen)))
    ))

(defmeth display-window-proto2 :resize ()
  ;(call-next-method)
  (send self :scroll 0 0)
  (send self :line-width (- (send self :canvas-width) 20))
  (when (send self :noformat) (send self :redraw))
  (when (and (not (send self :noformat))
             (not (send self :reformatting)))
        (send self :reformat)))
    

(defmeth display-window-proto2 :fit-window-to-text ()
  (let* ((nlines (send self :nlines))
         (line-height (send self :line-height))
         (window-height (+ 5 (* (1+ nlines) line-height)))
         (dwh (send self :default-window-height))
         )
    (when (= 0 window-height) (setf window-height dwh))
    (send self :size (first (send self :size)) window-height)
    window-height
    ))

(defmeth display-window-proto2 :flush-window ()
  (send self :erase-window)
  (send self :x 10)
  (send self :y 0)
  (send self :lines nil)
  (send self :x-list nil)
  (send self :y-list nil)
  (send self :strings nil)
  (send self :nstrings 0)
  (send self :nlines 0))

(defmeth display-window-proto2 :show-window ()
  (call-next-method))

(defmeth display-window-proto2 :close ()
  (call-next-method)
  (setf *current-text-window* nil))

(defmeth display-window-proto2 :save-text (&optional file listener &key (name nil setname))
"Args: (&optional file listener &key (name nil))
If FILE is T the text is written to a file called NAME.TXT as plain unformatted
text suitable for printing or editing. If the name of the file is not provided 
a dialog is presented for setting a name. When LISTENER is T, writes to listener."
  (let* ((name (if setname name (send self :title)))
         (L (min 8 (length name)))
         (suggest (strcat (subseq name 0 L) ".txt"))
         (strings (send self :strings))
         (num-strings (length strings)))
    (cond 
      (listener
       (format t "~&") 
       (dotimes (i num-strings)
                (format t "~a" (select strings i)))
       (format t "~&"))
      (file
       (if (not (set-working-directory (get-working-directory)))
           (error "User directory ~s does not exist." (get-working-directory)))
       (setf file #-X11 (set-file-dialog  "Save Text in File:" suggest)
                  #+X11 (get-string-dialog "Save Text in File:" :initial suggest)
            )
       (let ((f (open (string file) :direction :output))
             (oldbreak *breakenable*))
          (setq *breakenable* nil)
          (unwind-protect 
          (dotimes (i num-strings)
                   (format f "~a" (select strings i))))
          (setq *breakenable* oldbreak)
          (close f)
          (format t "; finished saving ~s~%" file)
          f)))
    ))

(defmeth display-window-proto2 :add-text (text &key (show t) fit scroll)
"Message args: (text &key (show t) fit scroll)
Add a text to the window."
  (let*  ((line-height (send self :line-height))
         (nlines (send self :nlines))
         (window-height (second (send self :size)))
         (text-height (* nlines line-height))
        )
    (send self :paste-string text) 
    (when (and scroll (> (+ text-height line-height) (- window-height line-height)))
          (send self :has-v-scroll (+ text-height (* 2 line-height)))
          (apply #'send self :scroll (+ (list 0 (* 2 line-height)) (send self :scroll))))
    (send self :redraw)
    (when fit (send self :fit-window-to-text))
    (when show (send self :show-window))
    (send self :reformat)
    t))
  

;; Functions added to original *vista* code
;;

(defparameter *current-text-window* nil 
    "This global variable contains the object address of the current text window, nil otherwise.")

(defun add-element-to-list (a b)
  (if (listp a) (append a (list b))
                (combine a b)))

(defun strcat (&rest strings)
"Args: &rest strings
Catenates the strings in args."
  (apply #'concatenate (combine 'string strings)))

(defun split-string-at (string &optional (char #\Space))
"Args: (string &optional (char #\Space))
Split string into a list of strings at separator char."
  (let ((n (position char string)))
    (if n (cons (subseq string 0 n) (split-string-at (subseq string (1+ n)) char))
          (list string))))

;; An additional function useful in conjunction to display-window
;;

(defun collect-output (fun &rest args)
"Args: (fun &rest args)
Collects output from applying function FUN with arguments given by ARGS.
The output is returned as a string. This may be useful in conjunction to the
display-window function in order to display an output on a window.
Example:
> (def x (normal-rand 100))
> (def y (+ (* 2 x) (/ (normal-rand 100) 10)))
> (collect-output #'regression-model x y :response-name \"Y\" 
                                         :predictor-names (list \"x\"))
> (display-window (collect-output #'regression-model x y :response-name \"Y\" 
                                                         :predictor-names (list \"x\")))
Note: the function redefines temporally the *standard-output* stream, then collects the
      output sent to the *standard-output* stream in a new stream, whose content is 
      then returned. If something goes wrong, you may lost the original *standard-output*
      stream. Usually, the latter stream is the *terminal-io* stream (i.e. the listener), 
      so you can restore it by typing 
      (setf *standard-output* *terminal-io*)."

  (let* ((stdout *standard-output*)
         (out nil)
        )
    (setf *standard-output* (make-string-output-stream))
    (apply fun args)
    (def out (get-output-stream-string *standard-output*))
    (def *standard-output*  stdout)
    out
))