Changeset 18947 in project for release/4/combinators


Ignore:
Timestamp:
07/24/10 04:16:17 (9 years ago)
Author:
Kon Lovett
Message:

hook+ added

File:
1 edited

Legend:

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

    r18946 r18947  
    77    o-with-apply
    88    left-hook right-hook
     9    left-hook+ right-hook+
    910    argument-each argument-all
    10     fork-each fork-all)
     11    fork-each fork-all
     12    fork-each+ fork-all+)
    1113
    1214  (import
     
    2123    (type
    2224      (o-with-apply (procedure (#!rest) (procedure (#!rest) *)))
    23       (left-hook (procedure (#!rest) (procedure (#!rest) *)))
    24       (right-hook (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) *)))
    2529      (argument-each (procedure (#!rest) (procedure (#!rest) list)))
    2630      (argument-all (procedure (#!rest) (procedure (#!rest) list)))
     31      (fork-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     32      (fork-all (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
    2733      (fork-each+ (procedure (#!rest) (procedure (#!rest) *)))
    2834      (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) ))
     
    6268; ((left-hook c f) arg...) -> (apply c (apply f arg...) arg...)
    6369; ((left-hook c) arg...) -> (apply c arg...)
    64 ; ((left-hook) arg...) -> (list arg...)
    6570
    66 (define (left-hook . fns)
    67   ; 0
    68   (if (null? fns) list
    69     (let ((c (car fns))
    70           (fns (cdr fns)) )
    71       ; 1
    72       (if (null? fns) (lambda xs (apply c xs))
    73         ; > 1
    74         (lambda xs (apply c (hook-recur+ (car fns) (cdr fns) xs) xs)) ) ) ) )
     71(define (left-hook c . fns)
     72  (let ((c (car fns))
     73        (fns (cdr fns)) )
     74    (if (null? fns) (lambda xs (apply c xs))
     75      (lambda xs (apply c (hook-recur+ (car fns) (cdr fns) xs) xs)) ) ) )
    7576
    7677;; right-hook
     
    7980; ((right-hook c f) arg...) -> (apply c arg... (apply f arg...))
    8081; ((right-hook c) arg...) -> (apply c arg...)
    81 ; ((right-hook) arg...) -> (list arg...)
    8282
    83 (define (right-hook . fns)
    84   ; 0
    85   (if (null? fns) list
    86     (let ((c (car fns))
    87           (fns (cdr fns)) )
    88       ; 1
    89       (if (null? fns) (lambda xs (apply c xs))
    90         ; > 1
    91         (lambda xs (apply c (append xs (list (hook-recur+ (car fns) (cdr fns) xs))))) ) ) ) )
     83(define (right-hook c . fns)
     84  (let ((c (car fns))
     85        (fns (cdr fns)) )
     86    (if (null? fns) (lambda xs (apply c xs))
     87      (lambda xs (apply c (append xs (list (hook-recur+ (car fns) (cdr fns) xs))))) ) ) )
     88
     89;; left-hook+
     90
     91; (left-hook+ c func...) -> (apply left-hook c func...)
     92; (left-hook+ c) -> (lambda (func...) (apply left-hook+ c func...))
     93; left-hook+) -> (lambda (c) (left-hook+ c))
     94
     95(define (left-hook+ . fns)
     96  (if (null? fns) (lambda (c) (left-hook+ c))
     97    (let ((c (car fns)) (fns (cdr fns)))
     98      (if (null? fns) (lambda fns (apply left-hook+ c fns))
     99        (apply left-hook c fns) ) ) ) )
     100
     101;; right-hook+
     102
     103; (right-hook+ c func...) -> (apply right-hook c func...)
     104; (right-hook+ c) -> (lambda (func...) (apply right-hook+ c func...))
     105; right-hook+) -> (lambda (c) (right-hook+ c))
     106
     107(define (right-hook+ . fns)
     108 (if (null? fns) (lambda (c) (right-hook+ c))
     109    (let ((c (car fns)) (fns (cdr fns)))
     110      (if (null? fns) (lambda fns (apply right-hook+ c fns))
     111        (apply right-hook c fns) ) ) ) )
    92112
    93113;;; Argument
     
    152172;; fork-each+ a fork-each that curries it's functions
    153173
    154 ; (fork-each+ c func...) -> (lambda xs (apply c (apply (apply argument-each func...) xs)))
    155 ; (fork-each+ c) -> (lambda funcs (apply fork-each c funcs))
    156 ; (fork-each+) -> (lambda (c) (fork-each c))
     174; (fork-each+ c func...) -> (apply fork-each c func...)
     175; (fork-each+ c) -> (lambda (func...) (apply fork-each+ c func...))
     176; (fork-each+) -> (lambda (c) (fork-each+ c))
    157177
    158178(define (fork-each+ . fns)
     
    164184;; fork-all+ a fork-all that curries it's functions
    165185
    166 ; (fork-all+ c func...) -> (lambda xs (apply c (apply (apply argument-all func...) xs)))
    167 ; (fork-all+ c) -> (lambda funcs (apply fork-all c funcs))
    168 ; (fork-all+) -> (lambda (c) (fork-all c))
     186; (fork-all+ c func...) -> (apply fork-all c func...)
     187; (fork-all+ c) -> (lambda (func...) (apply fork-all+ c func...))
     188; (fork-all+) -> (lambda (c) (fork-all+ c))
    169189
    170190(define (fork-all+ . fns)
Note: See TracChangeset for help on using the changeset viewer.