source: project/release/4/combinators/trunk/section-combinators.scm @ 18923

Last change on this file since 18923 was 18923, checked in by Kon Lovett, 11 years ago

Sections

File size: 4.5 KB
Line 
1;;;; section-combinators.scm
2;;;; Kon Lovett, Jul '10
3
4(module section-combinators
5
6  (;export
7    left-section
8    right-section
9    crop-left
10    crop-right
11    reversed
12    identities
13    apply@
14    apply*
15    combine@
16    combine*
17    )
18
19  (import
20    scheme
21    chicken
22    srfi-1)
23
24  (require-library srfi-1)
25
26  (declare
27    (type
28      (left-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
29      (right-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
30      (reversed (procedure ((procedure (#!rest) *)) (procedure (#!rest) *)))
31      (identities (procedure (#!rest) list))
32      (crop-left (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *)))
33      (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) ) )
34
35;;;
36
37(define (left-section proc . args)
38  (lambda xs (##sys#apply proc (##sys#append args xs))))
39
40(define (right-section proc . args)
41  (lambda xs (##sys#apply proc (##sys#append xs args))))
42
43(define (crop-left proc n)
44  (lambda xs (##sys#apply proc (drop xs n))) )
45
46(define (crop-right proc n)
47  (lambda xs (##sys#apply proc (drop-right xs n))) )
48
49(define (reversed proc)
50  (lambda xs (##sys#apply proc (reverse xs))))
51
52(define (identities . xs) xs)
53
54;;
55
56(define (apply@ proc . procs)
57  (if (null procs)
58    (lambda xs (##sys#list (##sys#map proc xs)))
59    (let ((procs (##sys#append (##sys#list proc) procs)))
60      (lambda xs (##sys#map (lambda (f x) (f x)) procs xs)) ) ) )
61 
62(define (apply* proc . procs)
63  (if (null procs)
64    (lambda xs (##sys#list (##sys#apply proc xs)))
65    (let ((procs (##sys#append (##sys#list proc) procs)))
66      (lambda xs (##sys#map (cut ##sys#apply <> xs) procs)) ) ) )
67
68;;
69
70(define combine@
71  (case-lambda
72    ((comb proc . procs)
73      (let ((reducer (##sys#apply apply@ proc procs)))
74        (lambda xs (##sys#apply comb (##sys#apply reducer xs)))) )
75    ((comb)
76      (lambda procs (##sys#apply combine@ comb procs)) )
77    (()
78      (lambda (comb) (combine@ comb)) ) ) )
79
80(define combine*
81  (case-lambda
82    ((comb proc . procs)
83      (let ((reducer (##sys#apply apply* procs)))
84        (lambda xs (##sys#apply proc (##sys#apply reducer xs)))) )
85    ((comb)
86      (lambda procs (##sys#apply combine* comb procs)) )
87    (()
88      (lambda (comb) (combine* comb)) ) ) )
89
90;;
91
92(define uni
93  (case-lambda
94    ((c f)  (lambda (x) (c (f x))))
95    ((c)    (lambda (f) (uni c f)))
96    (()     (lambda (c) (uni c)))))
97
98(define uni2
99  (case-lambda
100    ((c f)  (lambda (x y) (c (f x y))))
101    ((c)    (lambda (f) (uni2 c f)))
102    (()     (lambda (c) (uni2 c)))))
103
104(define uni3
105  (case-lambda
106    ((c f)  (lambda (x y z) (c (f x y z))))
107    ((c)    (lambda (f) (uni3 c f)))
108    (()     (lambda (c) (uni3 c)))))
109
110(define uni@    ; for completeness only
111  (case-lambda
112    ((c f)  (lambda (x) (c (f x))))))
113
114(define uni*
115  (case-lambda
116    ((c f)  (lambda xs (c (##sys#apply f xs))))))
117
118;;
119
120(define bi
121  (case-lambda
122    ((c f g)  (lambda (x) (c (f x) (g x))))
123    ((f g)    (lambda (c) (bi c f g)))
124    ((c)      (lambda (f g) (bi c f g)))
125    (()       (lambda (c) (bi c)))))
126
127(define bi2
128  (case-lambda
129    ((c f g)  (lambda (x y) (c (f x y) (g x y))))
130    ((f g)    (lambda (c) (bi2 c f g)))
131    ((c)      (lambda (f g) (bi2 c f g)))
132    (()       (lambda (c) (bi2 c)))))
133
134(define bi3
135  (case-lambda
136    ((c f g)  (lambda (x y z) (c (f x y z) (g x y z))))
137    ((f g)    (lambda (c) (bi3 c f g)))
138    ((c)      (lambda (f g) (bi3 c f g)))
139    (()       (lambda (c) (bi3 c)))))
140
141(define bi@
142  (case-lambda
143    ((c f)  (lambda (x y) (c (f x) (f y))))))
144
145(define bi*
146  (case-lambda
147    ((c f g)  (lambda xs (c (##sys#apply f xs) (##sys#apply g xs))))))
148
149;;
150
151(define tri
152  (case-lambda
153    ((c f g h)  (lambda (x) (c (f x) (g x) (h x))))
154    ((f g h)    (lambda (c) (tri c f g h)))
155    ((c)        (lambda (f g h) (tri c f g h)))
156    (()         (lambda (c) (tri c)))))
157
158(define tri2
159  (case-lambda
160    ((c f g h)  (lambda (x y) (c (f x y) (g x y) (h x y))))
161    ((f g h)    (lambda (c) (tri2 c f g h)))
162    ((c)        (lambda (f g h) (tri2 c f g h)))
163    (()         (lambda (c) (tri2 c)))))
164
165(define tri3
166  (case-lambda
167    ((c f g h)  (lambda (x y z) (c (f x y z) (g x y z) (h x y z))))
168    ((f g h)    (lambda (c) (tri3 c f g h)))
169    ((c)        (lambda (f g h) (tri3 c f g h)))
170    (()         (lambda (c) (tri3 c)))))
171
172(define tri@
173  (case-lambda
174    ((c f)  (lambda (x y z) (c (f x) (f y) (f z))))))
175
176(define tri*
177  (case-lambda
178    ((c f g h)  (lambda xs (c (##sys#apply f xs) (##sys#apply g xs) (##sys#apply h xs))))))
179
180) ;module section-combinators
Note: See TracBrowser for help on using the repository browser.