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

Last change on this file since 18946 was 18946, checked in by Kon Lovett, 10 years ago

nnary section combs in own mod

File size: 3.5 KB
Line 
1;;;; section-combinators.scm
2;;;; Kon Lovett, Jul '10
3
4(module section-combinators
5
6  (;export
7    left-section right-section
8    crop-left crop-right
9    reversed
10    uni uni2 uni3 uni-each uni-all
11    bi bi2 bi3 bi-each bi-all
12    tri tri2 tri3 tri-each tri-all)
13
14  (import
15    scheme
16    chicken
17    (only data-structures compose)
18    (only srfi-1 circular-list drop drop-right))
19
20  (require-library data-structures srfi-1)
21
22  (declare
23    (type
24      (left-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
25      (right-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
26      (reversed (procedure ((procedure (#!rest) *)) (procedure (#!rest) *)))
27      (crop-left (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *)))
28      (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) ) )
29
30;;; Section
31
32(define (left-section fn . args)
33  (lambda xs (apply fn (append args xs))) )
34
35; (reverse (append (reverse args) (reverse xs))) = (append xs args)
36(define (right-section fn . args)
37  (lambda xs (apply fn (append xs args))) )
38
39;;; Crop
40
41; (compose fn (right-section drop n) list)
42(define (crop-left fn n)
43  (lambda xs (apply fn (drop xs n))) )
44
45; (compose fn (right-section drop-right n) list)
46(define (crop-right fn n)
47  (lambda xs (apply fn (drop-right xs n))) )
48
49;;; Reverse
50
51; (compose fn reverse list)
52(define (reversed fn)
53  (lambda xs (apply fn (reverse xs))) )
54
55;;; Fork
56
57;; Unary
58
59(define uni
60  (case-lambda
61    ((c f)  (lambda (x) (c (f x))))
62    ((c)    (lambda (f) (uni c f)))
63    (()     (lambda (c) (uni c)))))
64
65(define uni2
66  (case-lambda
67    ((c f)  (lambda (x y) (c (f x y))))
68    ((c)    (lambda (f) (uni2 c f)))
69    (()     (lambda (c) (uni2 c)))))
70
71(define uni3
72  (case-lambda
73    ((c f)  (lambda (x y z) (c (f x y z))))
74    ((c)    (lambda (f) (uni3 c f)))
75    (()     (lambda (c) (uni3 c)))))
76
77(define (uni-each c f)
78  (lambda (x) (c (f x))) )
79
80(define (uni-all c f)
81  (lambda xs (c (apply f xs))) )
82
83;; Binary
84
85(define bi
86  (case-lambda
87    ((c f g)  (lambda (x) (c (f x) (g x))))
88    ((f g)    (lambda (c) (bi c f g)))
89    ((c)      (lambda (f g) (bi c f g)))
90    (()       (lambda (c) (bi c)))))
91
92(define bi2
93  (case-lambda
94    ((c f g)  (lambda (x y) (c (f x y) (g x y))))
95    ((f g)    (lambda (c) (bi2 c f g)))
96    ((c)      (lambda (f g) (bi2 c f g)))
97    (()       (lambda (c) (bi2 c)))))
98
99(define bi3
100  (case-lambda
101    ((c f g)  (lambda (x y z) (c (f x y z) (g x y z))))
102    ((f g)    (lambda (c) (bi3 c f g)))
103    ((c)      (lambda (f g) (bi3 c f g)))
104    (()       (lambda (c) (bi3 c)))))
105
106(define (bi-each c f)
107  (lambda (x y) (c (f x) (f y))) )
108
109(define (bi-all c f g)
110  (lambda xs (c (apply f xs) (apply g xs))) )
111
112;; Trinary
113
114(define tri
115  (case-lambda
116    ((c f g h)  (lambda (x) (c (f x) (g x) (h x))))
117    ((f g h)    (lambda (c) (tri c f g h)))
118    ((c)        (lambda (f g h) (tri c f g h)))
119    (()         (lambda (c) (tri c)))))
120
121(define tri2
122  (case-lambda
123    ((c f g h)  (lambda (x y) (c (f x y) (g x y) (h x y))))
124    ((f g h)    (lambda (c) (tri2 c f g h)))
125    ((c)        (lambda (f g h) (tri2 c f g h)))
126    (()         (lambda (c) (tri2 c)))))
127
128(define tri3
129  (case-lambda
130    ((c f g h)  (lambda (x y z) (c (f x y z) (g x y z) (h x y z))))
131    ((f g h)    (lambda (c) (tri3 c f g h)))
132    ((c)        (lambda (f g h) (tri3 c f g h)))
133    (()         (lambda (c) (tri3 c)))))
134
135(define (tri-each c f)
136  (lambda (x y z) (c (f x) (f y) (f z))) )
137
138(define (tri-all c f g h)
139  (lambda xs (c (apply f xs) (apply g xs) (apply h xs))) )
140
141) ;module section-combinators
Note: See TracBrowser for help on using the repository browser.