Ignore:
Timestamp:
07/31/10 03:14:44 (10 years ago)
Author:
Kon Lovett
Message:

Export Scheme-ish uni, etc. & arguments-X routines

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/combinators/trunk/section-combinators.scm

    r18946 r19028  
    88    crop-left crop-right
    99    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)
    1311
    1412  (import
    1513    scheme
    1614    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))
    1917
    20   (require-library data-structures srfi-1)
     18  (require-library srfi-1)
    2119
    2220  (declare
     
    2624      (reversed (procedure ((procedure (#!rest) *)) (procedure (#!rest) *)))
    2725      (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))) ) )
    2930
    3031;;; Section
     
    5354  (lambda xs (apply fn (reverse xs))) )
    5455
    55 ;;; Fork
     56;;; Argument
    5657
    57 ;; Unary
     58  (include "arguments-helpers.inc")
    5859
    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
    6461
    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...)
    7065
    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)) ) )
    7669
    77 (define (uni-each c f)
    78   (lambda (x) (c (f x))) )
     70;; arguments-each
    7971
    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...)
    8274
    83 ;; Binary
     75(define (arguments-each . fns)
     76  (let ((fn (each-func fns)))
     77    (lambda xs (fn xs)) ) )
    8478
    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
    9180
    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...)
    9883
    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)) ) )
    14087
    14188) ;module section-combinators
Note: See TracChangeset for help on using the changeset viewer.