mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

Add intmap-fold-right

Browse source 
* module/language/cps/intmap.scm (make-intmap-folder): Add forward? argument.
  (intmap-fold): Adapt.
  (intmap-fold-right): New function.
This commit is contained in:
Andy Wingo 2015-05-25 16:12:54 +02:00
parent dd2e0f519d
commit 8b4a523ad5
1 changed files with 20 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

30
module/language/cps/intmap.scm
View file

@ -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.