Name:
Anonymous
2013-01-02 23:43
(require 'logical)
(define (top-down-build n double increment zero)
(let loop ((n n))
(cond ((zero? n) zero)
((even? n) (double (loop (/ n 2))))
(else (increment (loop (- n 1)))))))
(define (bottom-up-build n double increment zero)
(if (= n 0)
zero
(let loop ((bit-index (- (integer-length n) 1)) (v zero))
(if (= bit-index 0)
(if (logbit? bit-index n)
(increment v)
v)
(if (logbit? bit-index n)
(loop (- bit-index 1) (double (increment v)))
(loop (- bit-index 1) (double v)))))))
(define (id-functor builder)
(lambda (n)
(let ((double (lambda (acc) (* acc 2)))
(increment (lambda (acc) (+ acc 1)))
(zero 0))
(builder n double increment zero))))
(define (exp-functor builder)
(lambda (x n)
(let ((double (lambda (acc) (* acc acc)))
(increment (lambda (acc) (* acc x)))
(zero 1))
(builder n double increment zero))))
(define (fibs-functor builder)
(lambda (n)
(let ((double (lambda (args) (apply (lambda (f1 f2)
(list (* f1 (- (* f2 2) f1))
(+ (* f1 f1) (* f2 f2))))
args)))
(increment (lambda (args) (apply (lambda (f1 f2)
(list f2
(+ f1 f2)))
args)))
(zero (list 0 1)))
(car (builder n double increment zero)))))
(define id_b (id-functor bottom-up-build))
(define id_t (id-functor top-down-build))
(define exp_b (exp-functor bottom-up-build))
(define exp_t (exp-functor top-down-build))
(define fibs_b (fibs-functor bottom-up-build))
(define fibs_t (fibs-functor top-down-build))