Changeset 19028 in project for release/4/combinators/trunk/sectioncombinators.scm
 Timestamp:
 07/31/10 03:14:44 (10 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

release/4/combinators/trunk/sectioncombinators.scm
r18946 r19028 8 8 cropleft cropright 9 9 reversed 10 uni uni2 uni3 unieach uniall 11 bi bi2 bi3 bieach biall 12 tri tri2 tri3 trieach triall) 10 argumentschain argumentseach argumentsall) 13 11 14 12 (import 15 13 scheme 16 14 chicken 17 (only datastructures compose)18 (only srfi1 circularlist drop dropright))15 (only srfi1 drop dropright circularlist) 16 (only datastructures identity)) 19 17 20 (requirelibrary datastructuressrfi1)18 (requirelibrary srfi1) 21 19 22 20 (declare … … 26 24 (reversed (procedure ((procedure (#!rest) *)) (procedure (#!rest) *))) 27 25 (cropleft (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) 28 (cropright (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) ) ) 26 (cropright (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) 27 (argumentschain (procedure (#!rest) (procedure (#!rest) *))) 28 (argumentseach (procedure (#!rest) (procedure (#!rest) list))) 29 (argumentsall (procedure (#!rest) (procedure (#!rest) list))) ) ) 29 30 30 31 ;;; Section … … 53 54 (lambda xs (apply fn (reverse xs))) ) 54 55 55 ;;; Fork56 ;;; Argument 56 57 57 ;; Unary 58 (include "argumentshelpers.inc") 58 59 59 (define uni 60 (caselambda 61 ((c f) (lambda (x) (c (f x)))) 62 ((c) (lambda (f) (uni c f))) 63 (() (lambda (c) (uni c))))) 60 ;; argumentschain 64 61 65 (define uni2 66 (caselambda 67 ((c f) (lambda (x y) (c (f x y)))) 68 ((c) (lambda (f) (uni2 c f))) 69 (() (lambda (c) (uni2 c))))) 62 ; ((argumentschain f g) arg...) > (apply f (apply g arg...)) 63 ; ((argumentschain f) arg...) > (apply f arg...) 64 ; ((argumentschain) arg...) > (list arg...) 70 65 71 (define uni3 72 (caselambda 73 ((c f) (lambda (x y z) (c (f x y z)))) 74 ((c) (lambda (f) (uni3 c f))) 75 (() (lambda (c) (uni3 c))))) 66 (define (argumentschain . fns) 67 (let ((fn (chainfunc fns))) 68 (lambda xs (fn xs)) ) ) 76 69 77 (define (unieach c f) 78 (lambda (x) (c (f x))) ) 70 ;; argumentseach 79 71 80 (define (uniall c f)81 (lambda xs (c (apply f xs))))72 ; ((argumentseach f g h) a b c d e) > (list (f a) (g b) (h c) (f d) (g e)) 73 ; ((argumentseach) arg...) > (list arg...) 82 74 83 ;; Binary 75 (define (argumentseach . fns) 76 (let ((fn (eachfunc fns))) 77 (lambda xs (fn xs)) ) ) 84 78 85 (define bi 86 (caselambda 87 ((c f g) (lambda (x) (c (f x) (g x)))) 88 ((f g) (lambda (c) (bi c f g))) 89 ((c) (lambda (f g) (bi c f g))) 90 (() (lambda (c) (bi c))))) 79 ;; argumentsall 91 80 92 (define bi2 93 (caselambda 94 ((c f g) (lambda (x y) (c (f x y) (g x y)))) 95 ((f g) (lambda (c) (bi2 c f g))) 96 ((c) (lambda (f g) (bi2 c f g))) 97 (() (lambda (c) (bi2 c))))) 81 ; ((argumentsall f g h) a b c) > (list (f a b c) (g a b c) (h a b c)) 82 ; ((argumentsall) arg...) > (list arg...) 98 83 99 (define bi3 100 (caselambda 101 ((c f g) (lambda (x y z) (c (f x y z) (g x y z)))) 102 ((f g) (lambda (c) (bi3 c f g))) 103 ((c) (lambda (f g) (bi3 c f g))) 104 (() (lambda (c) (bi3 c))))) 105 106 (define (bieach c f) 107 (lambda (x y) (c (f x) (f y))) ) 108 109 (define (biall c f g) 110 (lambda xs (c (apply f xs) (apply g xs))) ) 111 112 ;; Trinary 113 114 (define tri 115 (caselambda 116 ((c f g h) (lambda (x) (c (f x) (g x) (h x)))) 117 ((f g h) (lambda (c) (tri c f g h))) 118 ((c) (lambda (f g h) (tri c f g h))) 119 (() (lambda (c) (tri c))))) 120 121 (define tri2 122 (caselambda 123 ((c f g h) (lambda (x y) (c (f x y) (g x y) (h x y)))) 124 ((f g h) (lambda (c) (tri2 c f g h))) 125 ((c) (lambda (f g h) (tri2 c f g h))) 126 (() (lambda (c) (tri2 c))))) 127 128 (define tri3 129 (caselambda 130 ((c f g h) (lambda (x y z) (c (f x y z) (g x y z) (h x y z)))) 131 ((f g h) (lambda (c) (tri3 c f g h))) 132 ((c) (lambda (f g h) (tri3 c f g h))) 133 (() (lambda (c) (tri3 c))))) 134 135 (define (trieach c f) 136 (lambda (x y z) (c (f x) (f y) (f z))) ) 137 138 (define (triall c f g h) 139 (lambda xs (c (apply f xs) (apply g xs) (apply h xs))) ) 84 (define (argumentsall . fns) 85 (let ((fn (allfunc fns))) 86 (lambda xs (fn xs)) ) ) 140 87 141 88 ) ;module sectioncombinators
Note: See TracChangeset
for help on using the changeset viewer.