Ignore:
Timestamp:
07/31/10 03:14:44 (11 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/generic-section-combinators.scm

    r18947 r19028  
    11;;;; generic-section-combinators.scm
    22;;;; Kon Lovett, Jul '10
     3
     4!IN PROGRESS!
    35
    46(module generic-section-combinators
    57
    68  (;export
    7     o-with-apply
    8     left-hook right-hook
    9     left-hook+ right-hook+
    10     argument-each argument-all
     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+
    1113    fork-each fork-all
    1214    fork-each+ fork-all+)
     
    2224  (declare
    2325    (type
    24       (o-with-apply (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) *)))
    29       (argument-each (procedure (#!rest) (procedure (#!rest) list)))
    30       (argument-all (procedure (#!rest) (procedure (#!rest) list)))
     26      (left-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     27      (right-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     28      (left-hook-each+ (procedure (#!rest) (procedure (#!rest) *)))
     29      (right-hook-each+ (procedure (#!rest) (procedure (#!rest) *)))
     30      (left-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     31      (right-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     32      (left-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *)))
     33      (right-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *)))
    3134      (fork-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
    3235      (fork-all (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     
    3437      (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) ))
    3538
     39  (include "arguments-helpers.inc")
     40
    3641;;; Hook
    3742
    38 ;;l Helpers
     43(define (left-arguments-X . fns)
     44  (lambda xs ((X-funcs (cons fns list)) xs)) )
    3945
    40 (define-inline (hook-recur fns xs)
    41   ; assume the length of fns is << so recursion depth is also <<
    42   (let recur ((fns fns))
    43     (if (null? fns) xs
    44       (apply (car fns) (recur (cdr fns))) ) ) )
     46(define (right-arguments-X . fns)
     47  (lambda xs ((X-funcs (cons list fns)) xs)) )
    4548
    46 (define-inline (hook-recur+ g fns xs)
    47   (apply g (hook-recur fns xs)) )
     49?????
     50(left-hook-X c fn0 ... fnn) = (arguments-chain c (arguments-X fn0 ... fnn list))
     51(right-hook-X c fn0 ... fnn) = (arguments-chain c (arguments-X list fn0 ... fnn))
    4852
    49 ;; o-with-apply
     53;; left-hook-each
    5054
    51 ; ((o-with-apply f g) arg...) -> (apply f (apply g arg...))
    52 ; ((o-with-apply f) arg...) -> (apply f arg...)
    53 ; ((o-with-apply) arg...) -> (list arg...)
     55; ((left-hook-each c f g) arg...) -> (apply c (f arg0) (g arg1) ... argn...)
     56; ((left-hook-each c f) arg...) -> (apply c (f arg0) ... (f argn) arg...)
     57; ((left-hook-each c) arg...) -> (apply c arg...)
    5458
    55 (define (o-with-apply . fns)
    56   ; 0
    57   (if (null? fns) list
    58     (let ((f (car fns))
    59           (fns (cdr fns)) )
    60       ; 1
    61       (if (null? fns) (lambda xs (apply f xs))
    62         ; > 1
    63         (lambda xs (hook-recur+ f fns xs)) ) ) ) )
     59(define (left-hook-each c . fns)
     60  (if (null? fns) (lambda xs (apply c xs))
     61    (let ((fn (each-func fns)))
     62      (lambda xs (apply c (append (list (fn xs)) xs))) ) ) )
    6463
    65 ;; left-hook
     64;; right-hook-each
    6665
    67 ; ((left-hook c f g) arg...) -> (apply c (apply f (apply g arg...)) arg...)
    68 ; ((left-hook c f) arg...) -> (apply c (apply f arg...) arg...)
    69 ; ((left-hook c) arg...) -> (apply c arg...)
     66; ((right-hook-each c f g) arg...) -> (apply c argn... (f arg0) (g arg1) ...)
     67; ((right-hook-each c f) arg...) -> (apply c arg... (f arg0) ... (f argn))
     68; ((right-hook-each c) arg...) -> (apply c arg...)
    7069
    71 (define (left-hook c . fns)
     70(define (right-hook-each c . fns)
     71  (if (null? fns) (lambda xs (apply c xs))
     72    (let ((fn (each-func fns)))
     73      (lambda xs (apply c (append xs (list (fn xs))))) ) ) )
     74
     75;; left-hook-each+ a left-hook-each that curries it's functions
     76
     77; (left-hook-each+ c func...) -> (apply left-hook-each c func...)
     78; (left-hook-each+ c) -> (lambda (func...) (apply left-hook-each+ c func...))
     79; (left-hook-each+) -> (lambda (c) (left-hook-each+ c))
     80
     81(define (left-hook-each+ . fns)
     82  (if (null? fns) (lambda (c) (left-hook-each+ c))
     83    (let ((c (car fns)) (fns (cdr fns)))
     84      (if (null? fns) (lambda fns (apply left-hook-each+ c fns))
     85        (apply left-hook-each c fns) ) ) ) )
     86
     87;; right-hook-each+ a left-hook-each that curries it's functions
     88
     89; (right-hook-each+ c func...) -> (apply right-hook-each c func...)
     90; (right-hook-each+ c) -> (lambda (func...) (apply right-hook-each+ c func...))
     91; (right-hook-each+) -> (lambda (c) (right-hook-each+ c))
     92
     93(define (right-hook-each+ . fns)
     94 (if (null? fns) (lambda (c) (right-hook-each+ c))
     95    (let ((c (car fns)) (fns (cdr fns)))
     96      (if (null? fns) (lambda fns (apply right-hook-each+ c fns))
     97        (apply right-hook-each c fns) ) ) ) )
     98
     99;; left-hook-argument-chain
     100
     101; ((left-hook-argument-chain c f g) arg...) -> (apply c (apply f (apply g arg...)) arg...)
     102; ((left-hook-argument-chain c f) arg...) -> (apply c (apply f arg...) arg...)
     103; ((left-hook-argument-chain c) arg...) -> (apply c arg...)
     104
     105(define (left-hook-argument-chain c . fns)
    72106  (let ((c (car fns))
    73107        (fns (cdr fns)) )
    74108    (if (null? fns) (lambda xs (apply c xs))
    75       (lambda xs (apply c (hook-recur+ (car fns) (cdr fns) xs) xs)) ) ) )
     109      (lambda xs (apply c (chain-recur fns xs) xs)) ) ) )
    76110
    77 ;; right-hook
     111;; right-hook-argument-chain
    78112
    79 ; ((right-hook c f g) arg...) -> (apply c arg... (apply f (apply g arg...)))
    80 ; ((right-hook c f) arg...) -> (apply c arg... (apply f arg...))
    81 ; ((right-hook c) arg...) -> (apply c arg...)
     113; ((right-hook-argument-chain c f g) arg...) -> (apply c arg... (apply f (apply g arg...)))
     114; ((right-hook-argument-chain c f) arg...) -> (apply c arg... (apply f arg...))
     115; ((right-hook-argument-chain c) arg...) -> (apply c arg...)
    82116
    83 (define (right-hook c . fns)
     117(define (right-hook-argument-chain c . fns)
    84118  (let ((c (car fns))
    85119        (fns (cdr fns)) )
    86120    (if (null? fns) (lambda xs (apply c xs))
    87       (lambda xs (apply c (append xs (list (hook-recur+ (car fns) (cdr fns) xs))))) ) ) )
     121      (lambda xs (apply c (append xs (list (chain-recur fns xs))))) ) ) )
    88122
    89 ;; left-hook+
     123;; left-hook-argument-chain+ a left-hook-argument-chain that curries it's functions
    90124
    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))
     125; (left-hook-argument-chain+ c func...) -> (apply left-hook-argument-chain c func...)
     126; (left-hook-argument-chain+ c) -> (lambda (func...) (apply left-hook-argument-chain+ c func...))
     127; (left-hook-argument-chain+) -> (lambda (c) (left-hook-argument-chain+ c))
    94128
    95 (define (left-hook+ . fns)
    96   (if (null? fns) (lambda (c) (left-hook+ c))
     129(define (left-hook-argument-chain+ . fns)
     130  (if (null? fns) (lambda (c) (left-hook-argument-chain+ c))
    97131    (let ((c (car fns)) (fns (cdr fns)))
    98       (if (null? fns) (lambda fns (apply left-hook+ c fns))
    99         (apply left-hook c fns) ) ) ) )
     132      (if (null? fns) (lambda fns (apply left-hook-argument-chain+ c fns))
     133        (apply left-hook-argument-chain c fns) ) ) ) )
    100134
    101 ;; right-hook+
     135;; right-hook-argument-chain+ a right-hook-argument-chain that curries it's functions
    102136
    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))
     137; (right-hook-argument-chain+ c func...) -> (apply right-hook-argument-chain c func...)
     138; (right-hook-argument-chain+ c) -> (lambda (func...) (apply right-hook-argument-chain+ c func...))
     139; (right-hook-argument-chain+) -> (lambda (c) (right-hook-argument-chain+ c))
    106140
    107 (define (right-hook+ . fns)
    108  (if (null? fns) (lambda (c) (right-hook+ c))
     141(define (right-hook-argument-chain+ . fns)
     142 (if (null? fns) (lambda (c) (right-hook-argument-chain+ c))
    109143    (let ((c (car fns)) (fns (cdr fns)))
    110       (if (null? fns) (lambda fns (apply right-hook+ c fns))
    111         (apply right-hook c fns) ) ) ) )
    112 
    113 ;;; Argument
    114 
    115 ;; Helpers
    116 
    117 (define-inline (argument-each-func fns)
    118   (cond
    119     ((null? fns)
    120       identity )
    121     ((null? (cdr fns))
    122       (lambda (xs) (map (cute (car fns) <>) xs)) )
    123     (else
    124       (let ((fns (apply circular-list fns)))
    125         (lambda (xs) (map (cut <> <>) fns xs)) ) ) ) )
    126 
    127 (define-inline (argument-all-funcs fns)
    128   (cond
    129     ((null? fns)
    130       identity )
    131     ((null? (cdr fns))
    132       (lambda (xs) (list (apply (car fns) xs))) )
    133     (else
    134       (lambda (xs) (map (cut apply <> xs) fns)) ) ) )
    135 
    136 ;; argument-each
    137 
    138 ; ((argument-each f g h) a b c d e) -> (list (f a) (g b) (h c) (f d) (g e))
    139 ; ((argument-each) arg...) -> (list arg...)
    140 
    141 (define (argument-each . fns)
    142   (let ((fn (argument-each-func fns)))
    143     (lambda xs (fn xs)) ) )
    144 
    145 ;; argument-all
    146 
    147 ; ((argument-all f g h) a b c) -> (list (f a b c) (g a b c) (h a b c))
    148 ; ((argument-all) arg...) -> (list arg...)
    149 
    150 (define (argument-all . fns)
    151   (let ((fn (argument-all-func fns)))
    152     (lambda xs (fn xs)) ) )
     144      (if (null? fns) (lambda fns (apply right-hook-argument-chain+ c fns))
     145        (apply right-hook-argument-chain c fns) ) ) ) )
    153146
    154147;;; Fork
     
    156149;; fork-each
    157150
    158 ; (fork-each c func...) -> (lambda xs (apply c (apply (apply argument-each func...) xs)))
     151; (fork-each c func...) -> (lambda xs (apply c (apply (apply arguments-each func...) xs)))
    159152
    160153(define (fork-each c . fns)
    161   (let ((fn (argument-each-func fns)))
     154  (let ((fn (each-func fns)))
    162155    (lambda xs (apply c (fn xs))) ) )
    163156
    164157;; fork-all
    165158
    166 ; (fork-all c func...) -> (lambda xs (apply c (apply (apply argument-all func...) xs)))
     159; (fork-all c func...) -> (lambda xs (apply c (apply (apply arguments-all func...) xs)))
    167160
    168161(define (fork-all c . fns)
    169   (let ((fn (argument-all-func fns)))
     162  (let ((fn (all-func fns)))
    170163    (lambda xs (apply c (fn xs))) ) )
    171164
Note: See TracChangeset for help on using the changeset viewer.