source: project/release/4/combinators/trunk/bi-combinators.scm @ 19028

Last change on this file since 19028 was 19028, checked in by Kon Lovett, 9 years ago

Export Scheme-ish uni, etc. & arguments-X routines

File size: 1.2 KB
Line 
1;;;; bi-combinators.scm
2;;;; Kon Lovett, Jul '10
3
4(module bi-combinators
5
6  (;export
7    bi bi2 bi3 bi-each bi-all)
8
9  (import
10    scheme
11    chicken)
12
13#|
14;;; Hook
15
16;; Binary
17
18(define (bi-each-left c f)
19  (lambda (x y) (c (f x) (f y) x y)) )
20
21(define (bi-each-right c f)
22  (lambda (x y) (c x y (f x) (f y))) )
23
24(define (bi-all-left c f g)
25  (lambda xs (apply c (apply f xs) (apply g xs) xs)) )
26
27(define (bi-all-right c f g)
28  (lambda xs (apply c (append xs (list (apply f xs) (apply g xs))))) )
29|#
30
31;;; Fork
32
33;; Binary
34
35(define bi
36  (case-lambda
37    ((c f g)  (lambda (x) (c (f x) (g x))))
38    ((f g)    (lambda (c) (bi c f g)))
39    ((c)      (lambda (f g) (bi c f g)))
40    (()       (lambda (c) (bi c)))))
41
42(define bi2
43  (case-lambda
44    ((c f g)  (lambda (x y) (c (f x y) (g x y))))
45    ((f g)    (lambda (c) (bi2 c f g)))
46    ((c)      (lambda (f g) (bi2 c f g)))
47    (()       (lambda (c) (bi2 c)))))
48
49(define bi3
50  (case-lambda
51    ((c f g)  (lambda (x y z) (c (f x y z) (g x y z))))
52    ((f g)    (lambda (c) (bi3 c f g)))
53    ((c)      (lambda (f g) (bi3 c f g)))
54    (()       (lambda (c) (bi3 c)))))
55
56(define (bi-each c f)
57  (lambda (x y) (c (f x) (f y))) )
58
59(define (bi-all c f g)
60  (lambda xs (c (apply f xs) (apply g xs))) )
61
62) ;module bi-combinators
Note: See TracBrowser for help on using the repository browser.