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/2.1-function-combinators.scm | 361 +++++++++++++++++++++++++++++++++
 chapter-2/function-combinators.scm     | 361 ---------------------------------
 2 files changed, 361 insertions(+), 361 deletions(-)
 create mode 100644 chapter-2/2.1-function-combinators.scm
 delete mode 100644 chapter-2/function-combinators.scm

(limited to 'chapter-2')

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