1 | ;;;; uni-combinators.scm |
---|
2 | ;;;; Kon Lovett, Jul '10 |
---|
3 | |
---|
4 | (module uni-combinators |
---|
5 | |
---|
6 | (;export |
---|
7 | uni uni2 uni3 uni-each uni-all) |
---|
8 | |
---|
9 | (import |
---|
10 | scheme |
---|
11 | chicken) |
---|
12 | |
---|
13 | #| |
---|
14 | ;;; Hook |
---|
15 | |
---|
16 | ;; Unary |
---|
17 | |
---|
18 | (define uni-left |
---|
19 | (case-lambda |
---|
20 | ((c f) (lambda (x) (c (f x) x))) |
---|
21 | ((c) (lambda (f) (uni-left c f))) |
---|
22 | (() (lambda (c) (uni-left c))))) |
---|
23 | |
---|
24 | (define uni-right |
---|
25 | (case-lambda |
---|
26 | ((c f) (lambda (x) (c x (f x)))) |
---|
27 | ((c) (lambda (f) (uni-right c f))) |
---|
28 | (() (lambda (c) (uni-right c))))) |
---|
29 | |
---|
30 | (define uni2-left |
---|
31 | (case-lambda |
---|
32 | ((c f) (lambda (x y) (c (f x y) x y))) |
---|
33 | ((c) (lambda (f) (uni2-left c f))) |
---|
34 | (() (lambda (c) (uni2-left c))))) |
---|
35 | |
---|
36 | (define uni2-right |
---|
37 | (case-lambda |
---|
38 | ((c f) (lambda (x y) (c x y (f x y)))) |
---|
39 | ((c) (lambda (f) (uni2-right c f))) |
---|
40 | (() (lambda (c) (uni2-right c))))) |
---|
41 | |
---|
42 | (define uni3-left |
---|
43 | (case-lambda |
---|
44 | ((c f) (lambda (x y z) (c (f x y z) x y z))) |
---|
45 | ((c) (lambda (f) (uni3-left c f))) |
---|
46 | (() (lambda (c) (uni3-left c))))) |
---|
47 | |
---|
48 | (define uni3-right |
---|
49 | (case-lambda |
---|
50 | ((c f) (lambda (x y z) (c x y z (f x y z)))) |
---|
51 | ((c) (lambda (f) (uni3-right c f))) |
---|
52 | (() (lambda (c) (uni3-right c))))) |
---|
53 | |
---|
54 | (define (uni-each-left c f) |
---|
55 | (lambda (x) (c (f x) x)) ) |
---|
56 | |
---|
57 | (define (uni-each-right c f) |
---|
58 | (lambda (x) (c x (f x))) ) |
---|
59 | |
---|
60 | (define (uni-all-left c f) |
---|
61 | (lambda xs (apply c (apply f xs) xs)) ) |
---|
62 | |
---|
63 | (define (uni-all-right c f) |
---|
64 | (lambda xs (apply c (append xs (list (apply f xs))))) ) |
---|
65 | |# |
---|
66 | |
---|
67 | ;;; Fork |
---|
68 | |
---|
69 | ;; Unary |
---|
70 | |
---|
71 | (define uni |
---|
72 | (case-lambda |
---|
73 | ((c f) (lambda (x) (c (f x)))) |
---|
74 | ((c) (lambda (f) (uni c f))) |
---|
75 | (() (lambda (c) (uni c))))) |
---|
76 | |
---|
77 | (define uni2 |
---|
78 | (case-lambda |
---|
79 | ((c f) (lambda (x y) (c (f x y)))) |
---|
80 | ((c) (lambda (f) (uni2 c f))) |
---|
81 | (() (lambda (c) (uni2 c))))) |
---|
82 | |
---|
83 | (define uni3 |
---|
84 | (case-lambda |
---|
85 | ((c f) (lambda (x y z) (c (f x y z)))) |
---|
86 | ((c) (lambda (f) (uni3 c f))) |
---|
87 | (() (lambda (c) (uni3 c))))) |
---|
88 | |
---|
89 | (define (uni-each c f) |
---|
90 | (lambda (x) (c (f x))) ) |
---|
91 | |
---|
92 | (define (uni-all c f) |
---|
93 | (lambda xs (c (apply f xs))) ) |
---|
94 | |
---|
95 | ) ;module uni-combinators |
---|