From f1fde932f58e9fffe5a1561756eede8a9e98a44a Mon Sep 17 00:00:00 2001 From: David Thompson 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 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