source: project/release/4/combinators/trunk/section-combinators.scm @ 18923

;;;; section-combinators.scm
;;;; Kon Lovett, Jul '10

(module section-combinators

  (;export
    left-section
    right-section
    crop-left
    crop-right
    reversed
    identities
    apply@
    apply*
    combine@
    combine*
    )

  (import
    scheme
    chicken
    srfi-1)

  (require-library srfi-1)

  (declare
    (type
      (left-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
      (right-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
      (reversed (procedure ((procedure (#!rest) *)) (procedure (#!rest) *)))
      (identities (procedure (#!rest) list))
      (crop-left (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *)))
      (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *))) ) )

;;;

(define (left-section proc . args)
  (lambda xs (##sys#apply proc (##sys#append args xs))))

(define (right-section proc . args)
  (lambda xs (##sys#apply proc (##sys#append xs args))))

(define (crop-left proc n)
  (lambda xs (##sys#apply proc (drop xs n))) )

(define (crop-right proc n)
  (lambda xs (##sys#apply proc (drop-right xs n))) )

(define (reversed proc)
  (lambda xs (##sys#apply proc (reverse xs))))

(define (identities . xs) xs)

;;

(define (apply@ proc . procs)
  (if (null procs)
    (lambda xs (##sys#list (##sys#map proc xs)))
    (let ((procs (##sys#append (##sys#list proc) procs)))
      (lambda xs (##sys#map (lambda (f x) (f x)) procs xs)) ) ) )
  
(define (apply* proc . procs)
  (if (null procs)
    (lambda xs (##sys#list (##sys#apply proc xs)))
    (let ((procs (##sys#append (##sys#list proc) procs)))
      (lambda xs (##sys#map (cut ##sys#apply <> xs) procs)) ) ) )

;;

(define combine@
  (case-lambda
    ((comb proc . procs)
      (let ((reducer (##sys#apply apply@ proc procs)))
        (lambda xs (##sys#apply comb (##sys#apply reducer xs)))) )
    ((comb)
      (lambda procs (##sys#apply combine@ comb procs)) )
    (()
      (lambda (comb) (combine@ comb)) ) ) )

(define combine*
  (case-lambda
    ((comb proc . procs)
      (let ((reducer (##sys#apply apply* procs)))
        (lambda xs (##sys#apply proc (##sys#apply reducer xs)))) )
    ((comb)
      (lambda procs (##sys#apply combine* comb procs)) )
    (()
      (lambda (comb) (combine* comb)) ) ) )

;;

(define uni
  (case-lambda
    ((c f)  (lambda (x) (c (f x))))
    ((c)    (lambda (f) (uni c f)))
    (()     (lambda (c) (uni c)))))

(define uni2
  (case-lambda
    ((c f)  (lambda (x y) (c (f x y))))
    ((c)    (lambda (f) (uni2 c f)))
    (()     (lambda (c) (uni2 c)))))

(define uni3
  (case-lambda
    ((c f)  (lambda (x y z) (c (f x y z))))
    ((c)    (lambda (f) (uni3 c f)))
    (()     (lambda (c) (uni3 c)))))

(define uni@    ; for completeness only
  (case-lambda
    ((c f)  (lambda (x) (c (f x))))))

(define uni*
  (case-lambda
    ((c f)  (lambda xs (c (##sys#apply f xs))))))

;;

(define bi
  (case-lambda
    ((c f g)  (lambda (x) (c (f x) (g x))))
    ((f g)    (lambda (c) (bi c f g)))
    ((c)      (lambda (f g) (bi c f g)))
    (()       (lambda (c) (bi c)))))

(define bi2
  (case-lambda
    ((c f g)  (lambda (x y) (c (f x y) (g x y))))
    ((f g)    (lambda (c) (bi2 c f g)))
    ((c)      (lambda (f g) (bi2 c f g)))
    (()       (lambda (c) (bi2 c)))))

(define bi3
  (case-lambda
    ((c f g)  (lambda (x y z) (c (f x y z) (g x y z))))
    ((f g)    (lambda (c) (bi3 c f g)))
    ((c)      (lambda (f g) (bi3 c f g)))
    (()       (lambda (c) (bi3 c)))))

(define bi@
  (case-lambda
    ((c f)  (lambda (x y) (c (f x) (f y))))))

(define bi*
  (case-lambda
    ((c f g)  (lambda xs (c (##sys#apply f xs) (##sys#apply g xs))))))

;;

(define tri
  (case-lambda
    ((c f g h)  (lambda (x) (c (f x) (g x) (h x))))
    ((f g h)    (lambda (c) (tri c f g h)))
    ((c)        (lambda (f g h) (tri c f g h)))
    (()         (lambda (c) (tri c)))))

(define tri2
  (case-lambda
    ((c f g h)  (lambda (x y) (c (f x y) (g x y) (h x y))))
    ((f g h)    (lambda (c) (tri2 c f g h)))
    ((c)        (lambda (f g h) (tri2 c f g h)))
    (()         (lambda (c) (tri2 c)))))

(define tri3
  (case-lambda
    ((c f g h)  (lambda (x y z) (c (f x y z) (g x y z) (h x y z))))
    ((f g h)    (lambda (c) (tri3 c f g h)))
    ((c)        (lambda (f g h) (tri3 c f g h)))
    (()         (lambda (c) (tri3 c)))))

(define tri@
  (case-lambda
    ((c f)  (lambda (x y z) (c (f x) (f y) (f z))))))

(define tri*
  (case-lambda
    ((c f g h)  (lambda xs (c (##sys#apply f xs) (##sys#apply g xs) (##sys#apply h xs))))))

) ;module section-combinators