Changeset 18924 in project
 Timestamp:
 07/22/10 01:00:42 (11 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

release/4/combinators/trunk/sectioncombinators.scm
r18923 r18924 5 5 6 6 (;export 7 leftsection 8 rightsection 9 cropleft 10 cropright 7 leftsection rightsection 8 cropleft cropright 11 9 reversed 12 10 identities 13 apply@ 14 apply* 15 combine@ 16 combine* 17 ) 11 chainedapply 12 applyeach applyall 13 combineeach combineall 14 uni uni2 uni3 unieach uniall 15 bi bi2 bi3 bieach biall 16 tri tri2 tri3 trieach triall) 18 17 19 18 (import 20 19 scheme 21 20 chicken 22 srfi1)21 (only srfi1 drop dropright)) 23 22 24 23 (requirelibrary srfi1) … … 33 32 (cropright (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) ) ) 34 33 35 ;; ;34 ;; 36 35 37 36 (define (leftsection proc . args) … … 48 47 49 48 (define (reversed proc) 50 (lambda xs (##sys#apply proc (reverse xs))) )49 (lambda xs (##sys#apply proc (reverse xs))) ) 51 50 52 51 (define (identities . xs) xs) … … 54 53 ;; 55 54 56 (define (apply@ proc . procs) 55 (define chainedapply 56 (caselambda 57 ((proc1 proc2 proc3 . procs) 58 (let ((procs (reverse (##sys#append (list proc1 proc2 proc3) procs)))) 59 (lambda xs 60 (let loop ((res xs) (procs procs)) 61 (if (null? procs) res 62 (loop (##sys#apply (car procs) res) (cdr procs)) ) ) ) ) ) 63 ((proc1 proc2 proc3) 64 (lambda xs (##sys#apply proc1 (##sys#apply proc2 (##sys#apply proc3 xs)))) ) 65 ((proc1 proc2) 66 (lambda xs (##sys#apply proc1 (##sys#apply proc2 xs))) ) 67 ((proc1) 68 (lambda xs (##sys#apply proc1 xs)) ) 69 (() 70 identities ) ) ) 71 72 ;; 73 74 (define (applyeach proc . procs) 57 75 (if (null procs) 58 76 (lambda xs (##sys#list (##sys#map proc xs))) 59 77 (let ((procs (##sys#append (##sys#list proc) procs))) 60 (lambda xs ( ##sys#map (lambda (f x) (f x)) procs xs)) ) ) )78 (lambda xs (map (lambda (f x) (f x)) procs xs)) ) ) ) 61 79 62 (define (apply *proc . procs)80 (define (applyall proc . procs) 63 81 (if (null procs) 64 82 (lambda xs (##sys#list (##sys#apply proc xs))) … … 68 86 ;; 69 87 70 (define combine @88 (define combineeach 71 89 (caselambda 72 90 ((comb proc . procs) 73 (let ((reducer (##sys#apply apply@ proc procs))) 74 (lambda xs (##sys#apply comb (##sys#apply reducer xs)))) ) 91 (chainedapply comb (##sys#apply applyeach proc procs)) ) 75 92 ((comb) 76 (lambda procs (##sys#apply combine @comb procs)) )93 (lambda procs (##sys#apply combineeach comb procs)) ) 77 94 (() 78 (lambda (comb) (combine @comb)) ) ) )95 (lambda (comb) (combineeach comb)) ) ) ) 79 96 80 (define combine *97 (define combineall 81 98 (caselambda 82 99 ((comb proc . procs) 83 (let ((reducer (##sys#apply apply* procs))) 84 (lambda xs (##sys#apply proc (##sys#apply reducer xs)))) ) 100 (chainedapply comb (##sys#apply applyall proc procs)) ) 85 101 ((comb) 86 (lambda procs (##sys#apply combine *comb procs)) )102 (lambda procs (##sys#apply combineall comb procs)) ) 87 103 (() 88 (lambda (comb) (combine *comb)) ) ) )104 (lambda (comb) (combineall comb)) ) ) ) 89 105 90 106 ;; … … 108 124 (() (lambda (c) (uni3 c))))) 109 125 110 (define uni@ ; for completeness only 111 (caselambda 112 ((c f) (lambda (x) (c (f x)))))) 126 (define (unieach c f) 127 (lambda (x) (c (f x))) ) 113 128 114 (define uni* 115 (caselambda 116 ((c f) (lambda xs (c (##sys#apply f xs)))))) 129 (define (uniall c f) 130 (lambda xs (c (##sys#apply f xs))) ) 117 131 118 132 ;; … … 139 153 (() (lambda (c) (bi3 c))))) 140 154 141 (define bi@ 142 (caselambda 143 ((c f) (lambda (x y) (c (f x) (f y)))))) 155 (define (bieach c f) 156 (lambda (x y) (c (f x) (f y))) ) 144 157 145 (define bi* 146 (caselambda 147 ((c f g) (lambda xs (c (##sys#apply f xs) (##sys#apply g xs)))))) 158 (define (biall c f g) 159 (lambda xs (c (##sys#apply f xs) (##sys#apply g xs))) ) 148 160 149 161 ;; … … 170 182 (() (lambda (c) (tri3 c))))) 171 183 172 (define tri@ 173 (caselambda 174 ((c f) (lambda (x y z) (c (f x) (f y) (f z)))))) 184 (define (trieach c f) 185 (lambda (x y z) (c (f x) (f y) (f z))) ) 175 186 176 (define tri* 177 (caselambda 178 ((c f g h) (lambda xs (c (##sys#apply f xs) (##sys#apply g xs) (##sys#apply h xs)))))) 187 (define (triall c f g h) 188 (lambda xs (c (##sys#apply f xs) (##sys#apply g xs) (##sys#apply h xs))) ) 179 189 180 190 ) ;module sectioncombinators
Note: See TracChangeset
for help on using the changeset viewer.