#|-------------------- 1.2.0 |# "./generic-section-combinators.scm" 7201
;;;; generic-section-combinators.scm
;;;; Kon Lovett, Jul '10

!IN PROGRESS!

(module generic-section-combinators

  (;export
    left-hook-each right-hook-each
    left-hook-each+ right-hook-each+
    left-hook-argument-chain right-hook-argument-chain
    left-hook-argument-chain+ right-hook-argument-chain+
    fork-each fork-all
    fork-each+ fork-all+)

  (import
    (except scheme map)
    chicken
    (only data-structures identity)
    (only srfi-1 circular-list map))

  (require-library data-structures srfi-1)

  (declare
    (type
      (left-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
      (right-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
      (left-hook-each+ (procedure (#!rest) (procedure (#!rest) *)))
      (right-hook-each+ (procedure (#!rest) (procedure (#!rest) *)))
      (left-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
      (right-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
      (left-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *)))
      (right-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *)))
      (fork-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
      (fork-all (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
      (fork-each+ (procedure (#!rest) (procedure (#!rest) *)))
      (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) ))

  (include "arguments-helpers.inc")

;;; Hook

(define (left-arguments-X . fns)
  (lambda xs ((X-funcs (cons fns list)) xs)) )

(define (right-arguments-X . fns)
  (lambda xs ((X-funcs (cons list fns)) xs)) )

?????
(left-hook-X c fn0 ... fnn) = (arguments-chain c (arguments-X fn0 ... fnn list))
(right-hook-X c fn0 ... fnn) = (arguments-chain c (arguments-X list fn0 ... fnn))

;; left-hook-each

; ((left-hook-each c f g) arg...) -> (apply c (f arg0) (g arg1) ... argn...)
; ((left-hook-each c f) arg...) -> (apply c (f arg0) ... (f argn) arg...)
; ((left-hook-each c) arg...) -> (apply c arg...)

(define (left-hook-each c . fns)
  (if (null? fns) (lambda xs (apply c xs))
    (let ((fn (each-func fns)))
      (lambda xs (apply c (append (list (fn xs)) xs))) ) ) )

;; right-hook-each

; ((right-hook-each c f g) arg...) -> (apply c argn... (f arg0) (g arg1) ...)
; ((right-hook-each c f) arg...) -> (apply c arg... (f arg0) ... (f argn))
; ((right-hook-each c) arg...) -> (apply c arg...)

(define (right-hook-each c . fns)
  (if (null? fns) (lambda xs (apply c xs))
    (let ((fn (each-func fns)))
      (lambda xs (apply c (append xs (list (fn xs))))) ) ) )

;; left-hook-each+ a left-hook-each that curries it's functions

; (left-hook-each+ c func...) -> (apply left-hook-each c func...)
; (left-hook-each+ c) -> (lambda (func...) (apply left-hook-each+ c func...))
; (left-hook-each+) -> (lambda (c) (left-hook-each+ c))

(define (left-hook-each+ . fns)
  (if (null? fns) (lambda (c) (left-hook-each+ c))
    (let ((c (car fns)) (fns (cdr fns)))
      (if (null? fns) (lambda fns (apply left-hook-each+ c fns))
        (apply left-hook-each c fns) ) ) ) )

;; right-hook-each+ a left-hook-each that curries it's functions

; (right-hook-each+ c func...) -> (apply right-hook-each c func...)
; (right-hook-each+ c) -> (lambda (func...) (apply right-hook-each+ c func...))
; (right-hook-each+) -> (lambda (c) (right-hook-each+ c))

(define (right-hook-each+ . fns)
 (if (null? fns) (lambda (c) (right-hook-each+ c))
    (let ((c (car fns)) (fns (cdr fns)))
      (if (null? fns) (lambda fns (apply right-hook-each+ c fns))
        (apply right-hook-each c fns) ) ) ) )

;; left-hook-argument-chain

; ((left-hook-argument-chain c f g) arg...) -> (apply c (apply f (apply g arg...)) arg...)
; ((left-hook-argument-chain c f) arg...) -> (apply c (apply f arg...) arg...)
; ((left-hook-argument-chain c) arg...) -> (apply c arg...)

(define (left-hook-argument-chain c . fns)
  (let ((c (car fns))
        (fns (cdr fns)) )
    (if (null? fns) (lambda xs (apply c xs))
      (lambda xs (apply c (chain-recur fns xs) xs)) ) ) )

;; right-hook-argument-chain

; ((right-hook-argument-chain c f g) arg...) -> (apply c arg... (apply f (apply g arg...)))
; ((right-hook-argument-chain c f) arg...) -> (apply c arg... (apply f arg...))
; ((right-hook-argument-chain c) arg...) -> (apply c arg...)

(define (right-hook-argument-chain c . fns)
  (let ((c (car fns))
        (fns (cdr fns)) )
    (if (null? fns) (lambda xs (apply c xs))
      (lambda xs (apply c (append xs (list (chain-recur fns xs))))) ) ) )

;; left-hook-argument-chain+ a left-hook-argument-chain that curries it's functions

; (left-hook-argument-chain+ c func...) -> (apply left-hook-argument-chain c func...)
; (left-hook-argument-chain+ c) -> (lambda (func...) (apply left-hook-argument-chain+ c func...))
; (left-hook-argument-chain+) -> (lambda (c) (left-hook-argument-chain+ c))

(define (left-hook-argument-chain+ . fns)
  (if (null? fns) (lambda (c) (left-hook-argument-chain+ c))
    (let ((c (car fns)) (fns (cdr fns)))
      (if (null? fns) (lambda fns (apply left-hook-argument-chain+ c fns))
        (apply left-hook-argument-chain c fns) ) ) ) )

;; right-hook-argument-chain+ a right-hook-argument-chain that curries it's functions

; (right-hook-argument-chain+ c func...) -> (apply right-hook-argument-chain c func...)
; (right-hook-argument-chain+ c) -> (lambda (func...) (apply right-hook-argument-chain+ c func...))
; (right-hook-argument-chain+) -> (lambda (c) (right-hook-argument-chain+ c))

(define (right-hook-argument-chain+ . fns)
 (if (null? fns) (lambda (c) (right-hook-argument-chain+ c))
    (let ((c (car fns)) (fns (cdr fns)))
      (if (null? fns) (lambda fns (apply right-hook-argument-chain+ c fns))
        (apply right-hook-argument-chain c fns) ) ) ) )

;;; Fork

;; fork-each

; (fork-each c func...) -> (lambda xs (apply c (apply (apply arguments-each func...) xs)))

(define (fork-each c . fns)
  (let ((fn (each-func fns)))
    (lambda xs (apply c (fn xs))) ) )

;; fork-all

; (fork-all c func...) -> (lambda xs (apply c (apply (apply arguments-all func...) xs)))

(define (fork-all c . fns)
  (let ((fn (all-func fns)))
    (lambda xs (apply c (fn xs))) ) )

;; fork-each+ a fork-each that curries it's functions

; (fork-each+ c func...) -> (apply fork-each c func...)
; (fork-each+ c) -> (lambda (func...) (apply fork-each+ c func...))
; (fork-each+) -> (lambda (c) (fork-each+ c))

(define (fork-each+ . fns)
  (if (null? fns) (lambda (c) (fork-each+ c))
    (let ((c (car fns)) (fns (cdr fns)))
      (if (null? fns) (lambda fns (apply fork-each+ c fns))
        (apply fork-each c fns) ) ) ) )

;; fork-all+ a fork-all that curries it's functions

; (fork-all+ c func...) -> (apply fork-all c func...)
; (fork-all+ c) -> (lambda (func...) (apply fork-all+ c func...))
; (fork-all+) -> (lambda (c) (fork-all+ c))

(define (fork-all+ . fns)
  (if (null? fns) (lambda (c) (fork-all+ c))
    (let ((c (car fns)) (fns (cdr fns)))
      (if (null? fns) (lambda fns (apply fork-all+ c fns))
        (apply fork-all c fns) ) ) ) )

) ;module generic-section-combinators

#|-------------------- 1.2.0 |# "./arguments-helpers.inc" 997
;;;; arguments-helpers.inc
;;;; Kon Lovett, Jul '10

;;; Helpers

(define-inline (chain-recur fns xs)
  ; assume the length of fns is << so recursion depth is also <<
  (let recur ((fns fns))
    (if (null? fns) xs
      (apply (car fns) (recur (cdr fns))) ) ) )

(define-inline (chain-func fns)
  (cond
    ((null? fns)
      identity )
    ((null? (cdr fns))
      (let ((f (car fns)))
        (lambda (xs) (apply f xs)) ) )
    (else
      (lambda (xs) (chain-recur fns xs)) ) ) )

(define-inline (each-func fns)
  (cond
    ((null? fns)
      identity )
    ((null? (cdr fns))
      (let ((f (car fns)))
        (lambda (xs) (map (cut f <>) xs)) ) )
    (else
      (let ((fns (apply circular-list fns)))
        (lambda (xs) (map (cut <> <>) fns xs)) ) ) ) )

(define-inline (all-func fns)
  (cond
    ((null? fns)
      identity )
    ((null? (cdr fns))
      (let ((f (car fns)))
        (lambda (xs) (list (apply f xs))) ) )
    (else
      (lambda (xs) (map (cut apply <> xs) fns)) ) ) )

#|-------------------- 1.2.0 |# "./bi-combinators.scm" 1263
;;;; bi-combinators.scm
;;;; Kon Lovett, Jul '10

(module bi-combinators

  (;export
    bi bi2 bi3 bi-each bi-all)

  (import
    scheme
    chicken)

#|
;;; Hook

;; Binary

(define (bi-each-left c f)
  (lambda (x y) (c (f x) (f y) x y)) )

(define (bi-each-right c f)
  (lambda (x y) (c x y (f x) (f y))) )

(define (bi-all-left c f g)
  (lambda xs (apply c (apply f xs) (apply g xs) xs)) )

(define (bi-all-right c f g)
  (lambda xs (apply c (append xs (list (apply f xs) (apply g xs))))) )
|#

;;; Fork

;; Binary

(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-each c f)
  (lambda (x y) (c (f x) (f y))) )

(define (bi-all c f g)
  (lambda xs (c (apply f xs) (apply g xs))) )

) ;module bi-combinators

#|-------------------- 1.2.0 |# "./combinators.meta" 518
;;;; combinators.meta  -*- Hen -*-

((egg "combinators.egg")
 (category data)
 (author "[[kon lovett]]")
 (license "Public Domain")
 (doc-from-wiki)
 (synopsis "Combinators")
 (depends (setup-helper "1.2.0"))
 (test-depends test)
 (files "logical-combinators.scm" "section-combinators.scm" "combinators.meta" "uni-combinators.scm" "generic-section-combinators.scm" "combinators.setup" "arguments-helpers.inc" "stack-combinators.scm" "tri-combinators.scm" "bi-combinators.scm" "sort-combinators.scm" "tests/run.scm") )

#|-------------------- 1.2.0 |# "./combinators.setup" 1359
;;;; "combinators.setup  -*- Hen -*-

(include "setup-helper")

(verify-extension-name "combinators")

(setup-shared-extension-module 'uni-combinators (extension-version "1.2.0")
  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))

(setup-shared-extension-module 'bi-combinators (extension-version "1.2.0")
  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))

(setup-shared-extension-module 'tri-combinators (extension-version "1.2.0")
  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))

(setup-shared-extension-module 'section-combinators (extension-version "1.2.0")
  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))

#;
(setup-shared-extension-module 'generic-section-combinators (extension-version "1.2.0")
  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))

(setup-shared-extension-module 'logical-combinators (extension-version "1.2.0")
  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))

(setup-shared-extension-module 'sort-combinators (extension-version "1.2.0")
  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))

(setup-shared-extension-module 'stack-combinators (extension-version "1.2.0")
  #:compile-options '(-scrutinize -optimize-level 3 -lambda-lift))

(install-extension 'combinators '() `((version ,(extension-version "1.2.0"))))

#|-------------------- 1.2.0 |# "./logical-combinators.scm" 636
;;;; logical-combinators.scm
;;;; Kon Lovett, Mar '09

(module logical-combinators

  (;export
    andf
    orf)

  (import scheme chicken data-structures srfi-1)

  (declare
    (type
      (andf (procedure (#!rest) *))
      (orf (procedure (#!rest) *)) ) )

;; Eager 'or' & 'and'

(define (andf . args)
  (let loop ((args args) (prev #t))
    (if (null? args) prev
        (let ((cur (car args)))
          (and cur
               (loop (cdr args) cur) ) ) ) ) )

(define (orf . args)
  (let loop ((args args))
    (and (not (null? args))
         (or (car args)
             (loop (cdr args)) ) ) ) )

) ;module logical-combinators

#|-------------------- 1.2.0 |# "./section-combinators.scm" 2410
;;;; section-combinators.scm
;;;; Kon Lovett, Jul '10

(module section-combinators

  (;export
    left-section right-section
    crop-left crop-right
    reversed
    arguments-chain arguments-each arguments-all)

  (import
    scheme
    chicken
    (only srfi-1 drop drop-right circular-list)
    (only data-structures identity))

  (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) *)))
      (crop-left (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *)))
      (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *)))
      (arguments-chain (procedure (#!rest) (procedure (#!rest) *)))
      (arguments-each (procedure (#!rest) (procedure (#!rest) list)))
      (arguments-all (procedure (#!rest) (procedure (#!rest) list))) ) )

;;; Section

(define (left-section fn . args)
  (lambda xs (apply fn (append args xs))) )

; (reverse (append (reverse args) (reverse xs))) = (append xs args)
(define (right-section fn . args)
  (lambda xs (apply fn (append xs args))) )

;;; Crop

; (compose fn (right-section drop n) list)
(define (crop-left fn n)
  (lambda xs (apply fn (drop xs n))) )

; (compose fn (right-section drop-right n) list)
(define (crop-right fn n)
  (lambda xs (apply fn (drop-right xs n))) )

;;; Reverse

; (compose fn reverse list)
(define (reversed fn)
  (lambda xs (apply fn (reverse xs))) )

;;; Argument

  (include "arguments-helpers.inc")

;; arguments-chain

; ((arguments-chain f g) arg...) -> (apply f (apply g arg...))
; ((arguments-chain f) arg...) -> (apply f arg...)
; ((arguments-chain) arg...) -> (list arg...)

(define (arguments-chain . fns)
  (let ((fn (chain-func fns)))
    (lambda xs (fn xs)) ) )

;; arguments-each

; ((arguments-each f g h) a b c d e) -> (list (f a) (g b) (h c) (f d) (g e))
; ((arguments-each) arg...) -> (list arg...)

(define (arguments-each . fns)
  (let ((fn (each-func fns)))
    (lambda xs (fn xs)) ) )

;; arguments-all

; ((arguments-all f g h) a b c) -> (list (f a b c) (g a b c) (h a b c))
; ((arguments-all) arg...) -> (list arg...)

(define (arguments-all . fns)
  (let ((fn (all-func fns)))
    (lambda xs (fn xs)) ) )

) ;module section-combinators

#|-------------------- 1.2.0 |# "./sort-combinators.scm" 2236
;;;; sort-combinators.scm
;;;; Kon Lovett, Mar '09

;; Issues
;;
;; - group/key is not a combinator

(module sort-combinators (;export
  group-by group/key
  make-equal/key make-less-than/key)

  (import
    scheme
    chicken
    (only srfi-1 span)
    (only bi-combinators bi-each))

  (require-library srfi-1 bi-combinators)

  (declare
    (type
      (group-by (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (list) list)))
      (group/key (procedure ((procedure (*) *) list #!optional (procedure (* *) boolean)) list))
      (make-less-than/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean)))
      (make-equal/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean))) ) )

;;

;kinda violates the argument list orientation of comibinators
(define (group-by proc #!optional (equals equal?))
  (lambda (ls)
    (let loop ((ls ls) (acc '()))
      (if (null? ls) acc #;(reverse! acc)
          (let ((key (proc (car ls))))
            (receive (grouped rest) (span (lambda (item) (equals key (proc item))) ls)
              (loop rest (cons grouped acc)) ) ) ) ) ) )

;; Group a list of elements by some key attribute.
;;
;; The list must be in sorted order with respect to the key.
;;
;; examples:
;; (group/key identity '(1 2 3 3 4 4 4)) --> ((1) (2) (3 3) (4 4 4))
;; (group/key car '((a 1) (a 2) (b 1))) --> '(((a 1) (a 2)) ((b 1)))

(define (group/key keyproc ls #!optional (equals equal?))
  ((group-by keyproc equals) ls) )

;; Define a less-than function for a sort of a structured sequence.
;;
;; E.g. to sort a list of lists by their first items, using
;; string-case-insensitive comparison:
;; (sort ls (make-less-than/key first string-ci<?))

(define (make-less-than/key keyproc #!optional (less-than <))
  (bi-each less-than keyproc) )

;; Define a equal function for a sort of a structured sequence.
;;
;; E.g. to sort a list of lists by their first items, using
;; string-case-insensitive comparison:
;; (make-hash-table (o string-ci-hash first) (make-equal/key first string-ci=?))

(define (make-equal/key keyproc #!optional (equals =))
  (bi-each equals keyproc) )

) ;module sort-combinators

#|-------------------- 1.2.0 |# "./stack-combinators.scm" 3467
;;;; stack-combinators.scm
;;;; Kon Lovett, Mar '09
;;;; Portions from a 'comp.lang.scheme' posting by "wayo.cavazos@gmail.com"

;These are useless & sigle valued!

(module stack-combinators

  (;export
    uni uni2 uni3 uni@
    bi bi2 bi3 bi@
    tri tri2 tri3 tri@
    dip
    dup dupd
    swap
    drop drop/2)
  
  (import scheme chicken)

;;

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

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

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

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

;;

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

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

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

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

;;

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

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

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

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

;;

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

;;

(define dup
  (case-lambda
    ((x c)  (c x x))
    ((c)    (lambda (x) (dup x c)))))

(define dupd
  (case-lambda
    ((x y c)  (c x x y))
    ((c)      (lambda (x y) (dupd x y c)))))

;;

(define swap
  (case-lambda
    ((x y c)  (c y x))
    ((c)      (lambda (x y) (swap x y c)))))

;;

(define drop
  (case-lambda
    ((x c)  (c))
    ((c)    (lambda (x) (drop x c)))))

(define drop/2
  (case-lambda
    ((x y c)  (c x))
    ((c)      (lambda (x y) (drop/2 x y c)))))

) ;module stack-combinators

#|-------------------- 1.2.0 |# "./tri-combinators.scm" 1038
;;;; tri-combinators.scm
;;;; Kon Lovett, Jul '10

(module tri-combinators

  (;export
    tri tri2 tri3 tri-each tri-all)

  (import
    scheme
    chicken)

;;; Hook

;;; Fork

;; Trinary

(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-each c f)
  (lambda (x y z) (c (f x) (f y) (f z))) )

(define (tri-all c f g h)
  (lambda xs (c (apply f xs) (apply g xs) (apply h xs))) )

) ;module tri-combinators

#|-------------------- 1.2.0 |# "./uni-combinators.scm" 2013
;;;; uni-combinators.scm
;;;; Kon Lovett, Jul '10

(module uni-combinators

  (;export
    uni uni2 uni3 uni-each uni-all)

  (import
    scheme
    chicken)

#|
;;; Hook

;; Unary

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

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

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

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

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

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

(define (uni-each-left c f)
  (lambda (x) (c (f x) x)) )

(define (uni-each-right c f)
  (lambda (x) (c x (f x))) )

(define (uni-all-left c f)
  (lambda xs (apply c (apply f xs) xs)) )

(define (uni-all-right c f)
  (lambda xs (apply c (append xs (list (apply f xs))))) )
|#

;;; Fork

;; Unary

(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-each c f)
  (lambda (x) (c (f x))) )

(define (uni-all c f)
  (lambda xs (c (apply f xs))) )

) ;module uni-combinators