;;; Lisp Machine mail reader -*- Mode:LISP; Package:ZWEI -*- 
;;; These are the frames used by filtering and their commands
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-SELECT (STRING)
  (FORMAT STRING "Create//Select mail file: ~@[L: ~S; ~]M: filter; R: menu."
	  (DOLIST (MF *MAIL-FILE-LIST*)
	    (OR (EQ MF *MAIL-FILE*)
		(RETURN (MAIL-FILE-NAME MF))))))

(DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-SELECT "Select another mail file.
Left selects most recently selected other mail file.
Middle creates a new mail file by filtering.
Right gives a menu of existing mail files, and creation techniques such as reading in a new
file, or marking the survey window." (NO-MAIL-FILE-OK)
  (SET-ZMAIL-USER)
  (SELECT-MAIL-FILE (SELECTQ *ZMAIL-COMMAND-BUTTON*
		      (:RIGHT (GET-SELECT-MAIL-FILE))
		      (:MIDDLE (GET-FILTER-MAIL-FILE))
		      (OTHERWISE (OR (DOLIST (MF *MAIL-FILE-LIST*)
				       (OR (EQ MF *MAIL-FILE*)
					   (RETURN MF)))
				     (BARF "This is the only mail file"))))))

(DEFUN GET-SELECT-MAIL-FILE (&AUX ITEM-LIST)
  (MULTIPLE-VALUE-BIND (MAIL-FILE-ALIST TEMP-MAIL-FILE-ALIST)
      (GET-MAIL-FILE-ALISTS T)
    (LEXPR-FUNCALL *SELECT-MAIL-FILE-MENU* ':SET-GEOMETRY
		   (IF (OR MAIL-FILE-ALIST TEMP-MAIL-FILE-ALIST) '(2 NIL) '(NIL 1)))
    (SETQ ITEM-LIST (TV:APPEND-ITEM-LISTS MAIL-FILE-ALIST TEMP-MAIL-FILE-ALIST)))
  (SETQ ITEM-LIST (APPEND ITEM-LIST
			  (AND (ODDP (LENGTH ITEM-LIST)) '(("" :NO-SELECT T)))
			  '(("Find file" :VALUE :FIND-FILE :FONT FONTS:HL12I
					 :DOCUMENTATION "Read in a new file.")
			    ("Mark survey" :VALUE :MARKING :FONT FONTS:HL12I
			     :DOCUMENTATION
		       "Select a temporary mail file made by clicking on the summary window.")
			    ("Abort" :VALUE :ABORT :FONT FONTS:HL12I
				     :DOCUMENTATION "Abort this command.")
			    ("Filter" :VALUE :FILTER :FONT FONTS:HL12I
			     :DOCUMENTATION "Select a temporary mail file made by filtering.")
			    )))
  (OR (EQUAL ITEM-LIST (FUNCALL *SELECT-MAIL-FILE-MENU* ':ITEM-LIST))
      (FUNCALL *SELECT-MAIL-FILE-MENU* ':SET-ITEM-LIST ITEM-LIST))
  (UNWIND-PROTECT
    (PROGN
      (TV:EXPOSE-WINDOW-NEAR *SELECT-MAIL-FILE-MENU* (RECTANGLE-NEAR-COMMAND-MENU))
      (DO ((MAIL-FILE)) (NIL)
	(SETQ MAIL-FILE (FUNCALL *SELECT-MAIL-FILE-MENU* ':CHOOSE))
	(SET-COMMAND-BUTTON (FUNCALL *SELECT-MAIL-FILE-MENU* ':LAST-BUTTONS))
	(SELECTQ MAIL-FILE
	  (:ABORT
	   (ABORT-CURRENT-COMMAND))
	  (:FILTER
	   (FUNCALL *SELECT-MAIL-FILE-MENU* ':DEACTIVATE)
	   (SETQ MAIL-FILE (GET-FILTER-MAIL-FILE)))
	  (:MARKING
	   (FUNCALL *SELECT-MAIL-FILE-MENU* ':DEACTIVATE)
	   (SETQ MAIL-FILE (MAKE-MAIL-FILE-BY-MARKING)))
	  (:FIND-FILE
	   (SETQ MAIL-FILE (SELECT-MAIL-FILE-FIND-FILE *SELECT-MAIL-FILE-MENU*))))
	(COND ((OR (STRINGP MAIL-FILE) (TYPEP MAIL-FILE 'FS:PATHNAME))
	       (FUNCALL *SELECT-MAIL-FILE-MENU* ':DEACTIVATE)
	       (SETQ MAIL-FILE (MAKE-NEW-MAIL-FILE MAIL-FILE))))
	(AND MAIL-FILE (RETURN MAIL-FILE))))
    (FUNCALL *SELECT-MAIL-FILE-MENU* ':DEACTIVATE)))

(DEFUN SELECT-MAIL-FILE-FIND-FILE (NEAR-WINDOW &AUX MAIL-FILE)
  (*CATCH 'ZWEI-COMMAND-LOOP			;In case of G
    (SETQ MAIL-FILE (CALL-POP-UP-MINI-BUFFER-EDITOR
		      NEAR-WINDOW
		      #'READ-DEFAULTED-PATHNAME "Find file"
		      (IF *MAIL-FILE*
			  (DISK-MAIL-FILE-PATHNAME (IF (MAIL-FILE-DISK-P *MAIL-FILE*)
						       *MAIL-FILE*
						       *PRIMARY-MAIL-FILE*))
			  (DEFAULT-ZMAIL-MOVE-PATHNAME))
		      NIL NIL ':NEW-OK)))
  MAIL-FILE)

(TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* FILE "Select"
			  SELECT-MAIL-FILE-FROM-PATHNAME T "Select this file.")

(DEFUN SELECT-MAIL-FILE-FROM-PATHNAME (PATHNAME)
  (SELECT-MAIL-FILE (MAKE-NEW-MAIL-FILE PATHNAME)))

(DEFUN GET-FILTER-MAIL-FILE ()
  (MULTIPLE-VALUE-BIND (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)
      (GET-FILTER-FUNCTION)
    (MAKE-MAIL-FILE-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)))

(DEFUN MAKE-MAIL-FILE-FROM-FILTER (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG
				   &OPTIONAL MAIL-FILE)
  (OR MAIL-FILE
      (MULTIPLE-VALUE-BIND (NAME FULL-NAME)
	  (GENERATE-TEMP-MAIL-FILE-NAME MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)
	(SETQ MAIL-FILE (GET-RECYCLED-TEMP-MAIL-FILE NAME FULL-NAME))))
  (LOCAL-DECLARE ((SPECIAL *N*))
    (LET ((ARRAY (MAIL-FILE-ARRAY MAIL-FILE))
	  (*N* 0))
      (FUNCALL MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG
	       #'(LAMBDA (MSG ARRAY)
		   (AND ( *N* (ARRAY-LENGTH ARRAY))
			(ADJUST-ARRAY-SIZE ARRAY (// (* *N* 5) 4)))
		   (ASET MSG ARRAY *N*)
		   (SETQ *N* (1+ *N*)))
	       ARRAY)
      (SETF (ARRAY-LEADER ARRAY 0) *N*)))
  MAIL-FILE)

(DEFUN (COM-ZMAIL-SELECT ASSOCIATED-MAP-COMMAND) (MAP-FUNCTION MAP-ARG
						  FILTER-FUNCTION FILTER-ARG)
  (SELECT-MAIL-FILE (IF (AND (EQ MAP-FUNCTION 'MAP-OVER-SINGLE-MAIL-FILE)
			     (EQ FILTER-FUNCTION 'MSG-TRUE-FILTER))
			MAP-ARG
			(MAKE-MAIL-FILE-FROM-FILTER MAP-FUNCTION MAP-ARG
						    FILTER-FUNCTION FILTER-ARG))))

(DEFCONST *MAX-NAME-LENGTH* 50.)
(DEFUN GENERATE-TEMP-MAIL-FILE-NAME (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG
				     &AUX FULL-NAME NAME ADDED-NAME)
  (SETQ FULL-NAME (FUNCALL (GET MAP-FUNCTION 'MAP-FUNCTION-MAIL-FILE-NAME-FUNCTION) MAP-ARG)
	NAME FULL-NAME
	ADDED-NAME (FILTER-FUNCTION-MAIL-FILE-NAME FILTER-FUNCTION FILTER-ARG))
  (DO ((I 0)
       (LEN (STRING-LENGTH NAME))
       (MAXL (MAX (- *MAX-NAME-LENGTH* (STRING-LENGTH ADDED-NAME) 4) 0)))
      (( (- LEN I) MAXL)
       (OR (ZEROP I)
	   (SETQ NAME (STRING-APPEND "<...>" (SUBSTRING NAME I)))))
    (IF (SETQ I (STRING-SEARCH-SET '(#/> #/) #/} #/] #/) NAME I))
	(SETQ I (1+ I))
	(SETQ I LEN)))
  (LET ((SAME (EQ FULL-NAME NAME)))
    (SETQ NAME (STRING-APPEND NAME ADDED-NAME)
	  FULL-NAME (IF SAME NAME (STRING-APPEND FULL-NAME ADDED-NAME))))
  (VALUES NAME FULL-NAME))

(DEFUN FILTER-FUNCTION-MAIL-FILE-NAME (FILTER-FUNCTION FILTER-ARG &AUX TEM)
  (COND ((SETQ TEM (GET FILTER-FUNCTION 'FILTER-FUNCTION-MAIL-FILE-NAME-FUNCTION))
	 (FUNCALL TEM FILTER-ARG))
	((SETQ TEM (GET FILTER-FUNCTION 'FILTER-FUNCTION-OPPOSITE-FUNCTION))
	 (STRING-APPEND #/~ (FILTER-FUNCTION-MAIL-FILE-NAME TEM FILTER-ARG)))
	(T
	 (STRING-APPEND #/< FILTER-FUNCTION #/>))))

(DEFUN GET-RECYCLED-TEMP-MAIL-FILE (NAME &OPTIONAL (FULL-NAME NAME))
  ;; Make sure the name is unique
  (DO ((ORIGINAL-NAME NAME)
       (COUNT 1 (1+ COUNT)))
      ((NOT (GET-MAIL-FILE-FROM-NAME NAME)))
    (SETQ NAME (FORMAT NIL "~A-~D" ORIGINAL-NAME COUNT)))
  (MAKE-NEW-TEMP-MAIL-FILE NAME FULL-NAME))
  
(DEFUN MAKE-MAIL-FILE-BY-MARKING (&AUX OLD-CONFIG OLD-DOC)
  (OR *MAIL-FILE* (BARF "There is no current mail file"))
  (SETQ OLD-CONFIG *WINDOW-CONFIGURATION*
	OLD-DOC (FUNCALL *SUMMARY-WINDOW* ':WHO-LINE-OVERRIDE-DOCUMENTATION-STRING))
  (UNWIND-PROTECT
    (LET ((*MODE-LINE-LIST* `("ZMail " "Marking " *ZMAIL-FILE-NAME*
			      ,(FORMAT NIL " ~:@C to finish; ~:@C to abort." #\END #\ABORT)
			      (*MACRO-LEVEL* "  Macro-level: " *MACRO-LEVEL*))))
      (FUNCALL *SUMMARY-WINDOW* ':SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING
	       "Click left to complement marked state of message.")
      (UNMARK-ALL-MESSAGES)
      (OR (MEMQ OLD-CONFIG *MSG-AND-SUMMARY-CONFIGURATIONS*)
	  (FUNCALL *ZMAIL-WINDOW* ':SET-WINDOW-CONFIGURATION ':SUMMARY))
      (DO ((LIST NIL)
	   (CH))
	  (NIL)
	(REDISPLAY-MODE-LINE)
	(FUNCALL *SUMMARY-WINDOW* ':REDISPLAY-AS-NECESSARY)
	(SETQ CH (FUNCALL STANDARD-INPUT ':ANY-TYI))
	(COND ((AND (LISTP CH) (EQ (CAR CH) 'SUMMARY-MOUSE))
	       (LET* ((MSG (CADADR CH))
		      (STATUS (ASSURE-MSG-PARSED MSG)))
		 (IF (PUTPROP STATUS (NOT (GET STATUS 'MARKED)) 'MARKED)
		     (PUSH MSG LIST)
		     (SETQ LIST (DELQ MSG LIST)))
		 (FUNCALL *SUMMARY-WINDOW* ':NEED-TO-REDISPLAY-MSG MSG)))
	      ((OR (LISTP CH) (EQ CH #\END))
	       (OR (EQ CH #\END) (FUNCALL STANDARD-INPUT ':UNTYI CH))
	       (LET ((MAIL-FILE (GET-RECYCLED-TEMP-MAIL-FILE
				  (STRING-APPEND (SINGLE-MAIL-FILE-NAME *MAIL-FILE*)
						 "<Marked>"))))
		 (LET ((ARRAY (MAIL-FILE-ARRAY MAIL-FILE)))
		   (DOLIST (MSG (NREVERSE LIST))
		     (ARRAY-PUSH-EXTEND ARRAY MSG)))
		 (RETURN MAIL-FILE)))
	      ((MEMQ CH '(#\ABORT #/]))
	       (ABORT-CURRENT-COMMAND))
	      (T
	       (BEEP)))))
    (FUNCALL *SUMMARY-WINDOW* ':SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING OLD-DOC)
    (UNMARK-ALL-MESSAGES)
    (FUNCALL *SUMMARY-WINDOW* ':NEED-FULL-REDISPLAY)
    (OR (EQ OLD-CONFIG *WINDOW-CONFIGURATION*)
	(FUNCALL *ZMAIL-WINDOW* ':SET-WINDOW-CONFIGURATION OLD-CONFIG))))

(DEFUN UNMARK-ALL-MESSAGES (&AUX ARRAY)
  (SETQ ARRAY (MAIL-FILE-ARRAY *MAIL-FILE*))
  (DO ((I 0 (1+ I))
       (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY))
       (TEM))
      (( I NMSGS))
    ;; Avoid ASSURE-MSG-PARSED, since messages that haven't been cannot be marked.
    (AND (SETQ TEM (GETL (LOCF (MSG-STATUS (AREF ARRAY I))) '(MARKED)))
	 (SETF (CADR TEM) NIL))))

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION COM-ZMAIL-SURVEY
  "Survey messages in typeout window:  L: all messages; R: filter.")

(DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-SURVEY "Survey set of messages in typeout window.
Click right to give filter." (NO-MSG-OK)
  (LET ((MAP-FUNCTION 'MAP-OVER-SINGLE-MAIL-FILE)
	(MAP-ARG *MAIL-FILE*)
	(FILTER-FUNCTION 'MSG-TRUE-FILTER)
	(FILTER-ARG NIL))
    (AND (EQ *ZMAIL-COMMAND-BUTTON* ':RIGHT)
	 (MULTIPLE-VALUE (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)
	   (GET-FILTER-FUNCTION (RECTANGLE-NEAR-COMMAND-MENU))))
    (SURVEY-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)))

(DEFPROP COM-ZMAIL-SURVEY SURVEY-FROM-FILTER ASSOCIATED-MAP-COMMAND)

(DEFUN SURVEY-FROM-FILTER (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG
			   &AUX *TYPEOUT-WINDOW*)
  (IF (TV:SHEET-EXPOSED-P *SUMMARY-WINDOW*)
      (SETQ *TYPEOUT-WINDOW* (FUNCALL *SUMMARY-WINDOW* ':TYPEOUT-WINDOW))
      (SETQ *TYPEOUT-WINDOW* (WINDOW-TYPEOUT-WINDOW *WINDOW*))
      (FUNCALL *TYPEOUT-WINDOW* ':LINE-OUT *SUMMARY-WINDOW-LABEL*))
  (TV:WINDOW-CALL (*TYPEOUT-WINDOW*)		;For **MORE** blinking
    (LOCAL-DECLARE ((SPECIAL *N*))
      (LET ((*N* 0))
	(FUNCALL MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG
		 #'(LAMBDA (MSG STREAM &AUX STATUS)
		     (SETQ STATUS (ASSURE-MSG-PARSED MSG))
		     (FUNCALL STREAM ':TRUNCATED-ITEM 'SUMMARY-LINE MSG "~~3D~C~A"
			      (EQ MSG *MSG*) (SETQ *N* (1+ *N*)) (STATUS-LETTER STATUS)
			      (MSG-SUMMARY-LINE MSG))
		     (FUNCALL STREAM ':TYO #\CR))
		 *TYPEOUT-WINDOW*)))
    (FUNCALL *TYPEOUT-WINDOW* ':LINE-OUT "Done."))
  (CHECK-FOR-TYPEOUT-WINDOW-TYPEOUT)
  DIS-NONE)

(TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* SUMMARY-LINE "Select"
			  SELECT-MSG-AND-POSSIBLY-MAIL-FILE T
			  "Select this message.")

(DEFINE-ZMAIL-GLOBAL *LAST-GOTO-FILTER-FUNCTION* NIL)
(DEFINE-ZMAIL-GLOBAL *LAST-GOTO-FILTER-ARG* NIL)

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-GOTO (STRING)
  (APPEND-TO-ARRAY STRING "Move to message from filter: ")
  (COND (*LAST-GOTO-FILTER-FUNCTION*
	 (APPEND-TO-ARRAY STRING "L: ")
	 (APPEND-TO-ARRAY STRING (FILTER-FUNCTION-MAIL-FILE-NAME *LAST-GOTO-FILTER-FUNCTION*
								 *LAST-GOTO-FILTER-ARG*))
	 (APPEND-TO-ARRAY STRING "; ")))
  (APPEND-TO-ARRAY STRING "M: point pdl; R: specify filter."))

(DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-GOTO
  "Move to next message fitting a particular filter.
Left default to last filter used.  Middle gives a menu of recent messages.
Right to specify the filter." ()
  (IF (EQ *ZMAIL-COMMAND-BUTTON* ':MIDDLE)
      (COM-ZMAIL-MOUSE-POINT-PDL)
      (LET ((MAP-FUNCTION 'MAP-OVER-REST-OF-MAIL-FILE)
	    (MAP-ARG *MAIL-FILE*)
	    (FILTER-FUNCTION *LAST-GOTO-FILTER-FUNCTION*)
	    (FILTER-ARG *LAST-GOTO-FILTER-ARG*))
	(IF (NEQ *ZMAIL-COMMAND-BUTTON* ':RIGHT)
	    (OR FILTER-FUNCTION (BARF "There is no default for this command yet"))
	    (MULTIPLE-VALUE (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)
	      (GET-FILTER-FUNCTION-1 MAP-FUNCTION MAP-ARG
				     (FORMAT NIL "Rest of ~A" (MAIL-FILE-NAME MAP-ARG))
				     (RECTANGLE-NEAR-COMMAND-MENU)))
	    (SETQ *LAST-GOTO-FILTER-FUNCTION* FILTER-FUNCTION
		  *LAST-GOTO-FILTER-ARG* FILTER-ARG)
	    (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-GOTO))
	(LET ((MSG (FIND-MSG-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)))
	  (OR MSG (BARF "No more messages of this type"))
	  (SELECT-MSG-AND-POSSIBLY-MAIL-FILE MSG)))))

(DEFUN FIND-MSG-FROM-FILTER (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)
  (*CATCH 'FOUND
    (FUNCALL MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG
	     #'(LAMBDA (MSG IGNORE) (*THROW 'FOUND MSG)) NIL)
    NIL))

(DEFUN (COM-ZMAIL-NEXT ASSOCIATED-MAP-COMMAND) (MAP-FUNCTION MAP-ARG
						FILTER-FUNCTION FILTER-ARG)
  (AND (EQ MAP-FUNCTION 'MAP-OVER-SINGLE-MAIL-FILE)
       (SETQ MAP-FUNCTION 'MAP-OVER-REST-OF-MAIL-FILE))
  (LET ((MSG (FIND-MSG-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)))
    (OR MSG (BARF "No more messages of this type"))
    (SELECT-MSG-AND-POSSIBLY-MAIL-FILE MSG)))

(DEFUN (COM-ZMAIL-PREVIOUS ASSOCIATED-MAP-COMMAND) (MAP-FUNCTION MAP-ARG
						    FILTER-FUNCTION FILTER-ARG)
  (AND (EQ MAP-FUNCTION 'MAP-OVER-SINGLE-MAIL-FILE)
       (SETQ MAP-FUNCTION 'MAP-OVER-BEGINNING-OF-MAIL-FILE))
  (LET ((MSG (FIND-MSG-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)))
    (OR MSG (BARF "No more messages of this type"))
    (SELECT-MSG-AND-POSSIBLY-MAIL-FILE MSG)))

(DEFVAR *SYSTEM-FILTER-ALIST* '(("Deleted" :VALUE DELETED
					   :DOCUMENTATION "Messages marked as deleted.")
				("Unseen" :VALUE UNSEEN
					  :DOCUMENTATION "Messages never displayed before.")
				("Recent" :VALUE RECENT
					  :DOCUMENTATION
					  "Messages read in since last expunge.")
				("Answered" :VALUE ANSWERED
					    :DOCUMENTATION
					    "Messages to which replies have been sent.")
				("Filed" :VALUE FILED
					 :DOCUMENTATION
					 "Messages that have been moved into another file.")
				("Search" :VALUE :SEARCH
					  :DOCUMENTATION
					  "Messages containing a given string.")))

(DEFFLAVOR ZMAIL-COMMAND-MENU-PANE
	()
	TV:(WHITESPACE-PANE-MIXIN PANE-MIXIN COMMAND-MENU-MIXIN BASIC-MENU
	    TOP-LABEL-MIXIN BORDERS-MIXIN BASIC-SCROLL-BAR MINIMUM-WINDOW)
  (:DEFAULT-INIT-PLIST :COLUMNS 1 :BORDERS 2 :LABEL NIL
		       :FONT-MAP '(FONTS:HL12B FONTS:HL12BI)))

(DEFFLAVOR FILTER-SELECTION-FRAME () (TV:TEMPORARY-WINDOW-MIXIN TV:ANY-TYI-MIXIN
				      TV:STREAM-MIXIN TV:BORDERS-MIXIN
				      TV:ITEM-LIST-PANE-KLUDGE TV:FRAME-WITH-XOR-BUTTONS
				      TV:CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER
				      TV:MINIMUM-WINDOW))

(DEFMETHOD (FILTER-SELECTION-FRAME :BEFORE :INIT) (IGNORE)
  (SETQ TV:PANES `((UNIVERSE-BUTTON TV:BIG-BUTTON-WITH-TOP-OUTSIDE-LABEL-PANE
				    :LABEL "Universe:"
				    :DOCUMENTATION 
  "Give a menu of universes, mail files, and universe creation techniques.")
		   (NOT-BUTTON TV:BUTTON-PANE :NAME "Not"
					      :DOCUMENTATION "Toggle negation of filter.")
		   (KEYWORD-MENU ZMAIL-COMMAND-MENU-PANE
				 :ITEM-LIST NIL :LABEL "Keywords:")
		   (SYSTEM-FILTER-MENU ZMAIL-COMMAND-MENU-PANE
		     :ITEM-LIST ,`(("All" :VALUE :ALL
					  :DOCUMENTATION "All messages in this universe.")
				   ,@*SYSTEM-FILTER-ALIST*
				   ("From//To" :VALUE :FROM-TO
					       :DOCUMENTATION
 "Messages with a given From or To field, read from the keyboard or from message in summary.")
				   ("Subject" :VALUE :SUBJECT
					      :DOCUMENTATION
 "Messages with a given Subject field, read from the keyboard or from message in summary.")))
		   (USER-FILTER-MENU ZMAIL-COMMAND-MENU-PANE
				     :ITEM-LIST NIL :LABEL "Filters:")
		   (ABORT-BUTTON TV:BUTTON-PANE :NAME "Abort"
						:DOCUMENTATION "Abort this command."))
	TV:CONSTRAINTS
	      (LIST (FILTER-SELECTION-FRAME-MAKE-CONSTRAINT 'WITH T)
		    (FILTER-SELECTION-FRAME-MAKE-CONSTRAINT 'WITHOUT NIL))))

(DEFUN FILTER-SELECTION-FRAME-MAKE-CONSTRAINT (NAME UNIVERSE-P)
  `(,NAME . ((WHOLE-THING)
	     ((WHOLE-THING :HORIZONTAL (:EVEN)
	       (WHOLE)
	       ((WHOLE TV:WHITE-INCLUDE-WHITESPACE	;Vert
		 (0.95) (:EVEN)
		 (,@(AND UNIVERSE-P '(UNIVERSAL)) MENUS CONTROLS)
		 ,@(AND UNIVERSE-P
			'(((UNIVERSAL TV:SINGLE-PANE-IN-WHITESPACE UNIVERSE-BUTTON))))
		 ((CONTROLS TV:SINGLE-PANE-IN-WHITESPACE ABORT-BUTTON))
		 ((MENUS TV:WHITE-INCLUDE-WHITESPACE	;Horiz
			 (:ASK-WINDOW SELF :MENUS-SIZE) (:EVEN)
			 (KEYWORD-MENUX SYSTEM-FILTER-AND-BUTTON USER-FILTER-MENUX)
			 ((KEYWORD-MENUX TV:SINGLE-PANE-IN-WHITESPACE KEYWORD-MENU))
			 ((USER-FILTER-MENUX TV:SINGLE-PANE-IN-WHITESPACE USER-FILTER-MENU))
			 ((SYSTEM-FILTER-AND-BUTTON TV:PANES-IN-WHITESPACE
			   (:ASK-WINDOW SYSTEM-FILTER-MENU :PANE-SIZE)
			   (NOT-BUTTON SYSTEM-FILTER-MENU))))))))))))

(DEFMETHOD (FILTER-SELECTION-FRAME :MENUS-SIZE) (&REST ARGS)
  (MAX (LEXPR-FUNCALL-SELF ':SEND-PANE 'KEYWORD-MENU ':PANE-SIZE ARGS)
       (// (* (+ (LEXPR-FUNCALL-SELF ':SEND-PANE 'NOT-BUTTON ':PANE-SIZE ARGS)
		 (LEXPR-FUNCALL-SELF ':SEND-PANE 'SYSTEM-FILTER-MENU ':PANE-SIZE ARGS))
	      12.) 10.)
       (LEXPR-FUNCALL-SELF ':SEND-PANE 'USER-FILTER-MENU ':PANE-SIZE ARGS)))

(DEFMETHOD (FILTER-SELECTION-FRAME :COMPUTE-GEOMETRY) (UNIVERSE-NAME KEYWORD-ALIST
						       USER-FILTER-ALIST
						       &AUX MAX-WIDTH MAX-HEIGHT CHANGED-P
						            (CONFIG 'WITH))
  (SETQ MAX-WIDTH TV:(- (SHEET-INSIDE-WIDTH SUPERIOR) LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)
	MAX-HEIGHT TV:(- (SHEET-INSIDE-HEIGHT SUPERIOR) TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE))
  (IF UNIVERSE-NAME
      (FUNCALL-SELF ':SET-PANES-NAME 'UNIVERSE-BUTTON UNIVERSE-NAME)
      (SETQ CONFIG 'WITHOUT))
  (SETQ CHANGED-P (NEQ CONFIG TV:CONFIGURATION))
  (SETQ CHANGED-P (OR (FUNCALL-SELF ':SET-PANES-ITEM-LIST 'KEYWORD-MENU KEYWORD-ALIST)
		      CHANGED-P))
  (SETQ CHANGED-P (OR (FUNCALL-SELF ':SET-PANES-ITEM-LIST 'USER-FILTER-MENU USER-FILTER-ALIST)
		      CHANGED-P))
  (AND CHANGED-P
       (LET ((WID (MIN MAX-WIDTH
		       (// (* (MAX (FUNCALL-SELF ':SEND-PANE 'UNIVERSE-BUTTON
						 ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						 NIL NIL ':HORIZONTAL)
				   (+ (FUNCALL-SELF ':SEND-PANE 'KEYWORD-MENU
						    ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						    NIL NIL ':HORIZONTAL)
				      (FUNCALL-SELF ':SEND-PANE 'SYSTEM-FILTER-MENU
						    ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						    NIL NIL ':HORIZONTAL)
				      (FUNCALL-SELF ':SEND-PANE 'USER-FILTER-MENU
						    ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						    NIL NIL ':HORIZONTAL))
				   (FUNCALL-SELF ':SEND-PANE 'ABORT-BUTTON
						 ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						 NIL NIL ':HORIZONTAL))
			      15.) 10.)))
	     (HEI (MIN MAX-HEIGHT
		       (// (* (+ (FUNCALL-SELF ':SEND-PANE 'UNIVERSE-BUTTON
					       ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
					       NIL NIL ':VERTICAL)
				 (FUNCALL-SELF ':MENUS-SIZE MAX-WIDTH MAX-HEIGHT
					       NIL NIL ':VERTICAL)
				 (FUNCALL-SELF ':SEND-PANE 'ABORT-BUTTON
					       ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
					       NIL NIL ':VERTICAL))
			      12.) 10.))))
	 (IF (AND (= WID (TV:SHEET-INSIDE-WIDTH))
		  (= HEI (TV:SHEET-INSIDE-HEIGHT)))
	     (FUNCALL-SELF ':SET-CONFIGURATION CONFIG)
	     (OR (EQ CONFIG TV:CONFIGURATION)
		 (FUNCALL-SELF ':SET-CONFIGURATION CONFIG))
	     (FUNCALL-SELF ':SET-INSIDE-SIZE WID HEI)))))

(DEFUN GET-FILTER-FUNCTION (&OPTIONAL (NEAR-MODE '(:MOUSE)))
  (DECLARE (RETURN-LIST MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG))
  (OR *MAIL-FILE* (BARF "There is no current mail file"))
  (GET-FILTER-FUNCTION-1 'MAP-OVER-SINGLE-MAIL-FILE *MAIL-FILE* (MAIL-FILE-NAME *MAIL-FILE*)
			 NEAR-MODE))

(DEFUN GET-FILTER-FUNCTION-1 (MAP-FUNCTION MAP-ARG NAME NEAR-MODE
			      &AUX FILTER-FUNCTION FILTER-ARG NOT-P)
  (DECLARE (RETURN-LIST MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG))
  (FUNCALL *FILTER-SELECTION-FRAME* ':COMPUTE-GEOMETRY NAME
	   (APPEND '(("Any" :VALUE ANY
			    :FONT FONTS:HL12BI
			    :DOCUMENTATION "Messages with any keyword on them."))
		   *KEYWORD-ALIST*
		   NIL)				;Use a copy of the keyword-alist.
	   (APPEND *USER-FILTER-ALIST*
		   '(("New filter" :VALUE :NEW-FILTER
				   :FONT FONTS:HL12BI
				   :DOCUMENTATION "Define and use a new filter."))))
  (FUNCALL *FILTER-SELECTION-FRAME* ':TURN-OFF-ACCENTS)
  (UNWIND-PROTECT
    (PROGN
      (TV:EXPOSE-WINDOW-NEAR *FILTER-SELECTION-FRAME* NEAR-MODE)
      (DO ((CHAR)) (NIL)
	(SETQ CHAR (FUNCALL *FILTER-SELECTION-FRAME* ':ANY-TYI))
	(IF (NLISTP CHAR)
	    (TV:BEEP)
	    (SELECTQ (FIRST CHAR)
	      (:MOUSE-BUTTON
	       (LET* ((WINDOW (THIRD CHAR))
		      (WINDOW-NAME (FUNCALL *FILTER-SELECTION-FRAME* ':PANE-NAME WINDOW)))
		 (UNWIND-PROTECT
		   (SELECTQ WINDOW-NAME
		     (ABORT-BUTTON (ABORT-CURRENT-COMMAND))
		     (NOT-BUTTON)
		     (UNIVERSE-BUTTON
		      (MULTIPLE-VALUE-BIND (NEW-MAP-FUNCTION NEW-MAP-ARG NEW-NAME)
			  (GET-UNIVERSE-FUNCTION `(:WINDOW ,*FILTER-SELECTION-FRAME*))
			(AND NEW-MAP-FUNCTION
			     (SETQ MAP-FUNCTION NEW-MAP-FUNCTION
				   MAP-ARG NEW-MAP-ARG
				   NAME NEW-NAME)))
		      (FUNCALL *FILTER-SELECTION-FRAME* ':SET-PANES-NAME
			       'UNIVERSE-BUTTON NAME))
		     (OTHERWISE (FERROR NIL "~S is not a known window" (THIRD CHAR))))
		   (FUNCALL WINDOW ':SET-ACCENT (AND (EQ WINDOW-NAME 'NOT-BUTTON)
						     (SETQ NOT-P (NOT NOT-P)))))))
	      (:MENU
	       (SETQ FILTER-ARG (FUNCALL (FOURTH CHAR) ':EXECUTE-NO-SIDE-EFFECTS
					 (SECOND CHAR)))
	       (SELECTQ (FUNCALL *FILTER-SELECTION-FRAME* ':PANE-NAME (FOURTH CHAR))
		 (KEYWORD-MENU
		  (SETQ FILTER-FUNCTION (IF (EQ FILTER-ARG 'ANY)
					    (IF NOT-P
						'MSG-DOES-NOT-HAVE-KEYWORDS-P
						'MSG-HAS-KEYWORDS-P)
					    (IF NOT-P
						'MSG-DOES-NOT-HAVE-KEYWORD-P
						'MSG-HAS-KEYWORD-P))))
		 (SYSTEM-FILTER-MENU
		  (SETQ FILTER-FUNCTION (COND ((EQ FILTER-ARG ':ALL)
					       (IF NOT-P 'MSG-FALSE-FILTER 'MSG-TRUE-FILTER))
					      ((EQ FILTER-ARG ':SEARCH)
					       (FUNCALL *FILTER-SELECTION-FRAME* ':DEACTIVATE)
					       (MULTIPLE-VALUE-BIND (FUN KEY)
						   (ZMAIL-READ-FIND-SEARCH-STRING
						     "Messages containing string")
						 (SETQ FILTER-ARG KEY)
						 (SELECTQ FUN
						   (SEARCH
						    (IF NOT-P
							'MSG-DOES-NOT-HAVE-SEARCH-STRING
							'MSG-HAS-SEARCH-STRING))
						   (FSM-SEARCH
						    (IF NOT-P
							'MSG-DOES-NOT-HAVE-FSM-SEARCH-STRING
							'MSG-HAS-FSM-SEARCH-STRING))
						   (FSM-EXPR-SEARCH
						    (IF NOT-P
						     'MSG-DOES-NOT-HAVE-FSM-EXPR-SEARCH-STRING
							'MSG-HAS-FSM-EXPR-SEARCH-STRING)))))
					      ((EQ FILTER-ARG ':FROM-TO)
					       (FUNCALL *FILTER-SELECTION-FRAME* ':DEACTIVATE)
					       (LET (X)
						 (MULTIPLE-VALUE (X FILTER-ARG)
						   (CHOOSE-OR-READLINE-ADDRESS "From//To"
									       NOT-P))
						 X))
					      ((EQ FILTER-ARG ':SUBJECT)
					       (FUNCALL *FILTER-SELECTION-FRAME* ':DEACTIVATE)
					       (LET ((X (CHOOSE-MSG-OR-READLINE "Subject")))
						 (OR (STRINGP X)
						     (SETQ X (GET-MSG-SUBJECT-CLEVERLY X)))
						 (SETQ FILTER-ARG X))
					       (IF NOT-P 'MSG-DOES-NOT-HAVE-SUBJECT-STRING
							 'MSG-HAS-SUBJECT-STRING))
					      (T
					       (IF NOT-P 'MSG-DOES-NOT-HAVE-ATTRIBUTE-P
							 'MSG-HAS-ATTRIBUTE-P)))))
		 (USER-FILTER-MENU
		  (COND ((EQ FILTER-ARG ':NEW-FILTER)
			 (SETQ NOT-P NIL)
			 (FUNCALL *FILTER-SELECTION-FRAME* ':DEACTIVATE)
			 (SETQ FILTER-ARG (DEFINE-NEW-FILTER))
			 (OR FILTER-ARG (ABORT-CURRENT-COMMAND))))
		  (SETQ FILTER-FUNCTION (IF NOT-P 'MSG-DOES-NOT-FIT-FILTER-P
					    'MSG-FITS-FILTER-P)))
		 (OTHERWISE (FERROR NIL "~S is not a known window" (THIRD CHAR))))
	       (AND FILTER-FUNCTION (RETURN NIL)))))))
    (FUNCALL *FILTER-SELECTION-FRAME* ':DEACTIVATE))
  (VALUES MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG))

(DEFUN (MAP-OVER-SINGLE-MSG MAP-FUNCTION-MAIL-FILE-NAME-FUNCTION) (MSG)
  (STRING-APPEND #/$ (MSG-SUMMARY-LINE MSG) #/$))

(DEFUN MAP-OVER-SINGLE-MSG (MSG FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION PROCESSING-ARG)
  (AND (FUNCALL FILTER-FUNCTION MSG FILTER-ARG)
       (FUNCALL PROCESSING-FUNCTION MSG PROCESSING-ARG)))

(DEFPROP MAP-OVER-SINGLE-MAIL-FILE SINGLE-MAIL-FILE-NAME MAP-FUNCTION-MAIL-FILE-NAME-FUNCTION)

(DEFUN SINGLE-MAIL-FILE-NAME (MAIL-FILE)
  (IF (MAIL-FILE-DISK-P MAIL-FILE)
      (STRING-APPEND #/[ (MAIL-FILE-NAME MAIL-FILE) #/])
      (FUNCALL MAIL-FILE ':FULL-NAME)))

(DEFUN MAP-OVER-SINGLE-MAIL-FILE (MAIL-FILE FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION
				  PROCESSING-ARG)
  (DOMSGS (MSG MAIL-FILE)
    (AND (FUNCALL FILTER-FUNCTION MSG FILTER-ARG)
	 (FUNCALL PROCESSING-FUNCTION MSG PROCESSING-ARG))))

(DEFUN (MAP-OVER-REST-OF-MAIL-FILE MAP-FUNCTION-MAIL-FILE-NAME-FUNCTION) (MAIL-FILE)
  (STRING-APPEND #/ (SINGLE-MAIL-FILE-NAME MAIL-FILE)))

(DEFUN MAP-OVER-REST-OF-MAIL-FILE (MAIL-FILE FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION
				   PROCESSING-ARG &AUX INDEX ARRAY)
  (SETQ ARRAY (MAIL-FILE-ARRAY MAIL-FILE)
	INDEX (IF (EQ MAIL-FILE *MAIL-FILE*) (1+ *MSG-NO*) 0))
  (DO ((INDEX INDEX (1+ INDEX))
       (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY))
       (MSG))
      (NIL)
    (AND ( INDEX NMSGS)
	 (OR (FUNCALL MAIL-FILE ':READ-NEXT-MSG)
	     (RETURN NIL)))
    (SETQ MSG (AREF ARRAY INDEX))
    (AND (FUNCALL FILTER-FUNCTION MSG FILTER-ARG)
	 (FUNCALL PROCESSING-FUNCTION MSG PROCESSING-ARG))))

(DEFUN (MAP-OVER-BEGINNING-OF-MAIL-FILE MAP-FUNCTION-MAIL-FILE-NAME-FUNCTION) (MAIL-FILE)
  (STRING-APPEND #/ (SINGLE-MAIL-FILE-NAME MAIL-FILE)))

(DEFUN MAP-OVER-BEGINNING-OF-MAIL-FILE (MAIL-FILE FILTER-FUNCTION FILTER-ARG
					PROCESSING-FUNCTION PROCESSING-ARG &AUX ARRAY)
  (SETQ ARRAY (MAIL-FILE-ARRAY *MAIL-FILE*))
  (DO ((N (1- (IF (EQ MAIL-FILE *MAIL-FILE*) *MSG-NO* (ARRAY-ACTIVE-LENGTH ARRAY))) (1- N))
       (MSG))
      ((< N 0) NIL)
    (SETQ MSG (AREF ARRAY N))
    (AND (FUNCALL FILTER-FUNCTION MSG FILTER-ARG)
	 (FUNCALL PROCESSING-FUNCTION MSG PROCESSING-ARG))))

(DEFUN (MAP-OVER-LOADED-MAIL-FILES MAP-FUNCTION-MAIL-FILE-NAME-FUNCTION) (IGNORE)
  "[*]")

(DEFUN MAP-OVER-LOADED-MAIL-FILES (IGNORE FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION
				   PROCESSING-ARG)
  (DOLIST (MAIL-FILE *MAIL-FILE-LIST*)
    (COND ((MAIL-FILE-DISK-P MAIL-FILE)
	   (ASSURE-MAIL-FILE-FULLY-LOADED MAIL-FILE)
	   (MAP-OVER-SINGLE-MAIL-FILE MAIL-FILE FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION
				      PROCESSING-ARG)))))

(DEFUN (MAP-OVER-ALL-MAIL-FILES MAP-FUNCTION-MAIL-FILE-NAME-FUNCTION) (IGNORE)
  "[**]")

(DEFUN MAP-OVER-ALL-MAIL-FILES (IGNORE FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION
				PROCESSING-ARG &AUX MAIL-FILE)
  ;; First all that are loaded
  (MAP-OVER-LOADED-MAIL-FILES NIL FILTER-FUNCTION FILTER-ARG
			      PROCESSING-FUNCTION PROCESSING-ARG)
  (DOLIST (ALIST-ELEM (GET-MAIL-FILE-ALISTS T))
    (SETQ MAIL-FILE (CDR ALIST-ELEM))
    (COND ((OR (STRINGP MAIL-FILE) (TYPEP MAIL-FILE 'FS:PATHNAME))
	   (SETQ MAIL-FILE (MAKE-NEW-MAIL-FILE MAIL-FILE))
	   (MAP-OVER-SINGLE-MAIL-FILE MAIL-FILE FILTER-FUNCTION FILTER-ARG
				      PROCESSING-FUNCTION PROCESSING-ARG)))))

;;; Some built-in filters
(DEFUN (MSG-HAS-KEYWORDS-P FILTER-FUNCTION-MAIL-FILE-NAME-FUNCTION) (IGNORE)
  "{*}")

(DEFUN MSG-HAS-KEYWORDS-P (MSG IGNORE)
  (NOT (NULL (MSG-GET MSG 'KEYWORDS))))

(DEFPROP MSG-DOES-NOT-HAVE-KEYWORDS-P MSG-HAS-KEYWORDS-P FILTER-FUNCTION-OPPOSITE-FUNCTION)

(DEFUN MSG-DOES-NOT-HAVE-KEYWORDS-P (MSG IGNORE)
  (NULL (MSG-GET MSG 'KEYWORDS)))

(DEFUN (MSG-HAS-KEYWORD-P FILTER-FUNCTION-MAIL-FILE-NAME-FUNCTION) (KEYWORD)
  (STRING-APPEND #/{ (CAR (RASSQ KEYWORD *KEYWORD-ALIST*)) #/}))

(DEFUN MSG-HAS-KEYWORD-P (MSG KEYWORD)
  (MEMQ KEYWORD (MSG-GET MSG 'KEYWORDS)))

(DEFPROP MSG-DOES-NOT-HAVE-KEYWORD-P MSG-HAS-KEYWORD-P FILTER-FUNCTION-OPPOSITE-FUNCTION)

(DEFUN MSG-DOES-NOT-HAVE-KEYWORD-P (MSG KEYWORD)
  (NOT (MEMQ KEYWORD (MSG-GET MSG 'KEYWORDS))))

(DEFUN (MSG-TRUE-FILTER FILTER-FUNCTION-MAIL-FILE-NAME-FUNCTION) (IGNORE)
  "<*>")


(DEFUN MSG-TRUE-FILTER (IGNORE IGNORE)
  T)

(DEFPROP MSG-FALSE-FILTER MSG-TRUE-FILTER FILTER-FUNCTION-OPPOSITE-FUNCTION)

(DEFUN MSG-FALSE-FILTER (IGNORE IGNORE)
  NIL)

(DEFUN (MSG-HAS-ATTRIBUTE-P FILTER-FUNCTION-MAIL-FILE-NAME-FUNCTION) (ATTRIBUTE)
  (STRING-APPEND #/< (SYSTEM-ATTRIBUTE-NAME ATTRIBUTE) #/>))

(DEFUN SYSTEM-ATTRIBUTE-NAME (ATTRIBUTE)
  (OR (DOLIST (X *SYSTEM-FILTER-ALIST*)
	(AND (EQ ATTRIBUTE (GET X ':VALUE))
	     (RETURN (CAR X))))
      (STRING ATTRIBUTE)))

(DEFUN MSG-HAS-ATTRIBUTE-P (MSG ATTRIBUTE)
  (NOT (NULL (MSG-GET MSG ATTRIBUTE))))

(DEFPROP MSG-DOES-NOT-HAVE-ATTRIBUTE-P MSG-HAS-ATTRIBUTE-P FILTER-FUNCTION-OPPOSITE-FUNCTION)

(DEFUN MSG-DOES-NOT-HAVE-ATTRIBUTE-P (MSG ATTRIBUTE)
  (NOT (MSG-GET MSG ATTRIBUTE)))

(DEFUN (MSG-FITS-FILTER-P FILTER-FUNCTION-MAIL-FILE-NAME-FUNCTION) (FILTER)
  (STRING-APPEND #/< FILTER #/>))

(DEFUN MSG-FITS-FILTER-P (MSG FILTER)
  (NOT (NULL (FUNCALL (GET FILTER 'FILTER-FUNCTION) MSG))))

(DEFPROP MSG-DOES-NOT-FIT-FILTER-P MSG-FITS-FILTER-P FILTER-FUNCTION-OPPOSITE-FUNCTION)

(DEFUN MSG-DOES-NOT-FIT-FILTER-P (MSG FILTER)
  (NOT (FUNCALL (GET FILTER 'FILTER-FUNCTION) MSG)))

(DEFUN (MSG-HAS-SEARCH-STRING FILTER-FUNCTION-MAIL-FILE-NAME-FUNCTION) (KEY)
  (STRING-APPEND "(Search: " KEY ")"))

(DEFUN MSG-HAS-SEARCH-STRING (MSG KEY)
  (NOT (NULL (SEARCH (MSG-START-BP MSG) KEY NIL NIL NIL (MSG-END-BP MSG)))))

(DEFPROP MSG-DOES-NOT-HAVE-SEARCH-STRING MSG-HAS-SEARCH-STRING
	 FILTER-FUNCTION-OPPOSITE-FUNCTION)

(DEFUN MSG-DOES-NOT-HAVE-SEARCH-STRING (MSG KEY)
  (NULL (SEARCH (MSG-START-BP MSG) KEY NIL NIL NIL (MSG-END-BP MSG))))

(DEFUN MSG-HAS-FSM-SEARCH-STRING (MSG KEY)
  (NOT (NULL (FSM-SEARCH (MSG-START-BP MSG) KEY NIL NIL NIL (MSG-END-BP MSG)))))

(DEFUN MSG-DOES-NOT-HAVE-FSM-SEARCH-STRING (MSG KEY)
  (NULL (FSM-SEARCH (MSG-START-BP MSG) KEY NIL NIL NIL (MSG-END-BP MSG))))

(DEFUN MSG-HAS-FSM-EXPR-SEARCH-STRING (MSG KEY)
  (NOT (NULL (FSM-EXPR-SEARCH (MSG-START-BP MSG) KEY NIL NIL NIL (MSG-END-BP MSG)))))

(DEFUN MSG-DOES-NOT-HAVE-FSM-EXPR-SEARCH-STRING (MSG KEY)
  (NULL (FSM-EXPR-SEARCH (MSG-START-BP MSG) KEY NIL NIL NIL (MSG-END-BP MSG))))

(DEFUN (MSG-HAS-RECIPIENT-FIELD FILTER-FUNCTION-MAIL-FILE-NAME-FUNCTION) (FIELD)
  (STRING-APPEND "(Recipient: " FIELD #/)))

(DEFUN MSG-HAS-RECIPIENT-FIELD (MSG FIELD &AUX (STATUS (ASSURE-MSG-PARSED MSG)))
  (DOLIST (F *RECIPIENT-TYPE-HEADERS*)
    (AND (MSG-HEADER-RECIPIENT-MATCH (GET STATUS F) FIELD)
	 (RETURN T))))

(DEFPROP MSG-DOES-NOT-HAVE-RECIPIENT-FIELD MSG-HAS-RECIPIENT-FIELD
	 FILTER-FUNCTION-OPPOSITE-FUNCTION)

(DEFUN MSG-DOES-NOT-HAVE-RECIPIENT-FIELD (MSG FIELD &AUX (STATUS (ASSURE-MSG-PARSED MSG)))
  (NOT (DOLIST (F *RECIPIENT-TYPE-HEADERS*)
	 (AND (MSG-HEADER-RECIPIENT-MATCH (GET STATUS F) FIELD)
	      (RETURN T)))))

(DEFUN (MSG-HAS-FROM-FIELD FILTER-FUNCTION-MAIL-FILE-NAME-FUNCTION) (FIELD)
  (STRING-APPEND "(From: " FIELD #/)))

(DEFUN MSG-HAS-FROM-FIELD (MSG FIELD)
  (MSG-HEADER-RECIPIENT-MATCH (MSG-GET MSG ':FROM) FIELD))

(DEFPROP MSG-DOES-NOT-HAVE-FROM-FIELD MSG-HAS-FROM-FIELD FILTER-FUNCTION-OPPOSITE-FUNCTION)

(DEFUN MSG-DOES-NOT-HAVE-FROM-FIELD (MSG FIELD)
  (NOT (MSG-HEADER-RECIPIENT-MATCH (MSG-GET MSG ':FROM) FIELD)))

(DEFUN (MSG-HAS-SENDER-OR-RECIPIENT-FIELD FILTER-FUNCTION-MAIL-FILE-NAME-FUNCTION) (FIELD)
  (STRING-APPEND "(From//To: " FIELD #/)))

(DEFUN MSG-HAS-SENDER-OR-RECIPIENT-FIELD (MSG FIELD &AUX (STATUS (ASSURE-MSG-PARSED MSG)))
  (DOLIST (F *SENDER-OR-RECIPIENT-TYPE-HEADERS*)
    (AND (MSG-HEADER-RECIPIENT-MATCH (GET STATUS F) FIELD)
	 (RETURN T))))

(DEFPROP MSG-DOES-NOT-HAVE-SENDER-OR-RECIPIENT-FIELD MSG-HAS-SENDER-OR-RECIPIENT-FIELD
	 FILTER-FUNCTION-OPPOSITE-FUNCTION)

(DEFUN MSG-DOES-NOT-HAVE-SENDER-OR-RECIPIENT-FIELD (MSG FIELD
						    &AUX (STATUS (ASSURE-MSG-PARSED MSG)))
  (NOT (DOLIST (F *SENDER-OR-RECIPIENT-TYPE-HEADERS*)
	 (AND (MSG-HEADER-RECIPIENT-MATCH (GET STATUS F) FIELD)
	      (RETURN T)))))

(DEFUN (MSG-HAS-SUBJECT-STRING FILTER-FUNCTION-MAIL-FILE-NAME-FUNCTION) (KEY)
  (STRING-APPEND "(Subject: " KEY #/)))

(DEFUN MSG-HAS-SUBJECT-STRING (MSG KEY &AUX SUBJECT)
  (NOT (NULL (AND (SETQ SUBJECT (MSG-GET MSG ':SUBJECT))
		  (IF (LISTP SUBJECT)
		      (LOOP FOR STRING IN SUBJECT
			    THEREIS (STRING-SEARCH KEY STRING))
		      (STRING-SEARCH KEY SUBJECT))))))

(DEFPROP MSG-DOES-NOT-HAVE-SUBJECT-STRING MSG-HAS-SUBJECT-STRING
	 FILTER-FUNCTION-OPPOSITE-FUNCTION)

(DEFUN MSG-DOES-NOT-HAVE-SUBJECT-STRING (MSG KEY &AUX SUBJECT)
  (NOT (AND (SETQ SUBJECT (MSG-GET MSG ':SUBJECT))
	    (IF (LISTP SUBJECT)
		(LOOP FOR STRING IN SUBJECT
		      THEREIS (STRING-SEARCH KEY STRING))
		(STRING-SEARCH KEY SUBJECT)))))

(DEFFLAVOR BASIC-ZMAIL-FILTER
	(*EDITOR-WINDOW*
	 *EDITOR-INTERVAL*
	 *EDITOR-STREAM*
	 *EDITOR-INSERT-BP*
	 *SUMMARY-WINDOW*)
	())

(GLOBALLY-DECLARE-FLAVOR-INSTANCE-VARIABLES BASIC-ZMAIL-FILTER)

(DEFFLAVOR ZMAIL-FILTER-FRAME
       ((*MODE-LINE-LIST* '("ZMail " "Filter"))
	)
       (TOP-LEVEL-EDITOR BASIC-ZMAIL-FILTER
	ZMAIL-FRAME-MIXIN ZMAIL-COMMAND-LOOP-MIXIN-WITH-SUMMARY ZMAIL-COMMAND-LOOP-MIXIN
	TV:ANY-TYI-MIXIN TV:STREAM-MIXIN TV:BORDERS-MIXIN
	TV:PANE-MIXIN TV:ITEM-LIST-PANE-KLUDGE TV:FRAME-WITH-XOR-BUTTONS
	TV:SELECT-MIXIN TV:CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER TV:MINIMUM-WINDOW))

(DEFVAR *HEADER-FILTER-MENU-ALIST*
	'(("To" :VALUE :TO :DOCUMENTATION "Messages to a recipient in the To: line")
	  ("To//Cc" :VALUE :TO//CC
	   :DOCUMENTATION "Messages to a recipient in TO:, CC:, Forwarded to:, etc.")
	  ("From" :VALUE :FROM :DOCUMENTATION "Messages from a sender")
	  ("Subject" :VALUE :SUBJECT :DOCUMENTATION
	   "Messages with a given string anywhere in the subject line")
	  ("Other" :VALUE :OTHER
	   :DOCUMENTATION "messages with a string in an arbitrary header field")))

(DEFVAR *DATE-FILTER-MENU-ALIST*
	'(("Before" :VALUE :BEFORE :DOCUMENTATION "Messages before a given constant date")
	  ("On" :VALUE :ON :DOCUMENTATION "Messages on a specific date")
	  ("After" :VALUE :AFTER :DOCUMENTATION "Messages after a specific date")))

(DEFMETHOD (ZMAIL-FILTER-FRAME :BEFORE :INIT) (IGNORE &AUX MODE-LINE-HEIGHT)
  (SETQ MODE-LINE-HEIGHT (+ 11 (* 3 TV:(SHEET-LINE-HEIGHT SUPERIOR))))
  (SETQ TV:PANES `((NOT-BUTTON TV:BUTTON-PANE :NAME "Not"
					      :DOCUMENTATION "Negate a clause.")
		   (AND-BUTTON TV:BUTTON-PANE :NAME "And"
			       :DOCUMENTATION "Logical and of several clauses.")
		   (OR-BUTTON TV:BUTTON-PANE :NAME "Or"
					     :DOCUMENTATION "Logical or of several clauses.")
		   (CLOSE-BUTTON TV:BUTTON-PANE :NAME "Close"
					        :DOCUMENTATION
  "Add clauses to the next higher AND or OR.")
		   (SAMPLE-BUTTON TV:BUTTON-PANE :NAME "Sample"
					         :DOCUMENTATION
  "Show messages matching the filter as so far defined in the typeout window.")
		   (DONE-BUTTON TV:BUTTON-PANE :NAME "Done"
					       :DOCUMENTATION "Use this filter definition.")
		   (ABORT-BUTTON TV:BUTTON-PANE :NAME "Abort"
					        :DOCUMENTATION "Abort this command.")
		   (KEYWORD-COMMAND-MENU ZMAIL-COMMAND-MENU-PANE
					 :ITEM-LIST NIL :LABEL "Keywords:")
		   (USER-FILTER-MENU ZMAIL-COMMAND-MENU-PANE
				     :ITEM-LIST NIL :LABEL "Filters:")
		   (SYSTEM-FILTER-MENU ZMAIL-COMMAND-MENU-PANE
				       :ITEM-LIST ,*SYSTEM-FILTER-ALIST*)
		   (HEADER-FILTER-MENU ZMAIL-COMMAND-MENU-PANE
				       :ITEM-LIST ,*HEADER-FILTER-MENU-ALIST*)
		   (DATE-FILTER-MENU ZMAIL-COMMAND-MENU-PANE
				     :ITEM-LIST ,*DATE-FILTER-MENU-ALIST*)
		   (NAME-BUTTON TV:BIG-BUTTON-PANE :NAME "Name"
						   :BORDERS 3
						   :DOCUMENTATION
  "Specify a new name for this filter.  Click right for a menu of existing filters to edit.")
		   (EDITOR-WINDOW ZMAIL-WINDOW :LABEL NIL :BORDERS (2 2 2 1) :SAVE-BITS NIL
				  :FONT-MAP (FONTS:CPTFONT FONTS:SEARCH))
		   (MODE-LINE-WINDOW MODE-LINE-PANE
				     :HEIGHT ,MODE-LINE-HEIGHT
				     :MORE-P NIL :BORDERS (2 1 2 2)
				     :BLINKER-DESELECTED-VISIBILITY :OFF))
	TV:CONSTRAINTS
	       `((ONLY . ( (WHOLE-THING)
			   ((WHOLE-THING TV:WHITE-INCLUDE-WHITESPACE	;Horiz
			     (0.9) (:EVEN)
			     (MENUS FORM)
			     ((FORM TV:WHITE-INCLUDE-WHITESPACE	;Vert
			       (0.625) (:EVEN)
			       (NAMEX EDITORSS)
			       ((NAMEX TV:SINGLE-PANE-IN-WHITESPACE NAME-BUTTON))
			       ((EDITORSS :HORIZONTAL (0.85)
				 (EDITORS)
				 ((EDITORS :VERTICAL (:EVEN)
				   (EDITOR-WINDOW MODE-LINE-WINDOW)
				   ((MODE-LINE-WINDOW ,MODE-LINE-HEIGHT))
				   ((EDITOR-WINDOW :EVEN))))))))
			     ((MENUS TV:WHITE-INCLUDE-WHITESPACE	;Vert
			       (0.95) (:EVEN)
			       (CONDITIONALS CONTROLS SYSTEM-MENUS USER-MENUS)
			       ((CONDITIONALS TV:FLOATING-BUTTONS
				 (NOT-BUTTON AND-BUTTON OR-BUTTON CLOSE-BUTTON)))
			       ((CONTROLS TV:FLOATING-BUTTONS
				 (SAMPLE-BUTTON DONE-BUTTON ABORT-BUTTON)))
			       ((SYSTEM-MENUS TV:FLOATING-MENUS
				 (:ASK-WINDOW SYSTEM-FILTER-MENU :PANE-SIZE-WITH-WHITESPACE)
				 (SYSTEM-FILTER-MENU HEADER-FILTER-MENU DATE-FILTER-MENU)))
			       ((USER-MENUS TV:FLOATING-MENUS
				 (:ASK-WINDOW SELF :USER-MENUS-SIZE)
				 (KEYWORD-COMMAND-MENU USER-FILTER-MENU))))))))))))

(DEFMETHOD (BASIC-ZMAIL-FILTER :AFTER :INIT) (IGNORE)
  (MULTIPLE-VALUE (*EDITOR-WINDOW* *EDITOR-INTERVAL*)
    (CREATE-ZMAIL-WINDOW 'EDITOR-WINDOW))
  (SETQ *WINDOW* *EDITOR-WINDOW*)
  (SETQ *WINDOW-LIST* (NCONS *WINDOW*))
  (SETQ *EDITOR-STREAM* (INTERVAL-STREAM *EDITOR-INTERVAL* NIL NIL ':TYI))
  (SETQ *EDITOR-INSERT-BP* (COPY-BP (POINT) ':MOVES)))

(DEFMETHOD (ZMAIL-FILTER-FRAME :AFTER :INIT) (IGNORE)
  (SET-COMTAB *MODE-COMTAB* (LIST #/H (COMMAND-LOOKUP #/H *SEARCH-MINI-BUFFER-COMTAB*))))

(DEFMETHOD (ZMAIL-FILTER-FRAME :USER-MENUS-SIZE) (&REST ARGS)
  (MAX (LEXPR-FUNCALL-SELF ':SEND-PANE 'KEYWORD-COMMAND-MENU ':PANE-SIZE-WITH-WHITESPACE ARGS)
       (LEXPR-FUNCALL-SELF ':SEND-PANE 'USER-FILTER-MENU ':PANE-SIZE-WITH-WHITESPACE ARGS)))

(DEFMETHOD (ZMAIL-FILTER-FRAME :INITIALIZE) (&AUX NEW-NAME CHANGED-P)
  (SETQ NEW-NAME (GENERATE-UNIQUE-NAME *USER-FILTER-ALIST*))
  (SETQ *SUMMARY-WINDOW* (FUNCALL TV:SUPERIOR ':GET-PANE 'SUMMARY-WINDOW))
  (SETQ CHANGED-P (FUNCALL-SELF ':SET-PANES-ITEM-LIST 'KEYWORD-COMMAND-MENU
				(APPEND '(("Any" :VALUE ANY
					   :FONT FONTS:HL12BI :DOCUMENTATION
					   "Messages with any keyword on them."))
					*KEYWORD-ALIST*
					NIL)))
  (SETQ CHANGED-P (OR (FUNCALL-SELF ':SET-PANES-ITEM-LIST
				    'USER-FILTER-MENU (COPYLIST *USER-FILTER-ALIST*))
		      CHANGED-P))
  (AND CHANGED-P (FUNCALL-SELF ':SET-CONFIGURATION 'ONLY))
  (FUNCALL-SELF ':TURN-OFF-ACCENTS)
  (FUNCALL-SELF ':SET-PANES-NAME 'NAME-BUTTON NEW-NAME)
  (DELETE-INTERVAL *EDITOR-INTERVAL*)
  (INSERT-FORM-INTO-EDITOR-WINDOW
    `(DEFINE-FILTER ,(INTERN (STRING-UPCASE NEW-NAME)) (MSG)) -1)
  (MUST-REDISPLAY *EDITOR-WINDOW* DIS-ALL)
  (TYPEIN-LINE ""))

(DEFMETHOD (ZMAIL-FILTER-FRAME :TOP-LEVEL-TAG) () 'EXIT-FILTER-DEFINITION)

(DEFMETHOD (ZMAIL-FILTER-FRAME :PROCESS-SPECIAL-COMMAND) (&REST ARGS)
  (APPLY #'ZMAIL-FILTER-COMMAND-LIST ARGS))

(DEFSELECT (ZMAIL-FILTER-COMMAND-LIST ZMAIL-COMMAND-LIST-DEFAULT)
  (:MENU (ITEM IGNORE WINDOW &AUX WINDOW-NAME ITEM-NAME)
   (SETQ WINDOW-NAME (FUNCALL-SELF ':PANE-NAME WINDOW)
	 ITEM-NAME (IF (ATOM ITEM) ITEM (CAR ITEM))
	 ITEM (FUNCALL WINDOW ':EXECUTE-NO-SIDE-EFFECTS ITEM))
   (SELECTQ WINDOW-NAME
     (KEYWORD-COMMAND-MENU
      (INSERT-FORM-INTO-EDITOR-WINDOW (IF (EQ ITEM 'ANY)
					  'KEYWORDS
					  `(MEMQ ',ITEM KEYWORDS))))
     (USER-FILTER-MENU
      (INSERT-FORM-INTO-EDITOR-WINDOW `(MSG-FITS-FILTER-P MSG ',ITEM)))
     (OTHERWISE
      (INSERT-FILTER ITEM-NAME ITEM))))
  (:MOUSE-BUTTON (CH WINDOW IGNORE IGNORE &AUX WINDOW-NAME)
   (SETQ WINDOW-NAME (FUNCALL-SELF ':PANE-NAME WINDOW))
   (UNWIND-PROTECT
     (SELECTQ WINDOW-NAME
       (ABORT-BUTTON
	(*THROW 'EXIT-FILTER-DEFINITION NIL))
       (DONE-BUTTON
	(*THROW 'EXIT-FILTER-DEFINITION (GET-AND-COMPILE-FILTER)))
       (SAMPLE-BUTTON
	(LET ((MAP-FUNCTION 'MAP-OVER-SINGLE-MAIL-FILE)
	      (MAP-ARG *MAIL-FILE*))
	  (AND (= CH #\MOUSE-3-1)
	       (MULTIPLE-VALUE (MAP-FUNCTION MAP-ARG)
		 (GET-UNIVERSE-FUNCTION `(:WINDOW ,SELF))))
	  (OR MAP-FUNCTION (ABORT-CURRENT-COMMAND))
	  (SURVEY-FROM-FILTER MAP-FUNCTION MAP-ARG
			      #'MSG-FITS-FILTER-P (GET-AND-COMPILE-FILTER)))
	(CHECK-FOR-TYPEOUT-WINDOW-TYPEOUT))
       (NAME-BUTTON
	(READ-NEW-NAME WINDOW CH *USER-FILTER-ALIST* #'GET-FILTER-DEFINITION))
       (CLOSE-BUTTON
	(EDITOR-WINDOW-CLOSE-BUTTON))
       (OTHERWISE
	(INSERT-FORM-INTO-EDITOR-WINDOW `(,(SELECTQ WINDOW-NAME
					     (NOT-BUTTON 'NOT)
					     (AND-BUTTON 'AND)
					     (OR-BUTTON 'OR)))
					-1)))
     (FUNCALL WINDOW ':SET-ACCENT NIL)))
  (SUMMARY-MOUSE (ITEM IGNORE IGNORE &AUX (MSG (CADR ITEM)))	;Mouse in summary window
   (EXTRACT-FILTERS-FROM-MSG MSG))
  ((:TYPEOUT-EXECUTE SUMMARY-EXECUTE) (&REST IGNORE)
    (BARF)))

(DEFUN INSERT-FILTER (NAME TYPE)
  (INSERT-FORM-INTO-EDITOR-WINDOW
    (LOCAL-DECLARE ((SPECIAL *TYPE*))
      (LET ((*TYPE* TYPE))
	(CONDITION-BIND
	      ((UNKNOWN-SPECIAL-COMMAND #'ZMAIL-FILTER-MINI-BUFFER-UNKNOWN-SPECIAL-COMMAND))
	  (SELECTQ TYPE
	    ((DELETED UNSEEN ANSWERED RECENT FILED)
	     `(GET STATUS ',TYPE))
	    (:SEARCH
	     (LET ((KEY (READ-SEARCH-KEY-FROM-EDITOR-WINDOW "String to search for:")))
	       `(SEARCH-WITHIN-MSG ,KEY)))
	    ((:TO :TO//CC :FROM :SUBJECT :OTHER)
	     (COND ((EQ TYPE ':OTHER)
		    (MULTIPLE-VALUE (NAME TYPE)
		      (READ-HEADER-NAME-FROM-EDITOR-WINDOW "Header name:"))))
	     (LET ((KEY (READ-SEARCH-KEY-FROM-EDITOR-WINDOW (STRING-APPEND NAME #/:))))
	       (IF (ZEROP (STRING-LENGTH KEY))
		   `(NOT (NULL (GET STATUS ',TYPE)))
		   `(,(IF (OR (MEMQ TYPE *ADDRESS-TYPE-HEADERS*)
			      (EQ TYPE ':TO//CC))
			  'MSG-HEADER-RECIPIENT-SEARCH 'MSG-HEADER-SEARCH)
		     ,(IF (EQ TYPE ':TO//CC) '*RECIPIENT-TYPE-HEADERS* `',TYPE)
		     ,KEY))))
	    ((:ON :BEFORE :AFTER)
	     (MULTIPLE-VALUE-BIND (DATE RELATIVE-P)
		 (READ-DATE-FROM-EDITOR-WINDOW "~A date:" NAME)
	       (IF (NOT RELATIVE-P)
		   `(,(SELECTQ TYPE
			(:ON 'MSG-SAME-DATE)
			(:BEFORE 'MSG-DATE-LESSP)
			(:AFTER 'MSG-DATE-GREATERP))
		     ,DATE)
		   `(,(SELECTQ TYPE
			(:ON 'MSG-SAME-RELATIVE-DATE)
			(:BEFORE 'MSG-RELATIVE-DATE-LESSP)
			(:AFTER 'MSG-RELATIVE-DATE-GREATERP))
		     ,DATE
		     ,(FORMAT-CURRENT-DATE-FOR-FILTER)))))
	    ))))))

(DEFUN INSERT-FORM-INTO-EDITOR-WINDOW (FORM &OPTIONAL (NCHARS 0) &AUX BP (POINT (POINT)))
  (FUNCALL *EDITOR-STREAM* ':SET-BP *EDITOR-INSERT-BP*)
  (LET ((READTABLE (INITIALIZE-SPECIAL-/#/"-READTABLE)))
    (GRIND-TOP-LEVEL FORM (FUNCALL (WINDOW-SHEET *WINDOW*) ':SIZE-IN-CHARACTERS)
		     *EDITOR-STREAM* T 'SI:DISPLACED NIL))
  (SETQ BP (FUNCALL *EDITOR-STREAM* ':READ-BP))
  (MOVE-BP POINT (COND ((= NCHARS 0) BP)
		       ((< NCHARS 0) (FORWARD-CHAR BP NCHARS))
		       (T (FORWARD-CHAR POINT NCHARS))))
  (DO ((N)
       (FLAG NIL))
      (FLAG)
    (DELETE-BACKWARD-OVER *WHITESPACE-CHARS* POINT)
    (SETQ FLAG T
	  N (LET ((BP (FORWARD-SEXP POINT -1 NIL 1)))
	      (IF BP (COUNT-LIST-ELEMENTS BP) 0)))
    (COND ((ZEROP N))
	  ((= N 1) (INSERT-MOVING POINT #\SP))
	  ((MEMQ (RELEVANT-FUNCTION-NAME POINT NIL NIL) '(NOT ))
	   (MOVE-BP POINT (FORWARD-CHAR POINT 1))
	   (SETQ FLAG NIL))
	  (T (LET ((*NUMERIC-ARG-P* NIL) (*NUMERIC-ARG* 1))
	       (COM-INDENT-NEW-LINE)))))
  (MUST-REDISPLAY *WINDOW* DIS-TEXT)
  (MOVE-BP *EDITOR-INSERT-BP* POINT))

(DEFUN READ-SEARCH-KEY-FROM-EDITOR-WINDOW (PROMPT)
  (UNWIND-PROTECT
    (GET-EXTENDED-SEARCH-16B-STRING PROMPT)
    (FUNCALL-SELF ':SELECT NIL)))

(DEFUN READLINE-FROM-EDITOR-WINDOW (&REST PROMPT)
  (UNWIND-PROTECT
    (APPLY #'TYPEIN-LINE-READLINE PROMPT)
    (FUNCALL-SELF ':SELECT NIL)))

(DEFUN READ-HEADER-NAME-FROM-EDITOR-WINDOW (PROMPT)
  (UNWIND-PROTECT
    (LET ((KEY (COMPLETING-READ-FROM-MINI-BUFFER PROMPT *HEADER-NAME-ALIST* T)))
      (IF (STRINGP KEY)
	  (VALUES KEY (INTERN (STRING-UPCASE KEY) ""))
	  (VALUES (CAR KEY) (CDR KEY))))
    (FUNCALL-SELF ':SELECT NIL)))

(DEFUN FORMAT-DATE-FOR-FILTER (STRING)
  (DECLARE (RETURNS TIME-STRING RELATIVE-P))
  (MULTIPLE-VALUE-BIND (TIME RELATIVE-P)
      (TIME:PARSE-UNIVERSAL-TIME STRING 0 NIL NIL)	;Parse it, assuming not in future
    (IF (STRINGP TIME) (BARF TIME))
    (IF (AND RELATIVE-P
	     (Y-OR-N-P "Do you want that time relative to when the filter is run? (y or n)"))
	(VALUES STRING RELATIVE-P)
	(MULTIPLE-VALUE-BIND (SECONDS-OR-ERRMES MINUTES HOURS DAY MONTH YEAR)
	    (TIME:DECODE-UNIVERSAL-TIME TIME)
	  (AND ( YEAR 1900.) (< YEAR 2000.)
	       (SETQ YEAR (- YEAR 1900.)))
	  (FORMAT-DATE-FOR-FILTER-INTERNAL SECONDS-OR-ERRMES MINUTES HOURS DAY MONTH YEAR)))))

(DEFUN FORMAT-DATE-FOR-FILTER-INTERNAL (SECONDS MINUTES HOURS DAY MONTH YEAR)
  (FORMAT NIL "~D-~A-~D~:[ ~D:~2,48D~:[:~2,48D~]~]"
	  DAY (TIME:MONTH-STRING MONTH ':SHORT)
	  YEAR (AND (ZEROP HOURS) (ZEROP MINUTES) (ZEROP SECONDS))
	  HOURS MINUTES (ZEROP SECONDS) SECONDS))

(DEFUN FORMAT-CURRENT-DATE-FOR-FILTER ()
  (MULTIPLE-VALUE-BIND (SECONDS-OR-ERRMSG MINUTES HOURS DAY MONTH YEAR)
      (TIME:DECODE-UNIVERSAL-TIME (TIME:GET-UNIVERSAL-TIME))
    (IF (STRINGP SECONDS-OR-ERRMSG)
	(BARF SECONDS-OR-ERRMSG)
	(FORMAT-DATE-FOR-FILTER-INTERNAL SECONDS-OR-ERRMSG MINUTES HOURS DAY MONTH YEAR))))

(DEFUN READ-DATE-FROM-EDITOR-WINDOW (&REST PROMPT)
  (UNWIND-PROTECT
    (LET ((STRING (APPLY #'TYPEIN-LINE-READLINE PROMPT)))
      (FORMAT-DATE-FOR-FILTER STRING))
    (FUNCALL-SELF ':SELECT NIL)))

(DEFUN ZMAIL-FILTER-MINI-BUFFER-UNKNOWN-SPECIAL-COMMAND (&REST IGNORE &AUX MSG STRING)
  (DECLARE (SPECIAL *TYPE*))
  (COND ((EQ (CAR *LAST-COMMAND-CHAR*) 'SUMMARY-MOUSE)
	 (SETQ MSG (CADADR *LAST-COMMAND-CHAR*))
	 (SETQ STRING (MSG-HEADER-FILTER-STRING MSG *TYPE*))
	 (DELETE-INTERVAL *INTERVAL*)
	 (INSERT-MOVING (POINT) STRING)
	 (MUST-REDISPLAY *WINDOW* DIS-TEXT)
	 (VALUES 'EH:RETURN-VALUE T))))

(DEFUN MSG-HEADER-FILTER-STRING (MSG TYPE &AUX STATUS PROP)
  (SETQ STATUS (ASSURE-MSG-PARSED MSG))
  (AND (MEMQ TYPE '(:ON :BEFORE :AFTER))
       (SETQ TYPE ':DATE))
  (SETQ PROP (IF (EQ TYPE ':TO//CC)
		 (DO ((TYPES *RECIPIENT-TYPE-HEADERS* (CDR TYPES))
		      (L NIL))
		     ((NULL TYPES) L)
		   (SETQ L (APPEND L (GET STATUS (CAR TYPES)))))
		 (GET STATUS TYPE)))
  (COND ((NULL PROP) (BARF))
	((EQ TYPE ':DATE)
	 (OR PROP (BARF))
	 (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR)
	     (TIME:DECODE-UNIVERSAL-TIME PROP)
	   (AND ( YEAR 1900.) (< YEAR 2000.)
		(SETQ YEAR (- YEAR 1900.)))
	   (FORMAT NIL "~D-~A-~D ~D:~2,48D:~2,48D" DAY (TIME:MONTH-STRING MONTH ':SHORT) YEAR
		   HOURS MINUTES SECONDS)))
	((STRINGP PROP) PROP)
	((NULL (CDR PROP))
	 (CANONICALIZE-RECIPIENT-FILTER-STRING (CAR PROP)))
	(T
	 (UNWIND-PROTECT
	   (PROGN
	     (PRINT-TYPEOUT-FILTER (CAR (RASSQ TYPE *HEADER-FILTER-MENU-ALIST*))
				   'MINI-BUFFER-STRING
				   (MAPCAR #'CANONICALIZE-RECIPIENT-FILTER-STRING PROP))
	     (LET ((CH (FUNCALL STANDARD-INPUT ':ANY-TYI)))
	       (OR (AND (LISTP CH) (EQ (CAR CH) ':TYPEOUT-EXECUTE))
		   (BARF))
	       (CADDR CH)))
	   (FUNCALL *TYPEOUT-WINDOW* ':MAKE-COMPLETE)))))

(DEFUN CANONICALIZE-RECIPIENT-FILTER-STRING (STRING)
  (COND ((STRINGP STRING) STRING)
	((NULL (CDR STRING)) (CAR STRING))
	(T (STRING-FROM-HEADER STRING ':SHORT))))

(TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* MINI-BUFFER-STRING "Insert" STRING T
			  "Insert this string.")

(DEFUN EDITOR-WINDOW-CLOSE-BUTTON (&AUX (*NUMERIC-ARG* 1) (*NUMERIC-ARG-P* NIL)
					(*LAST-COMMAND-CHAR* #/)))
  (MUST-REDISPLAY *WINDOW* (COM-MOVE-OVER-/)))
  (MOVE-BP *EDITOR-INSERT-BP* (POINT)))

(DEFUN READ-FROM-EDITOR-WINDOW (&AUX (FORM '*EOF*))
  (FUNCALL *EDITOR-STREAM* ':SET-BP (INTERVAL-FIRST-BP *EDITOR-INTERVAL*))
  (CATCH-ERROR
    (LET ((READTABLE (INITIALIZE-SPECIAL-/#/"-READTABLE)))
      (SETQ FORM (READ *EDITOR-STREAM* '*EOF*)))
    NIL)
  (AND (EQ FORM '*EOF*) (BARF "Unbalanced parentheses"))
  FORM)

(DEFUN GET-AND-COMPILE-FILTER (&AUX FILTER-PROP FILTER)
  (SETQ *TYPEOUT-WINDOW* (WINDOW-TYPEOUT-WINDOW *WINDOW*)
	TERMINAL-IO *TYPEOUT-WINDOW*)
  (FUNCALL *TYPEOUT-WINDOW* ':MAKE-COMPLETE)
  (SETQ FILTER-PROP (EVAL (READ-FROM-EDITOR-WINDOW)))
  (OR (AND (EQ (CAR FILTER-PROP) ':PROPERTY)
	   (EQ (CADDR FILTER-PROP) 'FILTER-FUNCTION))
      (BARF "Does not look like a filter definition"))
  (SETQ FILTER (CADR FILTER-PROP))
  (PUTPROP FILTER (GET FILTER 'FILTER-FUNCTION) 'EXPR-FILTER-FUNCTION)
  (COMPILE FILTER-PROP)
  (AND (FUNCALL *TYPEOUT-WINDOW* ':INCOMPLETE-P)	;If there are warning messages,
       (NOT (Y-OR-N-P "Ok? " *TYPEOUT-WINDOW*))		;user has chance to not exit
       (ABORT-CURRENT-COMMAND))
  FILTER)

(DEFUN READ-NEW-NAME (NAME-BUTTON CHAR CHOICE-LIST DEFINITION-ACCESS-FUNCTION &AUX STRING)
  (COND ((= CHAR #\MOUSE-1-1)		;Left button gets new one
	 (SETQ STRING (READLINE-FROM-EDITOR-WINDOW "New name:"))
	 (LET ((BP (FORWARD-OVER *BLANKS* (FORWARD-ATOM (INTERVAL-FIRST-BP *INTERVAL*)))))
	   (SETQ BP (DELETE-INTERVAL BP (FORWARD-ATOM BP) T))
	   (INSERT BP (STRING-UPCASE STRING)))
	 (MUST-REDISPLAY *WINDOW* DIS-TEXT))
	(T
	 (SETQ STRING (TV:MENU-CHOOSE CHOICE-LIST NIL `(:WINDOW ,NAME-BUTTON)))
	 (OR STRING (ABORT-CURRENT-COMMAND))
	 (DELETE-INTERVAL *INTERVAL*)
	 (INSERT-FORM-INTO-EDITOR-WINDOW (FUNCALL DEFINITION-ACCESS-FUNCTION STRING))
	 (SETQ STRING (STRING STRING))))
  (FUNCALL (TV:SHEET-SUPERIOR NAME-BUTTON) ':SET-PANES-NAME 'NAME-BUTTON STRING))

(DEFVAR *FILTER-DEFINITION-SUMMARY-DOCUMENTATION* "Select filters based on this message.")

(DEFUN DEFINE-NEW-FILTER (&AUX (OLD-CONFIGURATION *WINDOW-CONFIGURATION*) LOCKED-P
			       OLD-DOC)
  (SETQ OLD-DOC (FUNCALL *SUMMARY-WINDOW* ':WHO-LINE-OVERRIDE-DOCUMENTATION-STRING))
  (PKG-BIND "ZWEI"
    (UNWIND-PROTECT
      (PROGN
	(SETQ LOCKED-P (LOCK-BACKGROUND-PROCESS))
	(FUNCALL *SUMMARY-WINDOW* ':SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING
		 *FILTER-DEFINITION-SUMMARY-DOCUMENTATION*)
	(FUNCALL *ZMAIL-WINDOW* ':SET-WINDOW-CONFIGURATION ':FILTER)
	(FUNCALL *FILTER-WINDOW* ':COMMAND-LOOP))
      (FUNCALL *SUMMARY-WINDOW* ':SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING OLD-DOC)
      (FUNCALL *ZMAIL-WINDOW* ':SET-WINDOW-CONFIGURATION OLD-CONFIGURATION)
      (AND LOCKED-P (PROCESS-UNLOCK *ZMAIL-BACKGROUND-PROCESS-LOCK*)))))

(DEFUN GENERATE-UNIQUE-NAME (LIST &OPTIONAL (NAME "Noname"))
  (DO ((I 1 (1+ I))
       (STRING))
      (NIL)
    (SETQ STRING (FORMAT NIL "~A-~D" NAME I))
    (OR (MEM #'(LAMBDA (X Y)
		 (IF (NOT (ATOM Y))
		     (SETQ Y (CAR Y)))
		 (STRING-EQUAL X Y))
	     STRING LIST)
	(RETURN STRING))
    (RETURN-ARRAY STRING)))

(DEFUN EXTRACT-FILTERS-FROM-MSG (MSG)
  (DO-NAMED TOP
      ((*TYPEOUT-WINDOW*))
      (NIL)
    (PRINT-MSG-TYPEOUT-FILTERS MSG)
    (DO ((CH) (TYPE))
	(NIL)
      (REDISPLAY-ALL-WINDOWS)
      (SETQ CH (FUNCALL STANDARD-INPUT ':ANY-TYI))
      (COND ((OR (NLISTP CH) (NOT (MEMQ (SETQ TYPE (CAR CH))
					'(:TYPEOUT-EXECUTE SUMMARY-MOUSE))))
	     (OR (EQ CH #\SP) (FUNCALL STANDARD-INPUT ':UNTYI CH))
	     (FUNCALL *TYPEOUT-WINDOW* ':MAKE-COMPLETE)
	     (RETURN-FROM TOP NIL))
	    ((EQ TYPE 'SUMMARY-MOUSE)
	     (SETQ MSG (CADADR CH))
	     (RETURN))
	    ((EQ TYPE ':TYPEOUT-EXECUTE)
	     (LEXPR-FUNCALL (CADR CH) (CDDR CH)))))))

(DEFUN PRINT-MSG-TYPEOUT-FILTERS (MSG &OPTIONAL JUST-FROM-TO INCLUDE-SITE &AUX STATUS)
  (SETQ *TYPEOUT-WINDOW* (FUNCALL *SUMMARY-WINDOW* ':TYPEOUT-WINDOW))
  (SETQ STATUS (ASSURE-MSG-PARSED MSG))
  (COND (JUST-FROM-TO
	 (PRINT-MSG-TYPEOUT-FILTERS-1 "From//To: " 'SENDER-OR-RECIPIENT-FIELD
				      STATUS *SENDER-OR-RECIPIENT-TYPE-HEADERS*
				      INCLUDE-SITE))
	(T
	 (PRINT-MSG-TYPEOUT-FILTERS-1 "From: " 'FROM-FIELD
				      STATUS *SENDER-TYPE-HEADERS* INCLUDE-SITE)
	 (PRINT-MSG-TYPEOUT-FILTERS-1 "Recipients: " 'RECIPIENT-FIELD
				      STATUS *RECIPIENT-TYPE-HEADERS* INCLUDE-SITE)
	 (PRINT-TYPEOUT-FILTER "Subject: " 'SUBJECT-FIELD
			       (GET-MSG-SUBJECT-CLEVERLY MSG NIL)))))

(DEFUN PRINT-MSG-TYPEOUT-FILTERS-1 (NAME TYPE STATUS LIST INCLUDE-SITE)
  (PRINT-TYPEOUT-FILTER NAME TYPE
			(LOOP FOR IND IN LIST
			      NCONC (MAKE-RECIPIENT-TYPEOUT-ALIST STATUS IND INCLUDE-SITE))))

(DEFUN PRINT-TYPEOUT-FILTER (NAME TYPE ELEMENTS)
  (COND ((NOT (NULL ELEMENTS))
	 (FUNCALL *TYPEOUT-WINDOW* ':FRESH-LINE)
	 (FUNCALL *TYPEOUT-WINDOW* ':STRING-OUT NAME)
	 (IF (OR (NLISTP ELEMENTS) (NULL (CDR ELEMENTS)))	;Only one element
	     (FUNCALL *TYPEOUT-WINDOW* ':ITEM TYPE
		      (IF (LISTP ELEMENTS) (CAR ELEMENTS) ELEMENTS))
	     (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST TYPE ELEMENTS)))))

(DEFUN MAKE-RECIPIENT-TYPEOUT-ALIST (STATUS TYPE INCLUDE-SITE)
  (LOOP FOR HEADER IN (GET STATUS TYPE)
	COLLECT (IF INCLUDE-SITE
		    (STRING-FROM-HEADER HEADER ':SHORT)
		    (GET (LOCF HEADER) ':NAME))))

(TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* FROM-FIELD "Insert" INSERT-FROM-FIELD T
			  "Insert this from field.")

(DEFUN INSERT-FROM-FIELD (FIELD)
  (INSERT-FORM-INTO-EDITOR-WINDOW `(MSG-HEADER-RECIPIENT-SEARCH ':FROM ,FIELD)))

(TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* RECIPIENT-FIELD "Insert"
			  INSERT-RECIPIENT-FIELD T
			  "Insert this recipient field.")

(DEFUN INSERT-RECIPIENT-FIELD (FIELD)
  (INSERT-FORM-INTO-EDITOR-WINDOW `(MSG-HEADER-RECIPIENT-SEARCH *RECIPIENT-TYPE-HEADERS*
								,FIELD)))

(TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* SENDER-OR-RECIPIENT-FIELD "Insert"
			  INSERT-SENDER-OR-RECIPIENT-FIELD T
			  "Insert this recipient field.")

(DEFUN INSERT-SENDER-OR-RECIPIENT-FIELD (FIELD)
  (INSERT-FORM-INTO-EDITOR-WINDOW
    `(MSG-HEADER-RECIPIENT-SEARCH *SENDER-OR-RECIPIENT-TYPE-HEADERS* ,FIELD)))

(TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* SUBJECT-FIELD "Insert"
			  INSERT-SUBJECT-FIELD T "Insert this subject field.")

(DEFUN INSERT-SUBJECT-FIELD (FIELD)
  (INSERT-FORM-INTO-EDITOR-WINDOW `(MSG-HEADER-SEARCH ':SUBJECT ,FIELD)))

(DEFUN CHOOSE-MSG-OR-READLINE (PROMPT &OPTIONAL DEFAULT &AUX RESULT)
  (*CATCH 'CHOOSE-MSG-OR-READLINE
    (WITH-BACKGROUND-PROCESS-LOCKED
      (CONDITION-BIND ((UNKNOWN-SPECIAL-COMMAND
			 #'CHOOSE-MSG-OR-READLINE-UNKNOWN-SPECIAL-COMMAND))
	(SETQ RESULT (TYPEIN-LINE-READLINE
		       "~A:~@[ (Default: ~A)~]~:[ (Or select message with mouse)~]"
		       PROMPT DEFAULT
		       (NOT (MEMQ *WINDOW-CONFIGURATION*
				  *SUMMARY-WINDOW-CONFIGURATIONS*))))))
    (AND DEFAULT (EQUAL RESULT "")
	 (SETQ RESULT DEFAULT))
    RESULT))

(DEFUN CHOOSE-MSG-OR-READLINE-UNKNOWN-SPECIAL-COMMAND (&REST IGNORE)
  (AND (EQ (CAR *LAST-COMMAND-CHAR*) 'SUMMARY-MOUSE)
       (*THROW 'CHOOSE-MSG-OR-READLINE (CADADR *LAST-COMMAND-CHAR*))))	;Return the msg

(DEFUN CHOOSE-OR-READLINE-ADDRESS (PROMPT &OPTIONAL NOT-P INCLUDE-SITE DEFAULT &AUX X)
  (SETQ X (CHOOSE-MSG-OR-READLINE PROMPT DEFAULT))
  (IF (STRINGP X)				;Typed by user
      (VALUES (IF NOT-P
		  'MSG-DOES-NOT-HAVE-SENDER-OR-RECIPIENT-FIELD
		  'MSG-HAS-SENDER-OR-RECIPIENT-FIELD)
	      X)
      (GET-FILTERS-FROM-MSG X NOT-P T INCLUDE-SITE)))

(DEFUN GET-FILTERS-FROM-MSG (MSG NOT-P &OPTIONAL JUST-FROM-TO INCLUDE-SITE
				       &AUX CH FUN *TYPEOUT-WINDOW*)
  (PRINT-MSG-TYPEOUT-FILTERS MSG JUST-FROM-TO INCLUDE-SITE)
  (FUNCALL *TYPEOUT-WINDOW* ':FRESH-LINE)
  (SETQ CH (FUNCALL STANDARD-INPUT ':ANY-TYI))
  (FUNCALL *TYPEOUT-WINDOW* ':MAKE-COMPLETE)
  (OR (AND (LISTP CH) (EQ (CAR CH) ':TYPEOUT-EXECUTE))
      (BARF))
  (SETQ FUN (SELECTQ (CADR CH)
	      (INSERT-FROM-FIELD
	       (IF NOT-P 'MSG-DOES-NOT-HAVE-FROM-FIELD 'MSG-HAS-FROM-FIELD))
	      (INSERT-RECIPIENT-FIELD
	       (IF NOT-P 'MSG-DOES-NOT-HAVE-RECIPIENT-FIELD 'MSG-HAS-RECIPIENT-FIELD))
	      (INSERT-SENDER-OR-RECIPIENT-FIELD
	       (IF NOT-P 'MSG-DOES-NOT-HAVE-SENDER-OR-RECIPIENT-FIELD
			 'MSG-HAS-SENDER-OR-RECIPIENT-FIELD))
	      (INSERT-SUBJECT-FIELD
	       (IF NOT-P 'MSG-DOES-NOT-HAVE-SUBJECT-STRING 'MSG-HAS-SUBJECT-STRING))
	      (OTHERWISE
	       (BARF))))
  (VALUES FUN (CADDR CH)))

(DEFUN GET-MSG-SUBJECT-CLEVERLY (MSG &OPTIONAL (ERROR-P T) &AUX SUBJECT START END)
  (COND ((SETQ SUBJECT (MSG-GET MSG ':SUBJECT))
	 (SETQ START 0 END (STRING-LENGTH SUBJECT))
	 (DO () ((NOT (%STRING-EQUAL SUBJECT START "Re: " 0 4)))
	   (SETQ START (+ START 4)))
	 (DO ((TEM)) ((NOT (AND (PLUSP END) (= (AREF SUBJECT (1- END)) #/]))))
	   (OR (SETQ TEM (STRING-SEARCH-CHAR #/: SUBJECT START END))
	       (RETURN))
	   (SETQ TEM (1+ TEM))
	   (DO () ((NOT (MEMQ (AREF SUBJECT TEM) '(#\SP #\TAB))))
	     (SETQ TEM (1+ TEM)))
	   (SETQ START TEM
		 END (1- END)))
	 (IF (AND (= START 0) (= END (STRING-LENGTH SUBJECT)))
	     SUBJECT (SUBSTRING SUBJECT START END)))
	(ERROR-P
	 (BARF "This message has no subject"))))

(DEFUN MAKE-MAIL-FILE-FROM-FILTER-FROM-MSG (MSG)
  (MULTIPLE-VALUE-BIND (FILTER-FUNCTION FILTER-ARG)
      (GET-FILTERS-FROM-MSG MSG NIL)
    (MAKE-MAIL-FILE-FROM-FILTER 'MAP-OVER-SINGLE-MAIL-FILE *MAIL-FILE*
				FILTER-FUNCTION FILTER-ARG)))

(DEFUN GET-UNIVERSE-FUNCTION (&OPTIONAL (NEAR-MODE '(:MOUSE)) LABEL
			      &AUX CHOICE MAP-FUNCTION MAP-ARG NAME)
  (DECLARE (RETURN-LIST MAP-FUNCTION MAP-ARG NAME))
  (FUNCALL *UNIVERSE-SELECTION-MENU* ':SET-LABEL LABEL)
  (MULTIPLE-VALUE-BIND (MAIL-FILE-ITEM-LIST TEMP-MAIL-FILE-ITEM-LIST)
      (GET-MAIL-FILE-ALISTS T)
    (FUNCALL *UNIVERSE-SELECTION-MENU* ':SET-ITEM-LISTS
	     MAIL-FILE-ITEM-LIST
	     TEMP-MAIL-FILE-ITEM-LIST
	     (APPEND *UNIVERSE-LIST*
		     ;; "Built-in" universes
		     '(("Find file" :VALUE :FIND-FILE :FONT FONTS:HL12I
			:DOCUMENTATION "Map over messages in a specified file.")
		       ("All" :VALUE :ALL :FONT FONTS:HL12I :DOCUMENTATION
  "All messages, including those in files not yet read in.")
		       ("Loaded files" :VALUE :LOADED :FONT FONTS:HL12I
			:DOCUMENTATION "All messages currently read in.")
		       ("New universe" :VALUE :NEW-UNIVERSE :FONT FONTS:HL12I
			:DOCUMENTATION "Create a new universe by set operations."))
		     (AND *MAIL-FILE*
			  '(("Rest of current" :VALUE :REST :FONT FONTS:HL12I
			     :DOCUMENTATION "Messsages after this in this mail file")
			    ("Beginning of current" :VALUE :BEGINNING :FONT FONTS:HL12I
			     :DOCUMENTATION "Messages before this in this mail file"))))))
  (TV:EXPOSE-WINDOW-NEAR *UNIVERSE-SELECTION-MENU* NEAR-MODE)
  (SETQ CHOICE (FUNCALL *UNIVERSE-SELECTION-MENU* ':CHOOSE))
  (AND (EQ CHOICE ':FIND-FILE)
       (SETQ CHOICE (SELECT-MAIL-FILE-FIND-FILE ':MOUSE)))
  (AND (OR (STRINGP CHOICE) (TYPEP CHOICE 'FS:PATHNAME))
       (SETQ CHOICE (MAKE-NEW-MAIL-FILE CHOICE)))
  (COND ((NULL CHOICE)
	 (SETQ MAP-FUNCTION NIL))
	((EQ CHOICE ':ALL)
	 (SETQ MAP-FUNCTION 'MAP-OVER-ALL-MAIL-FILES
	       NAME "All"))
	((EQ CHOICE ':LOADED)
	 (SETQ MAP-FUNCTION 'MAP-OVER-LOADED-MAIL-FILES
	       NAME "Loaded files"))
	((EQ CHOICE ':REST)
	 (SETQ MAP-FUNCTION 'MAP-OVER-REST-OF-MAIL-FILE
	       MAP-ARG *MAIL-FILE*
	       NAME (FORMAT NIL "Rest of ~A" (MAIL-FILE-NAME MAP-ARG))))
	((EQ CHOICE ':BEGINNING)
	 (SETQ MAP-FUNCTION 'MAP-OVER-BEGINNING-OF-MAIL-FILE
	       MAP-ARG *MAIL-FILE*
	       NAME (FORMAT NIL "Beginning of ~A" (MAIL-FILE-NAME MAP-ARG))))
	((EQ CHOICE ':NEW-UNIVERSE)
	 (MULTIPLE-VALUE (MAP-FUNCTION MAP-ARG NAME)
	   (DEFINE-NEW-UNIVERSE NEAR-MODE)))
	((SYMBOLP CHOICE)
	 (SETQ MAP-FUNCTION 'MAP-OVER-DEFINED-UNIVERSE
	       MAP-ARG CHOICE
	       NAME (STRING CHOICE)))
	(T
	 (SETQ MAP-FUNCTION 'MAP-OVER-SINGLE-MAIL-FILE
	       MAP-ARG CHOICE
	       NAME (MAIL-FILE-NAME MAP-ARG))
	 (AND (MAIL-FILE-DISK-P CHOICE) (ASSURE-MAIL-FILE-FULLY-LOADED CHOICE))))
  (VALUES MAP-FUNCTION MAP-ARG NAME))

(DEFFLAVOR BASIC-UNIVERSE-DEFINITION-FRAME
	(*EDITOR-WINDOW*
	 *EDITOR-INTERVAL*
	 *EDITOR-STREAM*
	 *EDITOR-INSERT-BP*)
	())

(GLOBALLY-DECLARE-FLAVOR-INSTANCE-VARIABLES BASIC-UNIVERSE-DEFINITION-FRAME)

(DEFFLAVOR UNIVERSE-DEFINITION-FRAME
       ((*MODE-LINE-LIST* '("ZMail " "Filter"))
	)
       (TOP-LEVEL-EDITOR BASIC-UNIVERSE-DEFINITION-FRAME
	ZMAIL-FRAME-MIXIN ZMAIL-COMMAND-LOOP-MIXIN
	TV:TEMPORARY-WINDOW-MIXIN TV:ANY-TYI-MIXIN TV:STREAM-MIXIN TV:BORDERS-MIXIN
	TV:ITEM-LIST-PANE-KLUDGE TV:FRAME-WITH-XOR-BUTTONS
	TV:CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER TV:MINIMUM-WINDOW))

(DEFMETHOD (UNIVERSE-DEFINITION-FRAME :BEFORE :INIT) (IGNORE &AUX MODE-LINE-HEIGHT)
  (SETQ MODE-LINE-HEIGHT (+ 11 (* 2 TV:(SHEET-LINE-HEIGHT SUPERIOR))))
  (SETQ TV:PANES `((UNION-BUTTON TV:BUTTON-PANE :NAME "Union"
				 :DOCUMENTATION "Set union of several universes.")
		   (INTERSECTION-BUTTON TV:BUTTON-PANE :NAME "Intersection"
						       :DOCUMENTATION
						    "Set intersection of several universes.")
		   (NOT-BUTTON TV:BUTTON-PANE :NAME "Not"
					      :DOCUMENTATION
					      "Set of all messages not in a universe.")
		   (CLOSE-BUTTON TV:BUTTON-PANE :NAME "Close"
					        :DOCUMENTATION
						"Move to next higher Union or Intersection.")
		   (MAIL-FILE-MENU ZMAIL-COMMAND-MENU-PANE
				   :ITEM-LIST NIL :LABEL "Mail files:")
		   (OTHER-MAIL-FILE-MENU ZMAIL-COMMAND-MENU-PANE
					 :ITEM-LIST NIL :LABEL "")
		   (UNIVERSE-MENU ZMAIL-COMMAND-MENU-PANE
				  :ITEM-LIST NIL :LABEL "Universes:")
		   (NAME-BUTTON TV:BIG-BUTTON-PANE :NAME "Name" :BORDERS 3
				:DOCUMENTATION 
 "Specify a new name for this universe.  Click right for a menu of existing filters to edit.")
		   (EDITOR-WINDOW ZMAIL-WINDOW :LABEL NIL :BORDERS (2 2 2 1) :SAVE-BITS NIL
				  :CHARACTER-HEIGHT 10.)
		   (MODE-LINE-WINDOW MODE-LINE-PANE
				     :HEIGHT ,MODE-LINE-HEIGHT
				     :MORE-P NIL :BORDERS (2 1 2 2)
				     :BLINKER-DESELECTED-VISIBILITY :OFF)
		   (DONE-BUTTON TV:BUTTON-PANE :NAME "Done"
				:DOCUMENTATION "Use this universe definition.")
		   (ABORT-BUTTON TV:BUTTON-PANE :NAME "Abort"
				 :DOCUMENTATION "Abort this command."))
	TV:CONSTRAINTS
	      `((ONLY . ( (WHOLE-THING)
			  ((WHOLE-THING :HORIZONTAL (:EVEN)
			    (WHOLE)
			    ((WHOLE TV:WHITE-INCLUDE-WHITESPACE	;Vert
			      (0.95) (:EVEN)
			      (OPERATIONS MENUS NAME EDITOR CONTROLS)
			      ((OPERATIONS TV:FLOATING-BUTTONS
				(UNION-BUTTON INTERSECTION-BUTTON NOT-BUTTON CLOSE-BUTTON)))
			      ((NAME TV:SINGLE-PANE-IN-WHITESPACE NAME-BUTTON))
			      ((CONTROLS TV:FLOATING-BUTTONS
				(DONE-BUTTON ABORT-BUTTON)))
			      ((EDITOR TV:WHITE-INCLUDE-WHITESPACE	;Horiz
				(:ASK-WINDOW SELF :EDITOR-SIZE) (:EVEN)
				(EDITORS)
				((EDITORS :VERTICAL (0.8)
				  (EDITOR-WINDOW MODE-LINE-WINDOW)
				  ((MODE-LINE-WINDOW ,MODE-LINE-HEIGHT))
				  ((EDITOR-WINDOW :EVEN))))))
			      ;; This comes last since it can afford a scroll bar
			      ((MENUS TV:FLOATING-MENUS
				(:ASK-WINDOW SELF :MENUS-SIZE)
				(MAIL-FILE-MENU OTHER-MAIL-FILE-MENU UNIVERSE-MENU))))))))))))

(DEFMETHOD (UNIVERSE-DEFINITION-FRAME :MENUS-SIZE) (&REST ARGS)
  (MAX (LEXPR-FUNCALL-SELF ':SEND-PANE 'MAIL-FILE-MENU ':PANE-SIZE ARGS)
       (LEXPR-FUNCALL-SELF ':SEND-PANE 'OTHER-MAIL-FILE-MENU ':PANE-SIZE ARGS)
       (LEXPR-FUNCALL-SELF ':SEND-PANE 'UNIVERSE-MENU ':PANE-SIZE ARGS)))

(DEFMETHOD (UNIVERSE-DEFINITION-FRAME :EDITOR-SIZE) (&REST IGNORE)
  (+ (TV:SHEET-HEIGHT (FUNCALL-SELF ':GET-PANE 'MODE-LINE-WINDOW))
     (LET ((EDITOR-WINDOW (FUNCALL-SELF ':GET-PANE 'EDITOR-WINDOW)))
       (+ (TV:SHEET-TOP-MARGIN-SIZE EDITOR-WINDOW)
	  (TV:SHEET-BOTTOM-MARGIN-SIZE EDITOR-WINDOW)
	  (* 10. (TV:SHEET-LINE-HEIGHT EDITOR-WINDOW))))))

(DEFMETHOD (UNIVERSE-DEFINITION-FRAME :COMPUTE-GEOMETRY) (UNIVERSE-NAME MAIL-FILE-ALIST
							 OTHER-MAIL-FILE-ALIST UNIVERSE-ALIST 
							 &AUX MAX-WIDTH MAX-HEIGHT CHANGED-P)
  (SETQ MAX-WIDTH TV:(- (SHEET-INSIDE-WIDTH SUPERIOR) LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)
	MAX-HEIGHT TV:(- (SHEET-INSIDE-HEIGHT SUPERIOR) TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE))
  (FUNCALL-SELF ':SET-PANES-NAME 'NAME-BUTTON UNIVERSE-NAME)
  (SETQ CHANGED-P (FUNCALL-SELF ':SET-PANES-ITEM-LIST 'MAIL-FILE-MENU MAIL-FILE-ALIST))
  (SETQ CHANGED-P (OR (FUNCALL-SELF ':SET-PANES-ITEM-LIST 'OTHER-MAIL-FILE-MENU
				    OTHER-MAIL-FILE-ALIST)
		      CHANGED-P))
  (SETQ CHANGED-P (OR (FUNCALL-SELF ':SET-PANES-ITEM-LIST 'UNIVERSE-MENU UNIVERSE-ALIST)
		      CHANGED-P))
  (AND CHANGED-P
       (LET ((WID (MIN MAX-WIDTH
		       (// (* (MAX (+ (FUNCALL-SELF ':SEND-PANE 'UNION-BUTTON
						    ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						    NIL NIL ':HORIZONTAL)
				      (FUNCALL-SELF ':SEND-PANE 'INTERSECTION-BUTTON
						    ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						    NIL NIL ':HORIZONTAL)
				      (FUNCALL-SELF ':SEND-PANE 'NOT-BUTTON
						    ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						    NIL NIL ':HORIZONTAL)
				      (FUNCALL-SELF ':SEND-PANE 'CLOSE-BUTTON
						    ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						    NIL NIL ':HORIZONTAL))
				   (+ (FUNCALL-SELF ':SEND-PANE 'MAIL-FILE-MENU
						    ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						    NIL NIL ':HORIZONTAL)
				      (FUNCALL-SELF ':SEND-PANE 'OTHER-MAIL-FILE-MENU
						    ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						    NIL NIL ':HORIZONTAL)
				      (FUNCALL-SELF ':SEND-PANE 'UNIVERSE-MENU
						    ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						    NIL NIL ':HORIZONTAL))
				   (FUNCALL-SELF ':SEND-PANE 'NAME-BUTTON
						 ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						 NIL NIL ':HORIZONTAL)
				   (+ (FUNCALL-SELF ':SEND-PANE 'DONE-BUTTON
						    ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						    NIL NIL ':HORIZONTAL)
				      (FUNCALL-SELF ':SEND-PANE 'ABORT-BUTTON
						    ':PANE-SIZE MAX-WIDTH MAX-HEIGHT
						    NIL NIL ':HORIZONTAL)))
			      15.) 10.)))
	     (HEI (MIN MAX-HEIGHT
		       (// (* (+ (FUNCALL-SELF ':SEND-PANE 'UNION-BUTTON
					       ':PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL
					       ':VERTICAL)
				 (FUNCALL-SELF ':MENUS-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL
					       ':VERTICAL)
				 (FUNCALL-SELF ':SEND-PANE 'NAME-BUTTON
					       ':PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL
					       ':VERTICAL)
				 (FUNCALL-SELF ':EDITOR-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL
					       ':VERTICAL)
				 (FUNCALL-SELF ':SEND-PANE 'DONE-BUTTON
					       ':PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL
					       ':VERTICAL))
			      12.) 10.))))
	 (IF (AND (= WID (TV:SHEET-INSIDE-WIDTH))
		  (= HEI (TV:SHEET-INSIDE-HEIGHT)))
	     (FUNCALL-SELF ':SET-CONFIGURATION 'ONLY)
	     (FUNCALL-SELF ':SET-INSIDE-SIZE WID HEI)))))

(DEFMETHOD (BASIC-UNIVERSE-DEFINITION-FRAME :AFTER :INIT) (IGNORE)
  (MULTIPLE-VALUE (*EDITOR-WINDOW* *EDITOR-INTERVAL*)
    (CREATE-ZMAIL-WINDOW 'EDITOR-WINDOW))
  (SETQ *WINDOW* *EDITOR-WINDOW*)
  (SETQ *WINDOW-LIST* (NCONS *WINDOW*))
  (SETQ *EDITOR-STREAM* (INTERVAL-STREAM *EDITOR-INTERVAL*))
  (SETQ *EDITOR-INSERT-BP* (COPY-BP (POINT) ':MOVES)))

(DEFMETHOD (UNIVERSE-DEFINITION-FRAME :INITIALIZE) (&AUX NEW-NAME)
  (SETQ NEW-NAME (GENERATE-UNIQUE-NAME *UNIVERSE-LIST*))
  (DELETE-INTERVAL *EDITOR-INTERVAL*)
  (INSERT-FORM-INTO-EDITOR-WINDOW
    `(DEFINE-UNIVERSE ,(INTERN (STRING-UPCASE NEW-NAME)) ()) -1)
  (MUST-REDISPLAY *EDITOR-WINDOW* DIS-ALL)
  (MULTIPLE-VALUE-BIND (MAIL-FILE-ALIST TEMP-MAIL-FILE-ALIST)
      (GET-MAIL-FILE-ALISTS T)
    (FUNCALL-SELF ':COMPUTE-GEOMETRY NEW-NAME
		  (NCONC MAIL-FILE-ALIST
			 '(("Primary" :VALUE PRIMARY :FONT FONTS:HL12BI
			    :DOCUMENTATION "The primary mail file.")))
		  (NCONC TEMP-MAIL-FILE-ALIST
			 '(("Current" :VALUE CURRENT :FONT FONTS:HL12BI
			    :DOCUMENTATION "The current mail file.")))
		  (APPEND *UNIVERSE-LIST*
			  '(("Loaded" :VALUE LOADED :FONT FONTS:HL12BI
			     :DOCUMENTATION "All mail files loaded.")))))
  (FUNCALL (WINDOW-SHEET *MINI-BUFFER-WINDOW*) ':DEACTIVATE)
  (FUNCALL-SELF ':TURN-OFF-ACCENTS))

(DEFMETHOD (UNIVERSE-DEFINITION-FRAME :GET-UNIVERSE) (&OPTIONAL (NEAR-MODE '(:MOUSE)))
  ;; Some domain specific knowledge here
  (AND (EQ (CAR NEAR-MODE) ':WINDOW)
       (LET ((MIN-BOTTOM (+ (TV:SHEET-INSIDE-TOP TV:SUPERIOR) TV:HEIGHT))
	     (BROTHER (CADR NEAR-MODE)))
	 (AND (< (TV:SHEET-Y-OFFSET BROTHER) MIN-BOTTOM)	;If we won't fit on top
	      ( MIN-BOTTOM (- (TV:SHEET-INSIDE-BOTTOM TV:SUPERIOR)	;and moving will help
			       (TV:SHEET-HEIGHT BROTHER)))
	      (FUNCALL BROTHER ':SET-POSITION (TV:SHEET-X-OFFSET BROTHER) MIN-BOTTOM))))
  (TV:EXPOSE-WINDOW-NEAR SELF NEAR-MODE)
  (FUNCALL-SELF ':COMMAND-LOOP))

(DEFMETHOD (UNIVERSE-DEFINITION-FRAME :TOP-LEVEL-TAG) ()
  'EXIT-UNIVERSE-DEFINITION)

(DEFMETHOD (UNIVERSE-DEFINITION-FRAME :PROCESS-SPECIAL-COMMAND) (&REST ARGS)
  (APPLY #'ZMAIL-UNIVERSE-COMMAND-LIST ARGS))

(DEFSELECT (ZMAIL-UNIVERSE-COMMAND-LIST ZMAIL-COMMAND-LIST-DEFAULT)
  (:MENU (ITEM IGNORE WINDOW &AUX WINDOW-NAME)
   (SETQ WINDOW-NAME (FUNCALL-SELF ':PANE-NAME WINDOW))
   (SETQ ITEM (FUNCALL WINDOW ':EXECUTE-NO-SIDE-EFFECTS ITEM))
   (IF (EQ WINDOW-NAME 'UNIVERSE-MENU)
       (SETQ ITEM `(,ITEM))
       (AND (TYPEP ITEM 'MAIL-FILE)
	    (SETQ ITEM (MAIL-FILE-NAME ITEM))))
   (INSERT-FORM-INTO-EDITOR-WINDOW ITEM))
  (:MOUSE-BUTTON (CH WINDOW IGNORE IGNORE &AUX WINDOW-NAME)
   (SETQ WINDOW-NAME (FUNCALL-SELF ':PANE-NAME WINDOW))
   (UNWIND-PROTECT
     (SELECTQ WINDOW-NAME
       (ABORT-BUTTON
	(*THROW 'EXIT-UNIVERSE-DEFINITION NIL))
       (DONE-BUTTON
	(*THROW 'EXIT-UNIVERSE-DEFINITION (EVAL (READ-FROM-EDITOR-WINDOW))))
       (NAME-BUTTON
	(READ-NEW-NAME WINDOW CH *UNIVERSE-LIST* #'GET-UNIVERSE-DEFINITION))
       (CLOSE-BUTTON
	(EDITOR-WINDOW-CLOSE-BUTTON))
       (OTHERWISE
	(INSERT-FORM-INTO-EDITOR-WINDOW `(,(SELECTQ WINDOW-NAME
					     (NOT-BUTTON ')
					     (UNION-BUTTON ')
					     (INTERSECTION-BUTTON ')))
					-1)))
     (FUNCALL WINDOW ':SET-ACCENT NIL)))
  )

;;; Cosmogony
(DEFUN DEFINE-NEW-UNIVERSE (&OPTIONAL (NEAR-MODE '(:MOUSE)))
  (PKG-BIND "ZWEI"
    (FUNCALL *UNIVERSE-DEFINITION-FRAME* ':INITIALIZE)
    (PROG KLUDGE ()
      (UNWIND-PROTECT
	(LET (UNIVERSE)
	  (AND (SETQ UNIVERSE (FUNCALL *UNIVERSE-DEFINITION-FRAME* ':GET-UNIVERSE NEAR-MODE))
	       (RETURN-FROM KLUDGE
		 'MAP-OVER-DEFINED-UNIVERSE UNIVERSE (STRING UNIVERSE) UNIVERSE)))
	(FUNCALL *UNIVERSE-DEFINITION-FRAME* ':DEACTIVATE)))))

;;; Filter definition components
(DEFUN MACRO-EXPAND-SEARCH-KEY (KEY &AUX FUNCTION (DEFAULT-CONS-AREA WORKING-STORAGE-AREA))
  (DECLARE (RETURN-LIST FUNCTION KEY))
  (COND ((STRINGP KEY)
	 (SETQ FUNCTION 'SEARCH))
	((EQ (ARRAY-TYPE KEY) 'ART-16B)
	 (MULTIPLE-VALUE (FUNCTION KEY)
	   (PARSE-EXTENDED-SEARCH-16B-STRING KEY)))
	(T
	 (FERROR NIL "~S not a valid search key" KEY)))
  (VALUES FUNCTION KEY))

(DEFMACRO SEARCH-WITHIN-MSG (KEY)
  (MULTIPLE-VALUE-BIND (FUNCTION KEY)
      (MACRO-EXPAND-SEARCH-KEY KEY)
    `(,FUNCTION (MSG-START-BP MSG) ',KEY NIL NIL NIL (MSG-END-BP MSG))))

(DEFMACRO MSG-HEADER-SEARCH (TYPE KEY)
  (MULTIPLE-VALUE-BIND (FUNCTION KEY)
      (MACRO-EXPAND-SEARCH-KEY KEY)
    (SETQ FUNCTION (SELECTQ FUNCTION
		     (SEARCH 'STRING-SEARCH)
		     (FSM-SEARCH 'FSM-STRING-SEARCH)))
    `(LET ((.HEADER. (GET STATUS ,TYPE)))
       (AND .HEADER.
	    (IF (LISTP .HEADER.)
		(LOOP FOR .STRING. IN .HEADER.
		      THEREIS (,FUNCTION ',KEY .STRING.))
		(,FUNCTION ',KEY .HEADER.))))))

(DEFMACRO MSG-HEADER-RECIPIENT-SEARCH (TYPE KEY)
  (MULTIPLE-VALUE-BIND (FUNCTION KEY)
      (MACRO-EXPAND-SEARCH-KEY KEY)
    (SETQ FUNCTION (COND ((EQ FUNCTION 'FSM-SEARCH)
			  'MSG-HEADER-RECIPIENT-FSM-SEARCH)
			 ((AND (= (AREF KEY 0) #/)
			       (= (AREF KEY (1- (STRING-LENGTH KEY))) #/))
			  (SETQ KEY (SUBSTRING KEY 1 (1- (STRING-LENGTH KEY))))
			  'MSG-HEADER-RECIPIENT-PARTIAL-MATCH)
			 (T
			  'MSG-HEADER-RECIPIENT-MATCH)))
    (IF (AND (LISTP TYPE) (EQ (CAR TYPE) 'QUOTE) (SYMBOLP (CADR TYPE)))
	`(,FUNCTION (GET STATUS ,TYPE) ',KEY)
	`(DO .L. ,TYPE (CDR .L.) (NULL .L.)
	     (AND (,FUNCTION (GET STATUS (CAR .L.)) ',KEY)
		  (RETURN T))))))

(DEFUN MSG-HEADER-RECIPIENT-FSM-SEARCH (RECIPIENTS KEY &AUX INTERVAL)
  (DOLIST (RECIPIENT RECIPIENTS)
    (AND (SETQ INTERVAL (GET (LOCF RECIPIENT) ':INTERVAL))
	 (FSM-SEARCH (CAR INTERVAL) KEY NIL NIL NIL (CADR INTERVAL))
	 (RETURN T))))

(DEFUN MSG-HEADER-RECIPIENT-PARTIAL-MATCH (RECIPIENTS KEY)
  (DO L RECIPIENTS (CDR L) (NULL L)
    (AND (STRING-SEARCH KEY (GET (LOCF (CAR L)) ':NAME))
	 (RETURN T))))

(DEFUN MSG-HEADER-RECIPIENT-MATCH (RECIPIENTS KEY &AUX END-1 START-2 PLIST)
  (AND (SETQ END-1 (STRING-SEARCH-CHAR #/@ KEY))
       (SETQ START-2 (1+ END-1))) 
  (DOLIST (RECIPIENT RECIPIENTS)
    (SETQ PLIST (LOCF RECIPIENT))
    (AND (STRING-EQUAL (GET PLIST ':NAME) KEY 0 0 NIL END-1)
	 (OR (NULL START-2) (STRING-EQUAL (CAR (GET PLIST ':HOST)) KEY 0 START-2))
	 (RETURN T))))

(DEFMACRO MSG-HEADER-RECIPIENT-EQUAL (TYPE KEY)
  `(LET ((.RECIPIENTS. (GET STATUS ,TYPE)))
     (AND (NULL (CDR .RECIPIENTS.))
	  (MSG-HEADER-RECIPIENT-MATCH .RECIPIENTS. ',KEY))))

(DEFMACRO DEFINE-FILTER (FILTER (MSG) . BODY)
  (LET ((DOCUMENTATION))
    (IF (STRINGP (CAR BODY))
	(SETQ DOCUMENTATION (CAR BODY)
	      BODY (CDR BODY)))
    `(PROGN 'COMPILE
       (DEFINE-FILTER-1 ',FILTER ',DOCUMENTATION)
       (DEFUN (:PROPERTY ,FILTER FILTER-FUNCTION) (,MSG &AUX STATUS KEYWORDS)
	 (SETQ STATUS (ASSURE-MSG-PARSED ,MSG)
	       KEYWORDS (GET STATUS 'KEYWORDS))
	 . ,BODY))))

;; Add a new filter-name, with optional mouse documentation

(DEFUN DEFINE-FILTER-1 (FILTER DOCUMENTATION)
  (IF DOCUMENTATION (SETQ DOCUMENTATION `(:DOCUMENTATION ,DOCUMENTATION)))
  (LET ((ALIST-ENTRY (ASSQ FILTER *USER-FILTER-ALIST*))
	(ALIST-DATA `(:VALUE ,FILTER ,@DOCUMENTATION)))
    (IF ALIST-ENTRY
	(RPLACD ALIST-ENTRY ALIST-DATA)
	(SETQ *USER-FILTER-ALIST*
	      (NCONC *USER-FILTER-ALIST*
		     (NCONS `(,FILTER ,@ALIST-DATA)))))))

(DEFUN GET-FILTER-DEFINITION (FILTER &AUX DEF)
  (SETQ DEF (GET FILTER 'FILTER-FUNCTION))
  (AND (ATOM DEF)
       (SETQ DEF (GET FILTER 'EXPR-FILTER-FUNCTION)))
  (OR (AND DEF (EQ (CAR DEF) 'NAMED-LAMBDA)
	   (NOT (ATOM (CADR DEF)))
	   (EQ (CAR (CAADR DEF)) ':PROPERTY)
	   (EQ (CADR (CAADR DEF)) FILTER))
      (BARF "~A is compiled" FILTER))
  `(DEFINE-FILTER ,FILTER (,(CAADDR DEF))
     . ,(CDDDDR DEF)))

(DEFUN MACRO-EXPAND-DATE (DATE &AUX UNIVERSAL-TIME
				    (DEFAULT-CONS-AREA WORKING-STORAGE-AREA)
				    RELATIVE-P)
  (OR (STRINGP DATE)
      (FERROR NIL "~S is not a valid date" DATE))
  (MULTIPLE-VALUE (UNIVERSAL-TIME RELATIVE-P)
    (TIME:PARSE-UNIVERSAL-TIME DATE))
  (AND (STRINGP UNIVERSAL-TIME) (FERROR NIL "~A in ~S" UNIVERSAL-TIME DATE))
  (VALUES UNIVERSAL-TIME RELATIVE-P))


;; Currently the "NOW" argument to MACRO-EXPAND-RELATIVE-DATE is useless.
;; However, if anything special is to be done with things like "A week after
;; my birthday" or "January", besides forcing them to be absolute, the current
;; date is required.

(DEFUN MACRO-EXPAND-RELATIVE-DATE (DATE NOW &REST OTHERS
				   &AUX (DEFAULT-CONS-AREA WORKING-STORAGE-AREA)
				   RELATIVE-P)
  (MULTIPLE-VALUE (DATE RELATIVE-P)
    (MACRO-EXPAND-DATE DATE))
  (SETQ OTHERS (COPYLIST OTHERS))
  (IF (EQ RELATIVE-P ':RELATIVE)
      `(- (TIME:GET-UNIVERSAL-TIME)
	  ,(- (TIME:GET-UNIVERSAL-TIME) DATE)	;Relative:  Compute offset from now
	  ,@OTHERS)
      `(- (TIME:GET-UNIVERSAL-TIME)
	  ,(- (MACRO-EXPAND-DATE NOW) DATE)	;Absolute:  Compute offset from then
	  ,@OTHERS)))


(DEFMACRO MSG-SAME-DATE (DATE)
  (SETQ DATE (MACRO-EXPAND-DATE DATE))
  `(LET ((.DATE. (GET STATUS ':DATE)))
     (AND (NOT (NULL .DATE.))
	  ( ',DATE .DATE.)
	  (> ',(LET ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA))
		 (+ DATE 86400.))
	     .DATE.))))

(DEFMACRO MSG-SAME-RELATIVE-DATE (DATE NOW)
  `(LET ((.DATE. (GET STATUS ':DATE)))
     (AND (NOT (NULL .DATE.))
	  ( ,(MACRO-EXPAND-RELATIVE-DATE DATE NOW) .DATE.)
	  (> ,(MACRO-EXPAND-RELATIVE-DATE DATE NOW -86400.) .DATE.))))
  
(DEFMACRO MSG-DATE-LESSP (DATE)
  `(LET ((.DATE. (GET STATUS ':DATE)))
     (AND (NOT (NULL .DATE.))
	  (< .DATE. ',(MACRO-EXPAND-DATE DATE)))))

(DEFMACRO MSG-RELATIVE-DATE-LESSP (DATE NOW)
  `(LET ((.DATE. (GET STATUS ':DATE)))
     (AND (NOT (NULL .DATE.))
	  (< .DATE. ,(MACRO-EXPAND-RELATIVE-DATE DATE NOW)))))

(DEFMACRO MSG-DATE-GREATERP (DATE)
  `(LET ((.DATE. (GET STATUS ':DATE)))
     (AND (NOT (NULL .DATE.))
	  ( .DATE. ',(MACRO-EXPAND-DATE DATE)))))

(DEFMACRO MSG-RELATIVE-DATE-GREATERP (DATE NOW)
  `(LET ((.DATE. (GET STATUS ':DATE)))
     (AND (NOT (NULL .DATE.))
	  ( .DATE. ,(MACRO-EXPAND-RELATIVE-DATE DATE NOW)))))

(DEFMACRO DEFINE-UNIVERSE (UNIVERSE IGNORE EXPANSION)
  (CHECK-EXPANSION EXPANSION)
  `(PROGN
     (OR (MEMQ ',UNIVERSE *UNIVERSE-LIST*)
	 (SETQ *UNIVERSE-LIST* (NCONC *UNIVERSE-LIST* (NCONS ',UNIVERSE))))
     (DEFPROP ,UNIVERSE ,EXPANSION UNIVERSE)))

(DEFUN GET-UNIVERSE-DEFINITION (UNIVERSE)
  `(DEFINE-UNIVERSE ,UNIVERSE ()
     ,(GET UNIVERSE 'UNIVERSE)))

(DEFUN CHECK-EXPANSION (EXPANSION)
  (COND ((STRINGP EXPANSION))
	((MEMQ EXPANSION '(PRIMARY CURRENT)))
	((AND (SYMBOLP EXPANSION) (GET EXPANSION 'UNIVERSE)))
	((NLISTP EXPANSION)
	 (FERROR NIL "~S is not a valid universe component" EXPANSION))
	((NULL (CDR EXPANSION))
	 (OR (SYMBOLP (CAR EXPANSION))
	     (FERROR NIL "~S is not a valid universe component" EXPANSION)))
	((EQ (CAR EXPANSION) ')
	 (OR (= (LENGTH EXPANSION) 2)
	     (FERROR NIL "~S wrong number of argument to " EXPANSION)))
	((NOT (MEMQ (CAR EXPANSION) '( )))
	 (FERROR NIL "~S is not a known set operator" (CAR EXPANSION)))
	(T
	 (DOLIST (EXP (CDR EXPANSION))
	   (CHECK-EXPANSION EXP)))))

(DEFUN (MAP-OVER-DEFINED-UNIVERSE MAP-FUNCTION-MAIL-FILE-NAME-FUNCTION) (UNIVERSE)
  (STRING-APPEND "" UNIVERSE ""))

(DEFUN MAP-OVER-DEFINED-UNIVERSE (UNIVERSE FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION
				  PROCESSING-ARG)
  (SETQ UNIVERSE (EXPAND-UNIVERSE UNIVERSE))
  (DOMSGS (MSG UNIVERSE)
    (AND (FUNCALL FILTER-FUNCTION MSG FILTER-ARG)
	 (FUNCALL PROCESSING-FUNCTION MSG PROCESSING-ARG))))

;;; This takes a universe and returns an array with the appropriate messages in it.
(DEFUN EXPAND-UNIVERSE (UNIVERSE &AUX (DEFAULT-CONS-AREA COMPILER:FASD-TEMPORARY-AREA))
  (COND ((SYMBOLP UNIVERSE)
	 (SELECTQ UNIVERSE
	   (PRIMARY *PRIMARY-MAIL-FILE*)
	   (CURRENT *MAIL-FILE*)
	   (LOADED (EXPAND-UNIVERSE-INTERSECTION NIL))
	   (OTHERWISE (EXPAND-UNIVERSE (GET UNIVERSE 'UNIVERSE)))))
	((STRINGP UNIVERSE)
	 (LET ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA))
	   (GET-MAIL-FILE-FROM-NAME UNIVERSE T)))
	((EQ (CAR UNIVERSE) ')
	 (EXPAND-UNIVERSE-NOT (EXPAND-UNIVERSE (CADR UNIVERSE))))
	((EQ (CAR UNIVERSE) ')
	 (EXPAND-UNIVERSE-UNION (MAPCAR 'EXPAND-UNIVERSE (CDR UNIVERSE))))
	((EQ (CAR UNIVERSE) ')
	 (EXPAND-UNIVERSE-INTERSECTION (MAPCAR 'EXPAND-UNIVERSE (CDR UNIVERSE))))
	((NULL (CDR UNIVERSE))
	 (EXPAND-UNIVERSE (GET (CAR UNIVERSE) 'UNIVERSE)))
	(T
	 (FERROR NIL "~S is not a valid universe" UNIVERSE))))

(DEFUN EXPAND-UNIVERSE-NOT (MAIL-FILE &AUX NEW-MAIL-FILE ARRAY)
  (SETQ NEW-MAIL-FILE (MAKE-MAIL-FILE 'TEMP-MAIL-FILE)
	ARRAY (MAIL-FILE-ARRAY NEW-MAIL-FILE))
  (DOLIST (MF *MAIL-FILE-LIST*)
    (AND (MAIL-FILE-DISK-P MF)
	 (DOMSGS (MSG MF)
	   (OR (MSG-IN-MAIL-FILE-P MSG MAIL-FILE)
	       (ARRAY-PUSH-EXTEND ARRAY MSG)))))
  NEW-MAIL-FILE)

(DEFUN EXPAND-UNIVERSE-UNION (MAIL-FILES &AUX NEW-MAIL-FILE ARRAY)
  ;; Move the larger mail files to the start of the list for speed
  (SETQ MAIL-FILES (SORT MAIL-FILES #'(LAMBDA (MF1 MF2)
					(> (MAIL-FILE-NMSGS MF1) (MAIL-FILE-NMSGS MF2))))
	NEW-MAIL-FILE (MAKE-MAIL-FILE 'TEMP-MAIL-FILE)
	ARRAY (MAIL-FILE-ARRAY NEW-MAIL-FILE))
  (DOLIST (MF MAIL-FILES)
    (DOMSGS (MSG MF)
      (OR (MSG-IN-MAIL-FILE-P MSG NEW-MAIL-FILE)
	  (ARRAY-PUSH-EXTEND ARRAY MSG))))
  NEW-MAIL-FILE)

(DEFUN EXPAND-UNIVERSE-INTERSECTION (MAIL-FILES &AUX NEW-MAIL-FILE MAIL-FILE ARRAY)
  (IF (NULL MAIL-FILES)				;Intersection of no args is everything
      (EXPAND-UNIVERSE-UNION *MAIL-FILE-LIST*)
      ;; Move the smaller mail files to the start of the list for speed
      (SETQ MAIL-FILES (SORT MAIL-FILES #'(LAMBDA (MF1 MF2)
					    (< (MAIL-FILE-NMSGS MF1) (MAIL-FILE-NMSGS MF2))))
	    NEW-MAIL-FILE (MAKE-MAIL-FILE 'TEMP-MAIL-FILE)
	    ARRAY (MAIL-FILE-ARRAY NEW-MAIL-FILE))
      (POP MAIL-FILES MAIL-FILE)
      (DOMSGS (MSG MAIL-FILE)
	(OR (DOLIST (MF MAIL-FILES)
	      (OR (MSG-IN-MAIL-FILE-P MSG MF)
		  (RETURN T)))
	    (ARRAY-PUSH-EXTEND ARRAY MSG)))
      NEW-MAIL-FILE))

(DEFUN COMMAND-WITH-UNIVERSE-OR-FILTER (&AUX BUTTON-FRAME UNIVERSE-BUTTON FILTER-BUTTON)
  (SETQ BUTTON-FRAME (FUNCALL *ZMAIL-WINDOW* ':GET-PANE 'BUTTONS-FRAME)
	UNIVERSE-BUTTON (FUNCALL BUTTON-FRAME ':GET-PANE 'UNIVERSE-BUTTON)
	FILTER-BUTTON (FUNCALL BUTTON-FRAME ':GET-PANE 'FILTER-BUTTON))
  (UNWIND-PROTECT
    (DO ((FILTER-FUNCTION 'MSG-TRUE-FILTER)
	 (FILTER-ARG NIL)
	 (MAP-FUNCTION 'MAP-OVER-SINGLE-MSG)
	 (MAP-ARG *MSG*)
	 (CHAR))
	(NIL)
      (SETQ CHAR (WITHOUT-IO-BUFFER-OUTPUT-FUNCTION
		   (FUNCALL STANDARD-INPUT ':ANY-TYI)))
      (SETQ *LAST-COMMAND-CHAR* CHAR)
      (COND ((AND (LISTP CHAR)
		  (EQ (FIRST CHAR) ':MENU))
	     (LET* ((COMMAND (FUNCALL (FOURTH CHAR) ':EXECUTE-NO-SIDE-EFFECTS (SECOND CHAR)))
		    (ALL-COMMAND (GET COMMAND 'ASSOCIATED-ALL-COMMAND))
		    (MAP-COMMAND (GET COMMAND 'ASSOCIATED-MAP-COMMAND)))
	       (SET-COMMAND-BUTTON (THIRD CHAR))
	       (DO () ((NEQ COMMAND 'COM-ZMAIL-OTHER-COMMANDS))
		 (SETQ COMMAND (CHOOSE-OTHER-COMMAND)))
	       (RETURN (COND ((EQ MAP-FUNCTION 'MAP-OVER-SINGLE-MSG)
			      (FUNCALL COMMAND))
			     ((AND ALL-COMMAND
				   (EQ MAP-FUNCTION 'MAP-OVER-SINGLE-MAIL-FILE)
				   (EQ MAP-ARG *MAIL-FILE*)
				   (EQ FILTER-FUNCTION 'MSG-TRUE-FILTER))
			      (FUNCALL ALL-COMMAND))
			     ((AND (NULL MAP-COMMAND)
				   ALL-COMMAND)
			      (LET ((*MAIL-FILE* (MAKE-MAIL-FILE-FROM-FILTER
						   MAP-FUNCTION MAP-ARG
						   FILTER-FUNCTION FILTER-ARG
						   (MAKE-MAIL-FILE 'TEMP-MAIL-FILE
								   ':NAME "Temp")))
				    (*MSG* ':NO-SELECT))				
				(FUNCALL ALL-COMMAND))
			      (ZMAIL-SELECT-MSG *MSG* NIL NIL))
			     (MAP-COMMAND
			      (FUNCALL MAP-COMMAND MAP-FUNCTION MAP-ARG
				       FILTER-FUNCTION FILTER-ARG))
			     (T
			      (BARF "That command does not take a filter argument"))))))
	    ((AND (LISTP CHAR)
		  (EQ (FIRST CHAR) ':MOUSE-BUTTON))
	     (SET-COMMAND-BUTTON (SECOND CHAR))
	     (LET ((WINDOW (THIRD CHAR)))
	       (UNWIND-PROTECT
		 (*CATCH 'ZWEI-COMMAND-LOOP
		   (COND ((EQ WINDOW UNIVERSE-BUTTON)
			  (MULTIPLE-VALUE (MAP-FUNCTION MAP-ARG)
			    (GET-UNIVERSE-OR-FILTER-FOR-COMMAND
			      'GET-UNIVERSE-FUNCTION-FOR-COMMAND WINDOW BUTTON-FRAME
			      '*LAST-COMMAND-UNIVERSE-FUNCTION*
			      '*LAST-COMMAND-UNIVERSE-ARG* '*LAST-COMMAND-UNIVERSE-NAME*
			      'MAP-OVER-SINGLE-MAIL-FILE *MAIL-FILE*
			      (AND *MAIL-FILE* (MAIL-FILE-NAME *MAIL-FILE*)))))
			 ((EQ WINDOW FILTER-BUTTON)
			  (MULTIPLE-VALUE (FILTER-FUNCTION FILTER-ARG)
			    (GET-UNIVERSE-OR-FILTER-FOR-COMMAND
			      'GET-FILTER-FUNCTION-FOR-COMMAND WINDOW BUTTON-FRAME
			      '*LAST-COMMAND-FILTER-FUNCTION*
			      '*LAST-COMMAND-FILTER-ARG* '*LAST-COMMAND-FILTER-NAME*
			      NIL NIL NIL))
			  (COND ((EQ MAP-FUNCTION 'MAP-OVER-SINGLE-MSG)
				 (SETQ MAP-FUNCTION 'MAP-OVER-SINGLE-MAIL-FILE
				       MAP-ARG *MAIL-FILE*)
				 (FUNCALL BUTTON-FRAME ':CHANGE-BUTTONS UNIVERSE-BUTTON
					  (MAIL-FILE-NAME *MAIL-FILE*)))))
			 (T (FERROR NIL "~S is not a known window" WINDOW))))
		 (FUNCALL WINDOW ':SET-ACCENT NIL))))
	    (T
	     (FUNCALL STANDARD-INPUT ':UNTYI CHAR)
	     (RETURN NIL))))
    (FUNCALL BUTTON-FRAME ':CHANGE-BUTTONS UNIVERSE-BUTTON "Just current message"
					   FILTER-BUTTON "All")))

(DEFUN GET-UNIVERSE-OR-FILTER-FOR-COMMAND (FUNCTION WINDOW SUPERIOR
					   FUNVAR ARGVAR NAMVAR MIDFUN MIDARG MIDNAM
					   &AUX FV AV NAME)
  (COND ((EQ *ZMAIL-COMMAND-BUTTON* ':LEFT)
	 (SETQ FV (OR (SYMEVAL FUNVAR) (BARF "There is no default for this yet."))
	       AV (SYMEVAL ARGVAR)
	       NAME (SYMEVAL NAMVAR)))
	(T
	 (IF (NEQ *ZMAIL-COMMAND-BUTTON* ':MIDDLE)
	     (MULTIPLE-VALUE (FV AV NAME)
	       (FUNCALL FUNCTION))
	     (OR MIDFUN (BARF))
	     (SETQ FV MIDFUN AV MIDARG NAME MIDNAM))
	 (SET FUNVAR FV)
	 (SET ARGVAR AV)
	 (SET NAMVAR NAME)
	 (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION FUNCTION)))
  (FUNCALL SUPERIOR ':CHANGE-BUTTONS WINDOW NAME)
  (VALUES FV AV))

(DEFINE-ZMAIL-GLOBAL *LAST-COMMAND-UNIVERSE-FUNCTION* NIL)
(DEFINE-ZMAIL-GLOBAL *LAST-COMMAND-UNIVERSE-ARG* NIL)
(DEFINE-ZMAIL-GLOBAL *LAST-COMMAND-UNIVERSE-NAME* NIL)

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION GET-UNIVERSE-FUNCTION-FOR-COMMAND
				       *UNIVERSE-BUTTON-DOCUMENTATION*)

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER GET-UNIVERSE-FUNCTION-FOR-COMMAND (STRING)
  (FORMAT STRING
	  "Change universe for next command: ~@[L: ~A; ~]M: Current mail file; R: menu."
	  *LAST-COMMAND-UNIVERSE-NAME*))

(DEFF GET-UNIVERSE-FUNCTION-FOR-COMMAND 'GET-UNIVERSE-FUNCTION)

(DEFINE-ZMAIL-GLOBAL *LAST-COMMAND-FILTER-FUNCTION* NIL)
(DEFINE-ZMAIL-GLOBAL *LAST-COMMAND-FILTER-ARG* NIL)
(DEFINE-ZMAIL-GLOBAL *LAST-COMMAND-FILTER-NAME* NIL)

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION GET-FILTER-FUNCTION-FOR-COMMAND
				       *FILTER-BUTTON-DOCUMENTATION*)

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER GET-FILTER-FUNCTION-FOR-COMMAND (STRING)
  (FORMAT STRING "Change filter for next command: ~@[L: ~A; ~]R: menu."
	  *LAST-COMMAND-FILTER-NAME*))

(DEFUN GET-FILTER-FUNCTION-FOR-COMMAND (&AUX FUN ARG)
  (MULTIPLE-VALUE (NIL NIL FUN ARG)
    (GET-FILTER-FUNCTION-1 NIL NIL NIL '(:MOUSE)))
  (VALUES FUN ARG (FILTER-FUNCTION-MAIL-FILE-NAME FUN ARG)))