source: project/release/4/combinators/trunk/generic-section-combinators.scm @ 18946

Last change on this file since 18946 was 18946, checked in by Kon Lovett, 10 years ago

nnary section combs in own mod

File size: 4.8 KB
Line 
1;;;; generic-section-combinators.scm
2;;;; Kon Lovett, Jul '10
3
4(module generic-section-combinators
5
6  (;export
7    o-with-apply
8    left-hook right-hook
9    argument-each argument-all
10    fork-each fork-all)
11
12  (import
13    (except scheme map)
14    chicken
15    (only data-structures identity)
16    (only srfi-1 circular-list map))
17
18  (require-library data-structures srfi-1)
19
20  (declare
21    (type
22      (o-with-apply (procedure (#!rest) (procedure (#!rest) *)))
23      (left-hook (procedure (#!rest) (procedure (#!rest) *)))
24      (right-hook (procedure (#!rest) (procedure (#!rest) *)))
25      (argument-each (procedure (#!rest) (procedure (#!rest) list)))
26      (argument-all (procedure (#!rest) (procedure (#!rest) list)))
27      (fork-each+ (procedure (#!rest) (procedure (#!rest) *)))
28      (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) ))
29
30;;; Hook
31
32;;l Helpers
33
34(define-inline (hook-recur fns xs)
35  ; assume the length of fns is << so recursion depth is also <<
36  (let recur ((fns fns))
37    (if (null? fns) xs
38      (apply (car fns) (recur (cdr fns))) ) ) )
39
40(define-inline (hook-recur+ g fns xs)
41  (apply g (hook-recur fns xs)) )
42
43;; o-with-apply
44
45; ((o-with-apply f g) arg...) -> (apply f (apply g arg...))
46; ((o-with-apply f) arg...) -> (apply f arg...)
47; ((o-with-apply) arg...) -> (list arg...)
48
49(define (o-with-apply . fns)
50  ; 0
51  (if (null? fns) list
52    (let ((f (car fns))
53          (fns (cdr fns)) )
54      ; 1
55      (if (null? fns) (lambda xs (apply f xs))
56        ; > 1
57        (lambda xs (hook-recur+ f fns xs)) ) ) ) )
58
59;; left-hook
60
61; ((left-hook c f g) arg...) -> (apply c (apply f (apply g arg...)) arg...)
62; ((left-hook c f) arg...) -> (apply c (apply f arg...) arg...)
63; ((left-hook c) arg...) -> (apply c arg...)
64; ((left-hook) arg...) -> (list arg...)
65
66(define (left-hook . fns)
67  ; 0
68  (if (null? fns) list
69    (let ((c (car fns))
70          (fns (cdr fns)) )
71      ; 1
72      (if (null? fns) (lambda xs (apply c xs))
73        ; > 1
74        (lambda xs (apply c (hook-recur+ (car fns) (cdr fns) xs) xs)) ) ) ) )
75
76;; right-hook
77
78; ((right-hook c f g) arg...) -> (apply c arg... (apply f (apply g arg...)))
79; ((right-hook c f) arg...) -> (apply c arg... (apply f arg...))
80; ((right-hook c) arg...) -> (apply c arg...)
81; ((right-hook) arg...) -> (list arg...)
82
83(define (right-hook . fns)
84  ; 0
85  (if (null? fns) list
86    (let ((c (car fns))
87          (fns (cdr fns)) )
88      ; 1
89      (if (null? fns) (lambda xs (apply c xs))
90        ; > 1
91        (lambda xs (apply c (append xs (list (hook-recur+ (car fns) (cdr fns) xs))))) ) ) ) )
92
93;;; Argument
94
95;; Helpers
96
97(define-inline (argument-each-func fns)
98  (cond
99    ((null? fns)
100      identity )
101    ((null? (cdr fns))
102      (lambda (xs) (map (cute (car fns) <>) xs)) )
103    (else
104      (let ((fns (apply circular-list fns)))
105        (lambda (xs) (map (cut <> <>) fns xs)) ) ) ) )
106
107(define-inline (argument-all-funcs fns)
108  (cond
109    ((null? fns)
110      identity )
111    ((null? (cdr fns))
112      (lambda (xs) (list (apply (car fns) xs))) )
113    (else
114      (lambda (xs) (map (cut apply <> xs) fns)) ) ) )
115
116;; argument-each
117
118; ((argument-each f g h) a b c d e) -> (list (f a) (g b) (h c) (f d) (g e))
119; ((argument-each) arg...) -> (list arg...)
120
121(define (argument-each . fns)
122  (let ((fn (argument-each-func fns)))
123    (lambda xs (fn xs)) ) )
124
125;; argument-all
126
127; ((argument-all f g h) a b c) -> (list (f a b c) (g a b c) (h a b c))
128; ((argument-all) arg...) -> (list arg...)
129
130(define (argument-all . fns)
131  (let ((fn (argument-all-func fns)))
132    (lambda xs (fn xs)) ) )
133
134;;; Fork
135
136;; fork-each
137
138; (fork-each c func...) -> (lambda xs (apply c (apply (apply argument-each func...) xs)))
139
140(define (fork-each c . fns)
141  (let ((fn (argument-each-func fns)))
142    (lambda xs (apply c (fn xs))) ) )
143
144;; fork-all
145
146; (fork-all c func...) -> (lambda xs (apply c (apply (apply argument-all func...) xs)))
147
148(define (fork-all c . fns)
149  (let ((fn (argument-all-func fns)))
150    (lambda xs (apply c (fn xs))) ) )
151
152;; fork-each+ a fork-each that curries it's functions
153
154; (fork-each+ c func...) -> (lambda xs (apply c (apply (apply argument-each func...) xs)))
155; (fork-each+ c) -> (lambda funcs (apply fork-each c funcs))
156; (fork-each+) -> (lambda (c) (fork-each c))
157
158(define (fork-each+ . fns)
159  (if (null? fns) (lambda (c) (fork-each+ c))
160    (let ((c (car fns)) (fns (cdr fns)))
161      (if (null? fns) (lambda fns (apply fork-each+ c fns))
162        (apply fork-each c fns) ) ) ) )
163
164;; fork-all+ a fork-all that curries it's functions
165
166; (fork-all+ c func...) -> (lambda xs (apply c (apply (apply argument-all func...) xs)))
167; (fork-all+ c) -> (lambda funcs (apply fork-all c funcs))
168; (fork-all+) -> (lambda (c) (fork-all c))
169
170(define (fork-all+ . fns)
171  (if (null? fns) (lambda (c) (fork-all+ c))
172    (let ((c (car fns)) (fns (cdr fns)))
173      (if (null? fns) (lambda fns (apply fork-all+ c fns))
174        (apply fork-all c fns) ) ) ) )
175
176) ;module generic-section-combinators
Note: See TracBrowser for help on using the repository browser.