utils: Add `fold2'.

* gnu/packages.scm (fold2): Remove.
* guix/utils.scm (fold2): New procedure.  Generalization of the above to
  one and two lists.
* tests/utils.scm ("fold2, 1 list", "fold2, 2 lists"): New tests.
This commit is contained in:
Ludovic Courtès 2013-04-14 16:56:08 +02:00
parent 77ffd691bf
commit 04fd96cac3
3 changed files with 53 additions and 9 deletions

View File

@ -110,14 +110,6 @@
(false-if-exception (resolve-interface name)))) (false-if-exception (resolve-interface name))))
(package-files))) (package-files)))
(define (fold2 f seed1 seed2 lst)
(if (null? lst)
(values seed1 seed2)
(call-with-values
(lambda () (f (car lst) seed1 seed2))
(lambda (seed1 seed2)
(fold2 f seed1 seed2 (cdr lst))))))
(define (fold-packages proc init) (define (fold-packages proc init)
"Call (PROC PACKAGE RESULT) for each available package, using INIT as "Call (PROC PACKAGE RESULT) for each available package, using INIT as
the initial value of RESULT. It is guaranteed to never traverse the the initial value of RESULT. It is guaranteed to never traverse the

View File

@ -59,7 +59,8 @@
%current-system %current-system
version-compare version-compare
version>? version>?
package-name->name+version)) package-name->name+version
fold2))
;;; ;;;
@ -463,6 +464,32 @@ introduce the version part."
((head tail ...) ((head tail ...)
(loop tail (cons head prefix)))))) (loop tail (cons head prefix))))))
(define fold2
(case-lambda
((proc seed1 seed2 lst)
"Like `fold', but with a single list and two seeds."
(let loop ((result1 seed1)
(result2 seed2)
(lst lst))
(if (null? lst)
(values result1 result2)
(call-with-values
(lambda () (proc (car lst) result1 result2))
(lambda (result1 result2)
(loop result1 result2 (cdr lst)))))))
((proc seed1 seed2 lst1 lst2)
"Like `fold', but with a two lists and two seeds."
(let loop ((result1 seed1)
(result2 seed2)
(lst1 lst1)
(lst2 lst2))
(if (or (null? lst1) (null? lst2))
(values result1 result2)
(call-with-values
(lambda () (proc (car lst1) (car lst2) result1 result2))
(lambda (result1 result2)
(fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
;;; ;;;
;;; Source location. ;;; Source location.

View File

@ -64,6 +64,31 @@
("nixpkgs" "1.0pre22125_a28fe19") ("nixpkgs" "1.0pre22125_a28fe19")
("gtk2" "2.38.0")))) ("gtk2" "2.38.0"))))
(test-equal "fold2, 1 list"
(list (reverse (iota 5))
(map - (reverse (iota 5))))
(call-with-values
(lambda ()
(fold2 (lambda (i r1 r2)
(values (cons i r1)
(cons (- i) r2)))
'() '()
(iota 5)))
list))
(test-equal "fold2, 2 lists"
(list (reverse '((a . 0) (b . 1) (c . 2) (d . 3)))
(reverse '((a . 0) (b . -1) (c . -2) (d . -3))))
(call-with-values
(lambda ()
(fold2 (lambda (k v r1 r2)
(values (alist-cons k v r1)
(alist-cons k (- v) r2)))
'() '()
'(a b c d)
'(0 1 2 3)))
list))
(test-assert "define-record-type*" (test-assert "define-record-type*"
(begin (begin
(define-record-type* <foo> foo make-foo (define-record-type* <foo> foo make-foo