;;; Commands to rearrange (group) message presentation
;;; Copyright (C) 1989 Kyle E. Jones
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 1, or (at your option)
;;; any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

(require 'vm)

(defun vm-group-by (group-function)
  (let (start end end-prev mp mp-prev)
    (setq start vm-message-list)
    (while start
      (setq end (cdr start)
	    end-prev start
	    mp end
	    mp-prev start)
      (while mp
	(if (funcall group-function (car start) (car mp))
	    (if (eq end mp)
		(setq end-prev end end (cdr end)
		      mp-prev mp mp (cdr mp))
	      (setcdr mp-prev (cdr mp))
	      (setcdr end-prev mp)
	      (setcdr mp end)
	      (setq end-prev (cdr end-prev)
		    mp (cdr mp)))
	  (setq mp-prev mp mp (cdr mp))))
      (setq start end))))

(defconst vm-group-by-subject-closure (cons t t))

(defun vm-group-by-subject (m1 m2)
  (let ((subject (vm-su-subject m1)))
    (if (eq subject (car vm-group-by-subject-closure))
	(setq subject (cdr vm-group-by-subject-closure))
      (setcar vm-group-by-subject-closure subject)
      (if (string-match "^\\(re: *\\)+" subject)
	  (setq subject (substring subject (match-end 0))))
      (setq subject (concat "^\\(re: *\\)*"
			    (regexp-quote subject)
			    " *$"))
      (setcdr vm-group-by-subject-closure subject))
    (string-match subject (vm-su-subject m2))))

(defun vm-group-by-author (m1 m2)
  (string= (vm-full-name-of m1) (vm-full-name-of m2)))

(defun vm-group-by-date-sent (m1 m2)
  (and (string= (vm-monthday-of m1) (vm-monthday-of m2))
       (string= (vm-month-of m1) (vm-month-of m2))
       (string= (vm-year-of m1) (vm-year-of m2))))

(defun vm-revert-to-arrival-time-grouping ()
  (let ((curr (car vm-message-pointer))
	(last (car vm-last-message-pointer)))
    (setq vm-message-list
	  (sort vm-message-list
		(function
		 (lambda (p q) (< (vm-start-of p) (vm-start-of q))))))
    (cond (curr
	   (setq vm-message-pointer vm-message-list)
	   (while (not (eq (car vm-message-pointer) curr))
	     (setq vm-message-pointer (cdr vm-message-pointer)))))
    (cond (last
	   (setq vm-last-message-pointer vm-message-list)
	   (while (not (eq (car vm-last-message-pointer) last))
	     (setq vm-last-message-pointer (cdr vm-last-message-pointer)))))))

(defun vm-group-messages (grouping)
  "Group messages by the argument GROUPING.
Interactively this argument is prompted for in the minibuffer,
with completion."
  (interactive
   (list 
    (completing-read
     (format "Group messages by (default %s): "
	     (or vm-group-by "arrival-time"))
     vm-supported-groupings-alist 'identity t)))
  (if vm-mail-buffer
      (set-buffer vm-mail-buffer))
  (if (equal grouping "")
      (setq grouping vm-group-by))
  (cond ((and grouping (not (stringp grouping)))
	 (error "Unsupported grouping: %s" grouping))
	((equal grouping "arrival-time")
	 (setq grouping nil)))
  (if grouping
      (let ((group-function (intern (concat "vm-group-by-" grouping))))
	(if (not (fboundp group-function))
	    (error "Unsupported grouping: %s" grouping))
	(vm-revert-to-arrival-time-grouping)
	(message "Grouping messages by %s..." grouping)
	(vm-group-by group-function)
	(message "Grouping messages by %s... done" grouping)
	(setq vm-current-grouping grouping)
	(vm-number-messages))
    (vm-revert-to-arrival-time-grouping)
    (setq vm-current-grouping grouping)
    (vm-number-messages)
    (if (interactive-p)
	(message "Reverted to arrival time grouping")))
  (if vm-summary-buffer
      (vm-do-summary))
  (if vm-message-pointer
      (progn
	(vm-update-summary-and-mode-line)
	(vm-set-summary-pointer (car vm-message-pointer)))))
