blob: 88ba4b4e5ea03a93ef17151628abb18fcb864fa4 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
;;; Copyright 2024 Peter McGoron
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
;;; implied. See the License for the specific language governing
;;; permissions and limitations under the License.
;;; Helper function.
(define (null-cdr? lst) (null? (cdr lst)))
;;; MAP-VALUES returns (VALUES L1 L2 ...), where L1 is the first
;;; value returned from (F (CAR LST)), (F (CADR LST)), ... and so on.
(define (map-values f . lists)
(define (null-cdr? lst) (null? (cdr lst)))
(let-values ((new-values (apply f (map car lists))))
(if (any null-cdr? lists)
(apply values (map list new-values))
(let-values ((returned (apply map-values f (map cdr lists))))
(apply values (map cons new-values returned))))))
;;; (ANY-VALUES F (A1 A2 ...) (B1 B2 ...) ...) runs
;;; (F A1 B1 ...) and checks if there any returned values. If there are
;;; none, runs (F A2 B2 ...), and so on.
;;;
;;; If any of the lists end, then ANY-VALUES returns no values.
(define (any-values f . lists)
(after ((when (not (null? lists)))
(when (every pair? lists)))
(let-values ((returned (apply f (map car lists))))
(if (null? returned)
(apply any-values f (map cdr lists))
(apply values returned)))))
;;; REVMAP-VALUES is a tail-recursive version of MAP-VALUES that returns
;;; (REVERSE (MAP-VALUES F . LISTS)).
(define (revmap-values f . lists)
(if (or (null? lists)
(any null? lists))
'()
(let revmap-values ((collected (apply f (map car lists)))
(lists (map cdr lists)))
(if (any null? lists)
collected
(let-values ((returned (apply f (map car lists))))
(revmap-values (map cons returned collected)
(map cdr lists)))))))
;;; (FOLD-VALUES F (LIST INIT-ARG ...) LIST ...)
;;; does
;;; (F (CAR LIST) ... INIT-ARG ...) => (NEW-ARG ...)
;;; (F (CADR LIST) ... NEW-ARG ..) => (NEW-ARG2 ...)
;;; and so on until at least one of LIST is NULL?.
(define (fold-values f init-arguments . lists)
(if (any null? lists)
(apply values init-arguments)
(let-values ((returned (apply f (append (map car lists)
init-arguments))))
(apply fold-values f returned (map cdr lists)))))
|
