Compositions

compositions.rkt

#lang racket


(define (arity f)
  (let ([a (procedure-arity f)])
    (if (number? a)
        a
        #f)))

(define (comp f g)
  (procedure-reduce-arity
   (λ args
     (call-with-values (λ () (apply g args)) f))
   (arity g)))

(define (comp-n . fs)
  (cond
    ((empty? fs) identity)
    (else (comp (first fs)
                (apply comp-n (rest fs))))))

; (arity comp)

(define ((iterate f) n)
  (if (= n 0)
      identity
      (comp f ((iterate f) (- n 1)))))

(define (parallel-apply f g)
  (procedure-reduce-arity
   (λ args
     (values (apply f args)
             (apply g args)))
   (arity f)))

(define (parallel-compose p f g)
  (comp p (parallel-apply f g)))

;(define c1 (parallel-compose (λ (x y) (list x y))
;                             (λ (a b c) (list a b c))
;                             (λ (a b c) (list c b a))))
;(c1 1 2 3)

;(define double-n (iterate (λ (x) (* x 2))))
;((double-n 4) 2)
;
;(define f1 (comp (λ (a b) (* a b))
;                 (λ (c d e) (list (+ c d)
;                                  (+ d e)))))
; (f1 2 3 4)

(define (spread-apply f g)
  (let* ([n (arity f)]
         [m (arity g)])
    (define (compf . args)
      (let ([args-f (take args n)]
            [args-g (drop args n)])
        (values (apply f args-f)
                (apply g args-g))))
    (procedure-reduce-arity compf (+ n m))))

(define (spread-compose p f g)
  (comp p (spread-apply f g)))

;(define f (spread-compose +
;                          (λ (a b c) (* a b c))
;                          (λ (d e) (+ d e))))
;
;(f 1 2 3 4 5)
;
;(arity f)

(define (drop-indices l ixs)
  (let* ([indxs-pairs (for/list ([i l]
                                 [j (range (length l))])
                        (list j i))]
         [retained-pairs (filter (λ (p) (not
                                         (member (first p)
                                                 ixs)))
                                 indxs-pairs)])
    (map second retained-pairs)))

(define (drop-args ixs)
  (λ (f)
    (let ([n (+ (arity f)
                (length ixs))])
      (procedure-reduce-arity
       (λ args
         (apply f (drop-indices args ixs)))
       (+ (arity f)
          (length ixs))))))

;(define d1 (drop-args '(2 4)))
;((d1 (λ (a b c) (+ a b c))) 1 2 3 4 5)
;(arity (d1 (λ (a b c) (+ a b c))))

(define (merge-indices l ixs args)
  (let* ([pairs (for/list ([i ixs]
                           [j args])
                  (list i j))])
    (for/fold ([acc l])
              ([p pairs])
      (append (take acc (first p))
              (list (second p))
              (drop acc (first p))))))

(define ((curry-args ixs) presets)
  (λ (f)
    (procedure-reduce-arity
     (λ args
       (apply f (merge-indices presets ixs args)))
     (length ixs))))

;(define c1 ((curry-args '(0 4)) '(a b c)))
;(define cf (c1 (λ (x a b c y) (list x a b c y))))
;(arity cf)
;(cf 1 2)

(define (permutate spec args)
  (map (λ (i) (list-ref args i)) spec))

(define (permutate-args spec)
  (λ (f)
    (procedure-reduce-arity
     (λ args
       (apply f (permutate spec args)))
     (length spec))))

;(define p1 (permutate-args '(3 1 2 0)))
;(define pf (p1 (λ (a b c d) (list a b c d))))
;(arity pf)
;(pf 'x 'y 'z 'w)
;
;(((permutate-args '(1 2 0 3))
;  (λ (x y z w) (list 'foo x y z w)))
; 'a 'b 'c 'd)
;
;(((permutate-args '(1 1 1 1))
;  (λ (x y z w) (list 'foo x y z w)))
; 'a 'b 'c 'd)

(provide (all-defined-out))