mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 08:40:19 +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-next
intmap-prev intmap-prev
intmap-fold intmap-fold
intmap-fold-right
intmap-union intmap-union
intmap-intersect)) intmap-intersect))
@ -470,23 +471,23 @@ already, and always calls the meet procedure."
(assert-readable! edit) (assert-readable! edit)
(prev min shift root)))) (prev min shift root))))
(define-syntax-rule (make-intmap-folder seed ...) (define-syntax-rule (make-intmap-folder forward? seed ...)
(lambda (f map seed ...) (lambda (f map seed ...)
(define (visit-branch node shift min seed ...) (define (visit-branch node shift min seed ...)
(let ((shift (- shift *branch-bits*))) (let ((shift (- shift *branch-bits*)))
(if (zero? shift) (if (zero? shift)
(let lp ((i 0) (seed seed) ...) (let lp ((i (if forward? 0 (1- *branch-size*))) (seed seed) ...)
(if (< i *branch-size*) (if (if forward? (< i *branch-size*) (<= 0 i))
(let ((elt (vector-ref node i))) (let ((elt (vector-ref node i)))
(call-with-values (lambda () (call-with-values (lambda ()
(if (present? elt) (if (present? elt)
(f (+ i min) elt seed ...) (f (+ i min) elt seed ...)
(values seed ...))) (values seed ...)))
(lambda (seed ...) (lambda (seed ...)
(lp (1+ i) seed ...)))) (lp (if forward? (1+ i) (1- i)) seed ...))))
(values seed ...))) (values seed ...)))
(let lp ((i 0) (seed seed) ...) (let lp ((i (if forward? 0 (1- *branch-size*))) (seed seed) ...)
(if (< i *branch-size*) (if (if forward? (< i *branch-size*) (<= 0 i))
(let ((elt (vector-ref node i))) (let ((elt (vector-ref node i)))
(call-with-values (call-with-values
(lambda () (lambda ()
@ -495,7 +496,7 @@ already, and always calls the meet procedure."
seed ...) seed ...)
(values seed ...))) (values seed ...)))
(lambda (seed ...) (lambda (seed ...)
(lp (1+ i) seed ...)))) (lp (if forward? (1+ i) (1- i)) seed ...))))
(values seed ...)))))) (values seed ...))))))
(let fold ((map map)) (let fold ((map map))
(match map (match map
@ -510,11 +511,20 @@ already, and always calls the meet procedure."
(define intmap-fold (define intmap-fold
(case-lambda (case-lambda
((f map seed) ((f map seed)
((make-intmap-folder seed) f map seed)) ((make-intmap-folder #t seed) f map seed))
((f map seed0 seed1) ((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) ((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)) (define* (intmap-union a b #:optional (meet meet-error))
;; Union A and B from index I; the result will be fresh. ;; Union A and B from index I; the result will be fresh.