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

Last change on this file since 14021 was 14021, checked in by Kon Lovett, 11 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#; ;UNUSED
46(define uni@
47  (case-lambda
48    ((x f c)  (c (f x)))
49    ((f c)    (lambda (x) (uni@ x f c)))))
50
51;;
52
53(define bi
54  (case-lambda
55    ((x f g c)  (c (f x) (g x)))
56    ((f g c)    (lambda (x) (bi x f g c)))
57    ((f g)      (lambda (c) (bi f g c)))
58    ((c)        (lambda (f g) (bi f g c)))
59    (()         (lambda (c) (bi c)))))
60
61(define bi2
62  (case-lambda
63    ((x y f g c)  (c (f x y) (g x y)))
64    ((f g c)      (lambda (x y) (bi2 x y f g c)))
65    ((f g)        (lambda (c) (bi2 f g c)))
66    ((c)          (lambda (f g) (bi2 f g c)))
67    (()           (lambda (c) (bi2 c)))))
68
69(define bi3
70  (case-lambda
71    ((x y z f g c)  (c (f x y z) (g x y z)))
72    ((f g c)        (lambda (x y z) (bi3 x y z f g c)))
73    ((f g)          (lambda (c) (bi3 f g c)))
74    ((c)            (lambda (f g) (bi3 f g c)))
75    (()             (lambda (c) (bi3 c)))))
76
77(define bi@
78  (case-lambda
79    ((x y f c)  (c (f x) (f y)))
80    ((f c)      (lambda (x y) (bi@ x y f c)))))
81
82;;
83
84(define tri
85  (case-lambda
86    ((x f g h c)  (c (f x) (g x) (h x)))
87    ((f g h c)    (lambda (x) (tri x f g h c)))
88    ((f g h)      (lambda (c) (tri f g h c)))
89    ((c)          (lambda (f g h) (tri f g h c)))
90    (()           (lambda (c) (tri c)))))
91
92(define tri2
93  (case-lambda
94    ((x y f g h c)  (c (f x y) (g x y) (h x y)))
95    ((f g h c)      (lambda (x y) (tri2 x y f g h c)))
96    ((f g h)        (lambda (c) (tri2 f g h c)))
97    ((c)            (lambda (f g h) (tri2 f g h c)))
98    (()             (lambda (c) (tri2 c)))))
99
100(define tri3
101  (case-lambda
102    ((x y z f g h c)  (c (f x y z) (g x y z) (h x y z)))
103    ((f g h c)        (lambda (x y z) (tri3 x y z f g h c)))
104    ((f g h)          (lambda (c) (tri3 f g h c)))
105    ((c)              (lambda (f g h) (tri3 f g h c)))
106    (()               (lambda (c) (tri3 c)))))
107
108(define tri@
109  (case-lambda
110    ((x y z f g h c)  (c (f x) (g y) (h z)))
111    ((f g h c)        (lambda (x y z) (tri@ x y z f g h c)))))
112
113;;
114
115(define dip
116  (case-lambda
117    ((x y f c)   (c (f x) y))
118    ((f c)       (lambda (x y) (dip x y f c)))))
119
120;;
121
122(define dup
123  (case-lambda
124    ((x c)  (c x x))
125    ((c)    (lambda (x) (dup x c)))))
126
127(define dupd
128  (case-lambda
129    ((x y c)  (c x x y))
130    ((c)      (lambda (x y) (dupd x y c)))))
131
132;;
133
134(define swap
135  (case-lambda
136    ((x y c)  (c y x))
137    ((c)      (lambda (x y) (swap x y c)))))
138
139;;
140
141(define drop
142  (case-lambda
143    ((x c)  (c))
144    ((c)    (lambda (x) (drop x c)))))
145
146(define drop/2
147  (case-lambda
148    ((x y c)  (c x))
149    ((c)      (lambda (x y) (drop/2 x y c)))))
150
151) ;module stack-combinators
Note: See TracBrowser for help on using the repository browser.