[Guile-commits] 10/12: Add intmap-fold-right

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 8b4a523ad5b0d7a665861dea595075c97c70e585
Author: Andy Wingo <address@hidden>
Date:   Mon May 25 16:12:54 2015 +0200

    Add intmap-fold-right
    
    * module/language/cps/intmap.scm (make-intmap-folder): Add forward? 
argument.
      (intmap-fold): Adapt.
      (intmap-fold-right): New function.
---
 module/language/cps/intmap.scm |   30 ++++++++++++++++++++----------
 1 files changed, 20 insertions(+), 10 deletions(-)

diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index 485f354..e3fdc2f 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -49,6 +49,7 @@
             intmap-next
             intmap-prev
             intmap-fold
+            intmap-fold-right
             intmap-union
             intmap-intersect))
 
@@ -470,23 +471,23 @@ already, and always calls the meet procedure."
      (assert-readable! edit)
      (prev min shift root))))
 
-(define-syntax-rule (make-intmap-folder seed ...)
+(define-syntax-rule (make-intmap-folder forward? seed ...)
   (lambda (f map seed ...)
     (define (visit-branch node shift min seed ...)
       (let ((shift (- shift *branch-bits*)))
         (if (zero? shift)
-            (let lp ((i 0) (seed seed) ...)
-              (if (< i *branch-size*)
+            (let lp ((i (if forward? 0 (1- *branch-size*))) (seed seed) ...)
+              (if (if forward? (< i *branch-size*) (<= 0 i))
                   (let ((elt (vector-ref node i)))
                     (call-with-values (lambda ()
                                         (if (present? elt)
                                             (f (+ i min) elt seed ...)
                                             (values seed ...)))
                       (lambda (seed ...)
-                        (lp (1+ i) seed ...))))
+                        (lp (if forward? (1+ i) (1- i)) seed ...))))
                   (values seed ...)))
-            (let lp ((i 0) (seed seed) ...)
-              (if (< i *branch-size*)
+            (let lp ((i (if forward? 0 (1- *branch-size*))) (seed seed) ...)
+              (if (if forward? (< i *branch-size*) (<= 0 i))
                   (let ((elt (vector-ref node i)))
                     (call-with-values
                         (lambda ()
@@ -495,7 +496,7 @@ already, and always calls the meet procedure."
                                             seed ...)
                               (values seed ...)))
                       (lambda (seed ...)
-                        (lp (1+ i) seed ...))))
+                        (lp (if forward? (1+ i) (1- i)) seed ...))))
                   (values seed ...))))))
     (let fold ((map map))
       (match map
@@ -510,11 +511,20 @@ already, and always calls the meet procedure."
 (define intmap-fold
   (case-lambda
     ((f map seed)
-     ((make-intmap-folder seed) f map seed))
+     ((make-intmap-folder #t seed) f map seed))
     ((f map seed0 seed1)
-     ((make-intmap-folder seed0 seed1) f map seed0 seed1))
+     ((make-intmap-folder #t seed0 seed1) f map seed0 seed1))
     ((f map seed0 seed1 seed2)
-     ((make-intmap-folder seed0 seed1 seed2) f map seed0 seed1 seed2))))
+     ((make-intmap-folder #t seed0 seed1 seed2) f map seed0 seed1 seed2))))
+
+(define intmap-fold-right
+  (case-lambda
+    ((f map seed)
+     ((make-intmap-folder #f seed) f map seed))
+    ((f map seed0 seed1)
+     ((make-intmap-folder #f seed0 seed1) f map seed0 seed1))
+    ((f map seed0 seed1 seed2)
+     ((make-intmap-folder #f seed0 seed1 seed2) f map seed0 seed1 seed2))))
 
 (define* (intmap-union a b #:optional (meet meet-error))
   ;; Union A and B from index I; the result will be fresh.