Ch 2.2 Hierarchical Data and the Closure Property

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

Comments are closed.