Archive for May, 2019

Ch 2.2 Hierarchical Data and the Closure Property

Tuesday, May 28th, 2019

Do you know every time I post these, I need to go through and put extra spaces in in between double parens to avoid my code turning into footnotes? Holy hell.

This is probably the first useful post to someone going through SICP using Common Lisp since it contains a little bit of code to draw your images from the end of the chapter to svg markup. Look at print-svg-header, draw-to-square-svg, and draw-line at the bottom to see the details.


;; 2.17

(defun last-pair (lst)
  (if (equal (cdr lst) nil)
      lst
      (last-pair (cdr lst))))

;; 2.18
(defun my-reverse (lst)
  (if (equal lst nil)
      nil
      (append (my-reverse (cdr lst)) (list (car lst)))))

;; 2.19

(defparameter *us-coins* (list 50 25 10 5 1))

(defun cc (amount coin-values)
  (defun no-more? (values) (null values))
  (defun except-first-denomination (values) (cdr values))
  (defun first-denomination (values) (car values))
  (cond ( (equal amount 0) 1)
	 ( (or (< amount 0) (no-more? coin-values)) 0)
	 (t
	  (+ (cc amount
		 (except-first-denomination coin-values))
	     (cc (- amount
		    (first-denomination coin-values))
		 coin-values)))))

;; 2.20

(defun same-parity (x &rest y)
  (let ( (parity (mod x 2)))
    (defun filter-parity (remaining)
      (cond
	((null remaining) nil)
	((equal (mod (car remaining) 2) parity)
	 (cons (car remaining) (filter-parity (cdr remaining))))
	(t (filter-parity (cdr remaining))))))
  (cons x (filter-parity y)))

;; 2.21

(defun square-list (items)
  (if (null items)
      nil
      (cons (square (car items)) (square-list (cdr items)))))

(defun square-list-two (items)
  (mapcar (lambda (x) (square x)) items))

;; 2.22
;; This would make the first element in the list nil, and would make the cons chain
;; look something like (nil (1 (4 (9 16)))) which is a malformed list.

;; 2.23

(defun for-each (f lst)
    (if (not (null lst)) (funcall f (car lst)))
    (if (null lst) nil (for-each f (cdr lst))))

;; Seems like a  better verison, but we do not have progn as a construct so far in the book.
(defun for-each-progn (f lst)
  (if (null lst)
      nil
      (progn (funcall f (car lst)) (for-each f (cdr lst)))))

;; 2.24 see picture

;; 2.25

;; (car (cdaddr '(1 3 (5 7) 9)))
;; (caar '((7)))
;; (cadadr ( cadadr (cadadr '(1 (2 (3 (4 (5 (6 7))))))))

;; 2.26

(defun twotwosix ()
  (let ( (x (list 1 2 3))
	(y (list 4 5 6)))
    (print (append x y)) ; (1 2 3 4 5 6)
    (print (cons x y))   ; ( (1 2 3) 4 5 6)
    (print (list x y)))) ; ( (1 2 3) (4 5 6))

;; 2.27

;; This was easy to do by looking at the simple solution of shallow-reverse.
(defun deep-reverse (lst)
  (cond
    ( (null lst) nil)
    ( (atom (car lst)) (append (deep-reverse (cdr lst)) (list (car lst))))
    (t (append (deep-reverse (cdr lst)) (list (deep-reverse (car lst)))))))

;; 2.28

;; flatten the list
(defun fringe (lst)
  (cond
    ( (null lst) nil)
    ( (atom (car lst)) (cons (car lst) (fringe (cdr lst))))
    (t (append (fringe (car lst)) (fringe (cdr lst))))))

;; 2.29

(defun make-mobile (left right) (list left right))
(defun left-branch (mobile)  (car mobile))
(defun right-branch (mobile) (cadr mobile))

(defun make-branch (length structure) (list length structure))
(defun branch-length (branch) (car branch))
(defun branch-structure (branch) (cadr branch))

(defun is-leaf-branch (branch) (atom (branch-structure branch)))

;; I wonder if I should not have these circular definitions of get-weight and total-weight.
;; But it seems very useful to separate the block structure for the is-balanced method.
(defun get-weight (branch)
  (if (is-leaf-branch branch)
      (branch-structure branch)
      (total-weight (branch-structure branch))))

(defun total-weight (mobile)
  (let ( (left (left-branch mobile))
	 (right (right-branch mobile)))
    (+ (get-weight left) (get-weight right))))

(defun is-balanced (mobile)
  (defun torque-of-branch (branch) (* (branch-length branch) (get-weight branch)))
  (defun is-just-a-weight (mobile) (atom mobile))
  (if (is-just-a-weight mobile)
      t
      (let ( (left (left-branch mobile))
	    (right (right-branch mobile)))
	(and
	 (equal (torque-of-branch left) (torque-of-branch right))
	 (is-balanced (branch-structure left))
	 (is-balanced (branch-structure right))))))

(make-mobile (make-branch 5 10) (make-branch 6 (make-mobile (make-branch 5 5) (make-branch 6 6))))
(make-mobile (make-branch 5 20) (make-branch 10 (make-mobile (make-branch 2 8) (make-branch 8 2))))

;; d) we would just need to change "cad" in branch-structure and right-branch to "cdr"

;; 2.30

(defun square-tree-direct (tree)
  (cond
    ( (null tree) nil)
    ( (atom tree) (square tree))
    (t (cons (square-tree-direct (car tree)) (square-tree-direct (cdr tree))))))

(defun square-tree (tree)
  (mapcar
   (lambda (element)
     (if (listp element)
	 (square-tree element)
	 (square element))) tree))

;; 2.31

(defun tree-map (f tree)
  (mapcar (lambda (element) (if (listp element) (tree-map f element) (funcall f element))) tree))

;; 2.32

;; To find the subsets of s, we append the first element of s to all the subsets of s minus
;; the first element.
(defun subsets (s)
  (if (null s)
      (list nil)
      (let ( (rest (subsets (cdr s))))
	(append rest (mapcar (lambda (ele) (append ele (list (car s)))) rest)))))

;; 2.33

(defun accumulate (op initial sequence)
  (if (null sequence)
      initial
      (funcall op
	       (car sequence)
	       (accumulate op initial (cdr sequence)))))

(defun my-map (f sequence)
  (accumulate  (lambda (x y) (cons (funcall f x) y)) nil sequence))

(defun my-append (seq1 seq2)
  (accumulate #'cons seq2 seq1))

(defun my-length (sequence)
  (accumulate (lambda (x y) (declare (ignore x)) (+ 1 y)) 0 sequence))

;; 2.34

(defun horner-eval (x-val coefficients)
  (accumulate (lambda (coefficient processed) (+ coefficient (* x-val processed))) 0 coefficients))

;; 2.35

(defun count-leaves-acc (tree)
  (accumulate #'+ 0
	      (mapcar (lambda (ele)
			(if (listp ele)
			    (count-leaves-acc ele)
			    1)) tree)))
;; 2.36

(defun accumulate-n (op init seqs)
  (if (null (car seqs))
      nil
      (cons (accumulate   op init (mapcar #'car seqs))
	    (accumulate-n op init (mapcar #'cdr seqs)))))

;; 2.37

;; I'm not sure how to get the equivilant map function found in scheme,
;; so I rewrote dot-product.

(defun dot-product (v w)
  (defun multiply-same-indices (v w)
    (cond
      ( (null v) nil)
      (t
       (cons (* (car v) (car w))
	     (multiply-same-indices (cdr v) (cdr w))))))
  (accumulate #'+ 0 (multiply-same-indices v w)))

(defun matrix-*-vector (m v)
  (mapcar (lambda  (w) (dot-product w v)) m))

(defun transpose (mat)
  (accumulate-n #'cons nil mat))

(defun matrix-*-matrix (m n)
  (let ( (cols (transpose n)))
    (mapcar (lambda (row) (matrix-*-vector cols row)) m)))

;; 2.38

(defun fold-right (op initial sequence) (accumulate op initial sequence))

(defun fold-left (op initial sequence)
  (defun iter (result rest)
    (if (null rest)
	result
	(iter (funcall op result (car rest))
	      (cdr rest))))
  (iter initial sequence))

;; (iter (list nil 1) (2 3))
;; (iter (list (list nil 1) 2) (3))
;; (iter (list (list (list nil 1) 2) 3))

;; (fold-right / 1 (list 1 2 3 ))     = 3/2
;; (fold-left / 1 (list 1 2 3 ))      = 1/6
;; (fold-right list nil (list 1 2 3)) = (1 (2 (3 nil)))
;; (fold-left list nil (list 1 2 3))  = ( ( (nil 1) 2) 3)

;; op must be communative and associative.

;; 2.39

(defun fold-right-reverse (sequence)
  (fold-right (lambda (x y) (append y (list x))) nil sequence))

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

;; 2.40

(defun enumerate-interval (start finish)
  (defun iter (current)
    (if (> current finish)
	nil
	(cons current (iter (+ current 1)))))
  (iter start))

(defun flatmap (proc seq)
  (accumulate #'append nil (mapcar proc seq)))

(defun pair-sum (pair)
  (+ (car pair) (cadr pair)))

;; primep must be imported from chapter1
(defun prime-sump (pair)
  (primep (pair-sum pair)))

(defun make-pair-sum (pair)
  (list (car pair) (cadr pair) (pair-sum pair)))

(defun unique-pairs (n)
  (flatmap
   (lambda (i) (mapcar (lambda (j) (list j i)) (enumerate-interval 1 (- i 1))))
   (enumerate-interval 2 n)))

(defun prime-sum-pairs (n)
  (mapcar #'make-pair-sum (remove-if-not #'prime-sump (unique-pairs n))))

;; 2.41

;; (1 2 3 4)
;; (1

(defun unique-triplets (n)
    (flatmap (lambda (i) (mapcar (lambda (pair) (append pair (list i))) (unique-pairs (- i 1)))) (enumerate-interval 3 n)))

(defun unique-triplets-that-sum-to (n s)
  (defun triplet-sums-to-s (triplet) (equal (+ (car triplet) (cadr triplet) (caddr triplet)) s))
  (remove-if-not #'triplet-sums-to-s (unique-triplets n)))

;; 2.42

;; Each board is represented as a list of numbers 1-8 that represent the position of the queen
;; in that column.
(defun queens (board-size)
  (defun adjoin-position (new-row k rest-of-queens)
    (declare (ignore k))
    (cons new-row rest-of-queens))

  (defun safe? (k positions)
    (declare (ignore k))
    (defun safe?-helper (ascending-diag horiz descending-diag positions)
      (cond
	((null positions) t)
	((or (equal (car positions) ascending-diag)
	     (equal (car positions) horiz)
	     (equal (car positions) descending-diag)) nil)
	(t (safe?-helper (+ ascending-diag 1) horiz (- descending-diag 1) (cdr positions)))))
    (safe?-helper (+ 1 (car positions)) (car positions) (- (car positions) 1) (cdr positions)))

  (defun queen-cols (k)
    (if (equal k 0)
	(list nil)
	(remove-if-not
	 (lambda (positions) (safe? k positions))
	 (flatmap
	  (lambda (rest-of-queens)
	    (mapcar (lambda (new-row)
		      (adjoin-position new-row k rest-of-queens))
		    (enumerate-interval 1 board-size)))
	  (queen-cols (- k 1))))))
  (queen-cols board-size))

;; 2.43

;; Louis Reasoner's solution is much slower because his program now calls queens-col for every
;; new possible position of a queen, instead of considering every new possible position of a queen
;; for one recusrive call to queens-cols.
;; This makes the recursive relationship switch from
;; T(k) = T(k-1) + C
;; to
;; T(k) = board-size * T(k-1) + C
;; So if the previous time was T the new time will be ~board-size^T.

;; 2.44

;; TODO Implement

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

(defun right-split (painter n)
  (if (equal n 0)
      painter
      (let ( (smaller (right-split painter (- n 1))))
	(beside painter (below smaller smaller)))))

(defun up-split (painter n)
  (if (equal n 0)
      painter
      (let ( (smaller (up-split painter (- n 1))))
	(below painter (beside smaller smaller)))))

(defun corner-split (painter n)
  (if (equal 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))
	      (corner (corner-split painter (- n 1))))
	  (beside (below painter top-left)
		  (below bottom-right corner))))))

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

(defun square-of-four (tl tr bl br)
  (lambda (painter)
    (let ( (top (beside (funcall tl painter) (funcall tr painter)))
	  (bottom (beside (funcall bl painter) (funcall br painter))))
      (below bottom top))))

(defun flipped-pairs (painter)
  (funcall (square-of-four #'identity #'flip-vert #'identity #'flip-vert) painter))

;; 2.45

(defun split (direction combine-smaller)
  (defun split-func (painter n)
    (if (equal n 0)
	painter
	(let ( (smaller (split-func painter (- n 1))))
	  (funcall direction painter (funcall combine-smaller smaller smaller)))))
  #'split-func)

;; 2.46

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

(defun make-vect (x y)
  (cons x y))

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

(defun sub-vect (v1 v2)
  (make-vect (- (xcor-vect v1) (xcor-vect v2))
	     (- (ycor-vect v1) (ycor-vect v2))))

(defun xcor-vect (v) (car v))
(defun ycor-vect (v) (cdr v))

(defun scale-vect (s v)
  (make-vect (* s (xcor-vect v)) (* s (ycor-vect v))))

;; 2.47
(defun make-frame (origin edge1 edge2)
  (list origin edge1 edge2))

(defun origin-frame (frame) (car frame))

(defun edge1-frame (frame) (cadr frame))

(defun edge2-frame (frame) (caddr frame))

(defun make-frame-2 (origin edge1 edge2)
  (cons origin (cons edge1 edge2)))

(defun origin-frame-2 (frame) (car frame))

(defun edge1-frame-2 (frame) (cadr frame))

(defun edge2-frame-2 (frame) (cddr frame))

;; 2.48

(defun make-segment-two (start-segment end-segment) (cons start-segment end-segment))
(defun start-segment-two (segment) (car segment))
(defun end-segment-two (segment) (cdr segment))

;; 2.49

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

;; a
(defun draw-outline ()
  (segments->painter
   (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)))))

;; b

(defun draw-x ()
  (segments->painter
   (list
    (make-segment (make-vect 0 0) (make-vect 1 1))
    (make-segment (make-vect 0 1) (make-vect 1 0)))))

;; c

(defun draw-diamond ()
  (segments->painter
   (list
    (make-segment (make-vect .5 0) (make-vect 1 .5))
    (make-segment (make-vect 1 .5) (make-vect .5 1))
    (make-segment (make-vect .5 1) (make-vect 0 .5))
    (make-segment (make-vect 0 .5) (make-vect .5 0)))))

;; d

(defun draw-wave  ()
  (segments->painter
   ;; note that left = left of screen, not left of body. same with right.
   (list
    (make-segment (make-vect .3 0)    (make-vect .35 .5)) ;; start with bottom left leg
    (make-segment (make-vect .35 .5)  (make-vect .31 .55)) ;; to armpit
    (make-segment (make-vect .31 .55) (make-vect  .2  .44)) ;; bottom left elbow
    (make-segment (make-vect .2  .44) (make-vect   0 .6)) ;; to end of left hand
    (make-segment (make-vect  0   .8) (make-vect  .19 .58)) ;; top of left hand to weenus
    (make-segment (make-vect .19 .58) (make-vect .31 .62)) ;; weenus to left shoulder
    (make-segment (make-vect .31 .62) (make-vect .4  .62)) ;; left shoulder to bottom of head
    (make-segment (make-vect .4  .62) (make-vect .33 .8)) ;; bottom of head to left ear
    (make-segment (make-vect .33 .8)  (make-vect .4   1)) ;; left ear to top left head
    (make-segment (make-vect .6 1)    (make-vect .67 .8)) ;; top right head to top right ear
    (make-segment (make-vect .67 .8)  (make-vect .6 .62)) ;; top right ear to bottom of head
    (make-segment (make-vect .6 .62)  (make-vect .78 .62)) ;; bottom of head to right shoulder
    (make-segment (make-vect .78 .62) (make-vect 1 .3)) ;; right shouldre to top of right hand
    (make-segment (make-vect 1 .15)   (make-vect .61 .46)) ;; bottom right of hand to right armpit
    (make-segment (make-vect .61 .46) (make-vect .77 0)) ;; right armpit to right of right leg
    (make-segment (make-vect .6 0)  (make-vect .5 .28)) ;; left of right leg to penis
    (make-segment (make-vect .5 .28) (make-vect .4 0)) ;; penis to right of left leg.
    )))

;; 2.50

(defun transform-painter (painter origin corner1 corner2)
  (lambda (frame)
    (let ( (m (frame-coord-map frame)))
      (let ( (new-origin (funcall m origin)))
	(funcall painter
		 (make-frame new-origin
			     (sub-vect (funcall m corner1) new-origin)
			     (sub-vect (funcall m corner2) new-origin)))))))

(defun flip-horiz (painter)
  (transform-painter painter
		     (make-vect 1.0 0)
		     (make-vect 0.0 0.0)
		     (make-vect 1.0 1.0)))

(defun rotate90 (painter)
  (transform-painter painter
		   (make-vect 1.0 0.0)
		   (make-vect 1.0 1.0)
		   (make-vect 0.0 0.0)))

(defun rotate180 (painter)
  (rotate90 (rotate90 painter)))

(defun rotate270 (painter)
  (rotate90 (rotate180 painter)))

;; 2.51

(defun beside (painter1 painter2)
  (let ( (split-point (make-vect 0.5 0.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)
	(funcall paint-left frame)
	(funcall paint-right frame)))))

(defun below (painter1 painter2)
  (let ( (split-point (make-vect 0.0 .5)))
    (let ( (paint-bottom
	   (transform-painter painter1
			      (make-vect 0 0)
			      (make-vect 1.0 0)
			      split-point))
	  (paint-top
	   (transform-painter painter2
			      split-point
			      (make-vect 1.0 .5)
			      (make-vect 0.0 1.0))))
      (lambda (frame)
	(funcall paint-bottom frame)
	(funcall paint-top frame)))))

(defun below-rotate (painter1 painter2)
  (rotate90 (beside (rotate270 painter1) (rotate270 painter2))))

;; 2.52

;; Maybe we draw
;;

;; extra code to draw

;; a
(defun draw-wave-with-smile  ()
  (segments->painter
   ;; note that left = left of screen, not left of body. same with right.
   (list
    (make-segment (make-vect .3 0)    (make-vect .35 .5)) ;; start with bottom left leg
    (make-segment (make-vect .35 .5)  (make-vect .31 .55)) ;; to armpit
    (make-segment (make-vect .31 .55) (make-vect  .2  .44)) ;; bottom left elbow
    (make-segment (make-vect .2  .44) (make-vect   0 .6)) ;; to end of left hand
    (make-segment (make-vect  0   .8) (make-vect  .19 .58)) ;; top of left hand to weenus
    (make-segment (make-vect .19 .58) (make-vect .31 .62)) ;; weenus to left shoulder
    (make-segment (make-vect .31 .62) (make-vect .4  .62)) ;; left shoulder to bottom of head
    (make-segment (make-vect .4  .62) (make-vect .33 .8)) ;; bottom of head to left ear
    (make-segment (make-vect .33 .8)  (make-vect .4   1)) ;; left ear to top left head

    ;; smile

    (make-segment (make-vect .37 .75) (make-vect .5 .65))
    (make-segment (make-vect .5 .65)  (make-vect .63 .75))

    (make-segment (make-vect .6 1)    (make-vect .67 .8)) ;; top right head to top right ear
    (make-segment (make-vect .67 .8)  (make-vect .6 .62)) ;; top right ear to bottom of head
    (make-segment (make-vect .6 .62)  (make-vect .78 .62)) ;; bottom of head to right shoulder
    (make-segment (make-vect .78 .62) (make-vect 1 .3)) ;; right shouldre to top of right hand
    (make-segment (make-vect 1 .15)   (make-vect .61 .46)) ;; bottom right of hand to right armpit
    (make-segment (make-vect .61 .46) (make-vect .77 0)) ;; right armpit to right of right leg
    (make-segment (make-vect .6 0)  (make-vect .5 .28)) ;; left of right leg to penis
    (make-segment (make-vect .5 .28) (make-vect .4 0)) ;; penis to right of left leg.
    )))

;; b

(defun new-corner-split (painter n)
  (if (equal n 0)
      painter
      (let ( (up (up-split painter (- n 1)))
	    (right (right-split painter (- n 1))))
	(let ( (top-left up)
	      (bottom-right right)
	      (corner (corner-split painter (- n 1))))
	  (beside (below painter top-left)
		  (below bottom-right corner))))))

;; c

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

(defmacro print-svg-header (width height &body body)
  ;; I have the intuition that there is a proper way to do this without the use of progn.
  `(progn
     (format 't "<svg width=\"~a\" height=\"~a\" version=\"1.1\" xlmns=\"http://www.w3.org/2000/svg\">" ,width ,height)
     ,@body
     (format 't "</svg>")))

;; This perhaps should just be a function, and not a macro.
(defun draw-to-square-svg (painter &optional (width 500) (height 500))
  (print-svg-header width height
    (funcall painter
	      (make-frame (make-vect 0 height) (make-vect width 0) (make-vect 0 (- height))))))

(defun draw-line (start end)
  (format 't "<line x1=\"~a\" y1=\"~a\" x2=\"~a\" y2=\"~a\" stroke=\"black\" stroke-width=\"5\"/>"
	  (xcor-vect start)
	  (ycor-vect start)
	  (xcor-vect end)
	  (ycor-vect end)))

Nightmare

Saturday, May 18th, 2019

Vivid dreams are one of the most beautiful aspects of living. I go to sleep every night1 knowing that I have a chance to have an experience akin to an acid trip.

This is not my first nightmare since I started _actually_ dreaming. But it had one moment that was so creepy and disturbing that it surpassed the realm of fear into the realm of beauty and awe.

The nightmare was long and involved, and I don't quite remember the storyline. What I do remember was there was some conflict between two groups of two people, and one person from one group set out to kill one from the other. The victim was sitting in a parked car, on a dark street near my high school. He was not paying attention, when all of the sudden his brains were blown out by a bullet that went through the driver's seat window.

My perspective was from ~5 meters outside the car looking into the driver's seat window at my friend. The bullet had gone straight through the center, leaving the pane of glass intact. But it was difficult to see my dead buddy, since the window had lost most of its transparency due to the cracks branching in all directions from the bullet hole.

The image of my dead friend through the cracked window then slowly began to morph. The window started slowly swirling counter clockwise, turning into a large eyeball as it spiraled. The bullet hole became the pupil, the white cracks the sclera. And the blood from my friend became red veins going every which way.

After a few seconds of morphing, the image froze on the completed transformation. The large eyeball stared at me in all of its magnificent horror.

  1. To do this I gave up smoking weed and started writing down my dreams []

SICP 2.1 Solutions - Introduction to Data Abstraction

Friday, May 17th, 2019

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.