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

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

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