Add mechanism to permute the message order of a folder.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 3a7ab3d6b46441ead7f97b851273095e7741ed4c..2eb89e7746f13b51acea413356dbdeba6bffdd30 100644 (file)
--- 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.144 2001/06/12 00:47:19 cph Exp $
+;;; $Id: imail-core.scm,v 1.145 2001/09/14 02:06:39 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -397,7 +397,16 @@
 (define-method url-base-name ((resource <resource>))
   (url-base-name (resource-locator resource)))
 
-(define-class <folder> (<resource>))
+(define-class <folder> (<resource>)
+  (permutation define accessor
+              initial-value #f))
+
+(define set-folder-permutation!
+  (let ((modifier (slot-modifier <folder> 'PERMUTATION)))
+    (lambda (folder permutation)
+      (modifier folder permutation)
+      (object-modified! folder 'PERMUTED))))
+
 (define-class <container> (<resource>))
 
 (define-method resource-type-name ((r <folder>)) r 'FOLDER)
@@ -505,7 +514,11 @@
   (guarantee-index index 'GET-MESSAGE)
   (if (not (< index (folder-length folder)))
       (error:bad-range-argument index 'GET-MESSAGE))
-  (%get-message folder index))
+  (%get-message folder
+               (let ((permutation (folder-permutation folder)))
+                 (if permutation
+                     (permute-index permutation folder index)
+                     index))))
 
 (define-generic %get-message (folder index))
 
@@ -583,6 +596,7 @@
   (folder define standard
          initial-value #f)
   (index define standard
+        accessor %message-index
         initial-value #f))
 
 (define-method write-instance ((message <message>) port)
@@ -591,7 +605,7 @@
       (write-char #\space port)
       (write (message-folder message) port)
       (write-char #\space port)
-      (write (message-index message) port))))
+      (write (%message-index message) port))))
 
 (define (guarantee-message message procedure)
   (if (not (message? message))
@@ -602,6 +616,16 @@
 (define-generic message-internal-time (message))
 (define-generic message-length (message))
 
+(define (message-index message)
+  (let ((index (%message-index message))
+       (folder (message-folder message)))
+    (let ((permutation
+          (and folder
+               (folder-permutation folder))))
+      (if permutation
+         (unpermute-index permutation folder index)
+         index))))
+
 (define %set-message-flags!
   (let ((modifier (slot-modifier <message> 'FLAGS)))
     (lambda (message flags)
@@ -644,7 +668,11 @@
 
 (define (first-unseen-message folder)
   (let ((end (folder-length folder)))
-    (let loop ((start (first-unseen-message-index folder)))
+    (let loop
+       ((start
+         (if (folder-permutation folder)
+             0
+             (first-unseen-message-index folder))))
       (and (< start end)
           (let ((message (get-message folder start)))
             (if (message-seen? message)
@@ -691,6 +719,52 @@
                     message
                     (loop index)))))))))
 \f
+;;;; Folder permutations
+
+(define-structure (folder-permutation
+                  (type-descriptor folder-permutation-rtd)
+                  (constructor make-folder-permutation (predicate)))
+  (predicate #f read-only #t)
+  (forward #f)
+  (reverse #f)
+  (modification-count -1))
+
+(define (permute-index permutation folder index)
+  (guarantee-valid-permutation permutation folder)
+  (let ((v (folder-permutation-forward permutation)))
+    (if (fix:< index (vector-length v))
+       (vector-ref v index)
+       index)))
+
+(define (unpermute-index permutation folder index)
+  (guarantee-valid-permutation permutation folder)
+  (let ((v (folder-permutation-reverse permutation)))
+    (if (fix:< index (vector-length v))
+       (vector-ref v index)
+       index)))
+
+(define (guarantee-valid-permutation permutation folder)
+  (let loop ()
+    (let ((count (object-modification-count folder)))
+      (if (not (= (folder-permutation-modification-count permutation) 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-permutation-predicate permutation))
+               (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-permutation-forward! permutation vf)
+               (set-folder-permutation-reverse! permutation vr)))
+           (set-folder-permutation-modification-count! permutation count)
+           (loop))))))
+\f
 ;;;; Message flags
 
 ;;; Flags are markers that can be attached to messages.  They indicate

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index ea87b8c15b22868ff535393f8424cb4e6034a513..aebfc2f89f7d48d13b5afeaad07e5c868260669b 100644 (file)
--- a/v7/src/imail/imail-file.scm
+++ b/v7/src/imail/imail-file.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-file.scm,v 1.78 2001/06/12 00:47:24 cph Exp $
+;;; $Id: imail-file.scm,v 1.79 2001/09/14 02:06:43 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -375,7 +375,7 @@
           (let loop ((index 0) (winners '()))
             (if (< index n)
                 (loop (+ index 1)
-                      (if (let ((message (get-message folder index)))
+                      (if (let ((message (%get-message folder index)))
                             (or (string-search-forward
                                  criteria
                                  (header-fields->string

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index b36b6078cf2afe2de02a5c718fff09fb988f6b4e..05ad08f1e8589562400b9036213f560827331152 100644 (file)
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.184 2001/07/21 03:53:36 cph Exp $
+;;; $Id: imail-imap.scm,v 1.185 2001/09/14 02:06:53 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -1072,7 +1072,7 @@
     (if (not (initpred message))
        (with-imap-message-open message
          (lambda (connection)
-           (let ((index (message-index message)))
+           (let ((index (%message-index message)))
              (let ((suffix
                     (string-append " UID for message "
                                    (number->string (+ index 1)))))
@@ -1099,7 +1099,7 @@
            (let ((suffix
                   (string-append
                    " " noun " for message "
-                   (number->string (+ (message-index message) 1)))))
+                   (number->string (+ (%message-index message) 1)))))
              ((imail-ui:message-wrapper "Reading" suffix)
               (lambda ()
                 (imap:read-literal-progress-hook imail-ui:progress-meter
@@ -1173,7 +1173,7 @@
          (reverse! messages)))))
 
 (define (message-list->set messages)
-  (let loop ((indexes (map message-index messages)) (groups '()))
+  (let loop ((indexes (map %message-index messages)) (groups '()))
     (if (pair? indexes)
        (let ((start (car indexes)))
          (let parse-group ((this start) (rest (cdr indexes)))
@@ -1235,7 +1235,7 @@
          (string-append " body"
                         (if (equal? section '(TEXT)) "" " part")
                         " for message "
-                        (number->string (+ (message-index message) 1)))))
+                        (number->string (+ (%message-index message) 1)))))
      ((imail-ui:message-wrapper "Reading" suffix)
       (lambda ()
        (imap:read-literal-progress-hook imail-ui:progress-meter
@@ -1972,8 +1972,8 @@
         (with-imap-connection-folder connection
           (lambda (folder)
             (process-fetch-attributes
-             (get-message folder
-                          (- (imap:response:fetch-index response) 1))
+             (%get-message folder
+                           (- (imap:response:fetch-index response) 1))
              response)))
         (eq? command 'FETCH))
        (else

diff --git a/v7/src/imail/imail-summary.scm b/v7/src/imail/imail-summary.scm
index 744da2f966cebc2bc7f4eabc76b9c1a1a6b09288..707fda7393cadf5b6f5cebf21516cb8cdcc6da09 100644 (file)
--- a/v7/src/imail/imail-summary.scm
+++ b/v7/src/imail/imail-summary.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-summary.scm,v 1.42 2001/05/23 05:05:16 cph Exp $
+;;; $Id: imail-summary.scm,v 1.43 2001/09/14 02:07:00 cph Exp $
 ;;;
 ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
 ;;;
@@ -240,7 +240,7 @@ SUBJECT is a string of regexps separated by commas."
           (let ((message (car parameters)))
             (if message
                 (imail-summary-select-message buffer message))))
-         ((EXPUNGE INCREASE-LENGTH SET-LENGTH)
+         ((EXPUNGE INCREASE-LENGTH SET-LENGTH PERMUTED)
           (maybe-add-command-suffix! rebuild-imail-summary-buffer buffer))))))
 \f
 ;;;; Summary content generation

diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm
index 34edd811f3a69f42b43f4c32a9fdb422021d55b7..7d74944637504ac64152a8fc1e96dd7d6cdc30b7 100644 (file)
--- a/v7/src/imail/load.scm
+++ b/v7/src/imail/load.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: load.scm,v 1.28 2001/08/17 13:01:06 cph Exp $
+;;; $Id: load.scm,v 1.29 2001/09/14 02:07:21 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -28,4 +28,4 @@
   (lambda ()
     (fluid-let ((*allow-package-redefinition?* #t))
       (load-package-set "imail"))))
-(add-subsystem-identification! "IMAIL" '(1 11))
\ No newline at end of file
+(add-subsystem-identification! "IMAIL" '(1 12))
\ No newline at end of file