Very Secure

SICP 2.1 Solutions - Introduction to Data Abstraction

The chapters seem to get progressively harder, so I plan to break my future posts into subchapters like this one. So far no problem has proven itself to be particularly difficult, save 1.15 and 2.16. 1.15 requires reviewing how to solve runtimes for recursive solutions, which is only slightly touched on in the book. 2.16 is a whole project in and of itself, so I've chosen to skip that problem for now.

 
;; Functions needed from Chapter 1.
(defun average (a b) (/ (+ a b) 2))

;; 2.1
(defun make-rat (a b)
  (defun negate (x) (- x))
  (if (< b 0)
      (cons (negate a) (negate b))
      (cons a b)))

;; 2.2

(defun make-point (x y) (cons x y))
(defun x-point (point) (car point))
(defun y-point (point) (cdr point))
(defun make-segment (a b) (cons a b))
(defun start-segment (segment) (car segment))
(defun end-segment   (segment) (cdr segment))
(defun midpoint-segment (segment)
  (defun average-two-points (get-point)
    (average (funcall get-point (start-segment segment))
	     (funcall get-point (end-segment   segment))))
  (make-point
   (average-two-points #'x-point)
   (average-two-points #'y-point)))

(defun print-point (point)
  (princ "(")
  (princ (x-point point))
  (princ ", ")
  (princ (y-point point))
  (princ ")")
  nil)

;; 2.3

(defun square (x) (* x x))
(defun distance (p1 p2)
  (sqrt (+ (square (- (x-point p1) (x-point p2)))
	   (square (- (y-point p1) (y-point p2))))))
(defun length-segment (segment)
  (distance (start-segment segment) (end-segment segment)))

;; Rectangle Abstraction 1
;; Requires user to give p1 p2 p3 so <(p1 p2 p3) = pi/2
(defun make-rectangle (p1 p2 p3)
  (cons (make-segment p1 p2) (make-segment p2 p3)))
(defun width  (rectangle) (length-segment (car rectangle)))
(defun height (rectangle) (length-segment (cdr rectangle)))

(defun make-rectangle-2 (bottom-left width height)
  (cons bottom-left (cons width height)))
(defun width-2  (rectangle) (cadr rectangle))
(defun height-2 (rectangle) (cddr rectangle))

;; End Rectangle Abstraction
(defun perimeter (rectangle) (* 2 (+ (width rectangle) (height rectangle))))
(defun area (rectangle) (* (width rectangle) (height rectangle)))

;; 2.4
(defun mycons (x y)
  (lambda (m) (funcall m x y)))

(defun mycar (z)
  (funcall z (lambda (p q) (declare (ignore q)) p)))

(defun mycdr (z)
  (funcall z (lambda (p q) (declare (ignore p)) q)))

;; Substitution Model, same for mycdr
;; (mycar (mycons 1 2))
;; (funcall (mycons 1 2) (lambda (p q) (declare ignore q) p))
;; (funcall (lambda (m) (funcall m 1 2)) (lambda (p q) (declare ignore q) p))
;; (funcall (lambda (p q) (declare ignore q) p) 1 2)
;; ( (declare ignore 2) 1)
;; 1

;; 2.5

(defun num-cons (x y) (* (expt 2 x) (expt 3 y)))

(defun num-car (z)
  (if (equal (mod z 2) 1)
      0
      (+ 1 (num-car (/ z 2)))))

(defun num-cdr (z)
  (if (not (equal (mod z 3) 0))
      0
      (+ 1 (num-cdr (/ z 3)))))

;; 2.6

(defun church-zero () (lambda (f) (declare (ignore f)) (lambda (x) x)))

(defun church-add-one (n)
  (lambda (f) (lambda (x) (funcall f (funcall (funcall n f) x)))))

;; Substitution method
(lambda (f) (lambda (x) (funcall f (funcall (funcall (my-zero) f) x))))

(lambda (f)
  (lambda (x)
    (funcall f
	     (funcall
	      (funcall (lambda (f) (declare (ignore f)) (lambda (x) x)) f) x))))

(lambda (f)
  (lambda (x)
    (funcall
     f
     (funcall (lambda (x) x) x))))

(lambda (f)
  (lambda (x)
    (funcall f x)))

(defun church-one ()
  (lambda (f) (lambda (x) (funcall f x))))

;; add one to church-one to get church-two

(lambda (f)
  (lambda (x)
    (funcall
     f
     (funcall (funcall (lambda (f) (lambda (x) (funcall f x))) f) x))))

(lambda (f)
  (lambda (x)
    (funcall
     f
     (funcall (lambda (x) (funcall f x)) x))))

(defun church-two ()
  (lambda (f) (lambda (x) (funcall f (funcall f x)))))

;; church zero returns a function that takes a function f,
;; and returns an identity function. It does nothing with f.

;; church one returns a function that takes a function f, and then creates a
;; new function that takes a function x and calls f on x.

;; church two returns a function that takes a function f, and then creates a
;; new function that takes a function x, and calls f twice on x.

;; church two, takes a function f, returns a function that calls f on a
;;
(defun church-add (a b)
  (lambda (f) (lambda (x) (funcall (funcall a f) (funcall (funcall b f) x)))))

;; example

(church-add #'church-one #'church-zero)

(lambda (f)
  (lambda (x)
    (funcall
     (funcall (church-one) f)
     (funcall (funcall (church-zero) f) x))))

(lambda (f)
  (lambda (x)
    (funcall
     (funcall (church-one) f)
     (funcall (lambda (x) x) x))))

(lambda (f)
  (lambda (x)
    (funcall
     (funcall (church-one) f)
     x)))

(lambda (f)
  (lambda (x)
    (funcall
     (lambda (x) (funcall f x))
     x)))

(lambda (f) (lambda (x) (funcall f x)))

;; 2.7

(defun make-interval (a b) (cons a b))

(defun lower-bound (interval) (car interval))
(defun upper-bound (interval) (cdr interval))

;; 2.8

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

(defun sub-interval (x y)
  (make-interval (- (lower-bound x) (upper-bound y))
		 (- (upper-bound x) (lower-bound y))))

;; 2.9

;; width =  (upper-bound - lower-bound)/2
;; addition:
;; 2w1 = u1 - l1
;; 2w2 = u2 - l2
;; 2w3 = (u1 + u2) - (l1 + l2)
;; 2w3 = (u1 - l1) + (u2 - l2)
;; w3 = w1 + w2

;; subtraction:
;; 2w1 = u1 - l1
;; 2w2 = u2 - l2
;; 2w3 = (u1 - l2) - (l1 - u2)
;; 2w3 = (u1 - l1) + (u2 - l2)
;; w3 = w1 + w2

;; multiplication counterexample:
;; i1 = -5 5
;; i2 =  5 10
;; i3 =  -5 0
;; i2 and i3 have the same width, but:
;; width of i1 * i2 (-50, 50) = 100
;; width of i1 * i3 (-25, 25) = 50

;; division counterexample:
;; i1 = 1 3
;; i2 = 1 3
;; i3 = -1 1
;; width of i1 / i2 (1/3, 3) = 10/3
;; width of i1 / i3 (-3, 3)  = 6

;; 2.10

(defun 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))))

(defun div-interval-fixed (x y)
  (if (or (equal x 0) (equal y 0))
      (error "Division by zero")
      (mul-interval
       x
       (make-interval (/ 1.0 (upper-bound y))
		      (/ 1.0 (lower-bound y))))))

;; 2.11

(defun mul-interval-fast (x y)
  (defun posp (x) (>= x 0))
  (defun negp (x) (not (posp x)))
  (let ( (lx (lower-bound x))
	(ux (upper-bound x))
	(ly (lower-bound y))
	(uy (upper-bound y)))
    (cond
      ( (posp lx)
       (cond
	 ( (posp ly)                 (make-interval (* lx ly) (* ux uy)))
	 ( (and (negp ly) (posp uy)) (make-interval (* ux ly) (* ux uy)))
	 (t                         (make-interval (* ux ly) (* lx uy)))))
      ( (and (negp lx) (posp ux))
       (cond
	 ( (posp ly)                 (make-interval (* lx uy) (* ux uy)))
	 ( (and (negp ly) (posp uy)) (make-interval (min (* lx uy) (* ux ly))
						   (max (* lx ly) (* ux uy))))
	 (t                         (make-interval (* ux ly) (* lx ly)))))
      (t ;; first interval is completely negative
       (cond
	 ( (posp ly)                 (make-interval (* lx uy) (* ux ly)))
	 ( (and (negp ly) (posp uy)) (make-interval (* uy lx) (* ly lx)))
	 (t                         (make-interval (* ux uy) (* lx ly))))))))

(defun test-mult-interval-fast ()
  ;; I rushed through checking for errors with zeros.

    (defun assert-mults-correctly (lx ux ly uy le ue)
      (let ( (new-interval (mul-interval-fast (make-interval lx ux) (make-interval ly uy))))
	(assert (equal le (lower-bound new-interval)))
	(assert (equal ue (upper-bound new-interval)))))

    (assert-mults-correctly 0 0   0 0   0 0)

    (assert-mults-correctly 2 4    3  5     6 20)
    (assert-mults-correctly 2 4    0 0   0 0)
    (assert-mults-correctly 2 4   -3  5   -12 20)
    (assert-mults-correctly 2 4   -5 -3   -20 -6)

    (assert-mults-correctly -2 5    3  4    -8   20)
    (assert-mults-correctly -2 5    0 0   0 0)
    (assert-mults-correctly -2 5   -3  5    -15  25)
    (assert-mults-correctly -9 3   -9  10   -90  81)
    (assert-mults-correctly -2 5   -4  -3   -20   8)

    (assert-mults-correctly -4 -2    0 0        0 0)
    (assert-mults-correctly -4 -2    3  5    -20 -6)
    (assert-mults-correctly -4 -2   -3  5    -20 12)

    ;; this last one caught a bug.
    (assert-mults-correctly -4 -2   -5 -3     6  20))

;; 2.12

(defun make-center-percent (center percent)
  (make-interval (- center (* (/ percent 100) center)) (+ center (* (/ percent 100) center))))

(defun center-i (i)
  (/ (+ (lower-bound i) (upper-bound i)) 2))

(defun width-i (i)
  (/ (- (upper-bound i) (lower-bound i)) 2))

(defun percent (i)
  (if (equal (center-i i) 0)
      (error "division by 0")
      (* (/ (width-i i) (center-i i)) 100)))

;; 2.13

;; first interval is  [C1 - (p1*C1) , C1 + (p1 * C1)]
;; second interval is [C2 - (p2*C2) , C2 + (p2 * C2)]
;; Since they're both positive the new min is min x min and new max is max x max
;; We will show work for the min x min.
;; ( C1 - (p1 * C1) ) * ( C2 - (p2 * C2) )
;; C1C2 + p1c1p2c2 - p1c1c2 - p2c1x2
;; c1c2 + p1p2c1c2 - (p1 + p2)c1c2
;; c1c2 (p1p2 - (p1+p2)) c1c2.
;; Since p1 and p2 are small p1p2 is ~0 so this reduces to c1c2 - (p1+p2)c1c2
;; So the new percentage is p1 + p2.

;; 2.14
;; Everytime you multiply or divide something with error bounds, the error increases. So if you
;; make an interval by taking A / A, it is going to have more of an error than simply making
;; the interval 1.

(defun par1 (r1 r2)
  (div-interval-fixed (mul-interval r1 r2)
		      (add-interval r1 r2)))

(defun par2 (r1 r2)
  (let ( (one (make-interval 1 1)))
    (div-interval-fixed one
			(add-interval (div-interval-fixed one r1)
				      (div-interval-fixed one r2)))))

;; 2.15
;; par2 is indeed better because we are not unnecessarily compounding our error.

;; 2.16 I believe requires writing a library that has a large set of algebraic identities used for reducing algebraic expression. Possibly a TODO, but I probably will not do this exercise.

Leave a Reply