source: project/release/4/combinators/tags/1.1.0/stack-combinators.scm @ 18914

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

Added section.

File size: 3.4 KB
Line 
1;;;; stack-combinators.scm
2;;;; Kon Lovett, Mar '09
3;;;; Portions from a 'comp.lang.scheme' posting by "wayo.cavazos@gmail.com"
4
5(module stack-combinators
6
7  (;export
8    uni uni2 uni3 uni@
9    bi bi2 bi3 bi@
10    tri tri2 tri3 tri@
11    dip
12    dup dupd
13    swap
14    drop drop/2)
15 
16  (import scheme chicken)
17
18;;
19
20(define uni
21  (case-lambda
22    ((x f c)  (c (f x)))
23    ((f c)    (lambda (x) (uni x f c)))
24    ((c)      (lambda (f) (uni f c)))
25    (()       (lambda (c) (uni c)))))
26
27(define uni2
28  (case-lambda
29    ((x y f c)  (c (f x y)))
30    ((f c)      (lambda (x y) (uni2 x y f c)))
31    ((c)        (lambda (f) (uni2 f c)))
32    (()         (lambda (c) (uni2 c)))))
33
34(define uni3
35  (case-lambda
36    ((x y z f c)  (c (f x y z)))
37    ((f c)        (lambda (x y z) (uni3 x y z f c)))
38    ((c)          (lambda (f) (uni3 f c)))
39    (()           (lambda (c) (uni3 c)))))
40
41(define uni@    ; for completeness only
42  (case-lambda
43    ((x f c)  (c (f x)))
44    ((f c)    (lambda (x) (uni@ x f c)))))
45
46;;
47
48(define bi
49  (case-lambda
50    ((x f g c)  (c (f x) (g x)))
51    ((f g c)    (lambda (x) (bi x f g c)))
52    ((f g)      (lambda (c) (bi f g c)))
53    ((c)        (lambda (f g) (bi f g c)))
54    (()         (lambda (c) (bi c)))))
55
56(define bi2
57  (case-lambda
58    ((x y f g c)  (c (f x y) (g x y)))
59    ((f g c)      (lambda (x y) (bi2 x y f g c)))
60    ((f g)        (lambda (c) (bi2 f g c)))
61    ((c)          (lambda (f g) (bi2 f g c)))
62    (()           (lambda (c) (bi2 c)))))
63
64(define bi3
65  (case-lambda
66    ((x y z f g c)  (c (f x y z) (g x y z)))
67    ((f g c)        (lambda (x y z) (bi3 x y z f g c)))
68    ((f g)          (lambda (c) (bi3 f g c)))
69    ((c)            (lambda (f g) (bi3 f g c)))
70    (()             (lambda (c) (bi3 c)))))
71
72(define bi@
73  (case-lambda
74    ((x y f c)  (c (f x) (f y)))
75    ((f c)      (lambda (x y) (bi@ x y f c)))))
76
77;;
78
79(define tri
80  (case-lambda
81    ((x f g h c)  (c (f x) (g x) (h x)))
82    ((f g h c)    (lambda (x) (tri x f g h c)))
83    ((f g h)      (lambda (c) (tri f g h c)))
84    ((c)          (lambda (f g h) (tri f g h c)))
85    (()           (lambda (c) (tri c)))))
86
87(define tri2
88  (case-lambda
89    ((x y f g h c)  (c (f x y) (g x y) (h x y)))
90    ((f g h c)      (lambda (x y) (tri2 x y f g h c)))
91    ((f g h)        (lambda (c) (tri2 f g h c)))
92    ((c)            (lambda (f g h) (tri2 f g h c)))
93    (()             (lambda (c) (tri2 c)))))
94
95(define tri3
96  (case-lambda
97    ((x y z f g h c)  (c (f x y z) (g x y z) (h x y z)))
98    ((f g h c)        (lambda (x y z) (tri3 x y z f g h c)))
99    ((f g h)          (lambda (c) (tri3 f g h c)))
100    ((c)              (lambda (f g h) (tri3 f g h c)))
101    (()               (lambda (c) (tri3 c)))))
102
103(define tri@
104  (case-lambda
105    ((x y z f g h c)  (c (f x) (g y) (h z)))
106    ((f g h c)        (lambda (x y z) (tri@ x y z f g h c)))))
107
108;;
109
110(define dip
111  (case-lambda
112    ((x y f c)   (c (f x) y))
113    ((f c)       (lambda (x y) (dip x y f c)))))
114
115;;
116
117(define dup
118  (case-lambda
119    ((x c)  (c x x))
120    ((c)    (lambda (x) (dup x c)))))
121
122(define dupd
123  (case-lambda
124    ((x y c)  (c x x y))
125    ((c)      (lambda (x y) (dupd x y c)))))
126
127;;
128
129(define swap
130  (case-lambda
131    ((x y c)  (c y x))
132    ((c)      (lambda (x y) (swap x y c)))))
133
134;;
135
136(define drop
137  (case-lambda
138    ((x c)  (c))
139    ((c)    (lambda (x) (drop x c)))))
140
141(define drop/2
142  (case-lambda
143    ((x y c)  (c x))
144    ((c)      (lambda (x y) (drop/2 x y c)))))
145
146) ;module stack-combinators
Note: See TracBrowser for help on using the repository browser.