🚀 go-pugleaf

Having finally lost my patience with grouping (slow? non sorted?) I have
decided to patch it up so that it works more like GNUS/Elm sorting
mode. Indeed what I have done is to take the GNUS speedups by Felix Lee
and crib/crash them into vm-group.el from VM %.33 BETA.

The result is the appended set of patches. The user interface has not
changed, the same commends apply; there are three differences:

  1) grouping also sorts (alphabetically, and by default
     ignoring case).

  2) each of author, recipient and subject group modes now
     has a counterpart that subgroups by date-sent (i.e.
     author-date-sent, recipient-date-sent, subject-date-sent).

  3) it seems rather faster; especially for some types of sorting.

There are some rough edges; for example I am not sure I understood
correctly how to resynchronize the current message pointer after
altering the message list (it works, but I suspect I was too cautious);
the major spedd problem is that for sorting/grouping by date I use the
GNUS speedups method of comparing the date as extracted by timezone.el,
and extraction is redone on each grouping. In the interestes of speed
this ought to be done when the message list if built, but in the in the
interest of minimizing changes I left in the existing code. Kyle Jones
can always do it in the next release, if he fancies so.

So here is the wondrous patch:

RCS file: vm-group.el,v
Index: vm-group.el
Prereq: 5.33
diff -c -r5.33 vm-group.el
*** 5.33	1993/06/11 10:21:53
--- vm-group.el	1993/06/11 14:19:03
***************
*** 15,87 ****
  ;;; along with this program; if not, write to the Free Software
  ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  
! (defun vm-group-by (compare-function)
!   (let (buckets bp cons (mp vm-message-list))
!     (while mp
!       (setq bp buckets)
!       (catch 'found
! 	(while bp
! 	  (if (funcall compare-function (car mp) (car (car bp)))
! 	      (progn
! 		(setq cons mp
! 		      mp (cdr mp))
! 		(setcdr cons nil)
! 		(setcar bp (nconc cons (car bp)))
! 		(throw 'found t)))
! 	  (setq bp (cdr bp)))
! 	(setq cons mp
! 	      mp (cdr mp))
! 	(setcdr cons nil)
! 	(setq buckets (cons cons buckets))))
!     (setq vm-message-list
! 	  (apply 'nconc (nreverse (mapcar 'nreverse buckets)))
! 	  vm-message-order-changed t)
!     (vm-reverse-link-messages)
!     (and (eq vm-retain-message-order t) (not vm-folder-read-only)
! 	 (vm-set-buffer-modified-p t))))
! 
! (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))))
!       (if (string-match " +$" subject)
! 	  (setq subject (substring subject 0 (match-beginning 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-su-full-name m1) (vm-su-full-name m2)))
! 
! (defun vm-group-by-recipient (m1 m2)
!   (equal (vm-su-to-names m1) (vm-su-to-names m2)))
! 
! (defun vm-group-by-date-sent (m1 m2)
!   (and (string= (vm-su-monthday m1) (vm-su-monthday m2))
!        (string= (vm-su-month m1) (vm-su-month m2))
!        (string= (vm-su-year m1) (vm-su-year m2))))
  
  (defun vm-revert-to-physical-order ()
!   (let ((curr (car vm-message-pointer))
! 	(last (car vm-last-message-pointer)))
!     (setq curr nil last nil)
!     (setq vm-message-list
! 	  (sort vm-message-list
! 		(function
! 		 (lambda (p q) (< (vm-start-of p) (vm-start-of q)))))
! 	  vm-message-order-changed vm-message-order-stuffed)
!     (vm-reverse-link-messages)
!     (and vm-message-order-changed
! 	 (eq vm-retain-message-order t)
! 	 (not vm-folder-read-only)
! 	 (vm-set-buffer-modified-p t))))
  
  (defun vm-group-messages (grouping)
    "Group messages by the argument GROUPING.
--- 15,164 ----
  ;;; along with this program; if not, write to the Free Software
  ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  
! (require 'timezone)
  
+ (defvar vm-group-fold-case t
+   "Ignore case when sorting subjects in *Subject* mode")
+ 
+ (defvar vm-group-truncate-subject 31
+   "Truncate subject for sorting VM headers to this position.  Why
+ truncate? Well, because Notes truncates subject strings, and we want for
+ truncated subjects to line up correctly with untruncated ones. This
+ might cause some confusion if two subjects are genuinely different yet
+ identical in their prefix. A tradeoff, as always.")
+ 
+ ; EXAMPLES:
+ ;  (vm-keyed-sort '("b" "B" "c" "a") (function string<) (function downcase))
+ ;  (vm-keyed-sort load-path (function string<) (function downcase))
+ 
+ (defun vm-keyed-sort (list compare extract)
+   "Sort LIST stably and return the sorted list.  Does not modify LIST.
+ Arguments are (LIST COMPARE EXTRACT).  Elements in the list are
+ compared as if the predicate were:
+ 	(COMPARE (EXTRACT a) (EXTRACT b))
+ but EXTRACT is run over each element of the list in a preprocessing
+ stage for efficiency.  This reduces the number of EXTRACT calls from
+ O(N log N) to O(N).
+ "
+   (mapcar
+    (function cdr)
+    (sort
+     (mapcar (function (lambda (a) (cons (funcall extract a) a))) list)
+     (function (lambda (a b) (funcall compare (car a) (car b)))))))
+ 
+ (defun vm-reset-message-pointer ()
+   (setq vm-message-pointer
+        (if vm-message-pointer
+ 	   (let ((prev (vm-reverse-link-of (car vm-message-pointer))))
+ 	     (if prev (cdr prev) vm-message-list))
+ 	 (vm-last vm-message-list))))
+ 
+ (defun vm-group-by (compare-function extract-function)
+   (setq vm-message-list
+ 	(vm-keyed-sort vm-message-list compare-function extract-function))
+   (setq vm-message-order-changed t)
+   (vm-reverse-link-messages)
+   (vm-reset-message-pointer) ; is this really necessary?
+   (and (eq vm-retain-message-order t) (not vm-folder-read-only)
+        (vm-set-buffer-modified-p t)))
+ 
+ (defmacro defsyn (symbol1 symbol2)
+   (list
+    'fset (list 'quote symbol1)
+    (list 'symbol-function (list 'quote symbol2))))
+ 
+ (defun vm-group-on-author (m)
+   (let ((name (vm-su-full-name m)))
+     (if vm-group-fold-case (downcase name) name)))
+ 
+ (defsyn vm-group-by-author string<)
+ 
+ (defun vm-group-on-recipient (m)
+   (let ((name (vm-su-to-names m)))
+     (if vm-group-fold-case (downcase name) name)))
+ 
+ (defsyn vm-group-by-recipient string<)
+ 
+ (defun vm-group-on-date-sent (m)
+   "Make sortable string by string-lessp from DATE.
+ Timezone package is used."
+   (let* (
+ 	 (hdate	 (or (vm-get-header-contents m "Date") (vm-grok-From_-date m)))
+ 	 (date   (timezone-parse-date hdate)) ;[Y M D T]
+ 	 (year   (string-to-int (aref date 0)))
+ 	 (month  (string-to-int (aref date 1)))
+ 	 (day    (string-to-int (aref date 2)))
+ 	 (time   (aref date 3)))	;HH:MM:SS
+     ;; Timezone package is used.  But, we don't have to care about
+     ;; the timezone since article's timezones are always GMT.
+     (timezone-make-sortable-date year month day time)))
+ 
+ (defsyn vm-group-by-date-sent string<)
+ 
+ (defun vm-simplify-subject (subject &optional re-only)
+   "Remove `Re:' and words in parentheses.
+ If optional argument RE-ONLY is non-nil, strip `Re:' only."
+   (let ((case-fold-search t))		;Ignore case.
+     ;; Remove `Re:' and `Re^N:'.
+     (if (string-match "\\`\\(re\\(\\^[0-9]+\\)?:[ \t]+\\)+" subject)
+ 	(setq subject (substring subject (match-end 0))))
+     ;; Remove words in parentheses from end.
+     (or re-only
+ 	(while (string-match "[ \t\n]*([^()]*)[ \t\n]*\\'" subject)
+ 	  (setq subject (substring subject 0 (match-beginning 0)))))
+     ;; Return subject string.
+     subject))
+ 
+ ; Why truncate? Well, because Notes truncates to 30 chars, and
+ ; we want for truncated subjects to line up "right" in the middle
+ ; of untruncated ones. A tradeoff, as always.
+ 
+ (defun vm-group-on-subject (m)
+   (let ((simplified (vm-simplify-subject (vm-subject-of m) 're-only)))
+       (setq simplified (substring simplified 0
+ 		(min vm-group-truncate-subject (length simplified))))
+     (if vm-group-fold-case
+ 	(downcase simplified)
+       simplified)))
+ 
+ (defsyn vm-group-by-subject string<)
+ 
+ (if (fboundp 'proclaim-inline)
+     (progn
+       (proclaim-inline vm-group-on-author)
+       (proclaim-inline vm-group-on-recipient)
+       (proclaim-inline vm-group-on-subject)
+       (proclaim-inline vm-group-on-date-sent)))
+ 
+ (defun vm-group-on-subject-date-sent (m)
+   (cons (vm-group-on-subject m) (vm-group-on-date-sent m)))
+ 
+ (defun vm-group-by-subject-date-sent (a b)
+   (if (string= (car a) (car b))
+       (string< (cdr a) (cdr b))
+     (string< (car a) (car b))))
+ 
+ (defun vm-group-on-author-date-sent (m)
+   (cons (vm-group-on-author m) (vm-group-on-date-sent m)))
+ 
+ (defsyn vm-group-by-author-date-sent vm-group-by-subject-date-sent)
+ 
+ (defun vm-group-on-recipient-date-sent (m)
+   (cons (vm-group-on-recipient m) (vm-group-on-date-sent m)))
+ 
+ (defsyn vm-group-by-recipient-date-sent vm-group-by-subject-date-sent)
+ 
  (defun vm-revert-to-physical-order ()
!   (setq vm-message-list
! 	(sort vm-message-list
! 	      (function
! 	       (lambda (p q) (< (vm-start-of p) (vm-start-of q)))))
! 	vm-message-order-changed vm-message-order-stuffed)
!   (vm-reverse-link-messages)
!   (and vm-message-order-changed
!        (eq vm-retain-message-order t)
!        (not vm-folder-read-only)
!        (vm-set-buffer-modified-p t)))
  
  (defun vm-group-messages (grouping)
    "Group messages by the argument GROUPING.
***************
*** 102,123 ****
  	((equal grouping "physical-order")
  	 (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-physical-order)
  	(message "Grouping messages by %s..." grouping)
! 	(vm-group-by group-function)
  	(message "Grouping messages by %s... done" grouping)
! 	(setq vm-current-grouping grouping
! 	      vm-numbering-redo-start-point t
! 	      vm-summary-redo-start-point t))
      (vm-revert-to-physical-order)
-     (setq vm-current-grouping grouping
- 	  vm-numbering-redo-start-point t
- 	  vm-summary-redo-start-point t)
      (if (interactive-p)
  	(message "Reverted to folder's physical ordering")))
    (vm-update-summary-and-mode-line))
  
  (defun vm-move-message-forward (count)
--- 179,199 ----
  	((equal grouping "physical-order")
  	 (setq grouping nil)))
    (if grouping
!       (let (
! 	  (extract-function (intern (concat "vm-group-on-" grouping)))
! 	  (compare-function (intern (concat "vm-group-by-" grouping)))
! 	)
! 	(if (not (and (fboundp compare-function) (fboundp extract-function)))
  	    (error "Unsupported grouping: %s" grouping))
  	(message "Grouping messages by %s..." grouping)
! 	(vm-group-by compare-function extract-function)
  	(message "Grouping messages by %s... done" grouping)
! 	(setq vm-current-grouping grouping))
      (vm-revert-to-physical-order)
      (if (interactive-p)
  	(message "Reverted to folder's physical ordering")))
+   (setq vm-numbering-redo-start-point t
+ 	vm-summary-redo-start-point t)
    (vm-update-summary-and-mode-line))
  
  (defun vm-move-message-forward (count)

RCS file: vm-vars.el,v
Index: vm-vars.el
Prereq: 1.0
diff -c -r1.0 vm-vars.el
*** 1.0	1993/06/11 12:03:59
--- vm-vars.el	1993/06/11 12:42:52
***************
*** 734,740 ****
    "^\\([^: \t\n]+\\)[\t ]*:\\(.*\n\\([ \t]+.*\n\\)*\\)")
  (defconst vm-header-regexp-format "^%s:[ \t]*\\(.*\\(\n[ \t]+.*\\)*\\)")
  (defconst vm-supported-groupings-alist
!   '(("physical-order") ("subject") ("author") ("date-sent") ("recipient")))
  (defconst vm-supported-window-configurations
    '(("composing-message") ("editing-message")
      ("showing-message") ("paging-message") ("auto-next-message")
--- 734,741 ----
    "^\\([^: \t\n]+\\)[\t ]*:\\(.*\n\\([ \t]+.*\n\\)*\\)")
  (defconst vm-header-regexp-format "^%s:[ \t]*\\(.*\\(\n[ \t]+.*\\)*\\)")
  (defconst vm-supported-groupings-alist
!   '(("physical-order") ("subject") ("author") ("date-sent") ("recipient")
!     ("subject-date-sent") ("recipient-date-sent") ("author-date-sent")))
  (defconst vm-supported-window-configurations
    '(("composing-message") ("editing-message")
      ("showing-message") ("paging-message") ("auto-next-message")