Changeset 18946 in project for release/4/combinators


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

nnary section combs in own mod

Location:
release/4/combinators/trunk
Files:
1 added
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/combinators/trunk/combinators.meta

    r18914 r18946  
    1111  "tests"
    1212  "section-combinators.scm"
     13  "generic-section-combinators.scm"
    1314  "logical-combinators.scm"
    1415  "sort-combinators.scm"
  • release/4/combinators/trunk/combinators.setup

    r18918 r18946  
    66
    77(setup-shared-extension-module 'section-combinators (extension-version "1.1.0")
    8   #:compile-options '(-scrutinize -optimize-level 3 -fixnum-arithmetic -no-procedure-checks))
     8  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))
     9(setup-shared-extension-module 'generic-section-combinators (extension-version "1.1.0")
     10  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))
    911(setup-shared-extension-module 'logical-combinators (extension-version "1.1.0")
    10   #:compile-options '(-scrutinize -optimize-level 3 -fixnum-arithmetic -no-procedure-checks))
     12  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))
    1113(setup-shared-extension-module 'sort-combinators (extension-version "1.1.0")
    12   #:compile-options '(-scrutinize -optimize-level 3 -fixnum-arithmetic -no-procedure-checks))
     14  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))
    1315(setup-shared-extension-module 'stack-combinators (extension-version "1.1.0")
    14   #:compile-options '(-scrutinize -optimize-level 3 -fixnum-arithmetic -no-procedure-checks))
     16  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))
    1517
    1618(install-extension 'combinators '() `((version ,(extension-version "1.1.0"))))
  • release/4/combinators/trunk/section-combinators.scm

    r18926 r18946  
    88    crop-left crop-right
    99    reversed
    10     identities
    11     argument-each argument-all
    12     left-hook right-hook
    13     fork-each fork-all
    1410    uni uni2 uni3 uni-each uni-all
    1511    bi bi2 bi3 bi-each bi-all
     
    2925      (right-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
    3026      (reversed (procedure ((procedure (#!rest) *)) (procedure (#!rest) *)))
    31       (identities (procedure (#!rest) list))
    3227      (crop-left (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *)))
    3328      (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) ) )
    34 
    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
    44 
    45 (define (identities . xs) xs)
    4629
    4730;;; Section
     
    5033  (lambda xs (apply fn (append args xs))) )
    5134
     35; (reverse (append (reverse args) (reverse xs))) = (append xs args)
    5236(define (right-section fn . args)
    5337  (lambda xs (apply fn (append xs args))) )
     
    5539;;; Crop
    5640
    57 ; (compose fn (right-section drop n) identities)
     41; (compose fn (right-section drop n) list)
    5842(define (crop-left fn n)
    5943  (lambda xs (apply fn (drop xs n))) )
    6044
    61 ; (compose fn (right-section drop-right n) identities)
     45; (compose fn (right-section drop-right n) list)
    6246(define (crop-right fn n)
    6347  (lambda xs (apply fn (drop-right xs n))) )
     
    6549;;; Reverse
    6650
    67 ; (compose fn reverse identities)
     51; (compose fn reverse list)
    6852(define (reversed fn)
    6953  (lambda xs (apply fn (reverse xs))) )
    7054
    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 
    14455;;; 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)) ) ) ) )
    17756
    17857;; Unary
Note: See TracChangeset for help on using the changeset viewer.