From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 14 Sep 2001 02:07:21 +0000 (+0000)
Subject: Add mechanism to permute the message order of a folder.
X-Git-Tag: 20090517-FFI~2581
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=58887c6ce988bdc728e79f91412e329d1ee23187;p=mit-scheme.git

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 3a7ab3d6b..2eb89e774 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.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)))))))))
 
+;;;; 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))))))
+
 ;;;; 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 ea87b8c15..aebfc2f89 100644
--- 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 b36b6078c..05ad08f1e 100644
--- 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 744da2f96..707fda739 100644
--- 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))))))
 
 ;;;; Summary content generation
diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm
index 34edd811f..7d7494463 100644
--- 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