whaack

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

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.

As I move towards a proper computer science education, I figure it'd be worthwhile to document my work. Perhaps someone in the future learning SICP will find an answer key written in CL helpful. The code provided is not polished nor checked very thoroughly. But I did see that most of my answers matched with the ones provided here. (link dead at time of writing)

NB: I realize I'm missing answers for 1.14 and 1.15 . They should be uploaded shortly.

;; answers for 1.1
;; 10
;; 12
;; 8
;; 3
;; -16
;; switched define->defparameter
;; A
;; B
;; nil
;; 4
;; 16
;; 6
;; 16
=
;; 1.2
(defparameter *ans2* (/ (+ 5 4 (- 2 (- 3 (+ 6 (/ 4 5))))) (* 3 (- 6 2) (- 2 7))))

;; 1.3

(defun ans3 (a b c)
(defun square (x) (* x x))
(defun sum-of-squares (a b) (+ (square a) (square b)))
(cond
((and (<= c a) (<= c b)) (sum-of-squares a b))
((and (<= b c) (<= b a)) (sum-of-squares a c))
('t                      (sum-of-squares b c))))

;; 1.4

;; describe the following function
;; ( (if (> b 0) + -) a b) )
;; Adds a plus the absolute value of b. in CL would need explicit funcall.

;; 1.5
;; infinite loop if applicative order, 0 if normal order

(defun p () (p))

(defun test (x y) (if (equal x 0) 0 y))

;; 1.6
;; The function gets caught in an infinite loop, because all the parameters are evaluated
;; first so it doesn't have a base case.

(defun square (x) (* x x))
(defun good-enough? (guess x) (< (abs (- (square guess) x)) .0001))
(defun average (a b) (/ (+ a b) 2))
(defun improve (guess x) (average guess (/ x guess)))
(defun sqrt-itr (guess x)
(if (good-enough? guess x)
guess
(sqrt-itr (improve guess x) x)))

;; 1.7
(defun new-sqrt-itr (guess x)
(if (< ( / (abs (- (improve guess x) guess)) guess) (* guess .0001))
guess
(new-sqrt-itr (improve guess x) x)))

;; 1.8
(defun cube (x) (* x x x))
(defun cube-good-enough?
(guess x)
(<= (abs (- (cube-improve guess x) guess)) (abs (* .0001 guess))))

(defun cube-improve (guess x) (/ (+ (/ x (square guess)) (* 2 guess)) 3))
(defun cube-root-itr (guess x)
(print (float guess))
(if (cube-good-enough? guess x)
guess
(cube-root-itr (cube-improve guess x) x)))

;; 1.9
;; First one is recursive process
;; Second one is iterative process

;; 1.10
;; (A 1 10) = 2^10
;; (A 2 4) = 2^16
;; (A 3 3) = (A 2 4) = 2^16

;; (f n) = 2n
;; (g n) = 2^n
;; (h n) = 2 ^ h(n-1) h(0) = 0

;; 1.11
(defun f-recursive (n)
(if (< n 3)
n
(+ (f-recursive (- n 1)) (* 2 (f-recursive (- n 2))) (* 3 (f-recursive (- n 3))))))

(defun f-iterative (n)
(defun f-iterative-helper (f1 f2 f3 count final)
(if (equal count final)
f3
(f-iterative-helper f2 f3 (+ (* f1 3) (* f2 2) f3) (+ count 1) final)))
(if (< n 3) n
(f-iterative-helper 0 1 2 2 n)))

;; 1.12
(defun pascals-triangle (n)
(defun get-harmonic-addition (n) (/ (- (sqrt (+ 1 (* 8 n))) 1) 2))
(defun is-on-edge? (n)
(defun is-mod-addition-whole-integer (x)
(equal (mod (get-harmonic-addition x) 1) 0.0))
(or (is-mod-addition-whole-integer n) (is-mod-addition-whole-integer (+ n 1))))
(defun get-current-level (n) (floor (get-harmonic-addition n)))
(if (is-on-edge? n)
1
(+ (pascals-triangle (- n (get-current-level n) 1))
(pascals-triangle (- n (get-current-level n))))))

1.14 -> 1.15 coming soon

;; 1.16
(defun iterative-repeated-squaring (b n)
"page 46"
(defun square   (x) (* x x))
(defun is-evenp (x) (equal (mod x 2) 0))
(defun iter-expt (b n a)
(cond
((equal n 0)  a)
((is-evenp n) (iter-expt (square b) (- (/ n 2) 1) (* a (square b))))
('t           (iter-expt b (- n 1) (* a b)))))
(iter-expt b n 1))

(defun is-evenp (x) (equal (mod x 2) 0))

;; 1.17
(defun my-multiply (a b)
(defun my-double (x) (* x 2))
(defun half   (x) (/ x 2))
(cond
((equal b 0)  0)
((is-evenp b) (my-multiply (my-double a) (half b)))
(t            (+ a (my-multiply a (- b 1))))))

;; 1.18
(defun my-mult-iterative (a b)
(defun my-double (x) (* x 2))
(defun half   (x) (/ x 2))
(defun my-mult-itr (a b c)
(cond
((equal b 0)  c)
((is-evenp b) (my-mult-itr (my-double a) (half b) c))
(t            (my-mult-itr a (- b 1)  (+ c a)))))
(my-mult-itr a b 0))

;; 1.19
(defun fib (n) (fast-fib 1 0 0 1 n))
(defun fast-fib (a b p q count)
(defun square (x) (* x x))
(cond ( (equal count 0) b)
((is-evenp count)
(fast-fib a b (+ (square p) (square q)) (+ (* 2 p q) (square q)) (/ count 2)))
(t (fast-fib (+ (* b q) (* a q) (* a p))
(+ (* b p) (* a q))
p
q
(- count 1)))))

;; 1.20 18 / 4 (the big thing here is that the if statement is where the actual reduction of the gcd happens)

;; 1.21 199, 1999, 7
(defun smallest-divisor (n)
(defun dividesp (a b) (equal (mod b a) 0))
(defun find-divisor (n test-divisor)
(cond ( (> (square test-divisor) n) n)
((dividesp test-divisor n) test-divisor)
(t (find-divisor n (+ test-divisor 1)))))
(find-divisor n 2))

(defun primep (n)
(equal (smallest-divisor n) n))

(defun timed-prime-test (n)
(defun prime-test (n start-time)
(if (primep n)
(progn
(princ n)
(princ "*****")
(princ (- (get-internal-run-time) start-time))
(print "")
)))
(prime-test n (get-internal-run-time)))

;; 1.22
;; 1013, 1019, 1021 (0 seconds all)
;; 10009, 10037, 10039 (0 seconds all)
;; 100019, 100043, 100049, (0 seconds)
;; 1000033, 1000037, 1000039, (0 seconds)
(defun search-for-primes (n limit)
(if (< n limit)
(progn (timed-prime-test n) (search-for-primes (+ n 2) limit))))

;; 1.25 problem is that the number gets super big, should be taking mod m along the way.
;; 1.26  logn height but number of leaves are doubling every round since u call expmod recursively twice.

(defun expmod (base exp m)
(cond ( (equal exp 0) 1)
((evenp exp) 	 (mod (square (expmod base (/ exp 2) m)) m))
(t               (mod (* base (expmod base (- exp 1) m)) m))))

(defun expmod-miller (base exp m)
;; i had a bug where i wasn't checking > exp 0...caused issues for a bit with infinite loop
(let ( (mod-of-half-exp (if (and (> exp 0) (evenp exp)) (expmod-miller base (/ exp 2) m))))
(cond ( (equal exp 0) 1)
((and (evenp exp)
(not (or (equal mod-of-half-exp 1) (equal mod-of-half-exp (- m 1))))
(equal (mod (square mod-of-half-exp) m) 1)) 0)
((evenp exp) 	 (mod (square mod-of-half-exp) m))
(t               (mod (* base (expmod-miller base (- exp 1) m)) m)))))

(defun fermat-full-test (n)
(defun fermat-test (a n)
(if (>= a n) t (and (equal (expmod a n n) a) (fermat-test (+ a 1) n))))
(fermat-test 2 n))

(defun miller-rabin-full-test (n)
(defun miller-rabin-test (a n)
(if (>= a n) t (and (equal (expmod-miller a n n) a) (miller-rabin-test (+ a 1) n))))
(miller-rabin-test 2 n))

;; 1.29
(defun simpson-integrate (f a b n)
(defun get-h () (/  (- b a) n))
(defun simpson-integrate-itr (h k current-sum)
(defun current-step-value ()  (funcall f (+ a (* h k))))
(cond
((equal k n) (+ current-sum (current-step-value)))
((equal k 0) (simpson-integrate-itr h (+ k 1) (current-step-value)))
((evenp k)   (simpson-integrate-itr h (+ k 1) (+ current-sum (* 2 (current-step-value)))))
(t           (simpson-integrate-itr h (+ k 1) (+ current-sum (* 4 (current-step-value)))))))
(* (/ (get-h) 3) (simpson-integrate-itr (get-h) 0 0)))

;; 1.30
(defun my-sum (term a next b)
(defun iter (a result)
(if (> a b)
result
(iter (funcall next a) (+ result (funcall term a)))))
(iter a 0))

;; 1.31 recursive process

(defun pi-over-4-term (a)
(/  (+ (* (floor a       2) 2) 2)
(+ (* (floor (+ a 1) 2) 2) 1)))

(defun pi-over-4-next (a) (+ a 1))
;; a

(defun my-product (term a next b)
(if (> a b)
1
(* (funcall term a) (my-product term (funcall next a) next b))))

;; b

(defun my-product-itr (term a next b)
(defun iter (a result)
(if (> a b)
result
(iter (funcall next a) (* result (funcall term a)))))
(iter a 1))

;; 1.32 accumulate

;; a
;; (accumulate-recursive #'+ 0 (lambda (x) x) 0 (lambda (x) (+ x 1)) 10)
;; (accumulate-recursive #'* 1 (lambda (x) x) 1 (lambda (x) (+ x 1)) 4)
(defun accumulate-recursive (combiner null-value term a next b)
(if (> a b)
null-value
(funcall combiner (funcall term a)
(accumulate-recursive combiner null-value term (funcall next a) next b))))

;; b
;; (accumulate-iterative #'* 1 (lambda (x) x) 1 (lambda (x) (+ x 1)) 4)
;; (accumulate-iterative #'+ 0 (lambda (x) x) 0 (lambda (x) (+ x 1)) 10)
(defun accumulate-iterative (combiner null-value term a next b)
(defun iter (a result)
(if (> a b)
result
(iter (funcall next a) (funcall combiner result (funcall term a)))))
(iter a null-value))

;; 1.33
;; (filter-accumulate #'primep #'+ 0 #'square 2 (lambda (x) (+ x 1)) 5)

;; kept to show error i made. notice how i accidently call accumulate-recursive
;; because i was copying and pasting the previous code without fully changing it.
;; i also didn't notice the bug because it was hard to tell for low values, since it filters
;; the first value correctly.
(defun filter-accumulate-broken (filter combiner null-value term a next b)
(if (> a b)
null-value
(cond
((funcall filter a)
(funcall combiner (funcall term a)
(accumulate-recursive combiner null-value term (funcall next a) next b)))
(t (funcall combiner
null-value
(accumulate-recursive combiner null-value term (funcall next a) next b))))))

(defun filter-accumulate (filter combiner null-value term a next b)
(if (> a b)
null-value
(funcall combiner (if (funcall filter a) (funcall term a) null-value)
(filter-accumulate filter combiner null-value term (funcall next a) next b))))

(defun sum-of-squares-of-primes (n)
(filter-accumulate #'primep #'+ 0 #'square 2 (lambda (x) (+ x 1)) n))

(defun product-of-relative-primes-less-than-n (n)
(filter-accumulate
(lambda (x) (equal (gcd n x) 1)) #'* 1 (lambda (x) x) 2 (lambda (x) (+ x 1)) (- n 1)))

;; 1.34
;; (f f) -> (f 2) -> (2 2)

;; 1.35
;; x -> 1 + 1 / x
;; x^2 = 1 + x

(defun average-damp (f) (lambda (x) (average x (funcall f x))))

;; This originally had (average-damp f) in the if statement, but it was removed after doing the q.
(defun fixed-point (f &optional (first-guess 1))
(defun iter (old new)
(if (< (abs (- new old)) .0001)
new
(iter new (funcall f new))))
(iter first-guess (funcall f first-guess)))

;; 1.36
;; = 30 iterations with tolerance .0001 and no average damping.
;; =  9 iterations with tolerance .0001 and average damping.
(defun fixed-point-expanded (f &optional (first-guess 1))
(defun iter (old new)
(print new)
(if (< (abs (- new old)) .0001)
new
(iter new (funcall (average-damp f) new))))
(iter first-guess (funcall f first-guess)))

;; 1.37
;; a)
;; it takes k=11  to get it right to 4 decimal places.
;; recursive version
(defun infinite-continued-fraction (n d k)
(defun iter (i)
(/ (funcall n i) (+ (funcall d i) (if (equal i k) 0 (iter (+ i 1))))))
(iter 1))

;; b)
;; iterative version
(defun infinite-continued-fraction-iterative (n d k)
;; work backwards for iterative process
(defun iter (i current-denominator)
(cond
((equal i 1) (/ (funcall n i) current-denominator))
(t           (iter (- i 1) (+ (funcall d (- i 1)) (/ (funcall n i) current-denominator))))))
(iter k (funcall d k)))

;; euler expansion e - 2
;; 1.38 infinite continued fraction with ni = 1 and di = 1,2,1,1,4,6,1,1,8
(defun euler-e-expanion (&optional (steps 10))
(defun ni (i) 1.0)
(defun di (i)
(if (equal (mod i 3) 2)
(* (+ (floor i 3) 1) 2)
1.0))
(infinite-continued-fraction #'ni #'di steps))

;; 1.39 Lambert tanx

(defun tan-cf (x k)
(defun ni (i) (if (equal i 1) x (- (square x))))
(defun di (i) (+ (* 2 (- i 1)) 1))
(infinite-continued-fraction #'ni #'di k))

;; 1.40

(defun deriv (f &optional (dx .0001))
(lambda (x) (/ (- (funcall f (+ x dx)) (funcall f x)) dx)))

(defun newton-transform (f)
(lambda (x) ( - x (/ (funcall f x) (funcall (deriv f) x)))))

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

(defun cubic (a b c)
(lambda (x) (+ (expt x 3) (* a (expt x 2)) (* b x) c)))

;; 1.41
(defun inc (x) (+ x 1))

(defun double-compose (f)
(lambda (x) (funcall f (funcall f x))))
; (funcall (funcall (double-compose (double-compose #'double-compose)) #'inc) 5) = 21

;; 1.42

(defun compose (f g)
(lambda (x) (funcall f (funcall g x))))

;; 1.43

(defun repeated-composition (f n)
(if (equal n 1)
f
(compose f (repeated-composition f (- n 1)))))

;; 1.44

(defun smooth (f)
(lambda (x)
(let ( (dx .0001))
(/ (+ (funcall f (- x dx))
(funcall f x)
(funcall f (+ x dx)))
3))))

(defun n-fold-smooth (f n)
(funcall (repeated-composition #'smooth n) f))

;; 1.45

(defun fixed-point-of-transform (g transform guess)
(fixed-point (funcall transform g) guess))

;;

;; I had issues with this because it was running out of memory for a different reason-namely from
;; display huge fractions. It only works consistently if you make sure that n is a float!
(defun nth-root (x n)
(fixed-point-of-transform
(lambda (y) (/ x (iterative-repeated-squaring y (- n 1))))
(repeated-composition #'average-damp (floor (log n 2)))
1))

;; 1.46

(defun iterative-improve (improve-guess good-enoughp)
(defun iter (guess)
(if (funcall good-enoughp guess)
guess
(iter (funcall improve-guess guess))))
#'iter)

(defun sqrt-iter-improve (n)
(funcall (iterative-improve
(average-damp (lambda (guess) (/ n guess)))
(lambda (guess) (< (abs (- (square guess) n)) .0001))) 1))

(defun fixed-point-iter-improve (f)
(funcall (iterative-improve
(lambda (guess) (funcall f guess))
(lambda (guess) (< (abs (- (funcall f guess) guess)) .0001))) 1))