source: project/release/4/combinators/trunk/stack-combinators.scm @ 14103

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

Wrong category.

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(declare
6  (usual-integrations)
7  (generic)
8  (inline)
9  (local)
10  (no-procedure-checks) )
11
12(module stack-combinators (;export
13  uni uni2 uni3 #;uni@
14  bi bi2 bi3 bi@
15  tri tri2 tri3 tri@
16  dip
17  dup dupd
18  swap
19  drop drop/2)
20 
21(import scheme chicken)
22
23;;
24
25(define uni
26  (case-lambda
27    ((x f c)  (c (f x)))
28    ((f c)    (lambda (x) (uni x f c)))
29    ((c)      (lambda (f) (uni f c)))
30    (()       (lambda (c) (uni c)))))
31
32(define uni2
33  (case-lambda
34    ((x y f c)  (c (f x y)))
35    ((f c)      (lambda (x y) (uni2 x y f c)))
36    ((c)        (lambda (f) (uni2 f c)))
37    (()         (lambda (c) (uni2 c)))))
38
39(define uni3
40  (case-lambda
41    ((x y z f c)  (c (f x y z)))
42    ((f c)        (lambda (x y z) (uni3 x y z f c)))
43    ((c)          (lambda (f) (uni3 f c)))
44    (()           (lambda (c) (uni3 c)))))
45
46#; ;UNUSED
47(define uni@
48  (case-lambda
49    ((x f c)  (c (f x)))
50    ((f c)    (lambda (x) (uni@ x f c)))))
51
52;;
53
54(define bi
55  (case-lambda
56    ((x f g c)  (c (f x) (g x)))
57    ((f g c)    (lambda (x) (bi x f g c)))
58    ((f g)      (lambda (c) (bi f g c)))
59    ((c)        (lambda (f g) (bi f g c)))
60    (()         (lambda (c) (bi c)))))
61
62(define bi2
63  (case-lambda
64    ((x y f g c)  (c (f x y) (g x y)))
65    ((f g c)      (lambda (x y) (bi2 x y f g c)))
66    ((f g)        (lambda (c) (bi2 f g c)))
67    ((c)          (lambda (f g) (bi2 f g c)))
68    (()           (lambda (c) (bi2 c)))))
69
70(define bi3
71  (case-lambda
72    ((x y z f g c)  (c (f x y z) (g x y z)))
73    ((f g c)        (lambda (x y z) (bi3 x y z f g c)))
74    ((f g)          (lambda (c) (bi3 f g c)))
75    ((c)            (lambda (f g) (bi3 f g c)))
76    (()             (lambda (c) (bi3 c)))))
77
78(define bi@
79  (case-lambda
80    ((x y f c)  (c (f x) (f y)))
81    ((f c)      (lambda (x y) (bi@ x y f c)))))
82
83;;
84
85(define tri
86  (case-lambda
87    ((x f g h c)  (c (f x) (g x) (h x)))
88    ((f g h c)    (lambda (x) (tri x f g h c)))
89    ((f g h)      (lambda (c) (tri f g h c)))
90    ((c)          (lambda (f g h) (tri f g h c)))
91    (()           (lambda (c) (tri c)))))
92
93(define tri2
94  (case-lambda
95    ((x y f g h c)  (c (f x y) (g x y) (h x y)))
96    ((f g h c)      (lambda (x y) (tri2 x y f g h c)))
97    ((f g h)        (lambda (c) (tri2 f g h c)))
98    ((c)            (lambda (f g h) (tri2 f g h c)))
99    (()             (lambda (c) (tri2 c)))))
100
101(define tri3
102  (case-lambda
103    ((x y z f g h c)  (c (f x y z) (g x y z) (h x y z)))
104    ((f g h c)        (lambda (x y z) (tri3 x y z f g h c)))
105    ((f g h)          (lambda (c) (tri3 f g h c)))
106    ((c)              (lambda (f g h) (tri3 f g h c)))
107    (()               (lambda (c) (tri3 c)))))
108
109(define tri@
110  (case-lambda
111    ((x y z f g h c)  (c (f x) (g y) (h z)))
112    ((f g h c)        (lambda (x y z) (tri@ x y z f g h c)))))
113
114;;
115
116(define dip
117  (case-lambda
118    ((x y f c)   (c (f x) y))
119    ((f c)       (lambda (x y) (dip x y f c)))))
120
121;;
122
123(define dup
124  (case-lambda
125    ((x c)  (c x x))
126    ((c)    (lambda (x) (dup x c)))))
127
128(define dupd
129  (case-lambda
130    ((x y c)  (c x x y))
131    ((c)      (lambda (x y) (dupd x y c)))))
132
133;;
134
135(define swap
136  (case-lambda
137    ((x y c)  (c y x))
138    ((c)      (lambda (x y) (swap x y c)))))
139
140;;
141
142(define drop
143  (case-lambda
144    ((x c)  (c))
145    ((c)    (lambda (x) (drop x c)))))
146
147(define drop/2
148  (case-lambda
149    ((x y c)  (c x))
150    ((c)      (lambda (x y) (drop/2 x y c)))))
151
152) ;module stack-combinators
Note: See TracBrowser for help on using the repository browser.