;;; Lisp Machine mail reader -*- Mode:LISP; Package:ZWEI; Base:8 ; Readtable : ZL-*- 
;;; Some special ZMAIL windows, definition are in DEFS
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **

(DEFFLAVOR ZMAIL-OVERLYING-WINDOW () (EDITOR-STREAM-WINDOW)
  (:DEFAULT-INIT-PLIST :MORE-P NIL))

(DEFMETHOD (ZMAIL-OVERLYING-WINDOW :DELETE-TEXT) ()
  (SYS:%USING-BINDING-INSTANCES (CLOSURE-BINDINGS EDITOR-CLOSURE))
  (DELETE-INTERVAL *INTERVAL*)
  (MUST-REDISPLAY SELF DIS-ALL))

(DEFMETHOD (ZMAIL-OVERLYING-WINDOW :MOVE-TO-END) ()
  (SYS:%USING-BINDING-INSTANCES (CLOSURE-BINDINGS EDITOR-CLOSURE))
  (MOVE-BP *STREAM-BP* (INTERVAL-LAST-BP *INTERVAL*))
  (MUST-REDISPLAY SELF DIS-BPS)
  (STREAM-REDISPLAY))

(DEFMETHOD (ZMAIL-OVERLYING-WINDOW :VIEW-STREAM) (STREAM
						  &OPTIONAL RETURN-IF-NO-MORE
						  &AUX (*STANDARD-INPUT* SI:SYN-TERMINAL-IO)
						       (*TERMINAL-IO* *STREAM-SHEET*))
  (SYS:%USING-BINDING-INSTANCES (CLOSURE-BINDINGS EDITOR-CLOSURE))
  ;; If everything has been typed out correctly, update the window datastructure
  (AND (< (WINDOW-REDISPLAY-DEGREE *WINDOW*) DIS-TEXT)
       (FAKE-OUT-TOP-LINE *WINDOW* *INTERVAL*))
  (VIEW-WINDOW *WINDOW* STREAM RETURN-IF-NO-MORE))

(DEFMETHOD (ZMAIL-OVERLYING-WINDOW :TRUNCATED-FORMAT) (&REST FORMAT-ARGS)
  (UNWIND-PROTECT
    (PROGN
      (SETF (TV:SHEET-TRUNCATE-LINE-OUT-FLAG) 1)
      (AND (*CATCH 'LINE-OVERFLOW
	     (PROG1 NIL
	       (APPLY 'FORMAT SELF FORMAT-ARGS)))
	   (LET ((LINE (BP-LINE *STREAM-BP*)))
	     (MULTIPLE-VALUE-BIND (NIL NIL I)
		 (TV:SHEET-COMPUTE-MOTION SELF 0 0 LINE 0 NIL NIL
					  TV:(- CURSOR-X (SHEET-INSIDE-LEFT)) 0)
	       (LET ((*INTERVAL* INTERVAL))
		 (AND I (DELETE-INTERVAL (CREATE-BP LINE I) (END-OF-LINE LINE))))))))
    (SETF (TV:SHEET-TRUNCATE-LINE-OUT-FLAG) 0)))

(DEFMETHOD (ZMAIL-OVERLYING-WINDOW :BEFORE :END-OF-LINE-EXCEPTION) ()
  (OR (ZEROP (TV:SHEET-TRUNCATE-LINE-OUT-FLAG))
      (*THROW 'LINE-OVERFLOW T)))

(DEFFLAVOR TRUNCATING-MOUSE-SENSITIVE-ITEMS ((TRUNCATE-P NIL)) ()
  (:REQUIRED-FLAVORS TV:BASIC-MOUSE-SENSITIVE-ITEMS))

(DEFMETHOD (TRUNCATING-MOUSE-SENSITIVE-ITEMS :TRUNCATED-ITEM) (TYPE ITEM &REST FORMAT-ARGS)
  ;; Do this before recording the Y position in case of more processing and wraparound
  (SEND SELF :HANDLE-EXCEPTIONS)
  (LET ((ENTRY (LIST TYPE ITEM TV:CURSOR-X TV:CURSOR-Y TV:(SHEET-INSIDE-RIGHT)
		     TV:(+ CURSOR-Y LINE-HEIGHT))))
    (PUSH ENTRY TV:ITEM-LIST)
    (*CATCH 'LINE-OVERFLOW
      (LET-GLOBALLY ((TRUNCATE-P T))
	(IF FORMAT-ARGS (APPLY 'FORMAT SELF FORMAT-ARGS) (PRINC ITEM SELF))
	(SETF (FIFTH ENTRY) TV:CURSOR-X)))))

(DEFMETHOD (TRUNCATING-MOUSE-SENSITIVE-ITEMS :BEFORE :END-OF-LINE-EXCEPTION) ()
  (AND TRUNCATE-P
       (*THROW 'LINE-OVERFLOW T)))

(DEFFLAVOR ZMAIL-TYPEOUT-WINDOW () (TRUNCATING-MOUSE-SENSITIVE-ITEMS EDITOR-TYPEOUT-WINDOW
				    ARROW-PRINTING-MIXIN)
  (:DEFAULT-INIT-PLIST :ITEM-TYPE-ALIST *ZMAIL-TYPEOUT-ITEM-ALIST*))

(DEFMETHOD (ZMAIL-TYPEOUT-WINDOW :MORE-TYI) ()
  (DO ((CH)) (NIL)
    (AND (OR (NUMBERP (SETQ CH (SEND SELF :ANY-TYI)))
	     (AND (CONSP CH)
		  (MEMQ (CAR CH) '(:TYPEOUT-EXECUTE SUMMARY-EXECUTE :MENU :MOUSE
				   SUMMARY-MOUSE MODE-LINE :MOUSE-BUTTON))))
	 (RETURN CH))))

(DEFFLAVOR ZMAIL-WHO-LINE-OVERRIDE-MIXIN
	((WHO-LINE-OVERRIDE-DOCUMENTATION-STRING NIL))
	()
  (:REQUIRED-FLAVORS TV:SHEET)
  :SETTABLE-INSTANCE-VARIABLES)

(DEFMETHOD (ZMAIL-WHO-LINE-OVERRIDE-MIXIN :OVERRIDE :WHO-LINE-DOCUMENTATION-STRING) ()
  (AND (SEND SELF :WHO-LINE-OVERRIDE-P)
       WHO-LINE-OVERRIDE-DOCUMENTATION-STRING))

(DEFMETHOD (ZMAIL-WHO-LINE-OVERRIDE-MIXIN :WHO-LINE-OVERRIDE-P) ()
  T)

(DEFFLAVOR ZMAIL-WINDOW () (ZWEI-WINDOW
			    ZMAIL-WHO-LINE-OVERRIDE-MIXIN)
  (:DEFAULT-INIT-PLIST :ITEM-TYPE-ALIST *ZMAIL-TYPEOUT-ITEM-ALIST*
    :TYPEOUT-WINDOW `(ZMAIL-TYPEOUT-WINDOW)))

(DEFMETHOD (ZMAIL-WINDOW :BEFORE :INIT) (IGNORE)
  (SETQ TV:TYPEOUT-WINDOW `(ZMAIL-TYPEOUT-WINDOW :IO-BUFFER ,TV:IO-BUFFER))
;; Is this the right place for this? -rpp
  (setq base-tick 0))


(DEFMETHOD (ZMAIL-WINDOW :AFTER :INIT) (IGNORE)
  (PUSH SELF *ALL-ZMAIL-WINDOWS*))

(DEFMETHOD (ZMAIL-WINDOW :BEFORE :KILL) ()
  (SETQ *ALL-ZMAIL-WINDOWS*
	(DELQ SELF *ALL-ZMAIL-WINDOWS*))
  (SETQ *EDITORS-WHOSE-MODES-TO-RESET*
	(DELQ EDITOR-CLOSURE *EDITORS-WHOSE-MODES-TO-RESET*)))

(DEFMETHOD (ZMAIL-WINDOW :SET-EDITOR-CLOSURE) (NEW-CLOSURE)
  (SETQ EDITOR-CLOSURE NEW-CLOSURE))

(DEFMETHOD (ZMAIL-WINDOW :FUNCALL-INSIDE-YOURSELF) (FUNCTION &REST ARGS)
  (APPLY EDITOR-CLOSURE FUNCTION ARGS))

(DEFMETHOD (ZMAIL-WINDOW :MOUSE-CLICK) (BUTTON X Y)
  (COND ((AND (= BUTTON #/MOUSE-1-1)
	      (NOT (SEND (SEND SELF :ALIAS-FOR-SELECTED-WINDOWS)
			 :SELF-OR-SUBSTITUTE-SELECTED-P)))
	 (TV:MOUSE-SELECT TV:SUPERIOR)
	 T)
	((AND (NOT (EDITOR-WINDOW-SELECTED-P SELF))
	      (= BUTTON #/MOUSE-1-1))
	 (COMMAND-BUFFER-PUSH `(SELECT-WINDOW ,SELF))
	 T)
	(T (COMMAND-BUFFER-PUSH `(:MOUSE-BUTTON ,BUTTON ,SELF ,X ,Y)) T)))

(DEFMETHOD (ZMAIL-WINDOW :TOP-LEVEL-P) () T)

(DEFMETHOD (ZMAIL-WINDOW :TOP-OF-EDITOR-HIERARCHY) ()
  (SEND TV:SUPERIOR :TOP-OF-EDITOR-HIERARCHY))

(DEFMETHOD (ZMAIL-WINDOW :MODE-LINE-WINDOW) ()
  (SEND TV:SUPERIOR :MODE-LINE-WINDOW))

(DEFMETHOD (ZMAIL-WINDOW :HEADER-WINDOW-HEIGHT) (&REST IGNORE)
  (+ TV:TOP-MARGIN-SIZE TV:BOTTOM-MARGIN-SIZE
     (* TV:LINE-HEIGHT (COUNT-LINES INTERVAL))))

(DEFMETHOD (ZMAIL-WINDOW :BEFORE :EDIT) (&REST IGNORE)
  (MAKE-WINDOW-CURRENT SELF)
  (SETQ BASE-TICK (TICK))
  (SELECT-WINDOW SELF))

(DEFMETHOD (ZMAIL-WINDOW :AROUND :EDIT) (CONT MT ARGS &REST IGNORE)
  (SYS:%BIND (LOCF (TV:BLINKER-DESELECTED-VISIBILITY POINT-BLINKER))
	     :ON)
  (LET-GLOBALLY ((WHO-LINE-OVERRIDE-DOCUMENTATION-STRING NIL))
    (LET ((*SELECTABLE-MODE-LINE-ELEMENTS* NIL))
      (AROUND-METHOD-CONTINUE CONT MT ARGS))))

;;; >> The :PROCESS-SPECIAL-COMMAND really ought to use :OR method combination, so that
;;; there's no need to use :AROUND methods to call the original ZWEI:ZWEI-WINDOW method for
;;; this, which handles the special commands like scrolling and so on.
(defmethod (zmail-window :around :process-special-command)
	   (cont mt args &rest ignore)	;used to have TYPE arg after ARGS.
  (let ((item (cdr args)))
    (cond ((and (listp item)
		(eq (car item) :menu))		; blip type
	   (let ((name (caadr item)))
	     ;; We really can't handle menu commands when we're composing mail or replying, because
	     ;; many of the commands refer to the current messsage, and so on.
	     (barf "~&You can't use the ~A menu command here." (or name ""))))
	  ((and (listp item)
		(eq (car item) 'read-background-response-queue))
	   ;;Gross crock!  This command manages to filter through here, and ZWEI doesnt have
	   ;; a handler, so it bombs.  Right thing is to ignore it here so it filters
	   ;; thru the main loop.  --rg 12/08/86
	   nil)
	  (t (lexpr-funcall-with-mapping-table cont mt args)))))

(DEFMETHOD (ZMAIL-WINDOW :EDITOR-WINDOWS) ()
  (SEND TV:SUPERIOR :EDITOR-WINDOWS))

;;; Make the mode line correct when inside reply edit
(DEFMETHOD (ZMAIL-WINDOW :AFTER :RESELECT) ()
  (SETQ *ZMAIL-INTERVAL-NAME* (SEND INTERVAL `:SEND-IF-HANDLES :NAME))
  (AND *INSIDE-MAIL*
       (SETQ *END-SENDS-MESSAGE-P* (NEQ SELF *DRAFT-HEADER-WINDOW*))))

;;; Stuff related to the summary window
(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-CONFIGURE (STRING)
  (FORMAT STRING "Change window configuration:  L: ~A; R: menu."
	  (NAME-FROM-MENU-VALUE (IF (EQ *WINDOW-CONFIGURATION* :BOTH)
				    :MSG :BOTH)
				*WINDOW-CONFIGURATION-ALIST*)))

(DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-CONFIGURE "Change window configuration.
Left both summary and message displayed.
Right gives menu of window configurations." (NO-ZMAIL-BUFFER-OK)
  (LET ((CONFIG (COND ((EQ *ZMAIL-COMMAND-BUTTON* :RIGHT)
		       (OR (TV:MENU-CHOOSE *WINDOW-CONFIGURATION-ALIST*
					   NIL (RECTANGLE-NEAR-COMMAND-MENU TV:MOUSE-SHEET))
			   (ABORT-CURRENT-COMMAND)))
		      ((EQ *WINDOW-CONFIGURATION* :BOTH)
		       :MSG)
		      (T
		       :BOTH))))
    (SET-MAIN-WINDOW-CONFIGURATION CONFIG))
  DIS-NONE)

(DEFUN SET-MAIN-WINDOW-CONFIGURATION (CONFIG &OPTIONAL FORCE-P)
  (COND ((OR (NEQ CONFIG *WINDOW-CONFIGURATION*) FORCE-P)
	 (SEND *ZMAIL-WINDOW* :SET-WINDOW-CONFIGURATION CONFIG)
	 (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-CONFIGURE))))

;;; The summary window.

(DEFINE-ZMAIL-GLOBAL *STATUS-LETTER-PROPERTY-ALIST*
  '((DELETED . #\D)
    (ANSWERED . #\A)
    (UNSEEN . #\-)
    (OTHERWISE . #\:))
  "Alist of MSG-STATUS properties vs letter to appear as status in summary.
The first property in this alist which is found on the message wins.")

(DEFUN STATUS-LETTER (STATUS)
  (LOOP FOR (IND . LETTER) IN *STATUS-LETTER-PROPERTY-ALIST*
	WHEN (OR (EQ IND 'OTHERWISE)
		 (GET STATUS IND))
	RETURN LETTER))

;; A summary template contains alternating keywords and arguments.
;; The keywords allowed are :SIZE, :RECIPIENTS, :KEYWORDS, :SUBJECT, :DATE.
;; For :SIZE and :RECIPIENTS, the argument is the number of columns to use.
;; for :DATE, the argument is :DATE, :TIME or :DATE-AND-TIME.
;; :KEYWORDS and :SUBJECT ignore the argument.
(DEFVAR *SUMMARY-WITHOUT-DATE-TEMPLATE*
	'(:SIZE 5 :RECIPIENTS 23. :KEYWORDS T :SUBJECT T)
  "A summary template without the date.")

(DEFVAR *SUMMARY-WITH-DATE-TEMPLATE*
	'(:SIZE 5 :DATE :DATE :RECIPIENTS 23. :KEYWORDS T :SUBJECT T)
  "A summary template with the date.")

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION SET-MSG-SUMMARY-LINE *SUMMARY-WINDOW-LABEL*)

(ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *DEFAULT-SUMMARY-TEMPLATE* SET-MSG-SUMMARY-LINE)

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER SET-MSG-SUMMARY-LINE (STRING)
  (APPEND-TO-ARRAY STRING "   No. ")
  (SET-MSG-SUMMARY-LINE (AND *ZMAIL-BUFFER* (PLUSP (ZMAIL-BUFFER-NMSGS *ZMAIL-BUFFER*))
			     (AREF (ZMAIL-BUFFER-ARRAY *ZMAIL-BUFFER*) 0))
			NIL STRING)
  (AND (SEND *SUMMARY-WINDOW* :EXPOSED-P)
       (NOT (STRING-EQUAL STRING (TV:LABEL-STRING (SEND *SUMMARY-WINDOW* :LABEL))))
       ;;Make a copy of the string for the label, since ours gets ASET here.
       (SEND *SUMMARY-WINDOW* :SET-LABEL (STRING-APPEND STRING)))
  STRING)

;;; Compute the summary line for a message, given the msg and the status plist
;;; If STATUS is nil, we make a heading line instead of a body line,
;;; using the same template.
(DEFUN SET-MSG-SUMMARY-LINE (MSG STATUS &OPTIONAL LINE &AUX TEMPLATE)
  (OR LINE (SETQ LINE (MAKE-SUMMARY-LINE)))
  (SETQ TEMPLATE (OR (AND MSG (GET (LOCF (ZMAIL-BUFFER-OPTIONS (MSG-MAIL-FILE-BUFFER MSG)))
				   :SUMMARY-window-format))
		     *DEFAULT-SUMMARY-TEMPLATE*))
  (COND ((EQ TEMPLATE NIL)
	 (SETQ TEMPLATE *SUMMARY-WITHOUT-DATE-TEMPLATE*))
	((EQ TEMPLATE T)
	 (SETQ TEMPLATE *SUMMARY-WITH-DATE-TEMPLATE*)))
  (LOOP FOR (KEY VAL) ON TEMPLATE BY 'CDDR
	DO (SEND (GET KEY 'SUMMARY-PRINTER) LINE VAL MSG STATUS)
	COLLECT `(,KEY ,VAL ,(SUMMARY-LINE-LENGTH LINE)) INTO TEMP
	FINALLY (SETF (SUMMARY-LINE-TEMPLATE LINE) TEMP))
  (AND STATUS (SETF (MSG-SUMMARY-LINE MSG) LINE))
  LINE)

(DEFVAR *SPACES* "                       "
  "Contains enough spaces to make the date and/or time look nice in ZMail.")

(DEFUN (:SIZE SUMMARY-PRINTER) (LINE COLS MSG STATUS)
  (COND (STATUS
	 (NUMBER-INTO-ARRAY LINE (COUNT-LINES (MSG-INTERVAL MSG)) 10.
			    (SUMMARY-LINE-LENGTH LINE) COLS)
	 (SETF (SUMMARY-LINE-LENGTH LINE) (+ (SUMMARY-LINE-LENGTH LINE) COLS)))
	(T
	 (APPEND-TO-ARRAY LINE "Lines" 0 (MIN COLS 5))
	 (APPEND-TO-ARRAY LINE *SPACES* 0 (MIN (- COLS 5) 0))))
  (VECTOR-PUSH-EXTEND #\Space LINE))

(DEFUN (:DATE SUMMARY-PRINTER) (LINE TYPE IGNORE STATUS &AUX DATE)
  (COND ((NULL STATUS)
	 (AND (MEMQ TYPE '(:DATE :DATE-AND-TIME))
	      (APPEND-TO-ARRAY LINE " Date "))
	 (AND (MEMQ TYPE '(:DATE-AND-TIME :TIME))
	      (APPEND-TO-ARRAY LINE "Time ")))
	((AND (SETQ DATE (CADR (GETL STATUS '(:DATE :DRAFT-COMPOSITION-DATE))))
	      (NOT (STRINGP DATE)))
	 (AND (CONSP DATE) (SETQ DATE (CAR DATE)))
	 (MULTIPLE-VALUE-BIND (NIL MINUTES HOURS DAY MONTH)
	     (TIME:DECODE-UNIVERSAL-TIME DATE)
	   (FORMAT LINE "~:[~2D-~A ~]~:[~2,0D~2,0D ~]"
		   (NOT (MEMQ TYPE '(:DATE :DATE-AND-TIME)))
		   DAY (TIME:MONTH-STRING MONTH :SHORT)
		   (NOT (MEMQ TYPE '(:DATE-AND-TIME :TIME)))
		   HOURS MINUTES)))
	((EQ TYPE :DATE) (APPEND-TO-ARRAY LINE *SPACES* 0 7))
	((EQ TYPE :TIME) (APPEND-TO-ARRAY LINE *SPACES* 0 5))
	((EQ TYPE :DATE-AND-TIME) (APPEND-TO-ARRAY LINE *SPACES* 0 12.))))

(DEFUN (:RECIPIENTS SUMMARY-PRINTER) (LINE SIZE IGNORE STATUS &AUX STR1 STR2 LEN1 LEN2)
  (IF STATUS
      (SETQ STR1 (SUMMARIZE-RECIPIENTS (GET STATUS :FROM) (1- SIZE))
	    STR2 (SUMMARIZE-RECIPIENTS (GET STATUS :TO) (1- SIZE)))
    (SETQ STR1 "From"
	  STR2 "To"))
  (SETQ LEN1 (MIN (MAX (TRUNCATE (1- SIZE) 2)
		       (- SIZE (SETQ LEN2 (STRING-LENGTH STR2)) 1))
		  (STRING-LENGTH STR1))
	LEN2 (MIN (- SIZE LEN1 1) LEN2))
  (APPEND-TO-ARRAY LINE STR1 0 LEN1)
  (APPEND-TO-ARRAY LINE "" 0 1)
  (APPEND-TO-ARRAY LINE STR2 0 LEN2)
  (APPEND-TO-ARRAY LINE *SPACES* 0 (- SIZE (+ LEN1 LEN2)))
  ;(RETURN-ARRAY STR2)
  ;(RETURN-ARRAY STR1)
  )

(DEFUN (:KEYWORDS SUMMARY-PRINTER) (LINE IGNORE IGNORE STATUS &AUX KEYSTR)
    (COND ((AND STATUS (SETQ KEYSTR (GET STATUS 'KEYWORDS-STRING)))
	   (APPEND-TO-ARRAY LINE KEYSTR)
	   (VECTOR-PUSH-EXTEND #\Space LINE))))

(DEFUN (:SUBJECT SUMMARY-PRINTER) (LINE IGNORE MSG STATUS &AUX SUBJ)
  (SETQ SUBJ (GET STATUS :SUBJECT))
  (COND ((NULL STATUS)
	 (SETQ SUBJ "Subject or Text"))
	((get status 'losing-headers)
	 (setq subj "Parsing error"))
	((NULL SUBJ)
	 (SETQ SUBJ (FIRST-TEXT-LINE (MSG-INTERVAL MSG))))
	((CONSP SUBJ)
	 (SETQ SUBJ (CAR SUBJ))))
  (APPEND-TO-ARRAY LINE SUBJ 0 (MIN (STRING-LENGTH SUBJ) 60.)))

(DEFUN UPDATE-MSG-SUMMARY-LINE (MSG FIELD-KEYWORD &AUX OLD-LINE NEW-LINE IDX FIELD)
  (SETQ OLD-LINE (MSG-SUMMARY-LINE MSG))
  (LOOP AS OF = NIL THEN F
	FOR F IN (SUMMARY-LINE-TEMPLATE OLD-LINE)
	WHEN (EQ (CAR F) FIELD-KEYWORD)
	DO (RETURN (SETQ IDX (IF OF (THIRD OF) 0)
			 FIELD F)))
  (COND (FIELD
	 (SETQ NEW-LINE (MAKE-SUMMARY-LINE :MAKE-ARRAY
					   (:LENGTH (SUMMARY-LINE-LENGTH OLD-LINE))))
	 (APPEND-TO-ARRAY NEW-LINE OLD-LINE 0 IDX)
	 (FUNCALL (GET FIELD-KEYWORD 'SUMMARY-PRINTER) NEW-LINE (SECOND FIELD)
		  MSG (LOCF (MSG-STATUS MSG)))
	 (APPEND-TO-ARRAY NEW-LINE OLD-LINE (THIRD FIELD))
	 (LOOP WITH TEMP = (SUMMARY-LINE-TEMPLATE OLD-LINE)
	       FOR ELEM IN TEMP
	       WITH DELTA = NIL
	       WHEN (EQ ELEM FIELD)
	       DO (SETQ DELTA (- (SUMMARY-LINE-LENGTH OLD-LINE)
				 (SUMMARY-LINE-LENGTH NEW-LINE)))
	       WHEN DELTA
	       DO (DECF (THIRD ELEM) DELTA)
	       FINALLY (SETF (SUMMARY-LINE-TEMPLATE NEW-LINE) TEMP))
	 (SETF (MSG-SUMMARY-LINE MSG) NEW-LINE)
	 (SEND *SUMMARY-WINDOW* :NEED-TO-REDISPLAY-MSG MSG))))

;;; Compress a list of recipients
(DEFINE-SITE-HOST-LIST *HOSTS-IGNORED-IN-SUMMARY* :LOCAL-MAIL-HOSTS
  "A list of the hosts that are ignored in summaries.")

(DEFUN SUMMARIZE-RECIPIENTS (LIST MAXL &AUX (STR (MAKE-EMPTY-STRING MAXL)))
  (DO-NAMED THE-LIST
      ((LIST LIST (CDR LIST))
       (PLIST)
       (COMMA NIL)
       (NAME))
      ((NULL LIST))
    (UNLESS (CONSP LIST) (RETURN))
    (SETQ PLIST (LOCF (CAR LIST)))
    (IF COMMA (OR (ARRAY-PUSH STR #/,) (RETURN-FROM THE-LIST)) (SETQ COMMA T))
    (COND ((SETQ NAME (GET PLIST :NAME))
	   (OR (STRING-EQUAL NAME USER-ID)
	       (DO ((I (1+ (or (string-reverse-search-char #/! name) -1)) (1+ I))
		    (LEN (STRING-LENGTH NAME)))
		   (( I LEN))
		 (OR (ARRAY-PUSH STR (AREF NAME I)) (RETURN-FROM THE-LIST))))
	   (DO ((HS (GET PLIST :HOST) (CDR HS)))
	       ((NULL HS))
	     (LET ((HOST (CAR HS)))
	       ;; Stop accumulating names when we run into one we know.
	       (AND (SEND FS:USER-LOGIN-MACHINE :PATHNAME-HOST-NAMEP HOST)
		    (RETURN))
	       (AND (LOOP FOR KNOWN IN *HOSTS-IGNORED-IN-SUMMARY*
			  THEREIS (SEND KNOWN :PATHNAME-HOST-NAMEP HOST))
		    (RETURN))
	       (OR (ARRAY-PUSH STR (IF (CDR HS) #/% #/@))
		   (RETURN-FROM THE-LIST))
	       (DO ((I 0 (1+ I))
		    (LEN (STRING-LENGTH HOST)))
		   (( I LEN))
		 (OR (ARRAY-PUSH STR (AREF HOST I)) (RETURN-FROM THE-LIST))))))))
  STR)

;;; Returns the first line that is likely to be meaningful
(DEFUN FIRST-TEXT-LINE (BP1 &OPTIONAL BP2 IN-ORDER-P)
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (DO ((LINE (BP-LINE BP1) (LINE-NEXT LINE))
       (END-LINE (BP-LINE BP2))
       (STATE :START))
      ((EQ LINE END-LINE) "")
    (COND ((AND (MEMQ STATE '(:START :RESTART))
		(PROBABLE-ITS-HEADER-P LINE))
	   (SETQ STATE :RESTART))
	  ((LINE-BLANK-P LINE)
	   (SETQ STATE :RESTART))
	  ;; Recognize start of *MSG's
	  ((AND (MEMQ STATE '(:START :RESTART))
		(STRING-EQUAL-START LINE "MSG: ")))
	  ((OR (MEMQ STATE '(:START :HEADERS-START))
	       (LET ((COLON (STRING-SEARCH-CHAR #/: LINE)))
		 (AND COLON
		      (ASS 'EQUALP (SUBSTRING LINE
					      (STRING-SEARCH-NOT-SET '(#/SP #/TAB) LINE)
					      COLON)
			     *HEADER-NAME-ALIST*))))
	   (SETQ STATE (IF (MEMQ STATE '(:START :HEADERS-START)) :HEADERS-START :HEADERS)))
	  ;; Recognize Lisp Machine bug reports.  This could perhaps be more general.
	  ((AND (STRING-EQUAL-START LINE "In " (STRING-SEARCH-NOT-SET '(#/SP #/TAB) LINE))
		(STRING-SEARCH " System " LINE))
	   ;; Skip down to the line where the version info ends
	   ;; The following line will be returned.
	   (DO () (())
	     (IF (STRING-SEARCH "microcode " LINE)
		 (RETURN))
	     (IF (EQ (LINE-NEXT LINE) END-LINE)
		 (RETURN))
	     (SETQ LINE (LINE-NEXT LINE))))
	  (T (RETURN LINE)))))

(ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *DEFAULT-SUMMARY-TEMPLATE*
					     CHANGE-MSGS-SUMMARY-LINES)

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER CHANGE-MSGS-SUMMARY-LINES (IGNORE)
  (AND *EXPLICIT-OPTION-UPDATE*			;Only if from profile mode
       (LOOP FOR ZMAIL-BUFFER IN *ZMAIL-BUFFER-LIST*
	     WITH ASKED-P = NIL
	     WHEN (ZMAIL-BUFFER-DISK-P ZMAIL-BUFFER)
	     DO (COND ((NULL ASKED-P)
		       (OR (TYPEOUT-BEEP-YES-OR-NO-P
			     "Also change any summary lines already computed? ")
			   (RETURN (VALUES)))
		       (SETQ ASKED-P T)))
	     (CHANGE-ZMAIL-BUFFER-MSGS-SUMMARY-LINES ZMAIL-BUFFER T))))

(DEFUN CHANGE-ZMAIL-BUFFER-MSGS-SUMMARY-LINES (ZMAIL-BUFFER &OPTIONAL NO-ASK-P)
  (COND ((OR NO-ASK-P
	     (TYPEOUT-BEEP-YES-OR-NO-P "Also change any summary lines already computed? "))
	 (LOOP FOR MSG BEING THE MSGS IN ZMAIL-BUFFER
	       WHEN (MSG-PARSED-P MSG)
	       DO (SET-MSG-SUMMARY-LINE MSG (ASSURE-MSG-PARSED MSG)))
	 (SEND *SUMMARY-WINDOW* :NEED-FULL-REDISPLAY))))

(DEFFLAVOR ARROW-PRINTING-MIXIN () ()
  (:REQUIRED-FLAVORS TV:STREAM-MIXIN))

(DEFMETHOD (ARROW-PRINTING-MIXIN :PRINT-ARROW) (TYPE &AUX CH)
  (SETQ CH (CASE TYPE
	     ((:CURRENT T) #\_)
	     (:MARKED #\x)))
  (TV:PREPARE-SHEET (SELF)
    (SYS:%DRAW-CHAR FONTS:NARROW CH TV:CURSOR-X TV:CURSOR-Y TV:CHAR-ALUF SELF)
    (TV:SHEET-INCREMENT-BITPOS SELF TV:CHAR-WIDTH 0)))

(DEFFLAVOR ZMAIL-SUMMARY-TYPEOUT-WINDOW () (ZMAIL-TYPEOUT-WINDOW))

;;; Normal scroll redisplay is the one that knows about the typeout window
(DEFMETHOD (ZMAIL-SUMMARY-TYPEOUT-WINDOW :AFTER :MAKE-COMPLETE) ()
  (SEND TV:SUPERIOR :NEED-FULL-REDISPLAY))

;; Copied from LAD: RELEASE-3.ZMAIL; WINDOW.LISP#349 on 2-Oct-86 03:00:49
(DEFFLAVOR ZMAIL-SUMMARY-SCROLL-WINDOW
	((CURRENT-ZMAIL-BUFFER NIL)
	 (CURRENT-MSG NIL)
	 (MSGS-TO-BE-REDISPLAYED NIL)
	 (RECENTER-P NIL)
	 (LAST-DISPLAYED-TOP-ZMAIL-BUFFER NIL))
	(TV:BORDERS-MIXIN TV:TOP-BOX-LABEL-MIXIN
	 ARROW-PRINTING-MIXIN TV:SCROLL-MOUSE-MIXIN TV:SCROLL-WINDOW-WITH-TYPEOUT-MIXIN
	 TV:WINDOW-WITH-TYPEOUT-MIXIN TV:BASIC-SCROLL-WINDOW TV:BASIC-SCROLL-BAR
	 ZMAIL-WHO-LINE-OVERRIDE-MIXIN TV:WINDOW)
  (:DEFAULT-INIT-PLIST :TRUNCATION T :SAVE-BITS :DELAYED :CR-NOT-NEWLINE-FLAG 1
		       :LABEL '(:string "Zmail Summary Pane" :centered)
		       :SCROLL-BAR 2 :DISPLAY-ITEM (SUMMARY-DISPLAY-ITEM)))

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :BEFORE :INIT) (IGNORE)
  (SETQ TV:TYPEOUT-WINDOW
	`(ZMAIL-SUMMARY-TYPEOUT-WINDOW :IO-BUFFER ,TV:IO-BUFFER)))

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :SET-CURRENT-ZMAIL-BUFFER) (ZMAIL-BUFFER)
  (COND ((NEQ CURRENT-ZMAIL-BUFFER ZMAIL-BUFFER)
	 (SETQ MSGS-TO-BE-REDISPLAYED T
	       RECENTER-P T)
	 (SETQ CURRENT-ZMAIL-BUFFER ZMAIL-BUFFER))))

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :BEFORE :REDISPLAY) (&AUX TOP-ZMAIL-BUFFER)
;								  OTHER-ZMAIL-BUFFER)
  (COND ((AND CURRENT-ZMAIL-BUFFER (PLUSP (ZMAIL-BUFFER-NMSGS CURRENT-ZMAIL-BUFFER)))
	 (SETQ TOP-ZMAIL-BUFFER (MSG-MAIL-FILE-BUFFER (SUMMARY-DISPLAY-ITEM-STEPPER 0)))
;	 (AND (TYPEP TOP-ZMAIL-BUFFER 'INBOX-BUFFER)
;	      (SETQ OTHER-ZMAIL-BUFFER (SEND TOP-ZMAIL-BUFFER :ASSOCIATED-MAIL-FILE-BUFFER))
;	      (SETQ TOP-ZMAIL-BUFFER OTHER-ZMAIL-BUFFER))
	 ))
  (OR (EQ LAST-DISPLAYED-TOP-ZMAIL-BUFFER TOP-ZMAIL-BUFFER)
      (SETQ TV:TOP-ITEM NIL TV:TARGET-TOP-ITEM NIL))
  (SETQ LAST-DISPLAYED-TOP-ZMAIL-BUFFER TOP-ZMAIL-BUFFER))

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :SET-CURRENT-MSG) (MSG)
  (COND ((NEQ CURRENT-MSG MSG)
	 (COND ((NEQ MSGS-TO-BE-REDISPLAYED T)
		(AND CURRENT-MSG (PUSH* CURRENT-MSG MSGS-TO-BE-REDISPLAYED))
		(AND MSG (PUSH* MSG MSGS-TO-BE-REDISPLAYED))))
	 (SETQ CURRENT-MSG MSG)))
  (SETQ RECENTER-P T))

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :NEED-TO-REDISPLAY-MSG) (MSG)
  (OR (EQ MSGS-TO-BE-REDISPLAYED T)
      (PUSH* MSG MSGS-TO-BE-REDISPLAYED)))

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :NEED-FULL-REDISPLAY) (&OPTIONAL RECENTER-TOO)
  (SETQ MSGS-TO-BE-REDISPLAYED T)
  (AND RECENTER-TOO (SETQ RECENTER-P T)))

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :REDISPLAY-AS-NECESSARY) ()
  (AND (SEND TV:TYPEOUT-WINDOW :BOTTOM-REACHED)
       (SETQ MSGS-TO-BE-REDISPLAYED T))
  (COND (MSGS-TO-BE-REDISPLAYED
	 (AND RECENTER-P (NEQ MSGS-TO-BE-REDISPLAYED T)
	      (SUMMARY-DISPLAY-VALIDATE-CURRENT-MSG-POSITION))
	 (IF (EQ MSGS-TO-BE-REDISPLAYED T)	;Full redisplay needed
	     (SEND SELF :REDISPLAY)
	   (TV:SCROLL-MAINTAIN-LIST-UPDATE-STATES MSGS-TO-BE-REDISPLAYED SELF))
	 (SETQ MSGS-TO-BE-REDISPLAYED NIL
	       RECENTER-P NIL))))

(DEFUN SUMMARY-DISPLAY-ITEM ()
  (TV:SCROLL-MAINTAIN-LIST
    'SUMMARY-DISPLAY-ITEM-INITIALIZER
    'SUMMARY-DISPLAY-ITEM-DISPLAYER
    NIL
    'SUMMARY-DISPLAY-ITEM-STEPPER
    T
    'SUMMARY-DISPLAY-ITEM-PRE-PROCESS-FUNCTION))

(DEFUN SUMMARY-DISPLAY-ITEM-INITIALIZER ()
  (DECLARE (:SELF-FLAVOR ZMAIL-SUMMARY-SCROLL-WINDOW))
  (AND CURRENT-ZMAIL-BUFFER (PLUSP (ZMAIL-BUFFER-NMSGS CURRENT-ZMAIL-BUFFER))
       0))

(DEFUN SUMMARY-DISPLAY-ITEM-DISPLAYER (MSG)
  (DECLARE (:SELF-FLAVOR ZMAIL-SUMMARY-SCROLL-WINDOW))
  (TV:SCROLL-PARSE-ITEM
    :MOUSE `(SUMMARY-MOUSE ,MSG)
    `(:FUNCTION SUMMARY-DISPLAY-UPDATE (,MSG) 1 ("~\ARROW\"))
    `(:VALUE 0 4 ("~4D"))
    `(:VALUE 1 1 ("~C"))
    `(:VALUE 2 NIL NIL)))

(DEFUN SUMMARY-DISPLAY-UPDATE (MSG &AUX STATUS)
  (DECLARE (:SELF-FLAVOR ZMAIL-SUMMARY-SCROLL-WINDOW))
  (SETQ STATUS (ASSURE-MSG-PARSED MSG))
  (SETF (TV:VALUE 2) (MSG-SUMMARY-LINE MSG))
  (SETF (TV:VALUE 1) (STATUS-LETTER STATUS))
  (SETF (TV:VALUE 0) (1+ (MSG-DISPLAYED-INDEX MSG)))
  (COND ((GET STATUS 'MARKED) :MARKED)
	((EQ MSG CURRENT-MSG) :CURRENT)))

(DEFPROP FORMAT:ARROW FORMAT-CTL-ARROW FORMAT:FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-ARROW (ARG IGNORE)
  (COND ((NULL ARG)
	 (SEND *STANDARD-OUTPUT* :TYO #/SP))
	((MEMQ :PRINT-ARROW (SEND *STANDARD-OUTPUT* :WHICH-OPERATIONS))
	 (SEND *STANDARD-OUTPUT* :PRINT-ARROW ARG))
	(T
	 (SEND *STANDARD-OUTPUT* :TYO (CASE ARG
				       ((:CURRENT T) #\)
				       (:MARKED #\x))))))

(DEFUN SUMMARY-DISPLAY-ITEM-STEPPER (INDEX &AUX ZMAIL-BUFFER LENGTH OTHER-ZMAIL-BUFFER NEW-INDEX
						DISPLAYED-INDEX MSG)
  (DECLARE (:SELF-FLAVOR ZMAIL-SUMMARY-SCROLL-WINDOW))
  (SETQ ZMAIL-BUFFER CURRENT-ZMAIL-BUFFER
	DISPLAYED-INDEX INDEX
	LENGTH (ZMAIL-BUFFER-NMSGS ZMAIL-BUFFER))
  (COND ((AND (TYPEP ZMAIL-BUFFER 'INBOX-BUFFER)
	      (SETQ OTHER-ZMAIL-BUFFER (SEND ZMAIL-BUFFER :ASSOCIATED-MAIL-FILE-BUFFER)))
;Better to show them out of order
;than to keep glitching the summary of the inbox buffer
;as messages are read into the mail file buffer by the background process.
;	 (AND (ZMAIL-BUFFER-APPEND-P OTHER-ZMAIL-BUFFER)
;	      (PSETQ ZMAIL-BUFFER OTHER-ZMAIL-BUFFER
;		     OTHER-ZMAIL-BUFFER ZMAIL-BUFFER
;		     LENGTH (ZMAIL-BUFFER-NMSGS OTHER-ZMAIL-BUFFER)))
	 (AND ( INDEX LENGTH)
	      (SETQ DISPLAYED-INDEX (- INDEX LENGTH)
		    ZMAIL-BUFFER OTHER-ZMAIL-BUFFER))
	 (SETQ LENGTH (+ LENGTH (ZMAIL-BUFFER-NMSGS OTHER-ZMAIL-BUFFER)))))
  (SETQ MSG (AREF (ZMAIL-BUFFER-ARRAY ZMAIL-BUFFER) DISPLAYED-INDEX))
  (SETF (MSG-DISPLAYED-INDEX MSG) DISPLAYED-INDEX)
  (VALUES MSG
	  (SETQ NEW-INDEX (1+ INDEX))
	  ( NEW-INDEX LENGTH)))

(DEFUN SUMMARY-DISPLAY-ITEM-PRE-PROCESS-FUNCTION (ITEM)
  (DECLARE (:SELF-FLAVOR ZMAIL-SUMMARY-SCROLL-WINDOW))
  (TV:SCROLL-MAINTAIN-LIST-UPDATE-FUNCTION ITEM)	;Do numbering pass
  (AND CURRENT-MSG (PLUSP (ZMAIL-BUFFER-NMSGS CURRENT-ZMAIL-BUFFER)) RECENTER-P
       (SUMMARY-DISPLAY-VALIDATE-CURRENT-MSG-POSITION)))

(DEFUN SUMMARY-DISPLAY-VALIDATE-CURRENT-MSG-POSITION ()
  (DECLARE (:SELF-FLAVOR ZMAIL-SUMMARY-SCROLL-WINDOW))
  (AND *SUMMARY-SCROLL-FRACTION*
       (LET* ((CURRENT-INDEX (MSG-DISPLAYED-INDEX CURRENT-MSG))
	      (TOP-INDEX (OR TV:TOP-ITEM 0))
	      (N-LINES (TV:SHEET-NUMBER-OF-INSIDE-LINES))
	      (BOTTOM-INDEX (+ TOP-INDEX N-LINES))
	      NEW-TARGET
;	      OTHER-ZMAIL-BUFFER
	      )
;	 (AND (TYPEP CURRENT-ZMAIL-BUFFER 'INBOX-BUFFER)
;	      (SETQ OTHER-ZMAIL-BUFFER
;		    (SEND CURRENT-ZMAIL-BUFFER :ASSOCIATED-MAIL-FILE-BUFFER))
;	      (ZMAIL-BUFFER-APPEND-P OTHER-ZMAIL-BUFFER)
;	      CURRENT-INDEX
;	      (SETQ CURRENT-INDEX (+ CURRENT-INDEX (ZMAIL-BUFFER-NMSGS OTHER-ZMAIL-BUFFER))))
	 (COND ((NULL CURRENT-INDEX))		;Not displayed yet
	       ((< CURRENT-INDEX TOP-INDEX)
		(SETQ NEW-TARGET (- CURRENT-INDEX
				    (FIX (* *SUMMARY-SCROLL-FRACTION* N-LINES)))))
	       (( CURRENT-INDEX BOTTOM-INDEX)
		(SETQ NEW-TARGET (+ (- CURRENT-INDEX N-LINES)
				    (FIX (* *SUMMARY-SCROLL-FRACTION* N-LINES))))))
	 (AND NEW-TARGET
	      (SETQ TV:TARGET-TOP-ITEM (MAX 0 NEW-TARGET)
		    MSGS-TO-BE-REDISPLAYED T)))))

;;; If told to scroll explicitly, don't jump back
(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :AFTER :SCROLL-TO) (&REST IGNORE)
  (SETQ RECENTER-P NIL))

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :BEFORE :HANDLE-MOUSE) ()
  (SEND SELF :MOUSE-STANDARD-BLINKER))

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :AFTER :MOUSE-MOVES) (X Y)
  (ZMAIL-SUMMARY-SCROLL-WINDOW-MOUSE-BLINKER X Y NIL))

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :MOUSE-STANDARD-BLINKER) ()
  (MULTIPLE-VALUE-BIND (XOFF YOFF)
      (TV:SHEET-CALCULATE-OFFSETS SELF TV:MOUSE-SHEET)
    (ZMAIL-SUMMARY-SCROLL-WINDOW-MOUSE-BLINKER (- TV:MOUSE-X XOFF) (- TV:MOUSE-Y YOFF) T)))

(DEFUN ZMAIL-SUMMARY-SCROLL-WINDOW-MOUSE-BLINKER (X Y &OPTIONAL (FORCE-P T) &AUX CHAR)
  (DECLARE (:SELF-FLAVOR ZMAIL-SUMMARY-SCROLL-WINDOW))
  (SETQ CHAR (COND (( Y (TV:SHEET-INSIDE-TOP)) 6)
		   ((AND ( X (TRUNCATE TV:WIDTH 4)) (< X (TRUNCATE (* 3 TV:WIDTH) 4))) 0)
		   (T 2)))
  (WITHOUT-INTERRUPTS
    (AND (OR FORCE-P
	     (NEQ TV:MOUSE-BLINKER (TV:MOUSE-GET-BLINKER :CHARACTER))
	     ( CHAR (SEND TV:MOUSE-BLINKER :CHARACTER)))
	 ;; Only flash blinker if something changed
	 (TV:MOUSE-SET-BLINKER-DEFINITION :CHARACTER 0 0 :ON
					  :SET-CHARACTER CHAR 'FONTS:MOUSE))))

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :MOUSE-CLICK) (BUTTON X Y)
  (COND ((AND (= BUTTON #/MOUSE-1-1)
	      (< Y (TV:SHEET-INSIDE-TOP)))	;If clicked inside the label
	 (COMMAND-BUFFER-PUSH
	   `(SUMMARY-EXECUTE CHANGE-SUMMARY-LAYOUT
			     ,(AND ( X (TRUNCATE TV:WIDTH 4))
				   (< X (TRUNCATE (* 3 TV:WIDTH) 4)))))
	 T)))

;;; If button is clicked inside the label of the summary window, change the layout
(DEFUN CHANGE-SUMMARY-LAYOUT (UP-P)
  (SET-MAIN-WINDOW-CONFIGURATION (IF UP-P
				     (IF (EQ *WINDOW-CONFIGURATION* :BOTH)
					 :SUMMARY
				       :BOTH)
				   :MSG))
  DIS-NONE)

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :WHO-LINE-DOCUMENTATION-STRING) (&AUX X Y)
  (MULTIPLE-VALUE (X Y)
    (TV:SHEET-CALCULATE-OFFSETS SELF TV:MOUSE-SHEET))
  (SETQ X (- TV:MOUSE-X X)
	Y (- TV:MOUSE-Y Y))
  (COND ((< Y (TV:SHEET-INSIDE-TOP))
	 (IF ( (TRUNCATE TV:WIDTH 4) X (TRUNCATE (* 3 TV:WIDTH) 4))
	     (IF (EQ (SYMEVAL-IN-CLOSURE (SEND TV:SUPERIOR :EDITOR-CLOSURE)
					 '*WINDOW-CONFIGURATION*)
		     :BOTH)
		 "Change layout to display just summary window."
	       "Change layout to display both summary and message.")
	   "Change layout to display just message."))
	(TV:CURRENT-ITEM
	 (GET 'ZMAIL-SUMMARY-MOUSE :WHO-LINE-DOCUMENTATION))))

(DEFMETHOD (ZMAIL-SUMMARY-SCROLL-WINDOW :WHO-LINE-OVERRIDE-P) ()
  TV:CURRENT-ITEM)

;;; This "command's" mouse documentation is used when the mouse
;;; is in the summary window.
(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER ZMAIL-SUMMARY-MOUSE (STRING)
  (FORMAT STRING "Operate on this message: L: Select;  M: ~A; Right: menu."
	  (NAME-FROM-MENU-VALUE *SUMMARY-MOUSE-MIDDLE-MODE*
				*SUMMARY-MOUSE-MIDDLE-MENU-ALIST*)))

(ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *SUMMARY-MOUSE-MIDDLE-MODE* ZMAIL-SUMMARY-MOUSE)

(DEFUN ZMAIL-SUMMARY-MOUSE (MSG &AUX OPTION DELETED-P)
  (SETQ DELETED-P (MSG-GET MSG 'DELETED))
  (IF (EQ *ZMAIL-COMMAND-BUTTON* :LEFT)
      (SETQ OPTION :SELECT)
    (MULTIPLE-VALUE (OPTION *LAST-SUMMARY-MOUSE-ITEM*)
      (ZMAIL-MENU-CHOOSE NIL
			 (IF (EQ *ZMAIL-COMMAND-BUTTON* :MIDDLE)
			     *SUMMARY-MOUSE-MIDDLE-MENU-ALIST*
			   `(,(SECOND *SUMMARY-MOUSE-MENU-ALIST*)	;Keywords
			     ,(IF DELETED-P
				  (FOURTH *SUMMARY-MOUSE-MENU-ALIST*)	;Undelete
				(THIRD *SUMMARY-MOUSE-MENU-ALIST*))	;Delete
			     ,@(AND (NOT (ZMAIL-BUFFER-DISK-P *ZMAIL-BUFFER*))
				    `(,(FIFTH *SUMMARY-MOUSE-MENU-ALIST*)))	;Remove
			     ,(IF (MSG-DRAFT-MSG-P MSG)
				  (FIRST *SUMMARY-MOUSE-MENU-ALIST*)	;Continue
				(SIXTH *SUMMARY-MOUSE-MENU-ALIST*))	;Reply
			     . ,(NTHCDR 6 *SUMMARY-MOUSE-MENU-ALIST*)))	;Append,Filter
			   *LAST-SUMMARY-MOUSE-ITEM* '(:MOUSE) *SUMMARY-MOUSE-MIDDLE-MODE*)))
  (COND (OPTION
	 (AND (EQ OPTION :DELETE-OR-REMOVE)
	      (SETQ OPTION (IF (ZMAIL-BUFFER-DISK-P *ZMAIL-BUFFER*)
			       :DELETE-OR-UNDELETE
			     :REMOVE)))
	 (AND (EQ OPTION :DELETE-OR-UNDELETE)
	      (SETQ OPTION (IF DELETED-P :UNDELETE :DELETE)))
	 (CASE OPTION
	   (:SELECT
	    (AND (EQ *WINDOW-CONFIGURATION* :SUMMARY)
		 (SEND *ZMAIL-WINDOW* :SET-WINDOW-CONFIGURATION :MSG))
	    (SELECT-MSG-AND-POSSIBLY-ZMAIL-BUFFER MSG)
	    (MUST-REDISPLAY *MSG-WINDOW* DIS-ALL))
	   (:DELETE
	    (OR DELETED-P (ZMAIL-DELETE-MSG MSG)))
	   (:UNDELETE
	    (AND DELETED-P (ZMAIL-UNDELETE-MSG MSG)))
	   (:REMOVE
	    (REMOVE-MSG *ZMAIL-BUFFER* MSG (MSG-DISPLAYED-INDEX MSG)))
	   (:KEYWORDS
	    (ZMAIL-KEYWORDS-MSG MSG))
	   (:REPLY
	    (ZMAIL-SELECT-MSG MSG)
	    (COM-ZMAIL-REPLY))
	   (:MOVE
	    (LET ((BUFFER (GET-DEFAULTED-MOVE-ZMAIL-BUFFER MSG)))
	      (SEND BUFFER :ADD-MSG MSG)
	      (FORMAT *QUERY-IO* "~&Moved to ~A" (SEND BUFFER :NAME))))
	   (:APPEND
	    (ZMAIL-CONCATENATE-MSG MSG))
	   (:FILTER
	    (SELECT-ZMAIL-BUFFER (MAKE-ZMAIL-BUFFER-FROM-FILTER-FROM-MSG MSG))))))
  DIS-TEXT)

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION SUMMARY-REPLY-DOCUMENTATION
				       *SUMMARY-REPLY-DOCUMENTATION*)

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER SUMMARY-REPLY-DOCUMENTATION
					       (STRING &OPTIONAL RECURSIVE)
  (OR RECURSIVE (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'NORMAL-REPLY NIL T))
  (STRING-NCONC STRING "Select and reply to this message: "
		(GET 'NORMAL-REPLY :WHO-LINE-DOCUMENTATION)))

;;; The mouse sensitive mode line
;;; When the mode line is updated, the value of *SENSITIVE-MODE-LINE-ELEMENTS*
;;; is saved in the mode line.  This is an alist which says what to do
;;; about mouse clicks.

(DEFFLAVOR MOUSE-SENSITIVE-MODE-LINE-WINDOW 
       ((CURRENT-ITEM NIL)			;The item the mouse is currently near
	ITEM-BLINKER				;Rectangular blinker for it
	SELECTABLE-ELEMENTS
	) 
       (MODE-LINE-WINDOW-MIXIN ECHO-AREA-WINDOW))

(DEFMETHOD (MOUSE-SENSITIVE-MODE-LINE-WINDOW :AFTER :INIT) (IGNORE)
  (SETQ ITEM-BLINKER (TV:MAKE-BLINKER SELF 'TV:HOLLOW-RECTANGULAR-BLINKER
				      :VISIBILITY NIL)))

(DEFMETHOD (MOUSE-SENSITIVE-MODE-LINE-WINDOW :MOUSE-MOVES) (X Y &AUX STRING X1
								(X0 (TV:SHEET-INSIDE-LEFT)))
  (TV:MOUSE-SET-BLINKER-CURSORPOS)
  (COND ((AND ( Y (TV:SHEET-INSIDE-TOP))
	      (< Y TV:(+ (SHEET-INSIDE-TOP) LINE-HEIGHT))
	      (SETQ STRING (DOLIST (STRING PREVIOUS-MODE-LINE)
			     (IF (AND (CONSP STRING) (EQ (CAR STRING) :RIGHT-FLUSH))
				 (SETQ X1 (TV:SHEET-INSIDE-RIGHT)
				       STRING (CADR STRING))
			       (SETQ X1 (+ X0 (TV:SHEET-STRING-LENGTH SELF STRING))))
			     (AND (> X1 X) (RETURN STRING))
			     (SETQ X0 X1)))
	      (DOLIST (ELEMENT SELECTABLE-ELEMENTS)
		(AND (EQ STRING (SYMEVAL-IN-CLOSURE (SEND TV:SUPERIOR :EDITOR-CLOSURE)
						    (CAR ELEMENT)))
		     (RETURN (SETQ CURRENT-ITEM (CDR ELEMENT))))))
	 (TV:BLINKER-SET-CURSORPOS ITEM-BLINKER (- X0 (TV:SHEET-INSIDE-LEFT)) 0)
	 (TV:BLINKER-SET-SIZE ITEM-BLINKER (- X1 X0) (FONT-BLINKER-HEIGHT TV:CURRENT-FONT))
	 (TV:BLINKER-SET-VISIBILITY ITEM-BLINKER T))
	(T
	 (TV:BLINKER-SET-VISIBILITY ITEM-BLINKER NIL)
	 (SETQ CURRENT-ITEM NIL))))

(DEFMETHOD (MOUSE-SENSITIVE-MODE-LINE-WINDOW :MOUSE-CLICK) (BUTTON X Y)
  X Y
  (COND ((AND CURRENT-ITEM (NOT (LDB-TEST %%KBD-MOUSE-N-CLICKS BUTTON)))
	 (COMMAND-BUFFER-PUSH `(MODE-LINE ,CURRENT-ITEM ,BUTTON))
	 T)))

(DEFMETHOD (MOUSE-SENSITIVE-MODE-LINE-WINDOW :WHO-LINE-DOCUMENTATION-STRING) ()
  (AND CURRENT-ITEM
       (OR (GET CURRENT-ITEM :WHO-LINE-DOCUMENTATION)
	   (GET CURRENT-ITEM :DOCUMENTATION))))

(DEFMETHOD (MOUSE-SENSITIVE-MODE-LINE-WINDOW :AFTER :HANDLE-MOUSE) ()
  (TV:BLINKER-SET-VISIBILITY ITEM-BLINKER NIL))

(DEFMETHOD (MOUSE-SENSITIVE-MODE-LINE-WINDOW :AFTER :REDISPLAY) (IGNORE &OPTIONAL FORCE-P)
  (AND FORCE-P (TV:MOUSE-WAKEUP)))

(DEFFLAVOR ZMAIL-MOUSE-SENSITIVE-MODE-LINE-PANE
	()
	(TV:BORDERS-MIXIN MODE-LINE-SUPERIOR-MIXIN MOUSE-SENSITIVE-MODE-LINE-WINDOW))

(DEFMETHOD (ZMAIL-MOUSE-SENSITIVE-MODE-LINE-PANE :BEFORE :REDISPLAY) (&REST IGNORE &AUX EXP-P)
  (SETQ SELECTABLE-ELEMENTS *SELECTABLE-MODE-LINE-ELEMENTS*)
  (AND (OR (NOT (SETQ EXP-P (SEND *MSG-WINDOW* :EXPOSED-P)))
	   (< (WINDOW-REDISPLAY-DEGREE *MSG-WINDOW*) DIS-BPS))
       (SETQ *MSG-MORE-STRING*
	     (AND EXP-P
		  (LET ((TOP-IS-TOP (BP-= (WINDOW-START-BP *MSG-WINDOW*)
					  (INTERVAL-FIRST-BP (WINDOW-INTERVAL *MSG-WINDOW*))))
			(BOT-IS-BOT (WINDOW-LAST-BP-DISPLAYED-P *MSG-WINDOW*)))
		    (COND ((AND (NOT TOP-IS-TOP) (NOT BOT-IS-BOT)) "--More above and below--")
			  ((NOT TOP-IS-TOP) "--More above--")
			  ((NOT BOT-IS-BOT) "--More below--")))))))

(DEFFLAVOR ZMAIL-MAIN-COMMAND-MENU-PANE () (MENU-COMMAND-MENU-MIXIN TV:COMMAND-MENU))

;;; Keyword hacking menu

(DEFFLAVOR ZMAIL-MULTIPLE-MENU-MIXIN
	(NEW-FUNCTION)
	()
  (:REQUIRED-FLAVORS TV:MARGIN-MULTIPLE-MENU-MIXIN)
  (:SETTABLE-INSTANCE-VARIABLES NEW-FUNCTION)
  (:DEFAULT-INIT-PLIST :COLUMNS 3
    		       :SPECIAL-CHOICES '(("Abort" :VALUE :ABORT
						   :DOCUMENTATION "Abort this command.")
					  ("Do It" :VALUE :DO-IT
					   :DOCUMENTATION "Use highlighted items.")
					  ("New" :VALUE :NEW
						 :DOCUMENTATION "Add a new item."))))

(DEFFLAVOR ZMAIL-MULTIPLE-MENU () (ZMAIL-MULTIPLE-MENU-MIXIN TV:MULTIPLE-MENU))

(DEFFLAVOR POP-UP-ZMAIL-MULTIPLE-MENU () (ZMAIL-MULTIPLE-MENU-MIXIN TV:TEMPORARY-WINDOW-MIXIN TV:MULTIPLE-MENU))

;;; This is the message to call, it takes a keyword alist and a list of currently on
;;; keywords, and returns updated versions of each.
(DEFMETHOD (ZMAIL-MULTIPLE-MENU-MIXIN :MULTIPLE-CHOOSE) (old-ITEM-LIST CURRENTLY-ACTIVE
							 &OPTIONAL (NEAR-MODE '(:MOUSE))
							 &AUX OLD-STATUS CHOICE
							 )
  (SETQ OLD-STATUS (SEND SELF :STATUS))
  (UNWIND-PROTECT
    (PROGN (SEND SELF :SET-ITEM-LIST old-ITEM-LIST)
	   (SEND SELF :SET-HIGHLIGHTED-VALUES CURRENTLY-ACTIVE)
	   (TV:EXPOSE-WINDOW-NEAR SELF NEAR-MODE)
	   (DO-FOREVER
	     (SETQ CHOICE (SEND SELF :CHOOSE))
	     (COND ((EQ CHOICE :DO-IT)
		    (RETURN (SETQ CURRENTLY-ACTIVE (SEND SELF :HIGHLIGHTED-VALUES))))
		   ((EQ CHOICE :ABORT)
		    (RETURN (SETQ tv:ITEM-LIST OLD-ITEM-LIST)))
		   ((EQ CHOICE :NEW)
		    (LET ((NEW (FUNCALL NEW-FUNCTION SELF tv:ITEM-LIST CURRENTLY-ACTIVE)))
		      (COND (NEW
			     ;(PUSH NEW ITEM-LIST) - add-item nconc's
			     (SEND SELF :ADD-ITEM NEW)
			     (SEND SELF :ADD-HIGHLIGHTED-ITEM NEW))))))))
    (SEND SELF :SET-STATUS OLD-STATUS))
  (VALUES tv:ITEM-LIST CURRENTLY-ACTIVE))

(DEFUN ZMAIL-MULTIPLE-MENU-CHOOSE (ITEM-LIST CURRENTLY-ACTIVE NEW-FUNCTION
				   &OPTIONAL (NEAR-MODE '(:MOUSE)) LABEL)
  (USING-RESOURCE (MENU POP-UP-ZMAIL-MULTIPLE-MENU *ZMAIL-WINDOW*)
    (SEND MENU :SET-NEW-FUNCTION NEW-FUNCTION)
    (SEND MENU :SET-LABEL LABEL)
    (SEND MENU :MULTIPLE-CHOOSE ITEM-LIST CURRENTLY-ACTIVE NEAR-MODE)))

(DEFUN MULTIPLE-MENU-NEW-KEYWORD (WINDOW KEYWORD-ALIST &OPTIONAL IGNORE
						       &AUX STR SYM ITEM)
  (SETQ STR (*CATCH 'ZWEI-COMMAND-LOOP
	      (CALL-POP-UP-MINI-BUFFER-EDITOR
		WINDOW 'TYPEIN-LINE-READLINE "New keyword:")))
  (COND ((NOT (STRINGP STR)) NIL)
	((> (STRING-LENGTH STR) 0)
	 (SETQ SYM (INTERN (STRING-UPCASE STR) ""))
	 (SETQ ITEM (RASSQ SYM KEYWORD-ALIST))
	 (IF ITEM				;If already have such an item,
	     (PROGN (BEEP) ITEM)		;BEEP and return it
	   (CONS STR SYM)))			;Otherwise cons new item
	(T (BEEP) NIL)))			;He just typed RETURN

(DEFUN MULTIPLE-MENU-NEW-PATHNAME (WINDOW ITEM-LIST &OPTIONAL IGNORE &AUX STR PATH)
  (SETQ PATH (*CATCH 'ZWEI-COMMAND-LOOP
	       (CALL-POP-UP-MINI-BUFFER-EDITOR
		 WINDOW 'READ-DEFAULTED-PATHNAME "New file:"
		 (DEFAULT-ZMAIL-MOVE-PATHNAME))))
  (COND ((SYMBOLP PATH) NIL)
	((NOT (ASSOC (SETQ STR (STRING PATH)) ITEM-LIST))
	 (CONS STR PATH))
	(T (BEEP) NIL)))

(DEFFLAVOR CLICK-REMEMBERING-MIXIN
	(LAST-BUTTONS)
	()
  :GETTABLE-INSTANCE-VARIABLES
  (:REQUIRED-FLAVORS TV:ESSENTIAL-MOUSE))

(DEFMETHOD (CLICK-REMEMBERING-MIXIN :AFTER :MOUSE-BUTTONS) (BD IGNORE IGNORE)
  (SETQ LAST-BUTTONS BD))

(DEFFLAVOR CLICK-REMEMBERING-POP-UP-MENU () (CLICK-REMEMBERING-MIXIN TV:POP-UP-MENU))

(DEFFLAVOR ZMAIL-MOMENTARY-MENU () (CLICK-REMEMBERING-MIXIN TV:MOMENTARY-MENU))

(DEFFLAVOR ZMAIL-MOMENTARY-COMMAND-MENU () (MENU-COMMAND-MENU-MIXIN ZMAIL-MOMENTARY-MENU))

(DEFFLAVOR ZMAIL-DYNAMIC-MOMENTARY-COMMAND-MENU () (TV:DYNAMIC-ITEM-LIST-MIXIN
						    ZMAIL-MOMENTARY-COMMAND-MENU))

(DEFUN ZMAIL-MENU-CHOOSE (MENU &OPTIONAL ITEM-LIST DEFAULT-ITEM NEAR-MODE MIDDLE)
  (COND ((SYMBOLP MENU)
	 (OR MENU (SETQ MENU 'ZMAIL-MOMENTARY-MENU))
	 (SETQ MENU (ALLOCATE-RESOURCE MENU *ZMAIL-WINDOW*))
	 (SEND MENU :SET-LABEL NIL)
	 (SEND MENU :SET-ITEM-LIST ITEM-LIST)
	 (SEND MENU :SET-LAST-ITEM DEFAULT-ITEM))
	(T
	 (SETQ ITEM-LIST (SEND MENU :ITEM-LIST))))
  (COND ((AND (EQ *ZMAIL-COMMAND-BUTTON* :MIDDLE) MIDDLE)
	 (DO L ITEM-LIST (CDR L) (NULL L)
	   (AND (EQ MIDDLE (SEND MENU :EXECUTE-NO-SIDE-EFFECTS (CAR L)))
		(RETURN (SETQ DEFAULT-ITEM (CAR L))))))
	((MEMQ *ZMAIL-COMMAND-BUTTON* '(:RIGHT :MIDDLE))
	 (TV:EXPOSE-WINDOW-NEAR MENU (OR NEAR-MODE (RECTANGLE-NEAR-COMMAND-MENU)))
	 (AND DEFAULT-ITEM
	      (MULTIPLE-VALUE-BIND (X Y)
		  (SEND MENU :ITEM-CURSORPOS DEFAULT-ITEM)
		(AND X Y
		     (SEND MENU :SET-MOUSE-POSITION
			   (+ X (TV:SHEET-INSIDE-LEFT MENU))
			   (+ Y (TV:SHEET-INSIDE-TOP MENU))))))
	 (OR (SEND MENU :CHOOSE) (ABORT-CURRENT-COMMAND))
	 (SETQ DEFAULT-ITEM (SEND MENU :LAST-ITEM))
	 (SET-COMMAND-BUTTON (SEND MENU :LAST-BUTTONS)))
	((NULL DEFAULT-ITEM)
	 (BARF "There is no default for this command yet")))
  (VALUES (SEND MENU :EXECUTE DEFAULT-ITEM)
	  DEFAULT-ITEM))

(DEFUN SET-COMMAND-BUTTON (BUTTON)
  (SETQ *ZMAIL-COMMAND-BUTTON*
	(IF (SYMBOLP BUTTON) BUTTON
	  (NTH (IF (TV:CHAR-MOUSE-P BUTTON)
		   (LDB %%KBD-MOUSE-BUTTON BUTTON)
		 (1- (HAULONG BUTTON)))
	       '(:LEFT :MIDDLE :RIGHT)))))

;;; Return location of last selected item for use as a near-mode
(DEFUN RECTANGLE-NEAR-COMMAND-MENU (&OPTIONAL (TOP-SHEET *ZMAIL-WINDOW*)
				    &AUX LEFT TOP RIGHT BOTTOM)
  (IF (NOT (AND (CONSP *LAST-COMMAND-CHAR*) (EQ (FIRST *LAST-COMMAND-CHAR*) :MENU)))
      '(:MOUSE)
    (MULTIPLE-VALUE (LEFT TOP RIGHT BOTTOM)
      (SEND (FOURTH *LAST-COMMAND-CHAR*) :ITEM-RECTANGLE (SECOND *LAST-COMMAND-CHAR*)))
    (MULTIPLE-VALUE-BIND (XOFF YOFF)
	(TV:SHEET-CALCULATE-OFFSETS (FOURTH *LAST-COMMAND-CHAR*) TOP-SHEET)
      (SETQ LEFT (+ LEFT XOFF)
	    RIGHT (+ RIGHT XOFF))
      (SETQ TOP (+ TOP YOFF)
	    BOTTOM (+ BOTTOM YOFF)))
    (LIST :RECTANGLE LEFT TOP RIGHT BOTTOM)))

(DEFUN DEFAULTED-MULTIPLE-MENU-CHOOSE-NEAR-MENU (ALIST &REST DEFAULTS)
  (SETQ DEFAULTS (TV:DEFAULTED-MULTIPLE-MENU-CHOOSE ALIST DEFAULTS
		   (RECTANGLE-NEAR-COMMAND-MENU TV:MOUSE-SHEET)))
  (OR DEFAULTS (ABORT-CURRENT-COMMAND))
  (VALUES-LIST DEFAULTS))

(DEFUN MENU-CHOOSE-WITH-NEW (ITEM-LIST NEW-FUNCTION &OPTIONAL (NEAR-MODE '(:MOUSE)) LABEL
						    &AUX VALUE)
  (USING-RESOURCE (MENU ZMAIL-MOMENTARY-MENU *ZMAIL-WINDOW*)
    (SEND MENU :SET-LABEL LABEL)
    (SEND MENU :SET-ITEM-LIST (CONS '("New" :VALUE :NEW :FONTS FONTS:TR12I
				       :DOCUMENTATION "Specify a new item.")
				     ITEM-LIST))
    (SEND MENU :SET-LAST-ITEM NIL)
    (TV:EXPOSE-WINDOW-NEAR MENU NEAR-MODE)
    (OR (SETQ VALUE (SEND MENU :CHOOSE)) (ABORT-CURRENT-COMMAND))
    (IF (EQ VALUE :NEW)
	(SEND MENU :EXECUTE-NO-SIDE-EFFECTS (FUNCALL NEW-FUNCTION MENU ITEM-LIST))
      VALUE)))