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

Last change on this file since 14018 was 14018, checked in by Kon Lovett, 12 years ago

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