Changeset 39452 in project
- Timestamp:
- 12/22/20 14:43:10 (4 weeks ago)
- Location:
- release/5/combinators/trunk
- Files:
-
- 1 added
- 10 edited
Legend:
- Unmodified
- Added
- Removed
-
release/5/combinators/trunk/bi-combinators.scm
r34400 r39452 4 4 (module bi-combinators 5 5 6 (;export7 bi bi2 bi3 bi-each bi-all)6 (;export 7 bi bi2 bi3 bi-each bi-all) 8 8 9 (import 10 scheme 11 chicken) 9 (import 10 scheme) 12 11 12 (cond-expand 13 (chicken-4 14 (import chicken)) 15 (chicken-5 16 (import (chicken base)))) 13 17 #| 14 18 ;;; Hook -
release/5/combinators/trunk/combinators.meta
r34400 r39452 9 9 (depends (setup-helper "1.5.2")) 10 10 (test-depends test) 11 (files 12 "arguments-helpers.inc.scm" 13 "logical-combinators.scm" 14 "section-combinators.scm" 15 "sort-combinators.scm" 16 "generic-section-combinators.scm" 17 "stack-combinators.scm" 18 "uni-combinators.scm" "bi-combinators.scm" "tri-combinators.scm" 19 "combinators.meta" "combinators.setup" "combinators.release-info" 20 "tests/run.scm") ) 11 (files "logical-combinators.scm" "section-combinators.scm" "combinators.meta" "combinators.release-info" "uni-combinators.scm" "generic-section-combinators.scm" "combinators.setup" "arguments-helpers.inc" "stack-combinators.scm" "tri-combinators.scm" "bi-combinators.scm" "sort-combinators.scm" "tests/run.scm") ) -
release/5/combinators/trunk/generic-section-combinators.scm
r34400 r39452 2 2 ;;;; Kon Lovett, Jul '10 3 3 4 ;; Issues 5 ;; 6 ;; !IN PROGRESS! 4 !IN PROGRESS! 7 5 8 6 (module generic-section-combinators 9 7 10 (;export11 left-hook-each right-hook-each12 left-hook-each+ right-hook-each+13 left-hook-argument-chain right-hook-argument-chain14 left-hook-argument-chain+ right-hook-argument-chain+15 fork-each fork-all16 fork-each+ fork-all+)8 (;export 9 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+ 13 fork-each fork-all 14 fork-each+ fork-all+) 17 15 18 (import 19 (except scheme map) 20 chicken 21 (only data-structures identity) 22 (only srfi-1 circular-list map)) 16 (import (except scheme map)) 23 17 24 (require-library data-structures srfi-1) 18 (cond-expand 19 (chicken-4 20 (require-library data-structures srfi-1) 21 (import 25 22 26 (declare 27 (type 28 (left-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 29 (right-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 30 (left-hook-each+ (procedure (#!rest) (procedure (#!rest) *))) 31 (right-hook-each+ (procedure (#!rest) (procedure (#!rest) *))) 32 (left-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 33 (right-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 34 (left-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *))) 35 (right-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *))) 36 (fork-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 37 (fork-all (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 38 (fork-each+ (procedure (#!rest) (procedure (#!rest) *))) 39 (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) )) 23 chicken 24 (only data-structures identity) 25 (only srfi-1 circular-list map))) 26 (chicken-5 27 (import (chicken base)) 28 (import 29 (only srfi-1 circular-list map)))) 40 30 41 (include "arguments-helpers.inc") 31 (declare 32 (type 33 (left-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 34 (right-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 35 (left-hook-each+ (procedure (#!rest) (procedure (#!rest) *))) 36 (right-hook-each+ (procedure (#!rest) (procedure (#!rest) *))) 37 (left-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 38 (right-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 39 (left-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *))) 40 (right-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *))) 41 (fork-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 42 (fork-all (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 43 (fork-each+ (procedure (#!rest) (procedure (#!rest) *))) 44 (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) )) 45 46 (include "arguments-helpers.inc") 42 47 43 48 ;;; Hook … … 49 54 (lambda xs ((X-funcs (cons list fns)) xs)) ) 50 55 51 #|52 56 ????? 53 57 (left-hook-X c fn0 ... fnn) = (arguments-chain c (arguments-X fn0 ... fnn list)) 54 58 (right-hook-X c fn0 ... fnn) = (arguments-chain c (arguments-X list fn0 ... fnn)) 55 |#56 59 57 60 ;; left-hook-each … … 62 65 63 66 (define (left-hook-each c . fns) 64 (if (null? fns) 65 (lambda xs (apply c xs)) 67 (if (null? fns) (lambda xs (apply c xs)) 66 68 (let ((fn (each-func fns))) 67 69 (lambda xs (apply c (append (list (fn xs)) xs))) ) ) ) … … 74 76 75 77 (define (right-hook-each c . fns) 76 (if (null? fns) 77 (lambda xs (apply c xs)) 78 (if (null? fns) (lambda xs (apply c xs)) 78 79 (let ((fn (each-func fns))) 79 80 (lambda xs (apply c (append xs (list (fn xs))))) ) ) ) … … 86 87 87 88 (define (left-hook-each+ . fns) 88 (if (null? fns) 89 (lambda (c) (left-hook-each+ c)) 89 (if (null? fns) (lambda (c) (left-hook-each+ c)) 90 90 (let ((c (car fns)) (fns (cdr fns))) 91 (if (null? fns) 92 (lambda fns (apply left-hook-each+ c fns)) 91 (if (null? fns) (lambda fns (apply left-hook-each+ c fns)) 93 92 (apply left-hook-each c fns) ) ) ) ) 94 93 … … 100 99 101 100 (define (right-hook-each+ . fns) 102 (if (null? fns) (lambda (c) 103 (right-hook-each+ c)) 101 (if (null? fns) (lambda (c) (right-hook-each+ c)) 104 102 (let ((c (car fns)) (fns (cdr fns))) 105 (if (null? fns) 106 (lambda fns (apply right-hook-each+ c fns)) 103 (if (null? fns) (lambda fns (apply right-hook-each+ c fns)) 107 104 (apply right-hook-each c fns) ) ) ) ) 108 105 … … 116 113 (let ((c (car fns)) 117 114 (fns (cdr fns)) ) 118 (if (null? fns) 119 (lambda xs (apply c xs)) 115 (if (null? fns) (lambda xs (apply c xs)) 120 116 (lambda xs (apply c (chain-recur fns xs) xs)) ) ) ) 121 117 … … 129 125 (let ((c (car fns)) 130 126 (fns (cdr fns)) ) 131 (if (null? fns) 132 (lambda xs (apply c xs)) 127 (if (null? fns) (lambda xs (apply c xs)) 133 128 (lambda xs (apply c (append xs (list (chain-recur fns xs))))) ) ) ) 134 129 … … 140 135 141 136 (define (left-hook-argument-chain+ . fns) 142 (if (null? fns) 143 (lambda (c) (left-hook-argument-chain+ c)) 137 (if (null? fns) (lambda (c) (left-hook-argument-chain+ c)) 144 138 (let ((c (car fns)) (fns (cdr fns))) 145 (if (null? fns) 146 (lambda fns (apply left-hook-argument-chain+ c fns)) 139 (if (null? fns) (lambda fns (apply left-hook-argument-chain+ c fns)) 147 140 (apply left-hook-argument-chain c fns) ) ) ) ) 148 141 … … 154 147 155 148 (define (right-hook-argument-chain+ . fns) 156 (if (null? fns) 157 (lambda (c) (right-hook-argument-chain+ c)) 149 (if (null? fns) (lambda (c) (right-hook-argument-chain+ c)) 158 150 (let ((c (car fns)) (fns (cdr fns))) 159 (if (null? fns) 160 (lambda fns (apply right-hook-argument-chain+ c fns)) 151 (if (null? fns) (lambda fns (apply right-hook-argument-chain+ c fns)) 161 152 (apply right-hook-argument-chain c fns) ) ) ) ) 162 153 … … 186 177 187 178 (define (fork-each+ . fns) 188 (if (null? fns) 189 (lambda (c) (fork-each+ c)) 179 (if (null? fns) (lambda (c) (fork-each+ c)) 190 180 (let ((c (car fns)) (fns (cdr fns))) 191 (if (null? fns) 192 (lambda fns (apply fork-each+ c fns)) 181 (if (null? fns) (lambda fns (apply fork-each+ c fns)) 193 182 (apply fork-each c fns) ) ) ) ) 194 183 … … 200 189 201 190 (define (fork-all+ . fns) 202 (if (null? fns) 203 (lambda (c) (fork-all+ c)) 191 (if (null? fns) (lambda (c) (fork-all+ c)) 204 192 (let ((c (car fns)) (fns (cdr fns))) 205 (if (null? fns) 206 (lambda fns (apply fork-all+ c fns)) 193 (if (null? fns) (lambda fns (apply fork-all+ c fns)) 207 194 (apply fork-all c fns) ) ) ) ) 208 195 -
release/5/combinators/trunk/logical-combinators.scm
r34400 r39452 4 4 (module logical-combinators 5 5 6 (;export7 andf8 orf)6 (;export 7 andf 8 orf) 9 9 10 (import scheme chicken data-structures srfi-1)10 (import scheme) 11 11 12 (declare 13 (type 14 (andf (procedure (#!rest) *)) 15 (orf (procedure (#!rest) *)) ) ) 12 (cond-expand 13 (chicken-4 14 (import chicken data-structures srfi-1)) 15 (chicken-5 16 (import (chicken base)) 17 (import srfi-1))) 18 19 (declare 20 (type 21 (andf (procedure (#!rest) *)) 22 (orf (procedure (#!rest) *)) ) ) 16 23 17 24 ;; Eager 'or' & 'and' … … 19 26 (define (andf . args) 20 27 (let loop ((args args) (prev #t)) 21 (if (null? args) 22 prev23 (let ((cur (car args)))24 (and cur(loop (cdr args) cur) ) ) ) ) )28 (if (null? args) prev 29 (let ((cur (car args))) 30 (and cur 31 (loop (cdr args) cur) ) ) ) ) ) 25 32 26 33 (define (orf . args) 27 34 (let loop ((args args)) 28 (and 29 (not (null? args))30 (or (car args)(loop (cdr args)) ) ) ) )35 (and (not (null? args)) 36 (or (car args) 37 (loop (cdr args)) ) ) ) ) 31 38 32 39 ) ;module logical-combinators -
release/5/combinators/trunk/section-combinators.scm
r34400 r39452 4 4 (module section-combinators 5 5 6 (;export7 left-section right-section8 crop-left crop-right9 reversed10 arguments-chain arguments-each arguments-all)6 (;export 7 left-section right-section 8 crop-left crop-right 9 reversed 10 arguments-chain arguments-each arguments-all) 11 11 12 (import 13 scheme 14 chicken 15 (only (srfi 1) drop drop-right circular-list) 16 (only data-structures identity)) 17 (require-library data-structures (srfi 1)) 12 (import 13 scheme) 18 14 19 (declare 20 (type 21 (left-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 22 (right-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 23 (reversed (procedure ((procedure (#!rest) *)) (procedure (#!rest) *))) 24 (crop-left (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) 25 (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) 26 (arguments-chain (procedure (#!rest) (procedure (#!rest) *))) 27 (arguments-each (procedure (#!rest) (procedure (#!rest) list))) 28 (arguments-all (procedure (#!rest) (procedure (#!rest) list))) ) ) 15 (cond-expand 16 (chicken-4 17 (import chicken) 18 (import (only srfi-1 drop drop-right circular-list)) 19 (import (only data-structures identity)) 20 (require-library srfi-1)) 21 (chicken-5 22 (import (chicken base)) 23 (import (only srfi-1 drop drop-right circular-list)) 24 (import (only (chicken base) identity)))) 25 26 27 (declare 28 (type 29 (left-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 30 (right-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *))) 31 (reversed (procedure ((procedure (#!rest) *)) (procedure (#!rest) *))) 32 (crop-left (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) 33 (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) 34 (arguments-chain (procedure (#!rest) (procedure (#!rest) *))) 35 (arguments-each (procedure (#!rest) (procedure (#!rest) list))) 36 (arguments-all (procedure (#!rest) (procedure (#!rest) list))) ) ) 29 37 30 38 ;;; Section … … 55 63 ;;; Argument 56 64 57 (include "arguments-helpers.inc")65 (include "arguments-helpers.inc") 58 66 59 67 ;; arguments-chain -
release/5/combinators/trunk/sort-combinators.scm
r34400 r39452 6 6 ;; - group/key is not a combinator 7 7 8 (module sort-combinators 9 10 (;export 8 (module sort-combinators (;export 11 9 group-by group/key 12 10 make-equal/key make-less-than/key) 13 11 14 (import 15 scheme 16 chicken 17 (only (srfi 1) span) 18 (only bi-combinators bi-each)) 19 (require-library (srfi 1) bi-combinators) 12 (import scheme) 20 13 21 (declare 22 (type 23 (group-by (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (list) list))) 24 (group/key (procedure ((procedure (*) *) list #!optional (procedure (* *) boolean)) list)) 25 (make-less-than/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean))) 26 (make-equal/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean))) ) ) 14 (cond-expand 15 (chicken-4 16 (import chicken) 17 (import (only srfi-1 span)) 18 (import (only bi-combinators bi-each)) 19 (require-library srfi-1 bi-combinators)) 20 (chicken-5 21 (import (chicken base)) 22 (import (only srfi-1 span)) 23 (import (only bi-combinators bi-each)))) 24 25 (declare 26 (type 27 (group-by (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (list) list))) 28 (group/key (procedure ((procedure (*) *) list #!optional (procedure (* *) boolean)) list)) 29 (make-less-than/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean))) 30 (make-equal/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean))) ) ) 27 31 28 32 ;; 29 33 30 ;kinda violates the argument list orientation of com binators34 ;kinda violates the argument list orientation of comibinators 31 35 (define (group-by proc #!optional (equals equal?)) 32 36 (lambda (ls) 33 37 (let loop ((ls ls) (acc '())) 34 (if (null? ls) 35 acc #;(reverse! acc) 36 (let ((key (proc (car ls)))) 37 (receive (grouped rest) (span (lambda (item) (equals key (proc item))) ls) 38 (loop rest (cons grouped acc)) ) ) ) ) ) ) 38 (if (null? ls) acc #;(reverse! acc) 39 (let ((key (proc (car ls)))) 40 (receive (grouped rest) (span (lambda (item) (equals key (proc item))) ls) 41 (loop rest (cons grouped acc)) ) ) ) ) ) ) 39 42 40 43 ;; Group a list of elements by some key attribute. -
release/5/combinators/trunk/stack-combinators.scm
r34400 r39452 7 7 (module stack-combinators 8 8 9 (;export 10 uni uni2 uni3 uni@ 11 bi bi2 bi3 bi@ 12 tri tri2 tri3 tri@ 13 dip 14 dup dupd 15 swap 16 drop drop/2) 9 (;export 10 uni uni2 uni3 uni@ 11 bi bi2 bi3 bi@ 12 tri tri2 tri3 tri@ 13 dip 14 dup dupd 15 swap 16 drop drop/2) 17 18 (import scheme) 17 19 18 (import scheme chicken) 19 20 (cond-expand 21 (chicken-4 22 (import chicken)) 23 (chicken-5 24 (import (chicken base)))) 20 25 ;; 21 26 -
release/5/combinators/trunk/tests/run.scm
r21916 r39452 1 (use test) 2 (use section-combinators) 1 (cond-expand 2 (chicken-4 3 (use test) 4 (use section-combinators)) 5 (chicken-5 6 (import test) 7 (import section-combinators))) 3 8 4 9 (test "arguments-chain" '6 ((arguments-chain + list) 1 2 3)) … … 8 13 (test "arguments-all" '(6 -4 6) ((arguments-all + - *) 1 2 3)) 9 14 10 (use sort-combinators) 15 (cond-expand 16 (chicken-4 17 (use sort-combinators)) 18 (chicken-5 19 (import sort-combinators))) 11 20 12 21 (test "make-less-than/key" '#t ((make-less-than/key car) '(2) '(3))) -
release/5/combinators/trunk/tri-combinators.scm
r34400 r39452 4 4 (module tri-combinators 5 5 6 (;export7 tri tri2 tri3 tri-each tri-all)6 (;export 7 tri tri2 tri3 tri-each tri-all) 8 8 9 (import 10 scheme 11 chicken) 12 9 (import 10 scheme) 11 12 (cond-expand 13 (chicken-4 14 (import chicken)) 15 (chicken-5 16 (import (chicken base)))) 13 17 ;;; Hook 14 18 -
release/5/combinators/trunk/uni-combinators.scm
r34400 r39452 4 4 (module uni-combinators 5 5 6 (;export7 uni uni2 uni3 uni-each uni-all)6 (;export 7 uni uni2 uni3 uni-each uni-all) 8 8 9 (import 10 scheme 11 chicken) 9 (import scheme) 10 11 (cond-expand 12 (chicken-4 13 (import chicken)) 14 (chicken-5 15 (import (chicken base)))) 12 16 13 17 #|
Note: See TracChangeset
for help on using the changeset viewer.