Changeset 19028 in project
- Timestamp:
- 07/31/10 03:14:44 (11 years ago)
- Location:
- release/4/combinators/trunk
- Files:
-
- 4 added
- 6 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/combinators/trunk/combinators.meta
r18946 r19028 10 10 (files 11 11 "tests" 12 "arguments-helpers.inc" 12 13 "section-combinators.scm" 13 "generic-section-combinators.scm" 14 "uni-combinators.scm" 15 "bi-combinators.scm" 16 "tri-combinators.scm" 17 ;"generic-section-combinators.scm" 14 18 "logical-combinators.scm" 15 19 "sort-combinators.scm" -
release/4/combinators/trunk/combinators.setup
r18946 r19028 5 5 (verify-extension-name "combinators") 6 6 7 (setup-shared-extension-module 'uni-combinators (extension-version "1.1.0") 8 #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift)) 9 10 (setup-shared-extension-module 'bi-combinators (extension-version "1.1.0") 11 #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift)) 12 13 (setup-shared-extension-module 'tri-combinators (extension-version "1.1.0") 14 #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift)) 15 7 16 (setup-shared-extension-module 'section-combinators (extension-version "1.1.0") 8 17 #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift)) 18 19 #; 9 20 (setup-shared-extension-module 'generic-section-combinators (extension-version "1.1.0") 10 21 #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift)) 22 11 23 (setup-shared-extension-module 'logical-combinators (extension-version "1.1.0") 12 24 #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift)) 25 13 26 (setup-shared-extension-module 'sort-combinators (extension-version "1.1.0") 14 27 #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift)) 28 15 29 (setup-shared-extension-module 'stack-combinators (extension-version "1.1.0") 16 30 #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift)) -
release/4/combinators/trunk/generic-section-combinators.scm
r18947 r19028 1 1 ;;;; generic-section-combinators.scm 2 2 ;;;; Kon Lovett, Jul '10 3 4 !IN PROGRESS! 3 5 4 6 (module generic-section-combinators 5 7 6 8 (;export 7 o-with-apply8 left-hook right-hook9 left-hook + right-hook+10 argument-each argument-all9 left-hook-each right-hook-each 10 left-hook-each+ right-hook-each+ 11 left-hook-argument-chain right-hook-argument-chain 12 left-hook-argument-chain+ right-hook-argument-chain+ 11 13 fork-each fork-all 12 14 fork-each+ fork-all+) … … 22 24 (declare 23 25 (type 24 (o-with-apply (procedure (#!rest) (procedure (#!rest) *))) 25 (left-hook (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 26 (right-hook (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 27 (left-hook+ (procedure (#!rest) (procedure (#!rest) *))) 28 (right-hook+ (procedure (#!rest) (procedure (#!rest) *))) 29 (argument-each (procedure (#!rest) (procedure (#!rest) list))) 30 (argument-all (procedure (#!rest) (procedure (#!rest) list))) 26 (left-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 27 (right-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 28 (left-hook-each+ (procedure (#!rest) (procedure (#!rest) *))) 29 (right-hook-each+ (procedure (#!rest) (procedure (#!rest) *))) 30 (left-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 31 (right-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 32 (left-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *))) 33 (right-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *))) 31 34 (fork-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 32 35 (fork-all (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) … … 34 37 (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) )) 35 38 39 (include "arguments-helpers.inc") 40 36 41 ;;; Hook 37 42 38 ;;l Helpers 43 (define (left-arguments-X . fns) 44 (lambda xs ((X-funcs (cons fns list)) xs)) ) 39 45 40 (define-inline (hook-recur fns xs) 41 ; assume the length of fns is << so recursion depth is also << 42 (let recur ((fns fns)) 43 (if (null? fns) xs 44 (apply (car fns) (recur (cdr fns))) ) ) ) 46 (define (right-arguments-X . fns) 47 (lambda xs ((X-funcs (cons list fns)) xs)) ) 45 48 46 (define-inline (hook-recur+ g fns xs) 47 (apply g (hook-recur fns xs)) ) 49 ????? 50 (left-hook-X c fn0 ... fnn) = (arguments-chain c (arguments-X fn0 ... fnn list)) 51 (right-hook-X c fn0 ... fnn) = (arguments-chain c (arguments-X list fn0 ... fnn)) 48 52 49 ;; o-with-apply53 ;; left-hook-each 50 54 51 ; (( o-with-apply f g) arg...) -> (apply f (apply g arg...))52 ; (( o-with-apply f) arg...) -> (apply farg...)53 ; (( o-with-apply) arg...) -> (listarg...)55 ; ((left-hook-each c f g) arg...) -> (apply c (f arg0) (g arg1) ... argn...) 56 ; ((left-hook-each c f) arg...) -> (apply c (f arg0) ... (f argn) arg...) 57 ; ((left-hook-each c) arg...) -> (apply c arg...) 54 58 55 (define (o-with-apply . fns) 56 ; 0 57 (if (null? fns) list 58 (let ((f (car fns)) 59 (fns (cdr fns)) ) 60 ; 1 61 (if (null? fns) (lambda xs (apply f xs)) 62 ; > 1 63 (lambda xs (hook-recur+ f fns xs)) ) ) ) ) 59 (define (left-hook-each c . fns) 60 (if (null? fns) (lambda xs (apply c xs)) 61 (let ((fn (each-func fns))) 62 (lambda xs (apply c (append (list (fn xs)) xs))) ) ) ) 64 63 65 ;; left-hook64 ;; right-hook-each 66 65 67 ; (( left-hook c f g) arg...) -> (apply c (apply f (apply g arg...)) arg...)68 ; (( left-hook c f) arg...) -> (apply c (apply f arg...) arg...)69 ; (( left-hookc) arg...) -> (apply c arg...)66 ; ((right-hook-each c f g) arg...) -> (apply c argn... (f arg0) (g arg1) ...) 67 ; ((right-hook-each c f) arg...) -> (apply c arg... (f arg0) ... (f argn)) 68 ; ((right-hook-each c) arg...) -> (apply c arg...) 70 69 71 (define (left-hook c . fns) 70 (define (right-hook-each c . fns) 71 (if (null? fns) (lambda xs (apply c xs)) 72 (let ((fn (each-func fns))) 73 (lambda xs (apply c (append xs (list (fn xs))))) ) ) ) 74 75 ;; left-hook-each+ a left-hook-each that curries it's functions 76 77 ; (left-hook-each+ c func...) -> (apply left-hook-each c func...) 78 ; (left-hook-each+ c) -> (lambda (func...) (apply left-hook-each+ c func...)) 79 ; (left-hook-each+) -> (lambda (c) (left-hook-each+ c)) 80 81 (define (left-hook-each+ . fns) 82 (if (null? fns) (lambda (c) (left-hook-each+ c)) 83 (let ((c (car fns)) (fns (cdr fns))) 84 (if (null? fns) (lambda fns (apply left-hook-each+ c fns)) 85 (apply left-hook-each c fns) ) ) ) ) 86 87 ;; right-hook-each+ a left-hook-each that curries it's functions 88 89 ; (right-hook-each+ c func...) -> (apply right-hook-each c func...) 90 ; (right-hook-each+ c) -> (lambda (func...) (apply right-hook-each+ c func...)) 91 ; (right-hook-each+) -> (lambda (c) (right-hook-each+ c)) 92 93 (define (right-hook-each+ . fns) 94 (if (null? fns) (lambda (c) (right-hook-each+ c)) 95 (let ((c (car fns)) (fns (cdr fns))) 96 (if (null? fns) (lambda fns (apply right-hook-each+ c fns)) 97 (apply right-hook-each c fns) ) ) ) ) 98 99 ;; left-hook-argument-chain 100 101 ; ((left-hook-argument-chain c f g) arg...) -> (apply c (apply f (apply g arg...)) arg...) 102 ; ((left-hook-argument-chain c f) arg...) -> (apply c (apply f arg...) arg...) 103 ; ((left-hook-argument-chain c) arg...) -> (apply c arg...) 104 105 (define (left-hook-argument-chain c . fns) 72 106 (let ((c (car fns)) 73 107 (fns (cdr fns)) ) 74 108 (if (null? fns) (lambda xs (apply c xs)) 75 (lambda xs (apply c ( hook-recur+ (car fns) (cdr fns)xs) xs)) ) ) )109 (lambda xs (apply c (chain-recur fns xs) xs)) ) ) ) 76 110 77 ;; right-hook 111 ;; right-hook-argument-chain 78 112 79 ; ((right-hook c f g) arg...) -> (apply c arg... (apply f (apply g arg...)))80 ; ((right-hook c f) arg...) -> (apply c arg... (apply f arg...))81 ; ((right-hook c) arg...) -> (apply c arg...)113 ; ((right-hook-argument-chain c f g) arg...) -> (apply c arg... (apply f (apply g arg...))) 114 ; ((right-hook-argument-chain c f) arg...) -> (apply c arg... (apply f arg...)) 115 ; ((right-hook-argument-chain c) arg...) -> (apply c arg...) 82 116 83 (define (right-hook c . fns)117 (define (right-hook-argument-chain c . fns) 84 118 (let ((c (car fns)) 85 119 (fns (cdr fns)) ) 86 120 (if (null? fns) (lambda xs (apply c xs)) 87 (lambda xs (apply c (append xs (list ( hook-recur+ (car fns) (cdr fns)xs))))) ) ) )121 (lambda xs (apply c (append xs (list (chain-recur fns xs))))) ) ) ) 88 122 89 ;; left-hook +123 ;; left-hook-argument-chain+ a left-hook-argument-chain that curries it's functions 90 124 91 ; (left-hook + c func...) -> (apply left-hookc func...)92 ; (left-hook + c) -> (lambda (func...) (apply left-hook+ c func...))93 ; left-hook+) -> (lambda (c) (left-hook+ c))125 ; (left-hook-argument-chain+ c func...) -> (apply left-hook-argument-chain c func...) 126 ; (left-hook-argument-chain+ c) -> (lambda (func...) (apply left-hook-argument-chain+ c func...)) 127 ; (left-hook-argument-chain+) -> (lambda (c) (left-hook-argument-chain+ c)) 94 128 95 (define (left-hook + . fns)96 (if (null? fns) (lambda (c) (left-hook + c))129 (define (left-hook-argument-chain+ . fns) 130 (if (null? fns) (lambda (c) (left-hook-argument-chain+ c)) 97 131 (let ((c (car fns)) (fns (cdr fns))) 98 (if (null? fns) (lambda fns (apply left-hook + c fns))99 (apply left-hook c fns) ) ) ) )132 (if (null? fns) (lambda fns (apply left-hook-argument-chain+ c fns)) 133 (apply left-hook-argument-chain c fns) ) ) ) ) 100 134 101 ;; right-hook +135 ;; right-hook-argument-chain+ a right-hook-argument-chain that curries it's functions 102 136 103 ; (right-hook + c func...) -> (apply right-hookc func...)104 ; (right-hook + c) -> (lambda (func...) (apply right-hook+ c func...))105 ; right-hook+) -> (lambda (c) (right-hook+ c))137 ; (right-hook-argument-chain+ c func...) -> (apply right-hook-argument-chain c func...) 138 ; (right-hook-argument-chain+ c) -> (lambda (func...) (apply right-hook-argument-chain+ c func...)) 139 ; (right-hook-argument-chain+) -> (lambda (c) (right-hook-argument-chain+ c)) 106 140 107 (define (right-hook + . fns)108 (if (null? fns) (lambda (c) (right-hook + c))141 (define (right-hook-argument-chain+ . fns) 142 (if (null? fns) (lambda (c) (right-hook-argument-chain+ c)) 109 143 (let ((c (car fns)) (fns (cdr fns))) 110 (if (null? fns) (lambda fns (apply right-hook+ c fns)) 111 (apply right-hook c fns) ) ) ) ) 112 113 ;;; Argument 114 115 ;; Helpers 116 117 (define-inline (argument-each-func fns) 118 (cond 119 ((null? fns) 120 identity ) 121 ((null? (cdr fns)) 122 (lambda (xs) (map (cute (car fns) <>) xs)) ) 123 (else 124 (let ((fns (apply circular-list fns))) 125 (lambda (xs) (map (cut <> <>) fns xs)) ) ) ) ) 126 127 (define-inline (argument-all-funcs fns) 128 (cond 129 ((null? fns) 130 identity ) 131 ((null? (cdr fns)) 132 (lambda (xs) (list (apply (car fns) xs))) ) 133 (else 134 (lambda (xs) (map (cut apply <> xs) fns)) ) ) ) 135 136 ;; argument-each 137 138 ; ((argument-each f g h) a b c d e) -> (list (f a) (g b) (h c) (f d) (g e)) 139 ; ((argument-each) arg...) -> (list arg...) 140 141 (define (argument-each . fns) 142 (let ((fn (argument-each-func fns))) 143 (lambda xs (fn xs)) ) ) 144 145 ;; argument-all 146 147 ; ((argument-all f g h) a b c) -> (list (f a b c) (g a b c) (h a b c)) 148 ; ((argument-all) arg...) -> (list arg...) 149 150 (define (argument-all . fns) 151 (let ((fn (argument-all-func fns))) 152 (lambda xs (fn xs)) ) ) 144 (if (null? fns) (lambda fns (apply right-hook-argument-chain+ c fns)) 145 (apply right-hook-argument-chain c fns) ) ) ) ) 153 146 154 147 ;;; Fork … … 156 149 ;; fork-each 157 150 158 ; (fork-each c func...) -> (lambda xs (apply c (apply (apply argument -each func...) xs)))151 ; (fork-each c func...) -> (lambda xs (apply c (apply (apply arguments-each func...) xs))) 159 152 160 153 (define (fork-each c . fns) 161 (let ((fn ( argument-each-func fns)))154 (let ((fn (each-func fns))) 162 155 (lambda xs (apply c (fn xs))) ) ) 163 156 164 157 ;; fork-all 165 158 166 ; (fork-all c func...) -> (lambda xs (apply c (apply (apply argument -all func...) xs)))159 ; (fork-all c func...) -> (lambda xs (apply c (apply (apply arguments-all func...) xs))) 167 160 168 161 (define (fork-all c . fns) 169 (let ((fn (a rgument-all-func fns)))162 (let ((fn (all-func fns))) 170 163 (lambda xs (apply c (fn xs))) ) ) 171 164 -
release/4/combinators/trunk/section-combinators.scm
r18946 r19028 8 8 crop-left crop-right 9 9 reversed 10 uni uni2 uni3 uni-each uni-all 11 bi bi2 bi3 bi-each bi-all 12 tri tri2 tri3 tri-each tri-all) 10 arguments-chain arguments-each arguments-all) 13 11 14 12 (import 15 13 scheme 16 14 chicken 17 (only data-structures compose)18 (only srfi-1 circular-list drop drop-right))15 (only srfi-1 drop drop-right circular-list) 16 (only data-structures identity)) 19 17 20 (require-library data-structuressrfi-1)18 (require-library srfi-1) 21 19 22 20 (declare … … 26 24 (reversed (procedure ((procedure (#!rest) *)) (procedure (#!rest) *))) 27 25 (crop-left (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) 28 (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) ) ) 26 (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) 27 (arguments-chain (procedure (#!rest) (procedure (#!rest) *))) 28 (arguments-each (procedure (#!rest) (procedure (#!rest) list))) 29 (arguments-all (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 "arguments-helpers.inc") 58 59 59 (define uni 60 (case-lambda 61 ((c f) (lambda (x) (c (f x)))) 62 ((c) (lambda (f) (uni c f))) 63 (() (lambda (c) (uni c))))) 60 ;; arguments-chain 64 61 65 (define uni2 66 (case-lambda 67 ((c f) (lambda (x y) (c (f x y)))) 68 ((c) (lambda (f) (uni2 c f))) 69 (() (lambda (c) (uni2 c))))) 62 ; ((arguments-chain f g) arg...) -> (apply f (apply g arg...)) 63 ; ((arguments-chain f) arg...) -> (apply f arg...) 64 ; ((arguments-chain) arg...) -> (list arg...) 70 65 71 (define uni3 72 (case-lambda 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 (arguments-chain . fns) 67 (let ((fn (chain-func fns))) 68 (lambda xs (fn xs)) ) ) 76 69 77 (define (uni-each c f) 78 (lambda (x) (c (f x))) ) 70 ;; arguments-each 79 71 80 (define (uni-all c f)81 (lambda xs (c (apply f xs))))72 ; ((arguments-each f g h) a b c d e) -> (list (f a) (g b) (h c) (f d) (g e)) 73 ; ((arguments-each) arg...) -> (list arg...) 82 74 83 ;; Binary 75 (define (arguments-each . fns) 76 (let ((fn (each-func fns))) 77 (lambda xs (fn xs)) ) ) 84 78 85 (define bi 86 (case-lambda 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 ;; arguments-all 91 80 92 (define bi2 93 (case-lambda 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 ; ((arguments-all f g h) a b c) -> (list (f a b c) (g a b c) (h a b c)) 82 ; ((arguments-all) arg...) -> (list arg...) 98 83 99 (define bi3 100 (case-lambda 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 (bi-each c f) 107 (lambda (x y) (c (f x) (f y))) ) 108 109 (define (bi-all c f g) 110 (lambda xs (c (apply f xs) (apply g xs))) ) 111 112 ;; Trinary 113 114 (define tri 115 (case-lambda 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 (case-lambda 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 (case-lambda 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 (tri-each c f) 136 (lambda (x y z) (c (f x) (f y) (f z))) ) 137 138 (define (tri-all c f g h) 139 (lambda xs (c (apply f xs) (apply g xs) (apply h xs))) ) 84 (define (arguments-all . fns) 85 (let ((fn (all-func fns))) 86 (lambda xs (fn xs)) ) ) 140 87 141 88 ) ;module section-combinators -
release/4/combinators/trunk/sort-combinators.scm
r18918 r19028 7 7 8 8 (module sort-combinators (;export 9 group /key9 group-by group/key 10 10 make-equal/key make-less-than/key) 11 11 12 (import scheme chicken srfi-1) 12 (import 13 scheme 14 chicken 15 (only srfi-1 span) 16 (only bi-combinators bi-each)) 13 17 14 (require-library srfi-1 )18 (require-library srfi-1 bi-combinators) 15 19 16 20 (declare 17 21 (type 22 (group-by (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (list) list))) 18 23 (group/key (procedure ((procedure (*) *) list #!optional (procedure (* *) boolean)) list)) 19 24 (make-less-than/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean))) … … 23 28 24 29 ;kinda violates the argument list orientation of comibinators 25 (define (group-by proc #!optional (equal ityequal?))30 (define (group-by proc #!optional (equals equal?)) 26 31 (lambda (ls) 27 32 (let loop ((ls ls) (acc '())) 28 33 (if (null? ls) acc #;(reverse! acc) 29 34 (let ((key (proc (car ls)))) 30 (receive (grouped rest) (span (lambda (item) (equal itykey (proc item))) ls)35 (receive (grouped rest) (span (lambda (item) (equals key (proc item))) ls) 31 36 (loop rest (cons grouped acc)) ) ) ) ) ) ) 32 37 … … 39 44 ;; (group/key car '((a 1) (a 2) (b 1))) --> '(((a 1) (a 2)) ((b 1))) 40 45 41 (define (group/key keyproc ls #!optional (equal ityequal?))42 ((group-by keyproc equal ity) ls) )46 (define (group/key keyproc ls #!optional (equals equal?)) 47 ((group-by keyproc equals) ls) ) 43 48 44 49 ;; Define a less-than function for a sort of a structured sequence. … … 49 54 50 55 (define (make-less-than/key keyproc #!optional (less-than <)) 51 ( lambda (a b) (less-than (keyproc a) (keyproc b))) )56 (bi-each less-than keyproc) ) 52 57 53 58 ;; Define a equal function for a sort of a structured sequence. … … 57 62 ;; (make-hash-table (o string-ci-hash first) (make-equal/key first string-ci=?)) 58 63 59 (define (make-equal/key keyproc #!optional (equal =))60 ( lambda (a b) (equal (keyproc a) (keyproc b))) )64 (define (make-equal/key keyproc #!optional (equals =)) 65 (bi-each equals keyproc) ) 61 66 62 67 ) ;module sort-combinators -
release/4/combinators/trunk/tests/run.scm
r14018 r19028 1 (use test) 2 (use section-combinators) 3 4 (test "arguments-chain" '6 ((arguments-chain + list) 1 2 3)) 5 6 (test "arguments-each" '(#f #f #f #f #f #f #f) ((arguments-each even? odd?) 1 2 3 4 5 6 7)) 7 8 (test "arguments-all" '(6 -4 6) ((arguments-all + - *) 1 2 3)) 9 10 (use sort-combinators) 11 12 (test "make-less-than/key" '#t ((make-less-than/key car) '(2) '(3)))
Note: See TracChangeset
for help on using the changeset viewer.