path: root/chapter-2/2.1-function-combinators.scm

;;; Copyright © 2021 Gerald Sussman and Chris Hanson
;;; Copyright © 2021 David Thompson <dthompson2@worcester.edu>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(use-modules (srfi srfi-11))


;; 2.1.1 Function combinators

(define (compose f g)
  (lambda args
    (f (apply g args))))

((compose (lambda (x) (list 'foo x))
          (lambda (x) (list 'bar x)))
 'z)

(define (identity x) x)

;; Could use (ice-9 curried-definitions) and use the exact code in the
;; book.
(define (iterate n)
  (lambda (f)
    (if (= n 0)
        identity
        (compose f ((iterate (- n 1)) f)))))

(define (square x) (* x x))

(((iterate 3) square) 5)

(define (parallel-combine h f g)
  (lambda args
    (h (apply f args) (apply g args))))

((parallel-combine list
                   (lambda (x y z) (list 'foo x y z))
                   (lambda (u v w) (list 'bar u v w)))
 'a 'b 'c)


;; Arity

(define (get-arity f)
  (let ((arity (procedure-minimum-arity f)))
    (if arity (car arity) 0)))

(define (restrict-arity f n)
  (set-procedure-minimum-arity! f n 0 #f)
  f)

(define-syntax-rule (assert cond)
  (unless cond
    (error "assertion failed" 'cond)))

(define (spread-combine h f g)
  (let* ((n (get-arity f))
         (m (get-arity g))
         (t (+ n m)))
    (define (the-combination . args)
      (assert (= (length args) t))
      (h (apply f (list-head args n))
         (apply g (list-tail args n))))
    (restrict-arity the-combination t)))

((spread-combine list
                 (lambda (x y) (list 'foo x y))
                 (lambda (u v w) (list 'bar u v w)))
 'a 'b 'c 'd 'e)


;; Exercise 2.1: Arity repair

(define (compose f g)
  (let ((n (get-arity f))
        (m (get-arity g)))
    (assert (= n 1))
    (define (the-composition . args)
      (assert (= (length args) m))
      (f (apply g args)))
    (restrict-arity the-composition m)))

(define (parallel-combine h f g)
  (let ((n (get-arity h))
        (m (get-arity f))
        (l (get-arity g)))
    (assert (= m l))
    (define (the-combination . args)
      (assert (= (length args) m))
      (h (apply f args) (apply g args)))
    (restrict-arity the-combination m)))


;; Exercise 2.2: Arity extension

;; Not sure how to accomplish this in Guile, honestly.  There is no
;; equivalent of procedure-arity-max that I can find.


;; Multiple values

(define (compose f g)
  (let ((n (get-arity g)))
    (define (the-composition . args)
      (assert (= (length args) n))
      (call-with-values (lambda () (apply g args))
        f))
    (restrict-arity the-composition n)))

(define (spread-apply f g)
  (let* ((n (get-arity f))
         (m (get-arity g))
         (t (+ n m)))
    (define (the-combination . args)
      (assert (= (length args) t))
      (let-values ((fv (apply f (list-head args n)))
                   (gv (apply g (list-tail args n))))
        (apply values (append fv gv))))
    (restrict-arity the-combination t)))

(define (spread-combine h f g)
  (compose h (spread-apply f g)))

((spread-combine list
                 (lambda (x y) (values x y))
                 (lambda (u v w) (values u v w)))
 'a 'b 'c 'd 'e)


;; Exercise 2.4: A quickie

(define (parallel-combine h f g)
  (let ((n (get-arity h))
        (m (get-arity f))
        (l (get-arity g)))
    (assert (= m l))
    (define (the-combination . args)
      (assert (= (length args) m))
      (let-values ((fv (apply f args))
                   (gv (apply g args)))
        (apply h (append fv gv))))
    (restrict-arity the-combination m)))

((parallel-combine list
                   (lambda (x y z) (values x y z))
                   (lambda (u v w) (values u v w)))
 'a 'b 'c)


;;; A small library

(define (list-remove l i)
  (if (= i 0)
      (cdr l)
      (cons (car l) (list-remove (cdr l) (- i 1)))))

(define (discard-argument i)
  (assert (and (exact-integer? i) (>= i 0)))
  (lambda (f)
    (let ((m (+ (get-arity f) 1)))
      (define (the-combination . args)
        (assert (= (length args) m))
        (apply f (list-remove args i)))
      (assert (< i m))
      (restrict-arity the-combination m))))

(((discard-argument 2)
  (lambda (x y z) (list 'foo x y z)))
 'a 'b 'c 'd)

(define (list-insert l i x)
  (if (= i 0)
      (cons x l)
      (cons (car l) (list-insert (cdr l) (- i 1) x))))

(define (curry-argument i)
  (lambda args
    (lambda (f)
      (assert (= (length args) (- (get-arity f) 1)))
      (lambda (x)
        (apply f (list-insert args i x))))))

((((curry-argument 2) 'a 'b 'c)
  (lambda (x y z w) (list 'foo x y z w)))
 'd)

(define (make-permutation permspec)
  (define (the-permuter lst)
    (map (lambda (p) (list-ref lst p))
         permspec))
  the-permuter)

(define (permute-arguments . permspec)
  (let ((permute (make-permutation permspec)))
    (lambda (f)
      (define (the-combination . args)
        (apply f (permute args)))
      (let ((n (get-arity f)))
        (assert (= n (length permspec)))
        (restrict-arity the-combination n)))))

(((permute-arguments 1 2 0 3)
  (lambda (x y z w) (list 'foo x y z w)))
 'a 'b 'c 'd)


;; Exercise 2.4: As compositions?

(define (discard-argument i)
  (assert (and (exact-integer? i) (>= i 0)))
  (lambda (f)
    (let ((n (+ (get-arity f) 1)))
      (define (the-combination . args)
        (assert (= (length args) n))
        (apply values (list-remove args i)))
      (assert (< i n))
      (compose f (restrict-arity the-combination n)))))

(((discard-argument 2)
  (lambda (x y z) (list 'foo x y z)))
 'a 'b 'c 'd)

(define (curry-argument i)
  (lambda args
    (lambda (f)
      (assert (= (length args) (- (get-arity f) 1)))
      (compose f (lambda (x)
                   (apply values (list-insert args i x)))))))

((((curry-argument 2) 'a 'b 'c)
  (lambda (x y z w) (list 'foo x y z w)))
 'd)

(define (permute-arguments . permspec)
  (let ((permute (make-permutation permspec)))
    (lambda (f)
      (define (the-combination . args)
        (apply values (permute args)))
      (let ((n (get-arity f)))
        (assert (= n (length permspec)))
        (compose f (restrict-arity the-combination n))))))

(((permute-arguments 1 2 0 3)
  (lambda (x y z w) (list 'foo x y z w)))
 'a 'b 'c 'd)


;; Exercise 2.5: Useful combinators

;; a - generalized {discard,curry}-argument

(define (make-discarder discard-spec)
  (define (the-discarder lst)
    (let loop ((spec discard-spec)
               (lst lst))
      (if (null? spec)
          lst
          (loop (cdr spec) (list-remove lst (car spec))))))
  the-discarder)

(define (discard-arguments . discard-spec)
  (let ((discarder (make-discarder discard-spec)))
    (lambda (f)
      (let ((n (+ (get-arity f) (length discard-spec))))
        (define (the-combination . args)
          (assert (= (length args) n))
          (apply values (discarder args)))
        (assert (< (length discard-spec) n))
        (compose f (restrict-arity the-combination n))))))

(((discard-arguments 0 2)
  (lambda (x y) (list 'foo x y)))
 'a 'b 'c 'd)

(define (make-currier curry-spec args)
  (define (the-currier lst)
    (let loop ((spec curry-spec)
               (lst lst)
               (args args))
      (if (null? spec)
          args
          (let ((i (car spec)))
            (loop (cdr spec) (cdr lst) (list-insert args i (car lst)))))))
  the-currier)

(define (curry-arguments . curry-spec)
  (lambda args
    (let ((currier (make-currier curry-spec args)))
      (lambda (f)
        (let ((n (length curry-spec)))
          (define (the-combination . args)
            (assert (= (length args) n))
            (apply values (currier args)))
          (assert (= (length args) (- (get-arity f) n)))
          (compose f (restrict-arity the-combination n)))))))

((((curry-arguments 1 2) 'a 'b 'c)
  (lambda (x y z w v) (list 'foo x y z w v)))
 'd 'e)


;; b - other useful combinators

(define (memoize f)
  (let ((cache (make-hash-table))
        (n (get-arity f)))
    (define (the-combination . args)
      (assert (= (length args) n))
      (let ((cached-values (hash-ref cache args)))
        (if cached-values
            (apply values cached-values)
            (let-values ((fv (apply f args)))
              (hash-set! cache args fv)
              (apply values fv)))))
    (restrict-arity the-combination n)))

(define memoize-test
  (memoize
   (lambda (x)
     (* x 3))))

(memoize-test 2) ; cache miss
(memoize-test 3) ; cache miss
(memoize-test 2) ; cache hit


;; c - compose with any number of args

(define (compose . procs)
  (cond
   ((null? procs)
    (error "must pass at least one procedure"))
   ((null? (cdr procs))
    (car procs))
   (else
    (let* ((f (car procs))
           (g (apply compose (cdr procs)))
           (n (get-arity g)))
      (define (the-composition . args)
        (assert (= (length args) n))
        (call-with-values (lambda () (apply g args))
          f))
      (restrict-arity the-composition n)))))

((compose (lambda (x) (list 'foo x))
          (lambda (x y z) (list 'bar x y z))
          (lambda (x y) (values 'baz x y)))
 'z 'w)