Changeset 18924 in project


Ignore:
Timestamp:
07/22/10 01:00:42 (11 years ago)
Author:
Kon Lovett
Message:

Added chained-apply

File:
1 edited

Legend:

Unmodified
Added
Removed

  • release/4/combinators/trunk/section-combinators.scm

    r18923 r18924  
    55
    66  (;export
    7     left-section
    8     right-section
    9     crop-left
    10     crop-right
     7    left-section right-section
     8    crop-left crop-right
    119    reversed
    1210    identities
    13     apply@
    14     apply*
    15     combine@
    16     combine*
    17     )
     11    chained-apply
     12    apply-each apply-all
     13    combine-each combine-all
     14    uni uni2 uni3 uni-each uni-all
     15    bi bi2 bi3 bi-each bi-all
     16    tri tri2 tri3 tri-each tri-all)
    1817
    1918  (import
    2019    scheme
    2120    chicken
    22     srfi-1)
     21    (only srfi-1 drop drop-right))
    2322
    2423  (require-library srfi-1)
    … …  
    3332      (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) ) )
    3433
    35 ;;;
     34;;
    3635
    3736(define (left-section proc . args)
    … …  
    4847
    4948(define (reversed proc)
    50   (lambda xs (##sys#apply proc (reverse xs))))
     49  (lambda xs (##sys#apply proc (reverse xs))) )
    5150
    5251(define (identities . xs) xs)
    … …  
    5453;;
    5554
    56 (define (apply@ proc . procs)
     55(define chained-apply
     56  (case-lambda
     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 (apply-each proc . procs)
    5775  (if (null procs)
    5876    (lambda xs (##sys#list (##sys#map proc xs)))
    5977    (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)) ) ) )
    6179 
    62 (define (apply* proc . procs)
     80(define (apply-all proc . procs)
    6381  (if (null procs)
    6482    (lambda xs (##sys#list (##sys#apply proc xs)))
    … …  
    6886;;
    6987
    70 (define combine@
     88(define combine-each
    7189  (case-lambda
    7290    ((comb proc . procs)
    73       (let ((reducer (##sys#apply apply@ proc procs)))
    74         (lambda xs (##sys#apply comb (##sys#apply reducer xs)))) )
     91      (chained-apply comb (##sys#apply apply-each proc procs)) )
    7592    ((comb)
    76       (lambda procs (##sys#apply combine@ comb procs)) )
     93      (lambda procs (##sys#apply combine-each comb procs)) )
    7794    (()
    78       (lambda (comb) (combine@ comb)) ) ) )
     95      (lambda (comb) (combine-each comb)) ) ) )
    7996
    80 (define combine*
     97(define combine-all
    8198  (case-lambda
    8299    ((comb proc . procs)
    83       (let ((reducer (##sys#apply apply* procs)))
    84         (lambda xs (##sys#apply proc (##sys#apply reducer xs)))) )
     100      (chained-apply comb (##sys#apply apply-all proc procs)) )
    85101    ((comb)
    86       (lambda procs (##sys#apply combine* comb procs)) )
     102      (lambda procs (##sys#apply combine-all comb procs)) )
    87103    (()
    88       (lambda (comb) (combine* comb)) ) ) )
     104      (lambda (comb) (combine-all comb)) ) ) )
    89105
    90106;;
    … …  
    108124    (()     (lambda (c) (uni3 c)))))
    109125
    110 (define uni@    ; for completeness only
    111   (case-lambda
    112     ((c f)  (lambda (x) (c (f x))))))
     126(define (uni-each c f)
     127  (lambda (x) (c (f x))) )
    113128
    114 (define uni*
    115   (case-lambda
    116     ((c f)  (lambda xs (c (##sys#apply f xs))))))
     129(define (uni-all c f)
     130  (lambda xs (c (##sys#apply f xs))) )
    117131
    118132;;
    … …  
    139153    (()       (lambda (c) (bi3 c)))))
    140154
    141 (define bi@
    142   (case-lambda
    143     ((c f)  (lambda (x y) (c (f x) (f y))))))
     155(define (bi-each c f)
     156  (lambda (x y) (c (f x) (f y))) )
    144157
    145 (define bi*
    146   (case-lambda
    147     ((c f g)  (lambda xs (c (##sys#apply f xs) (##sys#apply g xs))))))
     158(define (bi-all c f g)
     159  (lambda xs (c (##sys#apply f xs) (##sys#apply g xs))) )
    148160
    149161;;
    … …  
    170182    (()         (lambda (c) (tri3 c)))))
    171183
    172 (define tri@
    173   (case-lambda
    174     ((c f)  (lambda (x y z) (c (f x) (f y) (f z))))))
     184(define (tri-each c f)
     185  (lambda (x y z) (c (f x) (f y) (f z))) )
    175186
    176 (define tri*
    177   (case-lambda
    178     ((c f g h)  (lambda xs (c (##sys#apply f xs) (##sys#apply g xs) (##sys#apply h xs))))))
     187(define (tri-all c f g h)
     188  (lambda xs (c (##sys#apply f xs) (##sys#apply g xs) (##sys#apply h xs))) )
    179189
    180190) ;module section-combinators
Note: See TracChangeset for help on using the changeset viewer.