From f1fde932f58e9fffe5a1561756eede8a9e98a44a Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Wed, 17 Mar 2021 07:48:46 -0400
Subject: Add code for chapter 2's function combinators section.

---
 chapter-2/function-combinators.scm | 337 +++++++++++++++++++++++++++++++++++++
 1 file changed, 337 insertions(+)
 create 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
new file mode 100644
index 0000000..a55debb
--- /dev/null
+++ b/chapter-2/function-combinators.scm
@@ -0,0 +1,337 @@
+(use-modules (srfi srfi-11))
+
+(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)
+
+(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.
+
+
+;; 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"))
+   ((= (length procs) 1)
+    (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