;;; -*- Mode:Common-Lisp; Package:YW-ZWEI; 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.

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

;-------------------------------------------------------------------------------
;;; Mail type indentation...


(defun insert-spaces (tab-over)
"Inserts a bunch of spaces at point."
  (loop for i from 1 to tab-over
	do (let ((*last-command-char* #\space))
		(com-self-insert)
	   )
  )
)

(defun insert-char (char)
"Inserts a char in the font of the last char inserted."
  (let ((*last-command-char* char))
       (let ((*font* (char-font *last-command-char*)))
	    (com-self-insert)
       )
  )
)

(defun insert-string (string &optional (tab-over 0))
"Inserts a string at point tabbing over first by tab-over spaces."
  (if (equal (length (the string string)) 0)
      :nothing
      (progn (insert-spaces tab-over)
	     (loop for i from 0 to (- (length (the string string)) 1)
		   do (let ((*last-command-char*
			      (if (numberp (aref string i))
				  (int-char (aref string i))
				  (aref string i)
			      )
			    )
			   )
			   (let ((*font* (char-font *last-command-char*)))
			        (com-self-insert)
			   )
			   (if (and (equal *last-command-char* #\newline)
				    (not (equal
					   i (- (length (the string string)) 1)
					 )
				    )
			       )
			       (insert-spaces tab-over)
			       nil
			   )
		      )
	     )
	     (bp-line (point))
      )
  )
)

(defun show-region (start-line stop-line)
"Just a debug that prints out the lines between start-line and stop-line."
  (format t "~&-------------------------------------------------------------~&")
  (do-lines ()
    (terpri)
    (princ line)
  )
  (format t "~&-------------------------------------------------------------~&")
)

(defun ch-equal (a b)
"A safe version of char-equal."
  (and (characterp a) (characterp b) (char-equal a b))
)

(defun start-of-text (start-line stop-line)
"Finds the first non blank (whitespace) line below start-line and returns it."
  (let ((text-line start-line))
       (do-lines ()
	 (if (string-search-not-set *whitespace-chars* line)
	     (progn (setq text-line line)
		    (return)
	     )
	 )
       )
       text-line
  )
)

(defun stop-of-text (start-line stop-line)
"Finds the first non blank (whitespace) line below stop-line and returns it."
  (let ((text-line stop-line))
       (do-lines ()
	 (if (string-search-not-set *whitespace-chars* line)
	     (setq text-line line)
	     nil
	 )
       )
       text-line
  )
)

(defun blank-line-p (line)
"Is true if the line contains only whitespace."
  (not (string-search-not-set *whitespace-chars* line))
)

(defun first-text-char (line)
"Returns the index of the first non-whitespace char on the line."
  (let ((index (string-search-not-set *whitespace-chars* line)))
       (if index (aref line index) nil)
  )
)

(defun looks-like-lisp-p (start-line stop-line)
"Is true if the region between start-line and stop-line looks like
it might be lisp code.  This is said to be the case if there is
a line starting with an open paren.
"
  (if (ch-equal (first-text-char start-line) #\()
      t
      (let ((found-p nil))
	   (do-lines ()
	     (if (ch-equal (first-text-char line) #\()
		 (setq found-p t)
		 nil
	     )
	   )
	   found-p
      )
  )
)

(defun ask-if-lisp (start-line stop-line)
"asks the user whether the region specified by start-line and stop-line
is a piece of lisp code to regrind.  Pops up a mouse confirm to do it.
"
  (let ((line1
	  (string-trim *whitespace-chars* (start-of-text start-line stop-line))
	)
	(line2
	  (string-trim *whitespace-chars* (stop-of-text  start-line stop-line))
	)
       )
       (ignore line1 line2)
       (tv:mouse-confirm
	 (with-output-to-string (str)
	   (format str "Regrind the following interval as lisp?")
	   (loop with count = 0
		 with line = start-line
		 until (or (= count 4)
			   (equalp "" line)
			   (equal line stop-line)
		       )
		 do (format str "~&~A" line)
		    (setq line (line-next line))
		    (setq count (+ 1 count))
		 finally
		 (if (= count 4)
		     (progn (format str "...")
			    (format str "~&~A" stop-line)
		     )
		     nil
		 )
	   )
	 )
       )
;       (tv:mouse-confirm
;	 (format nil "Regrind the interval [~A  ~A] as lisp?"
;		 (subseq line1 0 20)
;		 (subseq line2 (max 0 (- (length line2) 20)))
;	 )
;       )
  )
)

(defun Rejustify-Interval
       (start-line stop-line start-indent new-indent old-stop-line)
"Rejustifies the intervall between start-line and stop-line.  Start-indent is
the existing indent on the lines in the region that we have already deduced.
New-indent is the indent that we will put in front of the existing indent on
each line.
"
  (let ((*fill-column* (- *fill-column*
			  (* (tv:font-char-width (send *window* :current-font))
			     (+ (length (the string start-indent))
				(length (the string new-indent))
			     )
			  )
		       )
	)
	(*fill-prefix* "")
	(bp1 (create-bp start-line 0))
	(bp2
	  (create-bp stop-line (max 0 (- (length (the string stop-line)) 1)))
	)
	(lisp-bp2
	  (create-bp old-stop-line
		     (max 0 (- (length (the string old-stop-line)) 1))
	  )
	)
	(lisp-p
	  (looks-like-lisp-p (start-of-text start-line stop-line) stop-line)
	)
       )
       (if (and yw:*enable-regrinding-lisp-regions-whilst-indenting*
	        (or (and (equal lisp-p :maybe)
			 (ask-if-lisp start-line stop-line)
		    )
		    (and lisp-p
			 (or *automatically-regrind-lisp-like-code*
			     (ask-if-lisp start-line stop-line)
			 )
		    )
		)
	   )
	   (multiple-value-bind (new-bp1 new-bp2)
	       (grind-form bp1 lisp-bp2 *standard-output* *fill-column*)
	     (insert-char #\newline)
	     (values new-bp1 new-bp2)
	   )
	   (progn (fill-interval bp1 bp2 t nil)
		  (values bp1 bp2)
	   )
       )
  )
)

(defun delete-forward ()
       "Delete one or more characters forward." ()
  (let ((point (point)))
       (let ((bp (forward-char point *numeric-arg*)))
	    (cond ((null bp)
		   (barf))
		  ((eq (bp-line point) (bp-line bp))
		   (zwei:must-redisplay *window* dis-line
					(bp-line bp)
					(min (bp-index bp) (bp-index point))
		   )
		  )
		  (t (zwei:must-redisplay *window* dis-text)))
	    (delete-interval bp point)
       )
  )
)


(defun Rejustify-Component
       (start-line stop-line start-indent new-indent old-stop-line)
"Rejustifies a component of the buffer denoted by start-line and stop-line.
Start-indent is the indent that we have already deduced is present on each
line of the region.  New-indent is the indent that we will put in front of
each line.  It does this separately for each paragraph in the region.
"
  (do-lines ()
    (move-bp (point) line 0)
    (let ((*numeric-arg* (length (the string start-indent)))
	  (*numeric-arg-p* t)
	 )
         (delete-forward)
    )
  )
  (multiple-value-bind (one two)
    (do-paragraphs ()
      (Rejustify-Interval
	start-line stop-line start-indent new-indent old-stop-line
      )
    )
    (let ((start-line (bp-line one))
	  (stop-line  (bp-line two))
	 )
	 (do-lines ()
	   (move-bp (point) line 0)
	   (insert-string start-indent)
	 )
    )
  )
)


(defun indent-prefices-1 (line start prefices all-prefices)
"Starting at the start index Start it looks along Line for a prefix in the list
of prefices All-prefices.  It returns a string of all of the prefixes that we
foud.
"
  (if prefices
      (if (and (not (equal "" (first prefices)))
	       (lisp:search (first prefices) line
			    :start2 start
			    :end2 (+ start (length (first prefices)))
	       )
	  )
	  (string-append (first prefices)
			 (indent-prefices-1 line
					    (+ start (length (first prefices)))
					    all-prefices
					    all-prefices
			 )
	  )
	  (if (equal line "")
	      ""
	      (indent-prefices-1 line start (rest prefices) all-prefices)
	  )
      )
      ""
  )
)

(defun indent-prefices (line)
"Returns a string for all of the indent prefices used on this line."
  (indent-prefices-1 line 0
		     *mail-reply-indent-prefix-strings*
		     *mail-reply-indent-prefix-strings*
  )
)

(defun find-next-line-to-rejustify (start-line stop-line start-indent)
"Finds the next line in the region between start-line and stop-line at which we
should restart justification.  It does this by looking for a line that has a
different indent prefix from that specified by start-indent.
"
  (or (do-lines ()
	(if (not (equalp (indent-prefices line) start-indent))
	    (return line)
	    nil
	)
      )
      stop-line
  )
)

(defun rejustify-region (start-line stop-line new-indent)
"Rejustifies a region between start-line and stop-line by adding new-indent
to the front of every line, filling as appropriate.
"
  (let ((start-indent (indent-prefices start-line)))
       (let ((next-line
	       (find-next-line-to-rejustify start-line stop-line start-indent)
	     )
	    )
	    (rejustify-component
	      start-line next-line start-indent
	      new-indent stop-line
	    )
	    (if (eq next-line stop-line)
		nil
		(rejustify-region (find-text-line next-line stop-line)
				  stop-line new-indent
		)
	    )
       )
  )
)

(defun text-line-p (line)
"Is true if the line contains any non spaces or tab chars."
  (string-search-not-set '(#\space #\tab) line)
)

(defun maybe-insert-reply-prefix (line indent)
"Inserts the indent specified at the beginning of each line that has text
on it.
"
  (if (text-line-p line)
      (progn (move-bp (point) line 0)
	     (insert-string indent)
      )
      nil
  )
)

(defun succ (index list)
"The successor element in the list starting at the element indexed by Index."
  (if (>= (+ 1 index) (length list))
      0
      (+ 1 index)
  )
)

(defun find-text-line (start-line stop-line)
"Finds the first line between start-line and stop-line that has printing text
on it.
"
  (if (eq start-line stop-line)
      stop-line
      (if (text-line-p start-line)
	  start-line
	  (find-text-line (line-next start-line) stop-line)
      )
  )
)


(defun find-common-prefix (prefix start-line)
"Finds the matching substring of prefix that matches the start of start-line."
  (let ((index nil)
	(length (min (length (the string prefix))
		     (length (the string start-line))
		)
	)
       )
       (if (plusp length)
	   (loop for i from 0 to (- length 1)
		 do (if (eql (aref start-line i) (aref prefix i))
			(setq index i)
			(return nil)
		    )
	   )
	   nil
       )
       (if index (subseq prefix 0 (+ 1 index)) nil)
  )
)

(defun look-for-new-prefix (start-line stop-line prefix)
"Looks for a prefix in the region specified by start-line and stop-line."
  (if (eq start-line stop-line)
      prefix
      (if (text-line-p start-line)
	  (let ((new-prefix (find-common-prefix prefix start-line)))
	       (if new-prefix
		   (look-for-new-prefix (line-next start-line)
					stop-line new-prefix
		   )
		   nil
	       )
	  )
	  (look-for-new-prefix
	    (find-text-line start-line stop-line) stop-line prefix
	  )
      )
  )
)

(defun clean-up-new-prefix (prefix all-prefices)
"Given a prefix and the list of all known prefices looks for the prefix in
the list.  When it finds a match it uses the matcning substring of the
prefix in the element in the prefix list.
"
  (if (or (not prefix) (equal "" prefix))
      nil
      (if all-prefices
	  (if (lisp:search (first all-prefices) prefix)
	      (clean-up-new-prefix
		(subseq prefix 0
			(lisp:search (first all-prefices) prefix)
		)
		all-prefices
	      )
	      (clean-up-new-prefix prefix (rest all-prefices))
	  )
	  prefix
      )
  )
)

(defun find-new-indent-1 (start-line stop-line all-prefices ring)
"Finds a new prefix from the prefix list all-prefices to put at the
beginning of each line in the start-line stop-line region.  It either
tries to deduce a prefix (maybe asking the user) or it just picks one
out of the prefix list.
"
  (if (and *try-to-deduce-prefices*
	   (not (eq start-line stop-line))
      )
      (let ((new-start-line (find-text-line start-line stop-line)))
	   (let ((deduced-prefix
		   (clean-up-new-prefix
		     (look-for-new-prefix (line-next new-start-line) stop-line
					  new-start-line
		     )
		     *mail-reply-indent-prefix-strings*
		   )
		 )
		)
	        (if (and deduced-prefix
			 (or *always-use-deduced-prefices*
			     (tv:mouse-confirm
			       (format nil "~&Use ~S as a prefix?"
				       deduced-prefix
			       )
			     )
			 )
		    )
		    (progn (nconc *mail-reply-indent-prefix-strings*
				  (list deduced-prefix)
			   )
			   (find-new-indent
			     (find-text-line start-line stop-line)
			     stop-line all-prefices ring
			   )
		    )
		    (first all-prefices)
		)
	   )
      )
      (first all-prefices)
  )
)

(defun get-index (indices)
"Given a list of index components finds the smallest index."
  (apply #'min
	 (cons most-positive-fixnum (remove nil (mapcar #'first indices)))
  )
)

(defun make-indices (prefices all-prefices)
"Returns a list of index points in the all-prefices list that says whether
the prefix was present in the list prefices and if so at what index.
"
  (mapcar #'(lambda (x)
	      (list (lisp:search x prefices)
		    (position x all-prefices)
	      )
	    )
	    all-prefices
  )
)

(defun read-new-indent ()
"Reads in a new indent prefix string from the user."
  (let ((prefix (if *selected-prefix*
		    (let ((string
			    (prompt-and-read :string
			      "~&Prefix to use (default ~S):" *selected-prefix*
			    )
			  )
			 )
			 (if (equal "" string) *selected-prefix* string)
		    )
		    (prompt-and-read :string "~&Prefix to use:")
		)
	)
       )
       (if (member prefix *mail-reply-indent-prefix-strings* :test #'equalp)
	   nil
	   (nconc *mail-reply-indent-prefix-strings* (list prefix))
       )
       prefix
  )
)

(defun find-new-indent (start-line stop-line all-prefices ring)
"If numeric arg is negative then it reads in a new indent prefix, otherwise it
finds out which prefix out of the prefix ring was used at the beginning
of the line and picks the next one in the prefix ring.
"
  (if (and *numeric-arg-p* (minusp *numeric-arg*))
      (read-new-indent)
      (if *selected-prefix*
	  *selected-prefix*
	  (let ((line (find-text-line start-line stop-line)))
	       (let ((prefices (indent-prefices line)))
		    (let ((indices (make-indices prefices all-prefices))
			  (indices-ring (make-indices prefices ring))
			 )
			 (let ((min (get-index indices))
			       (min-ring (get-index indices-ring))
			      )
			      (if (assoc min-ring indices-ring)
				  (nth (succ (second
					       (assoc min-ring indices-ring)
					     )
					     ring
				       )
				       ring
				  )
				  (if (assoc min indices)
				      (first ring)
				      (find-new-indent-1
					start-line stop-line all-prefices ring
				      )
				  )
			      )
			 )
		    )
	       )
	  )
      )
  )
)

(defun get-new-fill-column ()
"Computes a new fill column using the right margin specified for mail replies."
  (if (> (/ *fill-column* (tv:font-char-width (send *window* :current-font)))
	 *mail-reply-indent-rejustify-right-margin*
      )
      (* (tv:font-char-width (send *window* :current-font))
	 *mail-reply-indent-rejustify-right-margin*
      )
      *fill-column*
  )
)

(defun lines-overflow-p (start-line stop-line new-indent)
"Is true if the insertion of the new indent will make any of the lines
on the region specified by start-line and stop-line overflow the right
margin specified by *mail-reply-indent-rejustify-right-margin*.
"
  (and *mail-reply-indent-rejustify-right-margin*
       (do-lines ()
	 (if (>= (+ (length (the string new-indent)) (length (the string line)))
		 *mail-reply-indent-rejustify-right-margin*
	     )
	     (return t)
	     nil
	 )
	     
       )
  )
)

(defun indent-for-mail-reply-1 (start-line stop-line)
"Inserts a new indentation level for a mailer reply between start-line
and stop-line.  Looks to see if the insertion of the indent will make
any lines in the region overflow the right margin.  If it does then
(conditionally) it refills the region stripping off any prefices on
the lines, refilling and then putting the indent back at the beginning
of each line along with a new prefix.
"
  (let ((new-indent (find-new-indent start-line stop-line
				     *mail-reply-indent-prefix-strings*
				     *mail-reply-indent-prefix-string-ring*
		    )
	)
	(*fill-column* (get-new-fill-column))
	(*numeric-arg-p* nil)
	(*numeric-arg* 1)
       )
       (let ((overflow (lines-overflow-p start-line stop-line new-indent)))
	    (let ((rejustify
		    (and overflow
			 (or *automatic-rejustify-overflowing-replies*
			     (tv:mouse-confirm
			       (with-output-to-string (str)
				 (format str "~&Rejustify region:~%")
				 (loop with count = 0
				       with line = start-line
				       until (or (= count 4)
						 (equalp "" line)
						 (equal line stop-line)
					     )
				       do (format str "~&~A" line)
				          (setq line (line-next line))
					  (setq count (+ 1 count))
				       finally
				       (if (= count 4) (format str "...") nil)
				 )
			       )
			     )
			 )
		    )
		  )
		 )
		 (if rejustify
		     (rejustify-region start-line stop-line new-indent)
		     nil
		 )
		 (do-lines ()
		   (maybe-insert-reply-prefix line new-indent)
		 )
	    )
       )
  )
)

(defcom com-indent-for-mail-reply
 "Indent the region for a mail reply and makr the start of each line." ()
  (region-lines (start-line stop-line)
    (loop for i from 1 to (if (and *numeric-arg-p* (> *numeric-arg* 1))
			      *numeric-arg*
			      1
			  )
	  do (indent-for-mail-reply-1 start-line stop-line)
    )
  )
  dis-all
)

;;; Install the indent command o nthe M-+ keystroke.
(tv:install-zmacs-commmand '(#\m-+ com-indent-for-mail-reply))

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

(defcom com-add-mail-indent-prefix "Adds a new prefix to the list of mail
indent prefices." ()
  (format *query-io* "~&New prefix string (default is ~S:"
	  (subseq (bp-line (point)) 0 (bp-index (point)))
  )
  (let ((new-string (read-line *query-io*)))
       (pushnew (if (equal (length (the string new-string)) 0)
		    (subseq (bp-line (point)) 0 (bp-index (point)))
		    new-string
		)
		*mail-reply-indent-prefix-strings*
		:test #'equalp
       )
  )
  dis-none
)

;;; Add the command.
(set-comtab *standard-comtab* nil
   (make-command-alist '(com-add-mail-indent-prefix))
)

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

(defcom com-remove-mail-indent-prefix "Remove a new prefix from the list of mail
indent prefices." ()
  (let ((prefix (completing-read-from-mini-buffer
		    (if (and *selected-prefix* (stringp *selected-prefix*))
			(format nil "Prefix to remove (Default ~S):"
				*selected-prefix*
			)
			"Prefix to select:"
		    )
		    (mapcar #'(lambda (x) (cons x x))
			    *mail-reply-indent-prefix-strings*
		    )
		    nil
		)
	)
       )
       (setq *mail-reply-indent-prefix-strings*
	     (remove (if (consp prefix)
			 (first prefix)
			 *selected-prefix*
		     )
		     *mail-reply-indent-prefix-strings*
		     :test #'equalp
	     )
       )
       (if (equal *selected-prefix* (if (consp prefix)
					(first prefix)
					*selected-prefix*
				    )
	   )
	   (setq *selected-prefix* nil)
	   nil
       )
  )
  dis-none
)

;;; Add the command.
(set-comtab *standard-comtab* nil
   (make-command-alist '(com-remove-mail-indent-prefix))
)

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

(defcom com-select-mail-indent-prefix "Select a prefix from the list of mail
indent prefices.  Numeric arg cancels selection." ()
  (if *numeric-arg-p*
      (setq *selected-prefix* nil)
      (let ((prefix (completing-read-from-mini-buffer
			(if (and *selected-prefix* (stringp *selected-prefix*))
			    (format nil "Prefix to select (Default ~S):"
				    *selected-prefix*
			    )
			    "Prefix to select:"
			)
			(mapcar #'(lambda (x) (cons x x))
				*mail-reply-indent-prefix-strings*
			)
			t
		    )
	    )
	   )
	   (setq *selected-prefix*
		 (if (consp prefix)
		     (first prefix)
		     (if (stringp prefix)
			 (progn
			   (format *query-io* "Adding ~S to prefix list" prefix)
			   (push prefix *mail-reply-indent-prefix-strings*)
			   prefix
			 )
			 (barf "Cannot select ~S" prefix)
		     )
		 )
	   )
      )
  )
  dis-none
)

;;; Add the command.
(set-comtab *standard-comtab* nil
   (make-command-alist '(com-select-mail-indent-prefix))
)

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