;;; Thread support for VM
;;; Copyright (C) 1994 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.

(provide 'vm-thread)

(defun vm-toggle-threads-display ()
  "Toggle the threads display on and off.
When the threads display is on, the folder will be sorted by
thread and thread indentation (via the %I summary format specifier)
will be visible."
  (interactive)
  (vm-select-folder-buffer)
  (vm-check-for-killed-summary)
  (vm-set-summary-redo-start-point t)
  (setq vm-summary-show-threads (not vm-summary-show-threads))
  (if vm-summary-show-threads
      (vm-sort-messages "thread")
    (vm-sort-messages "physical-order")))

(defun vm-build-threads (message-list)
  (if (null vm-thread-obarray)
      (setq vm-thread-obarray (make-vector 641 0)
	    vm-thread-subject-obarray (make-vector 641 0)))
  (let ((mp (or message-list vm-message-list))
	(n 0)
	;; Just for laughs, make the update interval vary.
	(modulus (+ (% (vm-abs (random)) 11) 40))
	;; no need to schedule reindents of reparented messages
	;; unless there were already messages present.
	(schedule-reindents message-list)
	m parent parent-sym id id-sym date refs old-parent-sym)
    (while mp
      (setq m (car mp)
	    parent (vm-th-parent m)
	    id (vm-su-message-id m)
	    id-sym (intern id vm-thread-obarray)
	    date (vm-so-sortable-datestring m))
      (put id-sym 'messages (cons m (get id-sym 'messages)))
      (if (and (null (cdr (get id-sym 'messages)))
	       schedule-reindents)
	  (vm-thread-mark-for-summary-update (get id-sym 'children)))
      (if parent
	  (progn
	    (setq parent-sym (intern parent vm-thread-obarray))
	    (cond ((or (not (boundp id-sym))
		       (null (symbol-value id-sym))
		       (eq (symbol-value id-sym) parent-sym))
		   (set id-sym parent-sym))
		  (t
		   (setq old-parent-sym (symbol-value id-sym))
		   (put old-parent-sym 'children
			(let ((kids (get old-parent-sym 'children))
			      (msgs (get id-sym 'messages)))
			  (while msgs
			    (setq kids (delq m kids)
				  msgs (cdr msgs)))
			  kids ))
		   (set id-sym parent-sym)
		   (if schedule-reindents
		       (vm-thread-mark-for-summary-update
			(get id-sym 'messages)))))
	    (put parent-sym 'children
		 (cons m (get parent-sym 'children))))
	(if (not (boundp id-sym))
	    (set id-sym nil)))
      ;; use the references header to set parenting information
      ;; for ancestors of this message.  This does not override
      ;; a parent pointer for a message if it already exists.
      (if (cdr (setq refs (vm-th-references m)))
	  (let (parent-sym id-sym msgs)
	    (setq parent-sym (intern (car refs) vm-thread-obarray)
		  refs (cdr refs))
	    (while refs
	      (setq id-sym (intern (car refs) vm-thread-obarray))
	      (if (and (boundp id-sym) (symbol-value id-sym))
		  nil
		(set id-sym parent-sym)
		(if (setq msgs (get id-sym 'messages))
		    (put parent-sym 'children
			 (append msgs (get parent-sym 'children))))
		(if schedule-reindents
		    (vm-thread-mark-for-summary-update msgs)))
	      (setq parent-sym id-sym
		    refs (cdr refs)))))
      (if vm-thread-using-subject
	  ;; inhibit-quit because we need to make sure the asets
	  ;; below are an atomic group.
	  (let* ((inhibit-quit t)
		 (subject (vm-so-sortable-subject m))
		 (subject-sym (intern subject vm-thread-subject-obarray)))
	    ;; if this subject never seen before create the
	    ;; information vector.
	    (if (not (boundp subject-sym))
		(set subject-sym
		     (vector id-sym (vm-so-sortable-datestring m)
			     nil (list m)))
	      ;; this subject seen before 
	      (aset (symbol-value subject-sym) 3
		    (cons m (aref (symbol-value subject-sym) 3)))
	      (if (string< date (aref (symbol-value subject-sym) 1))
		  (let* ((vect (symbol-value subject-sym))
			 (i-sym (aref vect 0)))
		    ;; optimization: if we know that this message
		    ;; already has a parent, then don't bother
		    ;; adding it to the list of child messages
		    ;; since we know that it will be threaded and
		    ;; unthreaded using the parent information.
		    (if (or (not (boundp i-sym))
			    (null (symbol-value i-sym)))
			(aset vect 2 (append (get i-sym 'messages)
					     (aref vect 2))))
		    (aset vect 0 id-sym)
		    (aset vect 1 date)
		    ;; this loops _and_ recurses and I'm worried
		    ;; about it going into a spin someday.  So I
		    ;; unblock interrupts here.  It's not critical
		    ;; that it finish... the summary will just be out
		    ;; of sync.
		    (if schedule-reindents
			(let ((inhibit-quit nil))
			  (vm-thread-mark-for-summary-update (aref vect 2)))))
		;; optimization: if we know that this message
		;; already has a parent, then don't bother adding
		;; it to the list of child messages, since we
		;; know that it will be threaded and unthreaded
		;; using the parent information.
		(if (null parent)
		    (aset (symbol-value subject-sym) 2
			  (cons m (aref (symbol-value subject-sym) 2))))))))
      (setq mp (cdr mp) n (1+ n))
      (if (zerop (% n modulus))
	  (message "Building threads... %d" n)))
    (if (> n modulus)
	(message "Building threads... done"))))

(defun vm-thread-mark-for-summary-update (message-list)
  (let (m)
    (while message-list
      (setq m (car message-list))
      ;; if thread-list is null then we've already marked this
      ;; message, or it doesn't need marking.
      (if (null (vm-thread-list-of m))
	  nil
	(vm-mark-for-summary-update m t)
	(vm-set-thread-list-of m nil)
	(vm-set-thread-indentation-of m nil)
	(vm-thread-mark-for-summary-update
	 (get (intern (vm-su-message-id m) vm-thread-obarray)
	      'children)))
      (setq message-list (cdr message-list)))))

(defun vm-thread-list (message)
  (let ((done nil)
	(m message)
	thread-list id-sym subject-sym loop-sym root-date)
    (save-excursion
      (set-buffer (vm-buffer-of m))
      (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray)
	    thread-list (list id-sym))
      (fillarray vm-thread-loop-obarray 0)
      (while (not done)
	(setq loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray))
	(if (boundp loop-sym)
	    ;; loop detected, bail...
	    (setq done t)
	  (set loop-sym t)
	  (if (and (boundp id-sym) (symbol-value id-sym))
	      (progn
		(setq id-sym (symbol-value id-sym)
		      thread-list (cons id-sym thread-list)
		      m (car (get id-sym 'messages))))
	    (if (null m)
		(setq done t)
	      (if (null vm-thread-using-subject)
		  nil
		(setq subject-sym
		      (intern (vm-so-sortable-subject m)
			      vm-thread-subject-obarray))
		(if (or (not (boundp subject-sym))
			(eq (aref (symbol-value subject-sym) 0) id-sym))
		    (setq done t)
		  (setq id-sym (aref (symbol-value subject-sym) 0)
			thread-list (cons id-sym thread-list)
			m (car (get id-sym 'messages)))))))))
      ;; save the date of the oldest message in this thread
      (setq root-date (get id-sym 'oldest-date))
      (if (or (null root-date)
	      (string< (vm-so-sortable-datestring message) root-date))
	  (put id-sym 'oldest-date (vm-so-sortable-datestring message)))
      thread-list )))

;; remove message struct from thread data.
;;
;; optional second arg non-nil means forget information that
;; might be different if the message contents changed.
;;
;; message must be a real (non-virtual) message
(defun vm-unthread-message (message &optional message-changing)
  (save-excursion
    (let ((mp (cons message (vm-virtual-messages-of message)))
	  m id-sym subject-sym vect p-sym)
      (while mp
	(setq m (car mp))
	(let ((inhibit-quit t))
	  (vm-set-thread-list-of m nil)
	  (vm-set-thread-indentation-of m nil)
	  (set-buffer (vm-buffer-of m))
	  (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray)
		subject-sym (intern (vm-so-sortable-subject m)
				    vm-thread-subject-obarray))
	  (if (boundp id-sym)
	      (progn
		(put id-sym 'messages (delq m (get id-sym 'messages)))
		(vm-thread-mark-for-summary-update (get id-sym 'children))
		(setq p-sym (symbol-value id-sym))
		(and p-sym (put p-sym 'children
				(delq m (get p-sym 'children))))
		(if message-changing
		    (set id-sym nil))))
	  (if (and (boundp subject-sym) (setq vect (symbol-value subject-sym)))
	      (if (not (eq id-sym (aref vect 0)))
		  (aset vect 2 (delq m (aref vect 2)))
		(if message-changing
		    (if (null (cdr (aref vect 3)))
			(makunbound subject-sym)
		      (let ((p (aref vect 3))
			    oldest-msg oldest-date children)
			(setq oldest-msg (car p)
			      oldest-date (vm-so-sortable-datestring (car p))
			      p (cdr p))
			(while p
			  (if (and (string-lessp (vm-so-sortable-datestring (car p))
						 oldest-date)
				   (not (eq m (car p))))
			      (setq oldest-msg (car p)
				    oldest-date (vm-so-sortable-datestring (car p))))
			  (setq p (cdr p)))
			(aset vect 0 (intern (vm-su-message-id oldest-msg)
					     vm-thread-obarray))
			(aset vect 1 oldest-date)
			(setq children (delq oldest-msg (aref vect 2)))
			(aset vect 2 children)
			(aset vect 3 (delq m (aref vect 3)))
			;; I'm not sure there aren't situations
			;; where this might loop forever.
			(let ((inhibit-quit nil))
			  (vm-thread-mark-for-summary-update children))))))))
	  (setq mp (cdr mp))))))

(defun vm-th-references (m)
  (or (vm-references-of m)
      (vm-set-references-of
       m
       (let (references)
	 (setq references (vm-get-header-contents m "References:" " "))
	 (and references (vm-parse references "[^<]*\\(<[^>]+>\\)"))))))

(defun vm-th-parent (m)
  (or (vm-parent-of m)
      (vm-set-parent-of
       m
       (or (car (vm-last (vm-th-references m)))
	   (let (in-reply-to)
	     (setq in-reply-to (vm-get-header-contents m "In-Reply-To:" " "))
	     (and in-reply-to
		  (car (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)"))))))))

(defun vm-th-thread-indentation (m)
  (or (vm-thread-indentation-of m)
      (let ((p (vm-th-thread-list m)))
	(while (and p (null (get (car p) 'messages)))
	  (setq p (cdr p)))
	(vm-set-thread-indentation-of m (1- (length p)))
	(vm-thread-indentation-of m))))

(defun vm-th-thread-list (m)
  (or (vm-thread-list-of m)
      (progn
	(vm-set-thread-list-of m (vm-thread-list m))
	(vm-thread-list-of m))))