My solutions to exercises in SICP Book. (Warning: May have bugs or be wrong)

SICP Exercises.scm

(define true #t)
(define false #f)

(define pi 3.14159)
(define radius 10)
(* pi (* radius radius))
(define circumference (* 2 pi radius))
(define (square x) (* x x))
(define (sum-of-squares x y)
  (+ (square x) (square y)))

(define (f a)
  (sum-of-squares (+ a 1) (+ a 2)))

(define (abs x)
  (cond ((= x 0) 0)
	((> x 0) x)
	((< x 0) (- x))))

(define (abs x)
  (cond ((< x 0) (- x))
	(else x)))

(define (abs x)
  (if (< x 0)
      (- x)
      x))

; Exercise 1.2
(/
 (+ 5 4 (- 2 (- 3 (+ 6 (/ 4 5)))))
 (* 3 (- 6 2) (- 2 7)))

; Exercise 1.3

(define (g a b c)
  (cond ((and (< a b) (< a c)) (sum-of-squares b c))
	((and (< b c) (< b a)) (sum-of-squares a c))
	((and (< c a) (< c b)) (sum-of-squares a b))))

; Exercise 1.5
; (define (p) (p))

(define (test x y)
  (if (= x 0)
      0
      y))

; Runs forever for applicative-order
; (test 0 (p))

; 1.1.7 Example
(define (sqrt-iter guess x)
  (if (good-enough? guess x)
      guess
      (sqrt-iter (improve guess x) x)))

(define (improve guess x)
  (average guess (/ x guess)))

(define (average x y)
  (/ (+ x y) 2))

(define (good-enough? guess x)
  (< (abs (- (square guess) x)) 0.001))

(define (sqrt x)
  (sqrt-iter 1.0 x))

; Exercise 1.7
(define (better-good-enough? guess old-guess)
  (< (abs (- old-guess guess)) 0.001))

(define (sqrt-iter-better guess old-guess x)
  (if (better-good-enough? guess old-guess)
      guess
      (sqrt-iter-better (improve guess x) guess x)))

(define (sqrt-better x)
  (sqrt-iter-better (improve 1.0 x) 1.0 x))

; Exercise 1.8
(define (cube-root-iter guess old-guess x)
  (if (better-good-enough? guess old-guess)
      guess
      (cube-root-iter (improve-cube guess x) guess x)))

(define (improve-cube guess x)
  (/ (+ (/ x (square guess)) (* 2 guess)) 3))

(define (cube-root x)
  (cube-root-iter (improve-cube 1.0 x) 1.0 x))


(define (sqrt x)
  (define (good-enough? guess prev-guess)
    (< (/ (abs (- guess prev-guess)) guess) 0.001))
  (define (improve guess)
    (average guess (/ x guess)))
  (define (sqrt-iter guess prev-guess)
    (if (good-enough? guess prev-guess)
	guess
	(sqrt-iter (improve guess) guess)))
  (sqrt-iter (improve 1.0) 1.0))

; Sec 1.2
(define (factorial n)
  (if (= n 1)
      1
      (* n (factorial (- n 1)))))

(define (factorial n)
  (factorial-iter 1 1 n))

(define (factorial-iter product counter max-count)
  (if (> counter max-count)
      product
      (factorial-iter (* product counter)
		      (+ counter 1)
		      max-count)))
; Exercise 1.10
(define (A x y)
  (cond ((= y 0) 0)
        ((= x 0) (* 2 y))
        ((= y 1) 2)
        (else (A (- x 1)
                 (A x (- y 1))))))

(define (f n) (A 0 n))
(define (g n) (A 1 n))
(define (h n) (A 2 n))
(define (k n) (* 5 n n))

; 1.2.2
(define (fib n)
  (cond ((= n 0) 0)
	((= n 1) 1)
	(else (+ (fib (- n 1))
		 (fib (- n 2))))))

(define (fib n)
  (fib-iter 1 0 n))

(define (fib-iter a b n)
  (if (= n 0)
      b
      (fib-iter (+ a b) a (- n 1))))

; Example: Count Change
(define (count-change amount)
  (cc amount 5))

(define (cc amount kinds-of-coins)
  (cond ((= amount 0) 1)
	((or (< amount 0) (= kinds-of-coins 0)) 0)
	(else (+ (cc amount
		     (- kinds-of-coins 1))
		 (cc (- amount
			(first-denomination kinds-of-coins))
		     kinds-of-coins)))))

(define (first-denomination kinds-of-coins)
  (cond ((= kinds-of-coins 1) 1)
	((= kinds-of-coins 2) 5)
	((= kinds-of-coins 3) 10)
	((= kinds-of-coins 4) 25)
	((= kinds-of-coins 5) 50)))

; Exercise 1.11
(define (f n)
  (cond ((< n 3) n)
	(else (+ (f (- n 1))
		 (* 2 (f (- n 2)))
		 (* 3 (f (- n 3)))))))

(define (f n)
  (f-iter 2 1 0 0 n))

(define (f-iter a b c counter max-count)
  (cond ((= counter max-count) c)
	(else (f-iter (+ a (* 2 b) (* 3 c))
		      a
		      b
		      (+ counter 1)
		      max-count))))
; Exercise 1.12
(define (pascal x y)
  (cond ((= y 1) 1)
	((= y 2) 1)
	((= x 1) 1)
	((= x y) 1)
	(else (+ (pascal (- x 1) (- y 1))
		 (pascal x (- y 1))))))

; Exercise 1.13
(define phi
   (/ (+ 1 (sqrt 5)) 2))

(define (^ base exponent)
   (define (*^ exponent acc)
       (if (= exponent 0)
           acc
           (*^ (- exponent 1) (* acc base))))
   (*^ exponent 1))

(define (f n)
   (/ (^ phi n) (sqrt 5)))


; Exercise 1.15
(define (cube x) (* x x x))
(define (p x) (- (* 3 x) (* 4 (cube x))))
(define (sine angle)
   (if (not (> (abs angle) 0.1))
       angle
       (p (sine (/ angle 3.0)))))



(define (expt b n)
  (if (= n 0)
      1
      (* b (expt b (- n 1)))))

(define (expt b n)
  (expt-iter 1 b n))

(define (expt-iter product b counter)
  (cond ((= counter 0) product)
	(else (expt-iter (* b product)
			 b
			 (- counter 1)))))

(define (fast-expt b n)
  (cond ((= n 0) 1)
	((even? n) (square (fast-expt b (/ n 2))))
	(else (* b (fast-expt b (- n 1))))))

(define (even? n)
  (= (remainder n 2) 0))

; Exercise 1.16

(define (fast-expt b n)
  (fast-expt-iter 1 b n))

(define (fast-expt-iter a b n)
  (cond ((= n 0) a)
	((even? n) (fast-expt-iter
		    a
		    (* b b)
		    (/ n 2)))
	(else (fast-expt-iter
	       (* a b)
	       b
	       (- n 1)))))

; Exercise 1.17

(define (mul a b)
  (cond ((= b 0) 0)
	((even? b) (mul (* a 2) (/ b 2)))
	(else (+ a (mul a (- b 1))))))

; Exercise 1.18
(define (mul a b)
  (mul-iter 0 a b))

(define (mul-iter i a b)
  (cond ((= b 0 ) i)
	((even? b) (mul-iter i
			     (* a 2)
			     (/ b 2)))
	(else (mul-iter (+ i a)
			a
			(- b 1)))))


(define (fib n)
   (fib-iter 1 0 0 1 n))

(define (fib-iter a b p q count)
   (cond ((= count 0) b)
         ((even? count)
          (fib-iter a
                    b
                    (+ (* p p) (* q q))     ; compute p'
                    (+ (* 2 p q) (* q q))   ; compute q'
                    (/ count 2)))
         (else (fib-iter (+ (* b q) (* a q) (* a p))
                         (+ (* b p) (* a q))
                         p
                         q
                         (- count 1)))))



; 1.2.5 GCD
(define (gcd a b)
  (if (= b 0)
      a
      (gcd b (remainder a b))))


; 1.2.6 Primality
(define (smallest-divisor n)
  (find-divisor n 2))
(define (find-divisor n test-divisor)
  (cond ((> (square test-divisor) n) n)
        ((divides? test-divisor n) test-divisor)
        (else (find-divisor n (next test-divisor)))))

(define (next n)
  (cond ((= n 2) 3)
	(else (+ n 2))))

(define (divides? a b)
  (= (remainder b a) 0))

(define (prime? n)
  (and (> n 1) (= n (smallest-divisor n))))

; Fermat Test

(define (expmod base exp m)
  (cond ((= exp 0) 1)
	((even? exp)
	 (remainder (square (expmod base (/ exp 2) m))
		    m))
	(else
	 (remainder (* base (expmod base (- exp 1) m))
		    m))))

(define (fermat-test n)
  (define (try-it a)
    (= (expmod a n n) a))
  (try-it (+ 1 (random (- n 1)))))

(define (fast-prime? n times)
  (cond ((= times 0) #t)
        ((fermat-test n) (fast-prime? n (- times 1)))
        (else #f)))

; Exercise 1.22

(define (timed-prime-test n)
  (start-prime-test n (runtime)))

(define (start-prime-test n start-time)
  (if (fast-prime? n 1000)
      (report-prime n (- (runtime) start-time))
      #f))

(define (port-prime n elapsed-time)
  (newline)
  (display n)
  (display " *** ")
  (display elapsed-time)
  #t)

(define (search-for-primes min max counter)
  (cond ((= counter 0) 0)
	((> min max) 0)
	((even? min) (search-for-primes (+ min 1) max counter))
	((timed-prime-test min) (search-for-primes (+ min 2) max (- counter 1)))
	(else (search-for-primes (+ min 2) max counter))))


; Exercise 1.28
(define (expmod2 base exp m)
  (cond ((= exp 0) 1)
	((even? exp)
	 (square-check (expmod2 base (/ exp 2) m)
		       m))
	(else
	 (remainder (* base (expmod2 base (- exp 1) m))
		    m))))

(define (square-check x m)
  (if (and (not (or (= x 1) (= x (- m 1))))
	   (= (remainder (square x) m) 1))
      0
      (remainder (square x) m)))

(define (miller-rabin-test n)
  (define (try-it a)
    (= (expmod2 a (- n 1) n) 1))
  (try-it (+ 1 (random (- n 1)))))

(define (fast-prime2? n times)
  (cond ((= times 0) true)
        ((miller-rabin-test n) (fast-prime2? n (- times 1)))
        (else false)))


; 1.3.1
(define (cube x) (* x x x))

(define (sum-integers a b)
  (if (> a b)
      0
      (+ a (sum-integers (+ a 1) b))))


(define (sum-cubes a b)
  (if (> a b)
      0
      (+ (cube a) (sum-cubes (+ a 1) b))))

(define (pi-sum a b)
  (if (> a b)
      0
      (+ (/ 1.0 (* a (+ a 2))) (pi-sum (+ a 4) b))))

(define (sum term a next b)
  (if (> a b)
      0
      (+ (term a) (sum term (next a) next b))))

(define (inc n) (+ n 1))
(define (sum-cubes a b)
  (sum cube a inc b))

(define (identity n) n)
(define (sum-integers a b)
  (sum identity a inc b))

(define (pi-sum a b)
  (define (term x)
    (/ 1.0 (* x (+ x 2))))
  (define (next x)
    (+ x 4))
  (sum term a next b))

(define (integral f a b dx)
  (define (next x) (+ x dx))
  (* (sum f (+ a (/ dx 2.0)) next b) dx))

; Exercise 1.29
(define (integral2 f a b n)
  (define h (/ (- b a) n))
  (define (y k)
    (f (+ a (* k h))))
  (define (next x) (+ x 2))
  (+
   (* (/ h 3.0) (y 0))
   (* (/ h 3.0) (y (- n 1)))
   (* (/ h 3.0)
      (* 4 (sum y 1 next (- n 1))))
   (* (/ h 3.0)
      (* 2 (sum y 2 next (- n 2))))))


; Exercise 1.30
(define (sum term a next b)
  (define (iter a result)
    (if (> a b)
	result
	(iter (next a) (+ result (term a)))))
  (iter a 0))

; Exercise 1.31
(define (product term a next b)
  (define (iter a result)
    (if (> a b)
	result
	(iter (next a) (* result (term a)))))
  (iter a 1))

(define (product-integers a b)
  (define (next x) (+ x 1))
  (product identity a next b))

(define (factorial b)
  (product-integers 1 b))

(define (wallis-pi n)
   (define (term x)
      (/ (* 4.0 (square x))
         (- (* 4.0 (square x)) 1)))
   (* 2.0 (product term 1 inc n)))

; Exercise 1.32
(define (accumulate combiner null-value term a next b)
  (if (> a b)
      null-value
      (combiner (term a)
		(accumulate combiner null-value term (next a) next b))))

(define (sum term a next b)
  (accumulate + 0 term a next b))

(define (product term a next b)
  (accumulate * 1 term a next b))

(define (accumulate combiner null-value term a next b)
  (define (iter a result)
    (if (> a b)
	result
	(iter (next a) (combiner (term a) result))))
  (iter a null-value))

; Exercise 1.33
(define (filtered-accumulate combiner null-value term a next b filter)
  (define (next-filtered x)
    (define n (next x))
    (if (> n b)
	n
	(if (filter n)
	    n
	    (next-filtered n))))
  (define (start)
    (if (filter a)
	a
	(next-filtered a)))
  (accumulate combiner null-value term (start) next-filtered b))

(define (sum-squares-of-primes a b)
  (filtered-accumulate + 0 square a inc b prime?))

(define (ex133b n)
  (define (filter x)
    (= (gcd x n) 1))
  (filtered-accumulate * 1 identity 1 inc (- n 1) filter))

; Section 1.3.2

(define (pi-sum a b)
  (sum (lambda (x) (/ 1.0 (* x (+ x 2))))
       a
       (lambda (x) (+ x 4))
       b))

(define (integral f a b dx)
  (* (sum f
	  (+ a (/ dx 2.0))
	  (lambda (x) (+ x dx))
	  b)
     dx))

(define (search f neg-point pos-point)
  (let ((mid-point (average neg-point pos-point)))
    (if (close-enough? neg-point pos-point)
	mid-point
	(let ((test-value (f mid-point)))
	  (cond ((positive? test-value)
		 (search f neg-point mid-point))
		((negative? test-value)
		 (search f mid-point pos-point))
		(else midpoint))))))

(define (close-enough? x y)
  (< (abs (- x y)) 0.001))

(define (half-interval-method f a b)
  (let ((a-value (f a))
	(b-value (f b)))
    (cond ((and (negative? a-value) (positive? b-value))
	   (search f a b))
	  ((and (positive? a-value) (negative? b-value))
	   (search f b a))
	  (else
	   (error "Values are not of opposite sign" a b)))))

(define tolerance 0.000000001)
(define (fixed-point f first-guess)
  (define (close-enough? x y)
    (< (abs (- x y)) tolerance))
  (define (try guess)
    (let ((next (f guess)))
      (if (close-enough? next guess)
	  next
	  (try next))))
  (try first-guess))

(define (sqrt x)
  (fixed-point (lambda (y) (average y (/ x y)))
	       1.0))

(define golden-ratio (fixed-point
		      (lambda (x) (+ 1 (/ 1 x))) 2.0))


(define (fixed-point f first-guess)
  (define (close-enough? x y)
    (< (abs (- x y)) tolerance))
  (define (try guess)
;    (newline)
;    (display guess)
    (let ((next (f guess)))
      (if (close-enough? next guess)
	  next
	  (try next))))
  (try first-guess))


; Exercise 1.37
(define (cont-frac d n k)
  (define (iter i)
    (let ((di (d i))
	  (ni (n i)))
      (cond ((= i k) (/ ni di))
	    (else (/ ni
		     (+ di (iter (+ i 1))))))))
  (iter 1))

(define (cont-frac d n k)
  (define (iter i res)
    (let ((di (d i))
	  (ni (n i)))
      (cond ((= i 0) res)
	    (else (iter (- i 1) (/ ni (+ di res)))))))
  (iter k 0))

; Exercise 1.38
(define (e)
  (+ (cont-frac (lambda (i)
		  (cond ((= i 1) 1.0)
			((= i 2) 2.0)
			((= (remainder (- i 2) 3) 0)
			 (+ 2.0 (* (- i 2))))
			(else 1.0)))
		(lambda (i) 1.0)
		1000)
     2))

; Exercise 1.39
(define (tan-cf x)
  (/ x (+ 1.0 (cont-frac (lambda (i) (+ (* 2.0 i) 1.0)) (lambda (i) (* -1.0 (* x x))) 1000))))

; Sec 1.3.4

(define (average-damp f)
  (lambda (x) (average x (f x))))

(define (sqrt x)
  (fixed-point (average-damp (lambda (y) (/ x y)))
	       1.0))

(define (cube-root x)
  (fixed-point (average-damp (lambda (y) (/ x (square y))))
	       1.0))

(define dx 0.00001)

(define (deriv g)
  (lambda (x)
    (/ (- (g (+ x dx)) (g x))
       dx)))


(define (newton-transform g)
  (lambda (x)
    (- x (/ (g x) ((deriv g) x)))))

(define (newtons-method g guess)
  (fixed-point (newton-transform g) guess))

(define (sqrt x)
  (newtons-method (lambda (y) (- (square y) x))
		  1.0))

(define (fixed-point-of-transform g transform guess)
  (fixed-point (transform g) guess))

(define (sqrt x)
  (fixed-point-of-transform (lambda (y) (/ x y))
			    average-damp
			    1.0))

(define (sqrt x)
  (fixed-point-of-transform (lambda (y) (- (square y) x))
			    newton-transform
			    1.0))

; exercise 1.40
(define (cubic a b c)
  (lambda (x)
    (+ (cube x)
       (* a (square x))
       (* b x)
       c)))

; exercise 1.41
(define (double f)
  (lambda (x)
    (f (f x))))

; exercise 1.42
(define (compose f g)
  (lambda (x) (f (g x))))

; exercise 1.43
(define (repeated f n)
  (cond ((= n 1) (lambda (x) (f x)))
	(else (lambda (x)
		(f ((repeated f (- n 1)) x))))))


; exercise 1.44
(define (smoothing f)
  (lambda (x)
    (average (f (- x dx))
	     (average
	      (f x)
	      (f (+ x dx))))))

(define (smoothing-n-fold f n)
  ((repeated smoothing n) f))


; exercise 1.45
(define (power x n)
  (cond ((= n 0) 1)
	(else 
	 (* x (power x (- n 1))))))
(define (nth-root x n)
  (fixed-point-of-transform (lambda (y) (/ x (power y (- n 1))))
			    (repeated average-damp (- n 2))
			    1.0))

; exercise 1.46
(define (iterative-improve good? improve)
  (lambda (guess)
    (define (improve-iter guess)
      (cond ((good? guess) guess)
	    (else (improve-iter (improve guess)))))
    (improve-iter guess)))

(define (sqrt x)
  ((iterative-improve
    (lambda (guess)
      (< (abs (- (square guess) x)) 0.0001))
    (lambda (guess)
      (average guess (/ x guess))))
   1.0))

(define (fixed-point f guess)
  ((iterative-improve
    (lambda (guess)
      (< (abs (- guess (f guess
			  ))) tolerance))
    f)
   guess))


; Chapter 2

(define (add-rat x y)
  (make-rat (+ (* (numer x) (denom y))
	       (* (numer y) (denom x)))
	    (* (denom x) (denom y))))

(define (sub-rat x y)
  (make-rat (- (* (numer x) (denom y))
	       (* (numer y) (denom x)))
	    (* (denom x) (denom y))))

(define (mul-rat x y)
  (make-rat (* (numer x) (numer y))
	    (* (denom x) (denom y))))

(define (div-rat x y)
  (make-rat (* (numer x) (denom y))
	    (* (numer y) (denom x))))

(define (equal-rat? x y)
  (= (* (numer x) (denom y))
     (* (numer y) (denom x))))

(define (make-rat n d)
  (cons n d))

(define (numer x)
  (car x))

(define (denom x)
  (cdr x))

(define (print-rat x)
  (newline)
  (display (numer x))
  (display "/")
  (display (denom x)))


(define (make-rat n d)
  (let ((g (gcd n d)))
    (cons (/ n g) (/ d g))))


; Exercise 2.1
(define (make-rat n d)
  (let ((sign (if (or (and (< n 0) (< d 0))
		      (and (> n 0) (> d 0)))
		  1
		  -1))
	(g (gcd n d)))
    (cons (* sign (abs (/ n g))) (abs (/ d g)))))

; Exercise 2.2
(define (make-segment p1 p2)
  (cons p1 p2))

(define (start-segment seg)
  (car seg))

(define (end-segment seg)
  (cdr seg))

(define (make-point x y)
  (cons x y))

(define (x-point p)
  (car p))

(define (y-point p)
  (cdr p))

(define (print-point p)
  (newline)
  (display "(")
  (display (x-point p))
  (display ",")
  (display (y-point p))
  (display ")"))

(define (mid-point seg)
  (let ((start (start-segment seg))
	(end (end-segment seg)))
    (make-point (average (x-point start)
			 (x-point end))
		(average (y-point start)
			 (y-point end)))))

; Exercise 2.3
(define (make-rectangle p1 p2)
  (cons p1 p2))

(define (length-y rec)
  (let ((p1 (car rec))
	(p2 (cdr rec)))
    (distance-point
     p1
     (make-point (x-point p1) (y-point p2)))))

(define (length-x rec)
  (let ((p1 (car rec))
	(p2 (cdr rec)))
    (distance-point
     p1
     (make-point (x-point p2) (y-point p1)))))

(define (distance-point p1 p2)
  (sqrt (+
	 (square (- (x-point p1) (x-point p2)))
	 (square (- (y-point p1) (y-point p2))))))

(define (perimeter rec)
  (+ (* 2 (length-x rec))
     (* 2 (length-y rec))))

(define (area rec)
  (* (length-x rec) (length-y rec)))

(define (mycons x y)
  (define (dispatch m)
    (cond ((= m 0) x)
	  ((= m 1) y)
	  (else (error "Naa"))))
  dispatch)

(define (mycar x) (x 0))
(define (mycdr x) (x 1))

; Exercise 2.4
(define (mycons x y)
  (lambda (m) (m x y)))

(define (mycar x)
  (x (lambda (p q) p)))

(define (mycdr x)
  (x (lambda (p q) q)))

; Exercise 2.5
(define (mycons x y)
  (* (power 2 x) (power 3 y)))

(define (mycar x)
  (if (divides? 2 x)
      (+ 1 (mycar (/ x 2)))
      0))

(define (mycdr x)
  (if (divides? 3 x)
      (+ 1 (mycar (/ x 3)))
      0))

; Exercise 2.6
(define zero (lambda (f) (lambda (x) x)))

(define (add-1 n)
  (lambda (f) (lambda (x) (f ((n f) x)))))

(define one
  (lambda (f) (lambda (x) (f (((lambda (f) (lambda (x) x)) f) x)))))

(define one
  (lambda (f) (lambda (x) (f ((lambda (x) x) x)))))

(define one
  (lambda (f) (lambda (x) (f x))))

(define two
  (lambda (f) (lambda (x) (f (((lambda (f) (lambda (x) (f x))) f) x)))))

(define two
  (lambda (f) (lambda (x) (f ((lambda (x) (f x)) x)))))

(define two
  (lambda (f) (lambda (x) (f (f x)))))


(define (add-interval x y)
  (make-interval (+ (lower-bound x) (lower-bound y))
                 (+ (upper-bound x) (upper-bound y))))

(define (mul-interval x y)
  (let ((p1 (* (lower-bound x) (lower-bound y)))
        (p2 (* (lower-bound x) (upper-bound y)))
        (p3 (* (upper-bound x) (lower-bound y)))
        (p4 (* (upper-bound x) (upper-bound y))))
    (make-interval (min p1 p2 p3 p4)
                   (max p1 p2 p3 p4))))

(define (div-interval x y)
  (mul-interval x 
                (make-interval (/ 1.0 (upper-bound y))
                               (/ 1.0 (lower-bound y)))))

; Exercise 2.7
(define (make-interval a b)
  (cons a b))

(define (upper-bound i)
  (cdr i))

(define (lower-bound i)
  (car i))

; Exercise 2.8
(define (sub-interval x y)
  (add-interval x (make-interval
		   (* -1 (lower-bound y))
		   (* -1 (upper-bound y)))))

; Exercise 2.9
(define (width-interval x)
  (abs (- (lower-bound x) (upper-bound x))))

; Exercise 2.10
(define (div-interval x y)
  (if (or (= (lower-bound y) 0)
	  (= (upper-bound y) 0))
      (error "Division by zero is not defined")
      (mul-interval x (make-interval
		       (/ 1.0 (upper-bound y))
		       (/ 1.0 (lower-bound y))))))

; Exercise 2.11
(define (mul-interval x y)
  (let ((x1 (lower-bound x))
	(x2 (upper-bound x))
	(y1 (lower-bound y))
	(y2 (upper-bound y)))
    (cond ((and (> x1 0) (> y1 0))
	   (make-interval (* x1 y1) (* x2 y2)))
	  ((and (< x2 0) (< y2 0))
	   (make-interval (* x2 y2) (* x1 y1)))
	  ((and (> x1 0) (< y2 0))
	   (make-interval (* x2 y1) (* x1 y2)))
	  ((and (< x2 0) (> y1 0))
	   (make-interval (* x1 y2) (* x2 y1)))
	  ((and (< x1 0) (> x2 0) (> y1 0))
	   (make-interval (* x1 y2) (* x2 y2)))
	  ((and (< x1 0) (> x2 0) (< y2 0))
	   (make-interval (* x2 y1) (* x1 y1)))
	  ((and (> x1 0) (< y1 0) (> y2 0))
	   (make-interval (* x2 y1) (* x2 y2)))
	  ((and (< x2 0) (< y1 0) (> y2 0))
	   (make-interval (* x1 y2) (* x1 y1)))
	  (else
	   (make-interval (min (* x1 y1) (* x1 y2) (* x2 y1) (* x2 y2))
			  (max (* x1 y1) (* x1 y2) (* x2 y1) (* x2 y2)))))))

(define (make-center-width c w)
  (make-interval (- c w) (+ c w)))
(define (center i)
  (/ (+ (lower-bound i) (upper-bound i)) 2))
(define (width i)
  (/ (- (upper-bound i) (lower-bound i)) 2))

; Exercise 2.12
(define (make-center-percent c p)
  (make-interval (- c (* c (/ p 100)))
		 (+ c (* c (/ p 100)))))

(define (percent i)
  (/ (width i) (center i)))


(define (par1 r1 r2)
  (div-interval (mul-interval r1 r2)
                (add-interval r1 r2)))
(define (par2 r1 r2)
  (let ((one (make-interval 1 1))) 
    (div-interval one
                  (add-interval (div-interval one r1)
                                (div-interval one r2)))))

; 2.2

(define (list-ref list n)
  (if (= n 0)
      (car list)
      (list-ref (cdr list) (- n 1))))

(define (length list)
  (if (null? list)
      0
      (+ 1 (length (cdr list)))))

; Exercise 2.17

(define (last-pair list)
  (if (= (length list) 1)
      list
      (last-pair (cdr list))))

; Exercise 2.18

(define (reverse l)
  (if (null? l)
      nil
      (append (reverse (cdr l)) (list (car l)))))

; Exercise 2.19
(define us-coins (list 50 25 10 5 1))
(define uk-coins (list 100 50 20 10 5 2 1 0.5))

(define (cc amount coin-values)
  (cond ((= amount 0) 1)
        ((or (< amount 0) (no-more? coin-values)) 0)
        (else
         (+ (cc amount
                (except-first-denomination coin-values))
            (cc (- amount
                   (first-denomination coin-values))
                coin-values)))))

(define (no-more? coin-values)
  (= (length coin-values) 0))

(define (except-first-denomination coin-values)
  (cdr coin-values))

(define (first-denomination coin-values)
  (car coin-values))

; Exercise 2.20
(define (same-parity x . rest)
  (define (same-parity-helper items)
    (cond ((empty? items) nil)
	  ((and (even? x) (even? (car items)))
	   (cons (car items) (same-parity-helper (cdr items))))
	  ((and (odd? x) (odd? (car items)))
	   (cons (car items) (same-parity-helper (cdr items))))
	  (else (same-parity-helper (cdr items)))))
  (cons x (same-parity-helper rest)))
(define (empty? l)
  (= (length l) 0))

; Exercise 2.21
(define (square-list items)
  (if (null? items)
      nil
      (cons (square (car items)) (square-list (cdr items)))))

(define (square-list items)
  (map square items))

; Exercise 2.23
(define (for-each f items)
  (cond ((not (null? items))
	 (f (car items))
	 (for-each f (cdr items)))))


(define (count-leaves x)
  (cond ((null? x) 0)  
        ((not (pair? x)) 1)
        (else (+ (count-leaves (car x))
                 (count-leaves (cdr x))))))

; Exercise 2.26
(define x (list 1 2 3))
(define y (list 4 5 6))

; Exercise 2.27
(define (deep-reverse items)
  (cond ((null? items) nil)
	((pair? (car items)) (append (deep-reverse (cdr items)) (list (deep-reverse (car items)))))
	(else (append (cdr items) (list (car items))))))

; Exercise 2.28
(define (fringe items)
  (cond ((null? items) nil)
	((null? (car items)) (fringe (cdr items)))
	((list? (car items)) (append (fringe (car items)) (fringe (cdr items))))
	(else (cons (car items) (fringe (cdr items))))))

(define x (list (list 1 2) (list 3 4)))

; Exercise 2.29
(define (make-mobile left right)
  (list left right))

(define (make-branch length structure)
  (list length structure))

(define (left-branch mobile)
  (car mobile))

(define (right-branch mobile)
  (car (cdr mobile)))

(define (branch-length branch)
  (car branch))

(define (branch-structure branch)
  (car (cdr branch)))

(define (branch-weight branch)
  (if (pair? (branch-structure branch))
      (total-weight (branch-structure branch))
      (branch-structure branch)))

(define (total-weight mobile)
  (+ (branch-weight (left-branch mobile))
       (branch-weight (right-branch mobile))))

(define (balanced-branch? branch)
  (if (pair? (branch-structure branch))
      (balanced? (branch-structure branch))
      #t))

(define (balanced? mobile)
  (let ((lb (left-branch mobile))
	(rb (right-branch mobile)))
    (and (= (* (branch-length lb) (branch-weight lb))
	    (* (branch-length rb) (branch-weight rb)))
	 (balanced-branch? lb)
	 (balanced-branch? rb))))

(define (make-mobile left right)
  (cons left right))
(define (make-branch length structure)
  (cons length structure))

(define (right-branch mobile)
  (cdr mobile))

(define (branch-structure branch)
  (cdr branch))

; Exercise 2.30
(define (square-tree tree)
  (cond ((null? tree) nil)
	((not (pair? tree)) (* tree tree))
	(else (cons (square-tree (car tree))
		    (square-tree (cdr tree))))))

(define (square-tree tree)
  (map (lambda (subtree)
	 (if (pair? subtree)
	     (square-tree subtree)
	     (* subtree subtree)))
       tree))

; Exercise 2.31
(define (tree-map f tree)
  (map (lambda (st)
	 (if (pair? st)
	     (tree-map f st)
	     (f st)))
       tree))

(define (square-tree tree) (tree-map square tree))

; Exercise 2.32
(define (subsets s)
  (if (null? s)
      (list nil)
      (let ((rest (subsets (cdr s))))
	(append rest (map (lambda (x) (cons (car s) x)) rest)))))


(define (filter predicate sequence)
  (cond ((null? sequence) nil)
        ((predicate (car sequence))
         (cons (car sequence)
               (filter predicate (cdr sequence))))
        (else (filter predicate (cdr sequence)))))

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (enumerate-tree tree)
  (cond ((null? tree) nil)
        ((not (pair? tree)) (list tree))
        (else (append (enumerate-tree (car tree))
                      (enumerate-tree (cdr tree))))))

; Exercise 2.33
;; (define (map p sequence)
;;   (accumulate (lambda (x y) (cons (p x) y)) nil sequence))

(define nil (list))

(define (append seq1 seq2)
  (accumulate cons seq2 seq1))

(define (length sequence)
  (accumulate (lambda (x y) (+ 1 y)) 0 sequence))

; Exercise 2.34
(define (horner-eval x coefficient-sequence)
  (accumulate (lambda (this-coeff higher-terms)
		(+ this-coeff (* higher-terms x)))
              0
              coefficient-sequence))


; Exercise 2.35
(define (count-leaves t)
  (accumulate +
	      0
	      (map (lambda (x) 1) (enumerate-tree t))))

(define (count-leaves t)
  (accumulate (lambda (x y) (+ 1 y))
	      0
	      (enumerate-tree t)))

; Exercise 2.36
(define (accumulate-n op init seqs)
  (if (null? (car seqs))
      nil
      (cons (accumulate op init (map car seqs))
            (accumulate-n op init (map cdr seqs)))))


; Exercise 2.37
(define (dot-product v w)
  (accumulate + 0 (map * v w)))
(define (matrix-*-vector m v)
  (map (lambda (w) (dot-product w v)) m))
(define (transpose mat)
  (accumulate-n (lambda (x y) (cons x y)) nil mat))
(define (matrix-*-matrix m n)
  (let ((cols (transpose n)))
    (map (lambda (v) (matrix-*-vector cols v)) m)))

; Exercise 2.38
(define (fold-right op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (fold-right op initial (cdr sequence)))))

(define (fold-left op initial sequence)
  (define (iter result rest)
    (if (null? rest)
        result
        (iter (op result (car rest))
              (cdr rest))))
  (iter initial sequence))

; Exercise 2.39
(define (reverse sequence)
  (fold-right (lambda (x y) (append y (list x) )) nil sequence))

(define (reverse sequence)
  (fold-left (lambda (x y) (cons y x)) nil sequence))

; Nested Mappings
(define (flatmap proc seq)
  (accumulate append nil (map proc seq)))

(define (prime-sum? pair)
  (prime? (+ (car pair) (cadr pair))))

(define (make-pair-sum pair)
  (list (car pair) (cadr pair) (+ (car pair) (cadr pair))))

(define (prime-sum-pairs n)
  (map make-pair-sum
       (filter prime-sum?
               (flatmap
                (lambda (i)
                  (map (lambda (j) (list i j))
                       (enumerate-interval 1 (- i 1))))
                (enumerate-interval 1 n)))))

;Exercise 2.40
(define (unique-pairs n)
  (map (lambda (x) (list n x)) (enumerate-interval 1 (- n 1))))

(define (prime-sum-pairs n)
  (map make-pair-sum
       (filter prime-sum?
               (flatmap
                (lambda (i) (unique-pairs i))
                (enumerate-interval 1 n)))))

;Exercise 2.41
(define (f n s)
  (filter (lambda (l) (= s (accumulate + 0 l)))
	  (flatmap (lambda (k)
		     (flatmap (lambda (j)
				(map (lambda (i) (list i j k))
						   (enumerate-interval 1 (- j 1))))
			      (enumerate-interval 1 (- k 1))))
		   (enumerate-interval 1 n))))

; Exercise 2.42
(define (queens board-size)
  (define (queen-cols k)  
    (if (= k 0)
        (list empty-board)
        (filter
         (lambda (positions) (safe? k positions))
         (flatmap
          (lambda (rest-of-queens)
            (map (lambda (new-row)
                   (adjoin-position new-row k rest-of-queens))
                 (enumerate-interval 1 board-size)))
          (queen-cols (- k 1))))))
  (queen-cols board-size))

(define (make-position row col)
   (cons row col))

(define (position-row position)
   (car position))

(define (position-col position)
   (cdr position))

(define empty-board nil)

(define (adjoin-position row col positions)
  (append positions (list (make-position row col))))
(define (safe? col positions)
  (let ((kth-queen (list-ref positions (- col 1)))
	(other-queens (filter (lambda (q)
				(not (= col (position-col q))))
			      positions)))
    (define (attacks? q1 q2)
      (or (= (position-row q1) (position-row q2))
	  (= (abs (- (position-row q1) (position-row q2)))
	     (abs (- (position-col q1) (position-col q2))))))
    
    (define (iter q board)
      (or (null? board)
	  (and (not (attacks? q (car board)))
	       (iter q (cdr board)))))
    (iter kth-queen other-queens)))

; 2.2.4 Picture Language
;; (define wave2 (beside wave (flip-vert wave)))
;; (define wave4 (below wave2 wave2))

(define (flipped-pairs painter)
  (let ((painter2 (beside painter (flip-vert painter))))
    (below painter2 painter2)))

;; (define wave4 (flipped-pairs wave))
(define (right-split painter n)
  (if (= n 0)
      painter
      (let ((smaller (right-split painter (- n 1))))
	(beside painter (below smaller smaller)))))

(define (corner-split painter n)
  (if (= n 0)
      painter
      (let ((up (up-split painter (- n 1)))
	    (right (right-split painter (- n 1))))
	(let ((top-left (beside up up))
	      (bottom-right (below right right)))
	  (beside (below painter top-left)
		  (below bottom-right corner))))))

(define (square-limit painter n)
  (let ((quarter (corner-split painter n)))
    (let ((half (beside (flip-horiz quarter) quarter)))
      (below (flip-vert half) half))))

; Exercise 2.44
(define (up-split painter n)
  (if (= n 0)
      painter
      (let ((smaller (up-split painter (- n 1))))
	(below painter (beside smaller smaller)))))

; Higher order functions
(define (square-of-four tl tr bl br)
  (lambda (painter)
    (let ((top (beside (tl painter) (tr painter)))
	  (bottom (beside (bl painter) (br painter))))
      (below bottom top))))

(define (flipped-pairs painter)
  (let ((combine4 (square-of-four identity flip-vert
				  identity flip-vert)))
    (combine4 painter)))

(define (square-limit painter n)
  (let ((combine4 (square-of-four flip-horiz identity
				  rotate180 flip-horiz)))
    (combine4 (corner-split painter n))))

; Exercise 2.45
(define (split p1 p2)
  (define (f painter n)
    (if (= n 0)
	painter
	(let ((smaller (f painter (- n 1))))
	  (p1 painter (p2 smaller smaller)))))
  f)

; Frames
(define (frame-coord-map frame)
  (lambda (v)
    (add-vect
     (origin-frame frame)
     (add-vect (scale-vect (xcor-vect v)
			   (edge1-frame frame))
	       (scale-vect (ycor-vect v)
			   (edge2-frame frame))))))

; Exercise 2.46
(define (make-vect x y)
  (cons x y))

(define (xcor-vect v)
  (car v))

(define (ycor-vect v)
  (cdr v))

(define (add-vect v1 v2)
  (make-vect (+ (xcor-vect v1) (xcor-vect v2))
	     (+ (ycor-vect v1) (ycor-vect v2))))

(define (sub-vect v1 v2)
  (add-vect v1 (make-vect (- (xcor-vect v2))
			  (- (ycor-vect v2)))))

; Exercise 2.47
(define (make-frame origin edge1 edge2)
  (list origin edge1 edge2))

(define (origin-frame frame)
  (car frame))

(define (edge1-frame frame)
  (car (cdr frame)))

(define (edge2-frame frame)
  (car (cdr (cdr frame))))

(define (make-frame origin edge1 edge2)
  (cons origin (cons edge1 edge2)))

(define (origin-frame frame)
  (car frame))

(define (edge1-frame frame)
  (car (cdr frame)))

(define (edge2-frame frame)
  (cdr (cdr frame)))

; Painters

(define (segments-painter segment-list)
  (lambda (frame)
    (for-each
     (lambda (segment)
       (draw-line
	((frame-coord-map frame) (start-segment segment))
	((frame-coord-map frame) (end-segment segment))))
     segment-list)))

; Exercise 2.48

(define (make-segment v1 v2)
  (cons v1 v2))

(define (start-segment s)
  (car s))

(define (end-segment s)
  (cdr s))

; Exercise 2.49
; a
(define (frame-outline)
  (lambda (frame)
    (let ((segment-list (list (make-segment (make-vect 0 0) (make-vect 0 1))
			      (make-segment (make-vect 0 1) (make-vect 1 1))
			      (make-segment (make-vect 1 1) (make-vect 1 0))
			      (make-segment (make-vect 1 0) (make-vect 0 0)))))
      (segments-painter segment-list))))

; b
(define (frame-x-letter)
  (lambda (frame)
    (let ((segment-list (list (make-segment (make-vect 0 0) (make-vect 1 1))
			      (make-segment (make-vect 0 1) (make-vect 1 0)))))
      (segments-painter segment-list))))

; c
(define (frame-diamond)
  (lambda (frame)
    (let ((segment-list (list (make-segment (make-vect 0 0.5) (make-vect 0.5 1))
			      (make-segment (make-vect 0.5 1) (make-vect 1 0.5))
			      (make-segment (make-vect 1 0.5) (make-vect 0.5 0))
			      (make-segment (make-vect 0.5 0) (make-vect 0 0.5)))))
      (segments-painter segment-list))))

; wave
(define (wave)
  (lambda (frame)
    (let ((segment-list (list (make-segment (make-vect 0   0.6) (make-vect 0.2 0.4))
			      (make-segment (make-vect 0.2 0.4) (make-vect 0.3 0.5))
			      (make-segment (make-vect 0.3 0.5) (make-vect 0.35 0.45))
			      (make-segment (make-vect 0.35 0.45) (make-vect 0.3 0))
			      (make-segment (make-vect 0.45 0) (make-vect 0.5 0.3))
			      (make-segment (make-vect 0.5 0.3) (make-vect 0.55 0))
			      (make-segment (make-vect 0.75 0) (make-vect 0.55 0.4))
			      (make-segment (make-vect 0.55 0.4) (make-vect 1 0.8))
			      (make-segment (make-vect 1 0.6) (make-vect 0.6 0.6))
			      (make-segment (make-vect 0.6 0.6) (make-vect 0.55 0.6))
			      (make-segment (make-vect 0.55 0.6) (make-vect 0.6 0.8))
			      (make-segment (make-vect 0.6 0.8) (make-vect 0.55 1))
			      (make-segment (make-vect 0.45 1) (make-vect 0.40 0.8))
			      (make-segment (make-vect 0.40 0.8) (make-vect 0.45 0.6))
			      (make-segment (make-vect 0.45 0.6) (make-vect 0.3 0.6))
			      (make-segment (make-vect 0.3 0.6) (make-vect 0.2 0.5))
			      (make-segment (make-vect 0.2 0.5) (make-vect 0 0.8)))))
      (segments-painter segment-list))))

; Transformations

(define (transform-painter painter origin corner1 corner2)
  (lambda (frame)
    (let ((m (frame-coor-map frame)))
      (let ((new-origin (m origin)))
	(painter
	 (make-frame new-origin
		     (sub-vect (m corner1) new-origin)
		     (sub-vect (m corner2) new-origin)))))))

(define (flip-vert painter)
  (transform-painter painter
		     (make-vect 0.0 1.0)
		     (make-vect 1.0 1.0)
		     (make-vect 0.0 0.0)))

(define (shrink-to-upper-right painter)
  (transform-painter painter
		     (make-vect 0.5 0.5)
		     (make-vect 1.0 0.5)
		     (make-vect 0.5 1.0)))

(define (rotate90 painter)
  (transform-painter painter
		     (make-vect 1.0 0)
		     (make-vect 1.0 1.0)
		     (make-vect 0.0 0.0)))

(define (squash-inwards painter)
  (transform-painter painter
		     (make-vect 0.0 0.0)
		     (make-vect 0.65 0.35)
		     (make-vect 0.35 0.65)))

(define (beside painter1 painter2)
  (let ((split-point (make-vect 0.5 0)))
    (let ((paint-left
	   (transform-painter painter1
			      (make-vect 0.0 0.0)
			      split-point
			      (make-vect 0.0 1.0)))
	  (paint-right
	   (transform-painter painter2
			      split-point
			      (make-vect 1.0 0.0)
			      (make-vect 0.5 1.0))))
      (lambda (frame)
	(paint-left frame)
	(paint-right frame)))))

; Exercise 2.50
(define (flip-horiz painter)
  (transform-painter painter
		     (make-vect 1.0 0.0)
		     (make-vect 0.0 0.0)
		     (make-vect 1.0 1.0)))

(define (rotate180 painter)
  (transform-painter painter
		     (make-vect 1.0 1.0)
		     (make-vect 0.0 1.0)
		     (make-vect 1.0 0.0)))

(define (rotate270 painter)
  (transform-painter painter
		     (make-vect 0.0 1.0)
		     (make-vect 0.0 0.0)
		     (make-vect 1.0 1.0)))

; Exercise 2.51
(define (below painter1 painter2)
  (let ((split-point (make-vect 0.0 0.5)))
    (let ((paint-up
	   (transform-painter painter1
			      split-point
			      (make-vect 1.0 0.5)
			      (make-vect 0.0 1.0)))
	  (paint-down
	   (transform-painter painter2
			      (make-vect 0.0 0.0)
			      (make-vect 1.0 0.0)
			      split-point)))
      (lambda (frame)
	(paint-up frame)
	(paint-down frame)))))

(define (below painter1 painter2)
  (rotate90 (beside (rotate270 painter)
		    (rotate270 painter))))

; Section 2.3
; Exercise 2.54
(define (equal? list1 list2) 
   (cond ((and (not (pair? list1)) (not (pair? list2))) 
          (eq? list1 list2)) 
         ((and (pair? list1) (pair? list2)) 
          (and (equal? (car list1) (car list2)) (equal? (cdr list1) (cdr list2)))) 
         (else false))) 


; 2.3.2  Example: Symbolic Differentiation
(define (deriv exp var)
  (cond ((number? exp) 0)
	((variable? exp)
	 (if (same-variable? exp var) 1 0))
	((sum? exp)
	 (make-sum (deriv (addend exp) var)
		   (deriv (augend exp) var)))
	((product? exp)
	 (make-sum
	  (make-product (multiplier exp)
			(deriv (multiplicand exp) var))
	  (make-product (deriv (multiplier exp) var)
			(multiplicand exp))))
	(else
	 (error "unknown expression type -- DERIV" exp))))

(define (variable? x) (symbol? x))

(define (same-variable? x y)
  (and (variable? x) (variable? y) (eq? x y)))

(define (make-sum a b) (list '+ a b))
(define (make-product a b) (list '* a b))

(define (sum? x)
  (and (pair? x) (eq? (car x) '+)))

(define (addend x) (cadr x))

(define (augend x) (caddr x))

(define (product? x)
  (and (pair? x) (eq? (car x) '*)))

(define (multiplier x) (cadr x))

(define (multiplicand x) (caddr x))

(define (make-sum a b)
  (cond ((=number? a 0) b)
	((=number? b 0) a)
	((and (number? a) (number? b) (+ a b)))
	(else (list '+ a b))))

(define (=number? exp num)
  (and (number? exp) (= exp num)))

(define (make-product a b)
  (cond ((or (=number? a 0) (=number? b 0)) 0)
	((=number? a 1) b)
	((=number? b 1) a)
	((and (number? a) (number? b)) (* a b))
	(else (list '* a b))))

; Exercise 2.56
(define (deriv exp var)
  (cond ((number? exp) 0)
	((variable? exp)
	 (if (same-variable? exp var) 1 0))
	((sum? exp)
	 (make-sum (deriv (addend exp) var)
		   (deriv (augend exp) var)))
	((product? exp)
	 (make-sum
	  (make-product (multiplier exp)
			(deriv (multiplicand exp) var))
	  (make-product (deriv (multiplier exp) var)
			(multiplicand exp))))
	((exponentiation? exp)
	 (make-product
	  (make-product
	   (exponent exp)
	   (make-exponentiation
	    (base exp)
	    (make-sum (exponent exp) -1)))
	  (deriv (base exp) var)))
	(else
	 (error "unknown expression type -- DERIV" exp))))

(define (exponentiation? x)
  (and (pair? x) (eq? (car x) '**)))

(define (base x) (cadr x))

(define (exponent x) (caddr x))

(define (make-exponentiation a b)
  (cond ((=number? a 1) 1)
	((=number? a 0) 0)
	((=number? b 0) 1)
	((=number? b 1) a)
	((and (number? a) (number? b) (expt a b)))
	(else (list '** a b))))

; Exercise 2.57
(define (augend x)
  (cond ((= (length x) 3) (caddr x))
	(else (cons '+ (cddr x)))))

(define (multiplicand x)
  (cond ((= (length x) 3) (caddr x))
	(else (cons '* (cddr x)))))

; Exercise 2.58 a
(define (sum? s)
  (and (pair? s) (eq? (cadr s) '+)))
(define (addend s) (car s))
(define (augend s) (caddr s))
(define (product? s)
  (and (pair? s) (eq? (cadr s) '*)))
(define (multiplier s) (car s))
(define (multiplicand s) (caddr s))
(define (make-sum a b)
  (cond ((=number? a 0) b)
	((=number? b 0) a)
	((and (number? a) (number? b) (+ a b)))
	(else (list a '+ b))))
(define (make-product a b)
  (cond ((or (=number? a 0) (=number? b 0)) 0)
	((=number? a 1) b)
	((=number? b 1) a)
	((and (number? a) (number? b)) (* a b))
	(else (list a '* b))))
(define (exponentiation? s)
  (and (pair? s) (eq? (cadr s) '**)))
(define (base s) (car s))
(define (exponent s) (caddr s))
(define (make-exponentiation a b)
 (cond ((=number? a 1) 1)
	((=number? a 0) 0)
	((=number? b 0) 1)
	((=number? b 1) a)
	((and (number? a) (number? b) (expt a b)))
	(else (list a '** b))))
;Exercise 2.58 b
(define (add-parentheses s)
  (cond ((not (pair? s)) s)
	((= (length s) 1) (add-parentheses (car s)))
	((sum? s) (list (add-parentheses (car s))
			(cadr s)
			(add-parentheses (cddr s))))
	((has-sum? s) (add-parentheses (cons
					(list (add-parentheses (car s))
					      (cadr s)
					      (add-parentheses (caddr s)))
					(cdddr s))))
	(else (list (add-parentheses (car s))
		    (cadr s)
		    (add-parentheses (cddr s))))))
(define (has-sum? s)
  (not (empty? (filter (lambda (x) (eq? x '+)) s))))
(define (deriv exp_d var)
  (let ((exp (add-parentheses exp_d)))
    (cond ((number? exp) 0)
	  ((variable? exp)
	   (if (same-variable? exp var) 1 0))
	  ((sum? exp)
	   (make-sum (deriv (addend exp) var)
		     (deriv (augend exp) var)))
	  ((product? exp)
	   (make-sum
	    (make-product (multiplier exp)
			  (deriv (multiplicand exp) var))
	    (make-product (deriv (multiplier exp) var)
			  (multiplicand exp))))
	  ((exponentiation? exp)
	   (make-product
	    (make-product
	     (exponent exp)
	     (make-exponentiation
	      (base exp)
	      (make-sum (exponent exp) -1)))
	    (deriv (base exp) var)))
	  (else
	   (error "unknown expression type -- DERIV" exp)))))

; 2.3.3 Example: Representing Sets
(define (element-of-set? x set)
  (cond ((null? set) #f)
	((equal? x (car set)) #t)
	(else (element-of-set? x (cdr set)))))
(define (add-join-set x set)
  (if (element-of-set? x set)
      set
      (cons x set)))
(define (intersection-set set1 set2)
  (cond ((or (null? set1) (null? set2)) '())
	((element-of-set? (car set1) set2)
	 (cons (car set1)
	       (intersection-set (cdr set1) set2)))
	(else (intersection-set (cdr set1) set2))))
; Exercise 2.59
(define (union-set set1 set2)
  (cond ((null? set1) set2)
	((null? set2) set1)
	((element-of-set? (car set1) set2)
	 (union-set (cdr set1) set2))
	(else
	 (cons (car set1)
	       (union-set (cdr set1) set2)))))

; Exercise 2.60
(define (add-join-set x set)
  (cons x set))
(define (union-set set1 set2)
  (append set1 set2))

; Set as an ordered list O(n/2) = O(n)
(define (element-of-set? x set)
  (cond ((null? set) #f)
	((= x (car set)) #t)
	((< x (car set)) #f)
	(else (element-of-set? x (cdr set)))))
(define (intersection-set set1 set2)
  (if (or (null? set1) (null? set2))
      '()
      (let ((x1 (car set1)) (x2 (car set2)))
	(cond ((= x1 x2)
	       (cons x1 (intersection-set (cdr set1) (cdr set2))))
	      ((< x1 x2)
	       (intersection-set (cdr set1) set2))
	      ((< x2 x1)
	       (intersection-set set1 (cdr set2)))))))

; Exercise 2.61
(define (addjoin-set x set)
  (cond ((null? set) (list x))
	((= x (car set)) set)
	((< x (car set)) (cons x set))
	((> x (car set)) (cons (car set) (addjoin-set x (cdr set))))))

; Exercise 2.62
(define (union-set set1 set2)
  (cond ((null? set1) set2)
	((null? set2) set1)
	(else (let ((x1 (car set1)) (x2 (car set2)))
	  (cond ((= x1 x2)
		 (cons x1 (union-set (cdr set1) (cdr set2))))
		((< x1 x2)
		 (cons x1 (union-set (cdr set1) set2)))
		((> x1 x2)
		 (cons x2 (union-set set1 (cdr set2)))))))))

; Sets as binary trees
(define (entry tree) (car tree))
(define (left-branch tree) (cadr tree))
(define (right-branch tree) (caddr tree))
(define (make-tree entry left right)
  (list entry left right))
(define (element-of-set? x set)
  (cond ((null? set) #f)
	((= x (entry set)) #t)
	((< x (entry set))
	 (element-of-set? x (left-branch set)))
	((> x (entry set))
	 (element-of-set? x (right-branch set)))))
(define (addjoin-set x set)
  (cond ((null? set) (make-tree x '() '()))
	((= x (entry set)) set)
	((< x (entry set))
	 (make-tree (entry set)
		    (addjoin-set x (left-branch set))
		    (right-branch set)))
	((> x (entry set))
	 (make-tree (entry set)
		    (left-branch set)
		    (addjoin-set x (right-branch set))))))

; Exercise 2.63
(define tree1 (make-tree 7
			 (make-tree 3
				    (make-tree 1 '() '())
				    (make-tree 5 '() '()))
			 (make-tree 9
				    '()
				    (make-tree 11 '() '()))))
(define tree2 (make-tree 3
			 (make-tree 1 '() '())
			 (make-tree 7
				    (make-tree 5 '() '())
				    (make-tree 9
					       '()
					       (make-tree 11 '() '())))))
(define tree3 (make-tree 5
			 (make-tree 3
				    (make-tree 1 '() '())
				    '())
			 (make-tree 9
				    (make-tree 7 '() '())
				    (make-tree 11 '() '()))))
(define (tree->list-1 tree)
  (if (null? tree)
      '()
      (append (tree->list-1 (left-branch tree))
	      (cons (entry tree)
		    (tree->list-1 (right-branch tree))))))
(define (tree->list-2 tree)
  (define (copy-to-list tree result-list)
    (if (null? tree)
	result-list
	(copy-to-list (left-branch tree)
		      (cons (entry tree)
			    (copy-to-list (right-branch tree)
					  result-list)))))
  (copy-to-list tree '()))

; Exercise 2.64
(define (list->tree elements)
  (car (partial-tree elements (length elements))))

(define (partial-tree elts n)
  (if (= n 0)
      (cons '() elts)
      (let ((left-size (quotient (- n 1) 2)))
        (let ((left-result (partial-tree elts left-size)))
          (let ((left-tree (car left-result))
                (non-left-elts (cdr left-result))
                (right-size (- n (+ left-size 1))))
            (let ((this-entry (car non-left-elts))
                  (right-result (partial-tree (cdr non-left-elts)
                                              right-size)))
              (let ((right-tree (car right-result))
                    (remaining-elts (cdr right-result)))
                (cons (make-tree this-entry left-tree right-tree)
                      remaining-elts))))))))

; Exercise 2.65
(define (union-set-tree set1 set2)
  (let ((list1 (tree->list-2 set1))
        (list2 (tree->list-2 set2)))
    (list->tree (union-set list1 list2))))
(define (intersection-set-tree set1 set2)
  (let ((list1 (tree->list-2 set1))
        (list2 (tree->list-2 set2)))
    (list->tree (intersection-set list1 list2))))

; Exercise 2.66
(define (lookup given-key set-of-records)
  (if (null? set-of-records)
      false
      (let ((compare-key (key (entry set-of-records))))
        ((= given-key compare-key) (entry set-of-records))
        ((< given-key compare-key) (lookup given-key (left-branch set-of-records)))
        (else (lookup given-key (right-branch set-of-records))))))

; Huffman Encoding Trees
(define (make-leaf symbol weight)
  (list 'leaf symbol weight))
(define (leaf? object)
  (eq? (car object) 'leaf))
(define (symbol-leaf object) (cadr object))
(define (weight-leaf object) (caddr object))
(define (make-code-tree left right)
  (list left
        right
        (append (symbols left) (symbols right))
        (+ (weight left) (weight right))))
(define (left-branch tree) (car tree))
(define (right-branch tree) (cadr tree))
(define (symbols tree)
  (if (leaf? tree)
      (list (symbol-leaf tree))
      (caddr tree)))
(define (weight tree)
  (if (leaf? tree)
      (weight-leaf tree)
      (cadddr tree)))

(define (decode bits tree)
  (define (decode-1 bits current-branch)
    (if (null? bits)
        '()
        (let ((next-branch
               (choose-branch (car bits) current-branch)))
          (if (leaf? next-branch)
              (cons (symbol-leaf next-branch)
                    (decode-1 (cdr bits) tree))
              (decode-1 (cdr bits) next-branch)))))
  (decode-1 bits tree))
(define (choose-branch bit branch)
  (cond ((= bit 0) (left-branch branch))
        ((= bit 1) (right-branch branch))
        (else (error "bad bit -- CHOOSE-BRANCH" bit))))

(define (adjoin-set x set)
  (cond ((null? set) (list x))
        ((< (weight x) (weight (car set))) (cons x set))
        (else (cons (car set)
                    (adjoin-set x (cdr set))))))
(define (make-leaf-set pairs)
  (if (null? pairs)
      '()
      (let ((pair (car pairs)))
        (adjoin-set (make-leaf (car pair)    ; symbol
                               (cadr pair))  ; frequency
                    (make-leaf-set (cdr pairs))))))

; Exercise 2.67
(define sample-tree
  (make-code-tree (make-leaf 'A 4)
                  (make-code-tree
                   (make-leaf 'B 2)
                   (make-code-tree (make-leaf 'D 1)
                                   (make-leaf 'C 1)))))
(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))

; Exercise 2.68
(define (encode message tree)
  (if (null? message)
      '()
      (append (encode-symbol (car message) tree)
              (encode (cdr message) tree))))
(define (encode-symbol symbol tree)
  (define (encode-1 symbol current-branch bits)
    (if (leaf? current-branch)
        bits
        (cond ((element-of-leaf-set? symbol (symbols (left-branch current-branch)))
               (encode-1 symbol (left-branch current-branch) (append bits (list 0))))
              ((element-of-leaf-set? symbol (symbols (right-branch current-branch)))
               (encode-1 symbol (right-branch current-branch) (append bits (list 1))))
              (else (error "bad symbol " symbol)))))
  (encode-1 symbol tree '()))
(define (element-of-leaf-set? symbol symbols)
  (cond ((null? symbols) #f)
        ((eq? symbol (car symbols)) #t)
        (else
         (element-of-leaf-set? symbol (cdr symbols)))))

; Exercise 2.69
(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))

(define (successive-merge leaf-set)
  (if (= (length leaf-set) 1)
      (car leaf-set)
      (successive-merge
       (add-join-set (make-code-tree (cadr leaf-set)
                                     (car leaf-set))
                     (cddr leaf-set)))))

; 2.4 Multiple Representations for Abstract Data
(define (add-complex z1 z2)
  (make-from-real-imag (+ (real-part z1) (real-part z2))
                       (+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
  (make-from-real-imag (- (real-part z1) (real-part z2))
                       (- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
  (make-from-mag-ang (* (magnitude z1) (magnitude z2))
                     (+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
  (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
                     (- (angle z1) (angle z2))))

; Ben
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (magnitude z)
  (sqrt (+ (square (real-part z)) (square (imag-part z)))))
(define (angle z)
  (atan (imag-part z) (real-part z)))
(define (make-from-real-imag x y) (cons x y))
(define (make-from-mag-ang r a)
  (cons (* r (cos a)) (* r (sin a))))

; Alyssa
(define (real-part z)
  (* (magnitude r) (cos (angle z))))
(define (imag-part z)
  (* (magnitude r) (sin (angle z))))
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-real-imag x y)
  (cons (sqrt (+ (square x) (square y)))
        (atan y x)))
(define (make-from-mag-ang r a) (cons r a))

(define (attach-tag type-tag contents)
  (cons type-tag contents))
(define (type-tag datum)
  (if (pair? datum)
      (car datum)
      (error "Bad tagged datum -- TYPE-TAG" datum)))
(define (rectangular? z)
  (eq? (type-tag z) 'rectangular))
(define (polar? z)
  (eq? (type-tag z) 'polar))

(define (real-part-rectangular z) (car z))
(define (imag-part-rectangular z) (cdr z))
(define (magnitude-rectangular z)
  (sqrt (+ (square (real-partrectangular z))
           (square (imag-part-rectangular z)))))
(define (angle z)
  (atan (imag-part-rectangular z)
        (real-part-rectangular z)))
(define (make-from-real-imag-rectangular x y)
  (attach-tag 'rectangular (cons x y)))
(define (make-from-mag-ang-rectangular r a)
  (attach-tag 'rectangular
              (cons (* r (cos a)) (* r (sin a)))))

(define (real-part-polar z)
  (* (magnitude-polar z) (cos (angle-polar z))))
(define (imag-part-polar z)
  (* (magnitude-polar z) (sin (angle-polar z))))
(define (magnitude-polar z) (car z))
(define (angle-polar z) (cdr z))
(define (make-from-real-imag-polar x y)
  (attach-tag 'polar
              (cons (sqrt (+ (square x) (square y)))
                    (atan y x))))
(define (make-from-mag-and-polar r a)
  (attach-tag 'polar (cons r a)))

(define (real-part z)
  (cond ((rectangular? z)
         (real-part-rectangular (contents z)))
        ((polar? z)
         (real-part-polar (contents z)))
        (else (error "Unknown type -- REAL-PART" z))))
(define (imag-part z)
  (cond ((rectangular? z)
         (imag-part-rectangular (contents z)))
        ((polar? z)
         (imag-part-polar (contents z)))
        (else (error "Unknown type -- IMAG-PART" z))))
(define (magnitude z)
  (cond ((rectangular? z)
         (magnitude-rectangular (contents z)))
        ((polar? z)
         (magnitude-polar (contents z)))
        (else (error "Unknown type -- MAGNITUDE" z))))
(define (angle z)
  (cond ((rectangular? z)
         (angle-rectangular (contents z)))
        ((polar? z)
         (angle-polar (contents z)))
        (else (error "Unknown type -- ANGLE" z))))

(define (make-from-real-imag x y)
  (make-from-real-imag-rectangular x y))
(define (make-from-mag-ang r a)
  (make-from-mag-ang-polar r a))

; 2.4.3 Data Directed Programming and Additivity

; Definitions needed for the rest of the exercise
(define (assoc key records)
  (cond ((empty? records) false)
        ((equal? key (caar records)) (car records))
        (else (assoc key (cdr records)))))
(define (make-table)
  (list '*table*))
(define (lookup key1 key2 table)
  (let ((subtable (assoc key1 (cdr table))))
    (if subtable
        (let ((record (assoc key2 (cdr subtable))))
          (if record
              (cdr record)
              false))
        false)))
(define (insert! key1 key2 value table)
  (let ((subtable (assoc key1 (cdr table))))
    (if subtable
        (let ((record (assoc key2 (cdr subtable))))
          (if record
              (set-cdr! record value)
              (set-cdr! subtable
                        (cons (cons key2 value)
                              (cdr subtable)))))
        (set-cdr! table
                  (cons (list key1
                              (cons key2 value))
                        (cdr table)))))
  'ok)

(define definitions-table (make-table))
(define (put op type item)
  (insert! type op item definitions-table))
(define (get op type)
  (lookup type op definitions-table))

(define (install-rectangular-package)
  (define (real-part z) (car z))
  (define (imag-part z) (cdr z))
  (define (make-from-real-imag x y) (cons x y))
  (define (magnitude z)
    (sqrt (+ (square (real-part z))
             (square (imag-part z)))))
  (define (angle z)
    (atan (imag-part z) (real-part z)))
  (define (make-from-maf-ang r a)
    (cons (* r (cos a)) (* r (sin a))))
  (define (tag x) (attach-tag 'rectangular x))
  (put 'real-part '(rectangular) real-part)
  (put 'imag-part '(rectangular) imag-part)
  (put 'magnitude '(rectangular) magnitude)
  (put 'angle '(rectangular) angle)
  (put 'make-from-real-imag 'rectangular
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'rectangular
       (lambda (r a) (tag (make-from-mag-ang r a))))
  'done)

(define (install-polar-package)
  (define (magnitude z) (car z))
  (define (angle z) (cdr z))
  (define (make-from-mag-ang r a) (cons r a))
  (define (real-part z)
    (* (magnitude z) (cos (angle z))))
  (define (imag-part z)
    (* (magnitude z) (sin (angle z))))
  (define (make-from-real-imag x y)
    (cons (sqrt (+ (square x) (square y)))
          (atan y x)))
  (define (tag x) (attach-tag 'polar x))
  (put 'real-part '(polar) real-part)
  (put 'imag-part '(polar) imag-part)
  (put 'magnitude '(polar) magnitude)
  (put 'angle '(polar) angle)
  (put 'make-from-real-imag 'polar
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'polar
       (lambda (r a) (tag (make-from-mag-ang r a))))
  'done)

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (error
           "No method for these types -- APPLY-GENERIC"
           (list op type-tags))))))

(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))

(define (make-from-real-imag x y)
  ((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
  ((get 'make-from-mag-ang 'polar) r a))

; Exercise 2.73
(define (deriv exp var)
  (cond ((number? exp) 0)
        ((variable? exp) (if (same-variable? exp var) 1 0))
        (else ((get 'deriv (operator exp)) (operands exp)
               var))))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))

; Reset the definitions of make-sum, make-product, make-expo...
(define (make-sum a b)
  (cond ((=number? a 0) b)
	((=number? b 0) a)
	((and (number? a) (number? b) (+ a b)))
	(else (list '+ a b))))

(define (make-product a b)
  (cond ((or (=number? a 0) (=number? b 0)) 0)
	((=number? a 1) b)
	((=number? b 1) a)
	((and (number? a) (number? b)) (* a b))
	(else (list '* a b))))

(define (make-exponentiation a b)
  (cond ((=number? a 1) 1)
	((=number? a 0) 0)
	((=number? b 0) 1)
	((=number? b 1) a)
	((and (number? a) (number? b) (expt a b)))
	(else (list '** a b))))

(define (install-derivative-package)
  (define (deriv-sum operands var)
    (let ((addend (car operands))
          (augend (cadr operands)))
      (make-sum (deriv addend var)
                (deriv augend var))))
  (define (deriv-product operands var)
    (let ((multiplier (car operands))
          (multiplicand (cadr operands)))
      (make-sum
       (make-product multiplier (deriv multiplicand var))
       (make-product (deriv multiplier var) multiplicand))))
  (define (deriv-exponentiation operands var)
    (let ((base (car operands))
          (exponent (cadr operands)))
      (make-product
       (make-product
        exponent
        (make-exponentiation
         base
         (make-sum exponent -1)))
       (deriv base var))))
  (put 'deriv '+ deriv-sum)
  (put 'deriv '* deriv-product)
  (put 'deriv '** deriv-exponentiation)
  'done)

; Exercise 2.74
(define (install-acme-package)
  (define (lookup name list)
    (cond ((empty? list) false)
          ((equal? name (car (car list)))
           (cdr (car list)))
          (else (lookup name (cdr list)))))
  (define (get-record name file)
    (lookup name file))
  (define (get-salary record)
    (car record))
  (define (tag-record record) (attach-tag 'acme-record record))
  (put 'get-record '(acme-file name)
       (lambda (file name) (tag-record (get-record name file))))
  (put 'get-salary '(acme-record)
       (lambda (record) (get-salary record)))
  'done)

(define (create-name name)
  (attach-tag 'name name))
(define (get-record name file)
  (apply-generic 'get-record file name))
(define (get-salary record)
  (apply-generic 'get-salary record))
(define (find-employee-record name files)
  (cond ((null? files) nil)
        (else (let ((record (get-record name (car files))))
                (if record
                    record
                    (find-employee-record name (cdr files)))))))

; Message Passing
(define (make-from-real-imag x y)
  (define (dispatch op)
    (cond ((eq? op 'real-part) x)
          ((eq? op 'imag-part) y)
          ((eq? op 'magnitude)
           (sqrt (+ (square x) (square y))))
          ((eq? op 'angle) (atan x y))
          (else
           (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
  dispatch)
(define (apply-generic op arg) (arg op))
 
; Exercise 2.75
(define (make-from-mag-ang r a)
  (define (dispatch op)
    (cond ((eq? op 'real-part)
           (* r (cos a)))
          ((eq? op 'imag-part)
           (* r (sin a)))
          ((eq? op 'magnitude) r)
          ((eq? op 'angle) a)
          (else
           (error "Unknown op -- MAKE-FROM-MAG-ANG" op))))
  dispatch)
  
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
  (* (magnitude z) (cos (angle z))))
(define (imag-part z)
  (* (magnitude z) (sin (angle z))))

; Systems with Generic Operations

; Resetting definition due to exercise 2.75 above
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))

; Resetting definition due to Message Passing Section above
(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (error
           "No method for these types -- APPLY-GENERIC"
           (list op type-tags))))))

(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))

(define (install-scheme-number-package)
  (define (tag x)
    (attach-tag 'scheme-number x))    
  (put 'add '(scheme-number scheme-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(scheme-number scheme-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(scheme-number scheme-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(scheme-number scheme-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'scheme-number
       (lambda (x) (tag x)))
  'done)

(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))

(define (install-rational-package)
  ;; internal procedures
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (let ((g (gcd n d)))
      (cons (/ n g) (/ d g))))
  (define (add-rat x y)
    (make-rat (+ (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (numer x) (numer y))
              (* (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (* (numer x) (denom y))
              (* (denom x) (numer y))))
  ;; interface to rest of the system
  (define (tag x) (attach-tag 'rational x))
  (put 'add '(rational rational)
       (lambda (x y) (tag (add-rat x y))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat x y))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat x y))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat x y))))

  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  'done)
(define (make-rational n d)
  ((get 'make 'rational) n d))

(define (install-complex-package)
  ;; imported procedures from rectangular and polar packages
  (define (make-from-real-imag x y)
    ((get 'make-from-real-imag 'rectangular) x y))
  (define (make-from-mag-ang r a)
    ((get 'make-from-mag-ang 'polar) r a))
  ;; internal procedures
  (define (add-complex z1 z2)
    (make-from-real-imag (+ (real-part z1) (real-part z2))
                         (+ (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (- (real-part z1) (real-part z2))
                         (- (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (* (magnitude z1) (magnitude z2))
                       (+ (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
                       (- (angle z1) (angle z2))))
  ;; interface to rest of the system
  (define (tag z) (attach-tag 'complex z))
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
  (put 'sub '(complex complex)
       (lambda (z1 z2) (tag (sub-complex z1 z2))))
  (put 'mul '(complex complex)
       (lambda (z1 z2) (tag (mul-complex z1 z2))))
  (put 'div '(complex complex)
       (lambda (z1 z2) (tag (div-complex z1 z2))))
  (put 'make-from-real-imag 'complex
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'complex
       (lambda (r a) (tag (make-from-mag-ang r a))))
  'done)

(define (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
  ((get 'make-from-mag-ang 'complex) r a))

; Exercise 2.77
(define (install-complex-package)
  ;; imported procedures from rectangular and polar packages
  (define (make-from-real-imag x y)
    ((get 'make-from-real-imag 'rectangular) x y))
  (define (make-from-mag-ang r a)
    ((get 'make-from-mag-ang 'polar) r a))
  ;; internal procedures
  (define (add-complex z1 z2)
    (make-from-real-imag (+ (real-part z1) (real-part z2))
                         (+ (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (- (real-part z1) (real-part z2))
                         (- (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (* (magnitude z1) (magnitude z2))
                       (+ (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
                       (- (angle z1) (angle z2))))
  ;; interface to rest of the system
  (define (tag z) (attach-tag 'complex z))
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
  (put 'sub '(complex complex)
       (lambda (z1 z2) (tag (sub-complex z1 z2))))
  (put 'mul '(complex complex)
       (lambda (z1 z2) (tag (mul-complex z1 z2))))
  (put 'div '(complex complex)
       (lambda (z1 z2) (tag (div-complex z1 z2))))
  (put 'make-from-real-imag 'complex
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'complex
       (lambda (r a) (tag (make-from-mag-ang r a))))
  ; Additons due to exercise 2.77
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  'done)

; Exercise 2.78
(define (type-tag x)
  (cond ((number? x) 'scheme-number)
        (else (car x))))
(define (contents x)
  (cond ((number? x) x)
        (else (cdr x))))
(define (attach-tag type x)
  (cond ((number? x) x)
        (else (cons type x))))

; Exercise 2.79 and 2.80
(define (install-scheme-number-package)
  (define (tag x)
    (attach-tag 'scheme-number x))    
  (put 'add '(scheme-number scheme-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(scheme-number scheme-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(scheme-number scheme-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(scheme-number scheme-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'scheme-number
       (lambda (x) (tag x)))
  ;; Additions due to 2.79 and 2.80
  (put 'equ? '(scheme-number scheme-number)
       (lambda (x y) (= x y)))
  (put 'zero? '(scheme-number)
       (lambda (x) (= x 0)))
  'done)

(define (install-rational-package)
  ;; internal procedures
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (let ((g (gcd n d)))
      (cons (/ n g) (/ d g))))
  (define (add-rat x y)
    (make-rat (+ (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (numer x) (numer y))
              (* (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (* (numer x) (denom y))
              (* (denom x) (numer y))))
  ;; interface to rest of the system
  (define (tag x) (attach-tag 'rational x))
  (put 'add '(rational rational)
       (lambda (x y) (tag (add-rat x y))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat x y))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat x y))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat x y))))
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  ;; Additions due to 2.79 and 2.80
  (put 'equ? '(rational rational)
       (lambda (x y)
         (let ((z (div-rat x y)))
           (= (numer z) (denom z)))))
  (put 'zero? '(rational)
       (lambda (x) (= (numer x) 0)))
  'done)

(define (install-complex-package)
  ;; imported procedures from rectangular and polar packages
  (define (make-from-real-imag x y)
    ((get 'make-from-real-imag 'rectangular) x y))
  (define (make-from-mag-ang r a)
    ((get 'make-from-mag-ang 'polar) r a))
  ;; internal procedures
  (define (add-complex z1 z2)
    (make-from-real-imag (+ (real-part z1) (real-part z2))
                         (+ (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (- (real-part z1) (real-part z2))
                         (- (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (* (magnitude z1) (magnitude z2))
                       (+ (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
                       (- (angle z1) (angle z2))))
  ;; interface to rest of the system
  (define (tag z) (attach-tag 'complex z))
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
  (put 'sub '(complex complex)
       (lambda (z1 z2) (tag (sub-complex z1 z2))))
  (put 'mul '(complex complex)
       (lambda (z1 z2) (tag (mul-complex z1 z2))))
  (put 'div '(complex complex)
       (lambda (z1 z2) (tag (div-complex z1 z2))))
  (put 'make-from-real-imag 'complex
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'complex
       (lambda (r a) (tag (make-from-mag-ang r a))))
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  ;; Additions due to 2.79 and 2.80
  (put 'equ? '(complex complex)
       (lambda (z1 z2) (and (= (real-part z1) (real-part z2))
                            (= (imag-part z1) (imag-part z2)))))
  (put 'zero? '(complex)
       (lambda (z) (and (= (real-part z) 0)
                        (= (imag-part z) 0))))
  'done)

(define (equ? x y) (apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))

;; Coercion

(define coercion-definitions-table (make-table))
(define (put-coercion from-type to-type method)
  (insert! from-type to-type method coercion-definitions-table))
(define (get-coercion from-type to-type)
  (lookup from-type to-type coercion-definitions-table))

(define (scheme-number->complex n)
  (make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number 'complex scheme-number->complex)

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (if (= (length args) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car args))
                    (a2 (cadr args)))
                (let ((t1->t2 (get-coercion type1 type2))
                      (t2->t1 (get-coercion type2 type1)))
                  (cond (t1->t2
                         (apply-generic op (t1->t2 a1) a2))
                        (t2->t1
                         (apply-generic op a1 (t2->t1 a2)))
                        (else
                         (error "No method for these types"
                                (list op type-tags))))))
              (error "No method for these types"
                     (list op type-tags)))))))

;; Exercise 2.81
(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (if (= (length args) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car args))
                    (a2 (cadr args)))
                (if (eq? type1 type2)
                    (error "No method for these types"
                           (list op type-tags))
                    (let ((t1->t2 (get-coercion type1 type2))
                          (t2->t1 (get-coercion type2 type1)))
                      (cond (t1->t2
                             (apply-generic op (t1->t2 a1) a2))
                            (t2->t1
                             (apply-generic op a1 (t2->t1 a2)))
                            (else
                             (error "No method for these types"
                                    (list op type-tags)))))))
              (else
               (error "No method for these types"
                      (list op type-tags))))))))

;; Exercise 2.82
(define (apply-generic op . args)
  (define (get-type-coerced-args type args)
    (map (lambda (x)
           (let ((new-type (get-coercion (type-tag x) type)))
             (if new-type
                 (new-type x)
                 x)))
         args))
  (define (all-same-type? args)
    (let ((first-type (type-tag (car args))))
      (accumulate (lambda (x last)
                    (and (eq? first-type (type-tag x)) last))
                  #t (cdr args))))
  (define (try op args type-tags)
    (cond ((empty? type-tags)
           (error "No method for these types"
                  (list op (map type-tag args))))
          (else
           (let ((coerced-args (get-type-coerced-args (car type-tags) args)))
             (if (all-same-type? coerced-args)
                 (apply apply-generic (cons op coerced-args))
                 (try op args (cdr type-tags)))))))
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (if (all-same-type? args)
              (error "No method for these types"
                     (list op type-tags))
              (try op args type-tags))))))

;; Exercise 2.83
(define (install-raise-package)
  (define (integer->rational n)
    (make-rational n 1))
  (define (rational->real r)
    (cons 'real (/ (car r) (cdr r))))
  (define (real->complex r)
    (make-complex-from-real-imag r 0))
  (put 'raise '(scheme-number) integer->rational)
  (put 'raise '(rational) rational->real)
  (put 'raise '(real) real->complex)
  'done)
 
(define (raise x) (apply-generic 'raise x))

;; Exercise 2.84
(define type-tower '((complex 0) (real 1) (rational 2) (scheme-number 3)))
(define (get-tower-level type type-tower)
  (cond ((empty? type-tower) nil)
        ((eq? (car (car type-tower)) type) (cadr (car type-tower)))
        (else (get-tower-level type (cdr type-tower)))))
(define (is-higher-type type1 type2)
  (< (get-tower-level type1 type-tower) (get-tower-level type2 type-tower)))
 
(define (apply-generic op . args)
  (define (get-highest-level type-tags)
    (accumulate (lambda (type highest)
                  (if (is-higher-type type highest) type highest))
                (car type-tags)
                (cdr type-tags)))
  (define (raise-until type x)
    (cond ((eq? (type-tag x) type) x)
          (else (raise-until type (raise x)))))
  (define (all-same-type? args)
    (let ((first-type (type-tag (car args))))
      (accumulate (lambda (x last)
                    (and (eq? first-type (type-tag x)) last))
                  true
                  (cdr args))))
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (if (all-same-type? args)
              (error "No method for these types"
                     (list op type-tags))
              (let ((highest-level (get-highest-level type-tags)))
                (apply
                 apply-generic
                 (cons op (map (lambda (arg)
                                 (raise-until highest-level arg))
                               args)))))))))

;; Exercise 2.85
(define (install-rational-package)
  ;; internal procedures
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (let ((rn (round n)) (rd (round d)))
      (if (and (= n rn) (= d rd))
          (let ((g (gcd rn rd)))
            (cons (/ rn g) (/ rd g)))
          (make-rat (* 10 n) (* 10 d)))))
  (define (add-rat x y)
    (make-rat (+ (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (numer x) (numer y))
              (* (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (* (numer x) (denom y))
              (* (denom x) (numer y))))
  ;; Additions due to 2.85
  (define (project-rational r)
    (make-scheme-number (round (/ (numer r) (denom r)))))
  ;; interface to rest of the system
  (define (tag x) (attach-tag 'rational x))
  (put 'add '(rational rational)
       (lambda (x y) (tag (add-rat x y))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat x y))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat x y))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat x y))))
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  (put 'equ? '(rational rational)
       (lambda (x y)
         (let ((z (div-rat x y)))
           (= (numer z) (denom z)))))
  (put 'zero? '(rational)
       (lambda (x) (= (numer x) 0)))
  ;; Additions due to 2.85
  (put 'project '(rational) project-rational)
  'done)

(define (install-complex-package)
  ;; imported procedures from rectangular and polar packages
  (define (make-from-real-imag x y)
    ((get 'make-from-real-imag 'rectangular) x y))
  (define (make-from-mag-ang r a)
    ((get 'make-from-mag-ang 'polar) r a))
  ;; internal procedures
  (define (add-complex z1 z2)
    (make-from-real-imag (+ (real-part z1) (real-part z2))
                         (+ (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (- (real-part z1) (real-part z2))
                         (- (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (* (magnitude z1) (magnitude z2))
                       (+ (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
                       (- (angle z1) (angle z2))))
  ;; Additions due to 2.85
  (define (project-complex z)
    (cons 'real (real-part z)))
  ;; interface to rest of the system
  (define (tag z) (attach-tag 'complex z))
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
  (put 'sub '(complex complex)
       (lambda (z1 z2) (tag (sub-complex z1 z2))))
  (put 'mul '(complex complex)
       (lambda (z1 z2) (tag (mul-complex z1 z2))))
  (put 'div '(complex complex)
       (lambda (z1 z2) (tag (div-complex z1 z2))))
  (put 'make-from-real-imag 'complex
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'complex
       (lambda (r a) (tag (make-from-mag-ang r a))))
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  (put 'equ? '(complex complex)
       (lambda (z1 z2) (and (= (real-part z1) (real-part z2))
                            (= (imag-part z1) (imag-part z2)))))
  (put 'zero? '(complex)
       (lambda (z) (and (= (real-part z) 0)
                        (= (imag-part z) 0))))
  ;; Additions due to 2.85
  (put 'project '(complex) project-complex)
  'done)

(put 'project '(real) (lambda (r) (make-rational r 1)))
(put 'equ? '(real real) (lambda (r1 r2) (= r1 r2)))

(define (drop n)
  (let ((type (type-tag n)))
    (let ((project (get 'project (list type))))
      (if project
          (let ((dropped (project (contents n))))
            (let ((raise (get 'raise (list (type-tag dropped)))))
              (let ((equ? (get 'equ? (list type type))))
              (if equ?
                  (if (equ? (contents n)
                            (contents (raise (contents dropped))))
                      (if (drop? dropped)
                          (drop dropped)
                          dropped)
                      n)
                  n))))
          n))))

(define (drop? n)
  (cond ((boolean? n) false)
        ((eq? (type-tag n) 'scheme-number) false)
        (else true)))
  
(define (apply-generic op . args)
  (define (get-highest-level type-tags)
    (accumulate (lambda (type highest)
                  (if (is-higher-type type highest) type highest))
                (car type-tags)
                (cdr type-tags)))
  (define (raise-until type x)
    (cond ((eq? (type-tag x) type) x)
          (else (raise-until type (raise x)))))
  (define (all-same-type? args)
    (let ((first-type (type-tag (car args))))
      (accumulate (lambda (x last)
                    (and (eq? first-type (type-tag x)) last))
                  true
                  (cdr args))))
  (define (helper)
    (let ((type-tags (map type-tag args)))
      (let ((proc (get op type-tags)))
        (if proc
            (apply proc (map contents args))
            (if (all-same-type? args)
                (error "No method for these types"
                       (list op type-tags))
                (let ((highest-level (get-highest-level type-tags)))
                  (apply
                   apply-generic
                   (cons op (map (lambda (arg)
                                   (raise-until highest-level arg))
                                 args)))))))))
  (let ((result (helper)))
    (if (drop? result)
        (drop result)
        result)))

(define (install-all-packages)
  (install-scheme-number-package)
  (install-rational-package)
  (install-rectangular-package)
  (install-polar-package)
  (install-complex-package)
  (install-raise-package))