Changeset 18926 in project for release/4/combinators/trunk
 Timestamp:
 07/22/10 05:29:16 (10 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

release/4/combinators/trunk/sectioncombinators.scm
r18924 r18926 9 9 reversed 10 10 identities 11 chainedapply12 applyeach applyall13 combineeach combineall11 argumenteach argumentall 12 lefthook righthook 13 forkeach forkall 14 14 uni uni2 uni3 unieach uniall 15 15 bi bi2 bi3 bieach biall … … 19 19 scheme 20 20 chicken 21 (only srfi1 drop dropright)) 22 23 (requirelibrary srfi1) 21 (only datastructures compose) 22 (only srfi1 circularlist drop dropright)) 23 24 (requirelibrary datastructures srfi1) 24 25 25 26 (declare … … 32 33 (cropright (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) ) ) 33 34 34 ;; 35 36 (define (leftsection proc . args) 37 (lambda xs (##sys#apply proc (##sys#append args xs)))) 38 39 (define (rightsection proc . args) 40 (lambda xs (##sys#apply proc (##sys#append xs args)))) 41 42 (define (cropleft proc n) 43 (lambda xs (##sys#apply proc (drop xs n))) ) 44 45 (define (cropright proc n) 46 (lambda xs (##sys#apply proc (dropright xs n))) ) 47 48 (define (reversed proc) 49 (lambda xs (##sys#apply proc (reverse xs))) ) 35 ;;; Internal Utilities 36 37 (define (vVvs . xs) (if (null? (cdr xs)) (car xs) xs)) 38 39 (define (one/values f x) (callwithvalues (lambda () (f x)) vVvs)) 40 41 (define (n/values f xs) (callwithvalues (lambda () (apply f xs)) vVvs)) 42 43 ;;; Identity 50 44 51 45 (define (identities . xs) xs) 52 46 53 ;; 54 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) 75 (if (null procs) 76 (lambda xs (##sys#list (##sys#map proc xs))) 77 (let ((procs (##sys#append (##sys#list proc) procs))) 78 (lambda xs (map (lambda (f x) (f x)) procs xs)) ) ) ) 79 80 (define (applyall proc . procs) 81 (if (null procs) 82 (lambda xs (##sys#list (##sys#apply proc xs))) 83 (let ((procs (##sys#append (##sys#list proc) procs))) 84 (lambda xs (##sys#map (cut ##sys#apply <> xs) procs)) ) ) ) 85 86 ;; 87 88 (define combineeach 89 (caselambda 90 ((comb proc . procs) 91 (chainedapply comb (##sys#apply applyeach proc procs)) ) 92 ((comb) 93 (lambda procs (##sys#apply combineeach comb procs)) ) 94 (() 95 (lambda (comb) (combineeach comb)) ) ) ) 96 97 (define combineall 98 (caselambda 99 ((comb proc . procs) 100 (chainedapply comb (##sys#apply applyall proc procs)) ) 101 ((comb) 102 (lambda procs (##sys#apply combineall comb procs)) ) 103 (() 104 (lambda (comb) (combineall comb)) ) ) ) 105 106 ;; 47 ;;; Section 48 49 (define (leftsection fn . args) 50 (lambda xs (apply fn (append args xs))) ) 51 52 (define (rightsection fn . args) 53 (lambda xs (apply fn (append xs args))) ) 54 55 ;;; Crop 56 57 ; (compose fn (rightsection drop n) identities) 58 (define (cropleft fn n) 59 (lambda xs (apply fn (drop xs n))) ) 60 61 ; (compose fn (rightsection dropright n) identities) 62 (define (cropright fn n) 63 (lambda xs (apply fn (dropright xs n))) ) 64 65 ;;; Reverse 66 67 ; (compose fn reverse identities) 68 (define (reversed fn) 69 (lambda xs (apply fn (reverse xs))) ) 70 71 ;;; Argument 72 73 ; ((argumenteach f g h) a b c d e) > (list (f a) (g b) (h c) (f d) (g e)) 74 (define (argumenteach . fns) 75 (cond 76 ((null? fns) 77 identities ) 78 ((null? (cdr fns)) 79 (let ((f (car fns))) 80 (lambda xs (list (map (cut one/values f <>) xs))) ) ) 81 (else 82 (let ((fns (apply circularlist fns))) 83 (lambda xs (map (cut one/values <> <>) fns xs)) ) ) ) ) 84 85 ; ((argumentall f g h) a b c) > (list (f a b c) (g a b c) (h a b c)) 86 (define (argumentall . fns) 87 (cond 88 ((null? fns) 89 identities ) 90 ((null? (cdr fns)) 91 (let ((f (car fns))) 92 (lambda xs (list (n/values f xs))) ) ) 93 (else 94 (lambda xs (map (cut n/values <> xs) fns)) ) ) ) 95 96 ;;; Hook 97 98 ; ((lefthook f g h) arg...) > (f (g arg... (h arg...)) arg...) 99 ; ((lefthook f g) arg...) > (f (g arg...) arg...) 100 ; ((lefthook f) arg...) > (f arg...) 101 ; ((lefthook) arg...) > (arg...) 102 (define (lefthook . fns) 103 (define (recur fns) 104 (let ((h (car fns)) 105 (t (cdr fns)) ) 106 (if (null? t) (lambda xs (apply h xs)) 107 (lambda xs (apply h (recur t) xs)) ) ) ) 108 (cond 109 ((null? fns) 110 identities ) 111 ((null? (cdr fns)) 112 (let ((f (car fns))) 113 (lambda xs (apply f xs)) ) ) 114 ((null? (cddr fns)) 115 (let ((f (car fns)) 116 (g (cadr fns)) ) 117 (lambda xs (apply f (apply g xs))) ) ) 118 (else 119 (recur fns) ) ) ) 120 121 ; ((righthook f g h) arg...) > (f arg... (g arg... (h arg...))) 122 ; ((righthook f g) arg...) > (f arg... (g arg...)) 123 ; ((righthook f) arg...) > (f arg...) 124 ; ((righthook) arg...) > (arg...) 125 (define (righthook . fns) 126 (define (recur fns) 127 (let ((h (car fns)) 128 (t (cdr fns)) ) 129 (if (null? t) (lambda xs (apply h xs)) 130 (lambda xs (apply h (append xs (list (recur t))))) ) ) ) 131 (cond 132 ((null? fns) 133 identities ) 134 ((null? (cdr fns)) 135 (let ((f (car fns))) 136 (lambda xs (apply f xs)) ) ) 137 ((null? (cddr fns)) 138 (let ((f (car fns)) 139 (g (cadr fns)) ) 140 (lambda xs (apply f (append xs (list (apply g xs))))) ) ) 141 (else 142 (recur fns) ) ) ) 143 144 ;;; Fork 145 146 ;; Nnary 147 148 ; (forkeach c f g h) > (compose c (argumenteach f g h)) 149 ; (forkeach c) > (lambda (func...) (compose c (argumenteach func...))) 150 ; (forkeach) > (lambda (c) (lambda (func...) (compose c (argumenteach func...)))) 151 (define (forkeach . fns) 152 (cond 153 ((null? fns) 154 (lambda (c) (forkeach c)) ) 155 ((null? (cdr fns)) 156 (let ((c (car fns))) 157 (lambda fns (apply forkeach c fns)) ) ) 158 (else 159 (let ((c (car fns)) 160 (fns (cdr fns)) ) 161 (compose c (apply argumenteach fns)) ) ) ) ) 162 163 ; (forkall c f g h) > (compose c (argumentall f g h)) 164 ; (forkall c) > (lambda (func...) (compose c (argumentall func...))) 165 ; (forkall) > (lambda (c) (lambda (func...) (compose c (argumentall func...)))) 166 (define (forkall . fns) 167 (cond 168 ((null? fns) 169 (lambda (c) (forkall c)) ) 170 ((null? (cdr fns)) 171 (let ((c (car fns))) 172 (lambda fns (apply forkall c fns)) ) ) 173 (else 174 (let ((c (car fns)) 175 (fns (cdr fns)) ) 176 (compose c (apply argumentall fns)) ) ) ) ) 177 178 ;; Unary 107 179 108 180 (define uni … … 128 200 129 201 (define (uniall c f) 130 (lambda xs (c ( ##sys#apply f xs))) )131 132 ;; 202 (lambda xs (c (apply f xs))) ) 203 204 ;; Binary 133 205 134 206 (define bi … … 157 229 158 230 (define (biall c f g) 159 (lambda xs (c ( ##sys#apply f xs) (##sys#apply g xs))) )160 161 ;; 231 (lambda xs (c (apply f xs) (apply g xs))) ) 232 233 ;; Trinary 162 234 163 235 (define tri … … 186 258 187 259 (define (triall c f g h) 188 (lambda xs (c ( ##sys#apply f xs) (##sys#apply g xs) (##sys#apply h xs))) )260 (lambda xs (c (apply f xs) (apply g xs) (apply h xs))) ) 189 261 190 262 ) ;module sectioncombinators
Note: See TracChangeset
for help on using the changeset viewer.