Changeset 18926 in project for release/4/combinators


Ignore:
Timestamp:
07/22/10 05:29:16 (9 years ago)
Author:
Kon Lovett
Message:

Hook & Fork

File:
1 edited

Legend:

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

    r18924 r18926  
    99    reversed
    1010    identities
    11     chained-apply
    12     apply-each apply-all
    13     combine-each combine-all
     11    argument-each argument-all
     12    left-hook right-hook
     13    fork-each fork-all
    1414    uni uni2 uni3 uni-each uni-all
    1515    bi bi2 bi3 bi-each bi-all
     
    1919    scheme
    2020    chicken
    21     (only srfi-1 drop drop-right))
    22 
    23   (require-library srfi-1)
     21    (only data-structures compose)
     22    (only srfi-1 circular-list drop drop-right))
     23
     24  (require-library data-structures srfi-1)
    2425
    2526  (declare
     
    3233      (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) ) )
    3334
    34 ;;
    35 
    36 (define (left-section proc . args)
    37   (lambda xs (##sys#apply proc (##sys#append args xs))))
    38 
    39 (define (right-section proc . args)
    40   (lambda xs (##sys#apply proc (##sys#append xs args))))
    41 
    42 (define (crop-left proc n)
    43   (lambda xs (##sys#apply proc (drop xs n))) )
    44 
    45 (define (crop-right proc n)
    46   (lambda xs (##sys#apply proc (drop-right xs n))) )
    47 
    48 (define (reversed proc)
    49   (lambda xs (##sys#apply proc (reverse xs))) )
     35;;; Internal Utilities
     36
     37(define (vVvs . xs) (if (null? (cdr xs)) (car xs) xs))
     38
     39(define (one/values f x) (call-with-values (lambda () (f x)) vVvs))
     40
     41(define (n/values f xs) (call-with-values (lambda () (apply f xs)) vVvs))
     42
     43;;; Identity
    5044
    5145(define (identities . xs) xs)
    5246
    53 ;;
    54 
    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)
    75   (if (null procs)
    76     (lambda xs (##sys#list (##sys#map proc xs)))
    77     (let ((procs (##sys#append (##sys#list proc) procs)))
    78       (lambda xs (map (lambda (f x) (f x)) procs xs)) ) ) )
    79  
    80 (define (apply-all proc . procs)
    81   (if (null procs)
    82     (lambda xs (##sys#list (##sys#apply proc xs)))
    83     (let ((procs (##sys#append (##sys#list proc) procs)))
    84       (lambda xs (##sys#map (cut ##sys#apply <> xs) procs)) ) ) )
    85 
    86 ;;
    87 
    88 (define combine-each
    89   (case-lambda
    90     ((comb proc . procs)
    91       (chained-apply comb (##sys#apply apply-each proc procs)) )
    92     ((comb)
    93       (lambda procs (##sys#apply combine-each comb procs)) )
    94     (()
    95       (lambda (comb) (combine-each comb)) ) ) )
    96 
    97 (define combine-all
    98   (case-lambda
    99     ((comb proc . procs)
    100       (chained-apply comb (##sys#apply apply-all proc procs)) )
    101     ((comb)
    102       (lambda procs (##sys#apply combine-all comb procs)) )
    103     (()
    104       (lambda (comb) (combine-all comb)) ) ) )
    105 
    106 ;;
     47;;; Section
     48
     49(define (left-section fn . args)
     50  (lambda xs (apply fn (append args xs))) )
     51
     52(define (right-section fn . args)
     53  (lambda xs (apply fn (append xs args))) )
     54
     55;;; Crop
     56
     57; (compose fn (right-section drop n) identities)
     58(define (crop-left fn n)
     59  (lambda xs (apply fn (drop xs n))) )
     60
     61; (compose fn (right-section drop-right n) identities)
     62(define (crop-right fn n)
     63  (lambda xs (apply fn (drop-right xs n))) )
     64
     65;;; Reverse
     66
     67; (compose fn reverse identities)
     68(define (reversed fn)
     69  (lambda xs (apply fn (reverse xs))) )
     70
     71;;; Argument
     72
     73; ((argument-each f g h) a b c d e) -> (list (f a) (g b) (h c) (f d) (g e))
     74(define (argument-each . fns)
     75  (cond
     76    ((null? fns)
     77      identities )
     78    ((null? (cdr fns))
     79      (let ((f (car fns)))
     80        (lambda xs (list (map (cut one/values f <>) xs))) ) )
     81    (else
     82      (let ((fns (apply circular-list fns)))
     83        (lambda xs (map (cut one/values <> <>) fns xs)) ) ) ) )
     84
     85; ((argument-all f g h) a b c) -> (list (f a b c) (g a b c) (h a b c))
     86(define (argument-all . fns)
     87  (cond
     88    ((null? fns)
     89      identities )
     90    ((null? (cdr fns))
     91      (let ((f (car fns)))
     92        (lambda xs (list (n/values f xs))) ) )
     93    (else
     94      (lambda xs (map (cut n/values <> xs) fns)) ) ) )
     95
     96;;; Hook
     97
     98; ((left-hook f g h) arg...) -> (f (g arg... (h arg...)) arg...)
     99; ((left-hook f g) arg...) -> (f (g arg...) arg...)
     100; ((left-hook f) arg...) -> (f arg...)
     101; ((left-hook) arg...) -> (arg...)
     102(define (left-hook . fns)
     103  (define (recur fns)
     104    (let ((h (car fns))
     105          (t (cdr fns)) )
     106      (if (null? t) (lambda xs (apply h xs))
     107        (lambda xs (apply h (recur t) xs)) ) ) )
     108  (cond
     109    ((null? fns)
     110      identities )
     111    ((null? (cdr fns))
     112      (let ((f (car fns)))
     113        (lambda xs (apply f xs)) ) )
     114    ((null? (cddr fns))
     115      (let ((f (car fns))
     116            (g (cadr fns)) )
     117      (lambda xs (apply f (apply g xs))) ) )
     118    (else
     119      (recur fns) ) ) )
     120
     121; ((right-hook f g h) arg...) -> (f arg... (g arg... (h arg...)))
     122; ((right-hook f g) arg...) -> (f arg... (g arg...))
     123; ((right-hook f) arg...) -> (f arg...)
     124; ((right-hook) arg...) -> (arg...)
     125(define (right-hook . fns)
     126  (define (recur fns)
     127    (let ((h (car fns))
     128          (t (cdr fns)) )
     129      (if (null? t) (lambda xs (apply h xs))
     130        (lambda xs (apply h (append xs (list (recur t))))) ) ) )
     131  (cond
     132    ((null? fns)
     133      identities )
     134    ((null? (cdr fns))
     135      (let ((f (car fns)))
     136        (lambda xs (apply f xs)) ) )
     137    ((null? (cddr fns))
     138      (let ((f (car fns))
     139            (g (cadr fns)) )
     140        (lambda xs (apply f (append xs (list (apply g xs))))) ) )
     141    (else
     142      (recur fns) ) ) )
     143
     144;;; Fork
     145
     146;; Nnary
     147
     148; (fork-each c f g h) -> (compose c (argument-each f g h))
     149; (fork-each c) -> (lambda (func...) (compose c (argument-each func...)))
     150; (fork-each) -> (lambda (c) (lambda (func...) (compose c (argument-each func...))))
     151(define (fork-each . fns)
     152  (cond
     153    ((null? fns)
     154      (lambda (c) (fork-each c)) )
     155    ((null? (cdr fns))
     156      (let ((c (car fns)))
     157        (lambda fns (apply fork-each c fns)) ) )
     158    (else
     159      (let ((c (car fns))
     160            (fns (cdr fns)) )
     161        (compose c (apply argument-each fns)) ) ) ) )
     162
     163; (fork-all c f g h) -> (compose c (argument-all f g h))
     164; (fork-all c) -> (lambda (func...) (compose c (argument-all func...)))
     165; (fork-all) -> (lambda (c) (lambda (func...) (compose c (argument-all func...))))
     166(define (fork-all . fns)
     167  (cond
     168    ((null? fns)
     169      (lambda (c) (fork-all c)) )
     170    ((null? (cdr fns))
     171      (let ((c (car fns)))
     172        (lambda fns (apply fork-all c fns)) ) )
     173    (else
     174      (let ((c (car fns))
     175            (fns (cdr fns)) )
     176        (compose c (apply argument-all fns)) ) ) ) )
     177
     178;; Unary
    107179
    108180(define uni
     
    128200
    129201(define (uni-all c f)
    130   (lambda xs (c (##sys#apply f xs))) )
    131 
    132 ;;
     202  (lambda xs (c (apply f xs))) )
     203
     204;; Binary
    133205
    134206(define bi
     
    157229
    158230(define (bi-all c f g)
    159   (lambda xs (c (##sys#apply f xs) (##sys#apply g xs))) )
    160 
    161 ;;
     231  (lambda xs (c (apply f xs) (apply g xs))) )
     232
     233;; Trinary
    162234
    163235(define tri
     
    186258
    187259(define (tri-all c f g h)
    188   (lambda xs (c (##sys#apply f xs) (##sys#apply g xs) (##sys#apply h xs))) )
     260  (lambda xs (c (apply f xs) (apply g xs) (apply h xs))) )
    189261
    190262) ;module section-combinators
Note: See TracChangeset for help on using the changeset viewer.