From 2ab11d968b1985a5ef2b458946ccdd5c6df1fbb9 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Wed, 17 Mar 2021 09:30:16 -0400
Subject: Include section number in file name.

---
 chapter-2/function-combinators.scm | 361 -------------------------------------
 1 file changed, 361 deletions(-)
 delete mode 100644 chapter-2/function-combinators.scm

(limited to 'chapter-2/function-combinators.scm')

diff --git a/chapter-2/function-combinators.scm b/chapter-2/function-combinators.scm
deleted file mode 100644
index 2b820f2..0000000
--- a/chapter-2/function-combinators.scm
+++ /dev/null
@@ -1,361 +0,0 @@
-;;; 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)
-- 
cgit v1.2.3