;;; -*- Mode:Common-Lisp; Package:Yes-Way; Base:10 -*-

;;; **********************************************************************
;;; Copyright (c) 1990 Stanford University.
;;; This code was written by James Rice.
;;; Copyright is held by Stanford University except where code has been
;;; modified from TI source code.  In these cases TI code is marked with
;;; a suitable comment.

;;; All Stanford Copyright code is in the public domain.  This code may be
;;; distributed and used without restriction as long as this copyright
;;; notice is included and no fee is charged.  This can be thought of as
;;; being equivalent to the Free Software Foundation's Copyleft policy.

;;; TI source code may only be distributed to users who hold valid TI
;;; software licenses.

;;; The development of this software was assisted by the following grants:
;;; Biomedical Research Technology Program of the National Institutes
;;; of Health under grant RR-00785
;;; Information Systems Technologies office of the Defense Advanced
;;; Research Projects Agency under contract N00039-86-C0033.

;;; **********************************************************************

(defun parse-out-special-number (keyword numbers index)
"Is passed a keyword like :+, a list of numbers represented as strings
and an index into the numbers list.  Returns validates sequence components
for those numbers.
"
  (cons keyword
	(cons (validate-sequence
		(yw-read-from-string (first numbers) t nil :End index)
	      )
	      (validate-sequence
		(Parse-numbers
		  (cons (subseq (first numbers) (+ 1 index)) (rest numbers))
		)
	      )
	)
  )
)

(Defun parse-numbers (numbers)
"Given a list of strings for numbers, returns parsed out sequence specifiers."
  (let ((*package* (find-package :Keyword)))
       (if numbers
	   (typecase (first numbers)
	     (number (cons (first numbers) (parse-numbers (rest numbers))))
	     (symbol
	      (Parse-Numbers (cons (symbol-name (first numbers)) (rest numbers))
	      )
	     )
	     (string
	      (let ((index (string-search-set ",:+-" (first numbers))))
		   (if index
		       (case (aref (first numbers) index)
			 (#\: (parse-out-special-number :Through numbers index))
			 (#\+ (parse-out-special-number :+       numbers index))
			 (#\- (parse-out-special-number :-       numbers index))
			 (#\,
			   (cons (yw-read-from-string (first numbers)
						   t nil :End index
				 )
				 (Parse-numbers
				   (cons (subseq (first numbers) (+ 1 index))
					 (rest numbers)
				   )
				 )
			   )
			 )
			 (otherwise
			  (yw-warn "Cannot understand \"~A\" as message ~
                                    ~%numbers.  Please use Help for help ~
                                    ~%on message sequences. " numbers
			  )
			 )
		       )
		       (if (equal "" (first numbers))
			   (parse-numbers (rest numbers))
			   (cons (yw-read-from-string
				   (first numbers) t nil :End index
				 )
				 (Parse-Numbers (rest numbers))
			   )
		       )
		   )
	      )
	     )
	   )
	   nil
       )
  )
)

;-------------------------------------------------------------------------------

;;; Help commands.

(defun layout-string-in-window (string start x y window)
"Sort of fills the string String starting at the index start into the string
at coordinates x y no window.
"
  ;;; assume that we're starting with a newline.
  (declare (optimize (safety 0)))
  (let ((index (string-search-set (cons #\ *whitespace-chars*) string start))
	(space-width (tv:sheet-compute-motion window 0 0 " "))
       )
       (if index
	   (multiple-value-bind (new-x new-y)
	       (tv:sheet-compute-motion
		 window (+ x space-width) y string start index
	       )
	     (if (> new-y y)
		 (progn (terpri window)
			(layout-string-in-window string start 0 new-y window)
		 )
		 (let ((newline nil))
		      (if (not (equal start index))
			  (let ((char (aref string index))
				(next (if (>= index (- (length string) 1))
					  #\newline
					  (aref string (+ 1 index))
				      )
				)
				(next+ (if (>= (+ 1 index)
					       (- (length string) 1)
					   )
					   #\newline
					   (aref string (+ 2 index))
				       )
				)
				(last (aref string (max 0 (- index 1))))
			       )
			       (send window :String-Out string start index)
			       (if (char-equal char #\newline)
				   (if (char-equal next #\newline)
				       (progn (terpri window)
					      (terpri window)
					      (setq newline t)
				       )
				       (send window :Tyo #\space)
				   )
				   (if (char-equal char #\)
				       (progn (terpri window)
					      (if (and
					           (char-equal next  #\newline)
						   (char-equal next+ #\newline)
						  )
						  (terpri window)
						  nil
					      )
					      (setq newline t)
				       )
				       (send window :Tyo char)
				   )
			       )
			  )
			  nil
		      )
		      (if index
			  (if newline
			      (Layout-String-In-Window
				string (+ 1 index) 0 new-y window
			      )
			      (Layout-String-In-Window
				string (+ 1 index)
				(+ new-x space-width)
				new-y window
			      )
			  )
			  nil
		      )
		 )
	     )
	   )
	   (send window :String-Out string start)
       )
  )
)

(defun unparse-documentation (documentation continuation)
"Takes the documentation of a command and unparses it (it may be in some strange
format).  Continuation is used for documentation being a string to fill it
to the output stream.
"
  (typecase documentation
    (string (funcall continuation documentation))
    (cons (mapcar #'(lambda (x) (unparse-documentation x continuation))
		  documentation
	  )
    )
    (symbol (unparse-documentation (symbol-value documentation) continuation))
    (otherwise (yw-warn "Cannot parse documentation ~S" documentation))
  )
)


(defun Format-Command
       (command &optional (typed-commands-only t) (verbose-p nil))
"Given a command, formats it to standard-output.  If typed-commands-only is
true then it only shows the command names, not keystrokes for the commands.
If verbose-p is true then more stuff gets printed out.
"
  (let ((str
	  (if typed-commands-only
	      (if (send command :keys)
		  (format nil "~&~C~{, ~C~}:	~A~{, ~A~}:	~A"
			  (first (yw-zwei:flatten (send command :keys)))
			  (rest (yw-zwei:flatten (send command :keys)))
			  (first (first (send command :Names)))
			  (rest (mapcar #'first (send command :Names)))
			  (send command :Description)
		  )
		  (format nil "~&~A~{, ~A~}:	~A"
			  (first (first (send command :Names)))
			  (rest (mapcar #'first (send command :Names)))
			  (send command :Description)
		  )
	      )
	      (format nil "~&~A:	~A~{, ~A~}:	~A"
		      (or (send command :keys) "")
		      (first (first (send command :Names)))
		      (rest (mapcar #'first (send command :Names)))
		      (send command :Description)
	      )
	  )
	)
       )
       (if str
	   (progn (Layout-String-In-Window str 0 0 0 *standard-output*)
		  (terpri)
		  (if (get command :Short-forms)
		      (format t "	Short form~P: ~A~{, ~A~}~%"
			      (length (get command :Short-forms))
			      (first (get command :Short-forms))
			      (rest (get command :Short-forms))
		      )
		      nil
		  )
		  (if verbose-p
		      (progn (terpri)
			     (Unparse-Documentation
			       (send command :Documentation)
			       #'(lambda (str)
				   (terpri)
				   (Layout-String-In-Window
				     str 0 0 0 *standard-output*
				   )
				 )
			     )
		      )
		  )
	   )
	   (format *standard-output*
		   "~&Couldn't find documentation for ~S"
		   (send command :Name)
	   )
       )
  )
)

;;; Puts a wrapper on basic help for YW.
(defadvise tv:rh-com-basic-help (:yw-help) ()
  (declare (special *command-stack*))
  (if (boundp '*mailer*)
      (let ((tv:rubout-handler nil))
	   (multiple-value-bind
	     (ignore ignore completions)
	       (tv:yw-rh-complete-word
		 :recognition '(tv:complete-lisp-atom :Auto-Complete-P) t t
	       )
	     (let ((commands
		     (loop for compl in completions
			   for command =
			   (send
			     (symbol-value (first (send self :Typein-Modes)))
			     :Get-Command-For-String compl
			   )
			   when command collect command
		     )
		   )
		  )
		  (si:with-help-stream
		    (*standard-output* :label "Help" :superior *mailer*)
		    (if (boundp '*command-stack*)
			(progn (loop for command in commands do
				     (Format-Command command)
			       )
			       (Format-Command (first *command-stack*) nil t)
			)
			(if commands
			    (loop for command in commands do
				  (Format-Command command)
			    )
			    (Looping-Through-Command-Tables (table nil nil)
			      (looping-through-commands (command table)
				(format-command command)
			      )
			    )
			)
		    )
		  )
		  (clean-up-rh *standard-input*)
	     )
	   )
      )
      :Do-It
  )
)


;-------------------------------------------------------------------------------