summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--chapter-2/function-combinators.scm337
1 files changed, 337 insertions, 0 deletions
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)
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-24 19:04:30 +0000