From 72e98bdfce7905fdc08cb5400b663fc956e66d87 Mon Sep 17 00:00:00 2001
From: "Taylor R. Campbell" <net/mumble/campbell>
Date: Sun, 11 Mar 2007 01:11:41 +0000
Subject: [PATCH] New implementation of folder orders that uses AVL trees
 instead of sorted vectors to store the order of messages.  Modifications to
 the folder are now reflected in incremental updates to the folder order by
 AVL insertions, instead of rebuilding the order vector for every modification
 to the folder.  Also, the key by which the message is sorted is now computed
 once per message in the order record, instead of every time that the message
 comparison predicate is called.

---
 v7/src/imail/imail-core.scm | 104 ++++++++++++++++++++++++------------
 v7/src/imail/imail-top.scm  |   7 +--
 v7/src/imail/load.scm       |   3 +-
 3 files changed, 74 insertions(+), 40 deletions(-)

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 7621e8f1a..ba61aa6b5 100644
--- a/v7/src/imail/imail-core.scm
+++ b/v7/src/imail/imail-core.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: imail-core.scm,v 1.156 2007/01/05 21:19:25 cph Exp $
+$Id: imail-core.scm,v 1.157 2007/03/11 01:11:19 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -410,7 +410,12 @@ USA.
 (define set-folder-order!
   (let ((modifier (slot-modifier <folder> 'ORDER)))
     (lambda (folder order)
-      (modifier folder order)
+      (let ((original-order (folder-order folder)))
+        (modifier folder order)
+        (cond ((not (and original-order order))
+               (receive-modification-events folder update-folder-order))
+              ((not (or original-order order))
+               (ignore-modification-events folder update-folder-order))))
       (object-modified! folder 'REORDERED))))
 
 (define-class <container> (<resource>))
@@ -724,21 +729,18 @@ USA.
 
 (define-structure (folder-order
 		   (type-descriptor <folder-order>)
-		   (constructor make-folder-order (predicate)))
+		   (constructor make-folder-order (predicate selector)))
   (predicate #f read-only #t)
-  (forward #f)
-  (reverse #f)
-  (modification-count -1))
+  (selector #f read-only #t)
+  (tree #f))
 
 (define (map-folder-index folder index)
   (let ((order (folder-order folder)))
     (if order
 	(begin
 	  (memoize-folder-order order folder)
-	  (let ((v (folder-order-forward order)))
-	    (if (fix:< index (vector-length v))
-		(vector-ref v index)
-		index)))
+          (%message-index
+           (wt-tree/index-datum (folder-order-tree order) index)))
 	index)))
 
 (define (unmap-folder-index folder index)
@@ -746,33 +748,67 @@ USA.
     (if order
 	(begin
 	  (memoize-folder-order order folder)
-	  (let ((v (folder-order-reverse order)))
-	    (if (fix:< index (vector-length v))
-		(vector-ref v index)
-		index)))
+          (wt-tree/rank (folder-order-tree order)
+                        (cons ((folder-order-selector order)
+                               (%get-message folder index))
+                              index)))
 	index)))
 
+(define (make-wt-message-tree key<?)
+  (make-wt-tree
+   (make-wt-tree-type
+    (lambda (a b)
+      (or (key<? (car a) (car b))
+          (and (not (key<? (car b) (car a)))
+               (< (cdr a) (cdr b))))))))
+
 (define (memoize-folder-order order folder)
-  (let loop ()
-    (let ((count (object-modification-count folder)))
-      (if (not (= (folder-order-modification-count order) count))
-	  (begin
-	    (let ((n (folder-length folder)))
-	      (let ((vf (make-vector n))
-		    (vr (make-vector n)))
-		(do ((i 0 (fix:+ i 1)))
-		    ((fix:= i n))
-		  (vector-set! vf i (%get-message folder i)))
-		(sort! vf (folder-order-predicate order))
-		(do ((i 0 (fix:+ i 1)))
-		    ((fix:= i n))
-		  (let ((j (%message-index (vector-ref vf i))))
-		    (vector-set! vf i j)
-		    (vector-set! vr j i)))
-		(set-folder-order-forward! order vf)
-		(set-folder-order-reverse! order vr)))
-	    (set-folder-order-modification-count! order count)
-	    (loop))))))
+  (without-interrupts
+   (lambda ()
+     (if (not (folder-order-tree order))
+         ((imail-ui:message-wrapper "Sorting folder")
+          (lambda ()
+            (let ((length (folder-length folder))
+                  (selector (folder-order-selector order))
+                  (tree (make-wt-message-tree (folder-order-predicate order))))
+              (do ((index 0 (+ index 1)))
+                  ((= index length))
+                (imail-ui:progress-meter index #f)
+                (let ((message (%get-message folder index)))
+                  (wt-tree/add! tree
+                                (cons (selector message) index)
+                                message)))
+              (set-folder-order-tree! order tree))))))))
+
+(define (update-folder-order folder modification-type . args)
+  (without-interrupts
+   (lambda ()
+     (let ((order (folder-order folder)))
+       (if order
+           (case modification-type
+             ((SET-LENGTH)
+              (set-folder-order-tree! order #f))
+             ((INCREASE-LENGTH)
+              (let ((tree (folder-order-tree order)))
+                (if tree
+                    (let ((index (car args))
+                          (count (cadr args))
+                          (selector (folder-order-selector order)))
+                      (do ((index index (+ index 1)))
+                          ((= index count))
+                        (let ((message (%get-message folder index)))
+                          (wt-tree/add! tree
+                                        (cons (selector message) index)
+                                        message)))))))
+             ((EXPUNGE)
+              (let ((tree (folder-order-tree order)))
+                (if tree
+                    (let ((index (car args))
+                          (selector (folder-order-selector order)))
+                      (wt-tree/delete!
+                       tree
+                       (cons (selector (%get-message folder index))
+                             index))))))))))))
 
 ;;;; Message flags
 
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 0ededf4e4..6964f177f 100644
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: imail-top.scm,v 1.296 2007/01/05 21:19:25 cph Exp $
+$Id: imail-top.scm,v 1.297 2007/03/11 01:11:33 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -1560,10 +1560,7 @@ With prefix argument, sort them in reverse order."
 	"")))
 
 (define (sort-selected-folder < message-key)
-  (set-folder-order! (selected-folder)
-		     (make-folder-order
-		      (lambda (a b)
-			(< (message-key a) (message-key b))))))
+  (set-folder-order! (selected-folder) (make-folder-order < message-key)))
 
 ;;;; Miscellany
 
diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm
index ac54d8c59..fb0cbc3fc 100644
--- a/v7/src/imail/load.scm
+++ b/v7/src/imail/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 1.46 2007/01/05 21:19:25 cph Exp $
+$Id: load.scm,v 1.47 2007/03/11 01:11:41 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -29,6 +29,7 @@ USA.
 
 (load-option 'REGULAR-EXPRESSION)
 (load-option 'SOS)
+(load-option 'WT-TREE)
 (with-working-directory-pathname (directory-pathname (current-load-pathname))
   (lambda ()
     (fluid-let ((*allow-package-redefinition?* #t))
-- 
2.25.1