;;; SICP Section 3.1

;;; 3.1
(defun make-accumulator (n)
  (lambda (x)
    (incf n x)))

;;; 3.2
(defun make-monitored (f)
  (let ((count 0))
    (lambda (x)
      (cond ((eq x 'how-many-calls?) count)
     ((eq x 'reset-count) (setf count 0))
     (t (incf count)
        (funcall f x))))))

;;; 3.3 and 3.4 - updated for 3.7
(defun make-account (balance password)
  (let ((consecutive-attempts 0))
    (labels ((withdraw (amount)
        (if (>= balance amount)
     (setf balance (- balance amount))
     "Insufficient funds"))
      (deposit (amount)
        (setf balance (+ balance amount)))
      (dispatch (pass m)
        (cond
   ;; Incorrect password?
   ((not (eq pass password))
    (lambda (x)
      (if (<= 7 (incf consecutive-attempts))
   "Calling cops"
   "Incorrect password")))
   ;; Withdrawing?
   ((eq m 'withdraw)
    (setf consecutive-attempts 0)
    #'withdraw)
   ;; Depositing?
   ((eq m 'deposit)
    (setf consecutive-attempts 0)
    #'deposit)
   ;; Creating joint account?
   ((eq m 'joint)
    (lambda (new-pass)
      (lambda (pass m)
        (if (eq pass new-pass)
     (funcall #'dispatch password m)
     (funcall #'dispatch nil m)))))
   (t (error "Unknown request -- MAKE-ACCOUNT")))))
      #'dispatch)))

(defun withdraw (acc pwd amt)
  (funcall (funcall acc pwd 'withdraw) amt))

(defun deposit (acc pwd amt)
  (funcall (funcall acc pwd 'deposit) amt))

;;; 3.5
(defun random-in-range (low high)
  (let ((range (- high low)))
    (+ low (random range))))

(defun monte-carlo (trials experiment)
  (labels ((iter (trials-remaining trials-passed)
      (cond ((= trials-remaining 0)
      (float (/ trials-passed trials)))
     ((funcall experiment)
      (iter (- trials-remaining 1) (+ trials-passed 1)))
     (t
      (iter (- trials-remaining 1) trials-passed)))))
    (iter trials 0)))

(defun in-circle-p ()
  (let ((x (random-in-range 0 1.0))
 (y (random-in-range 0 1.0)))
    (<= (+ (expt (- x 0.5) 2)
    (expt (- y 0.5) 2))
 (expt 0.5 2))))

(defun estimate-integral (p x1 x2 y1 y2 trials)
  (let ((area-of-rect (* (- x2 x1)
    (- y2 y1)))
 (frac-inside (monte-carlo trials p)))
    (* frac-inside area-of-rect)))

;;; 3.6
(let ((st (make-random-state)))
  (defun rnd (sym)
    (cond ((eq sym 'generate)
    (lambda (x)
      (random x st)))
   ((eq sym 'reset)
    (lambda (x)
      (setf st x)))
   (t "Unknown symbol"))))

;;; 3.7
(defun make-joint (acc pass new-pass)
  (funcall (funcall acc pass 'joint) new-pass))

;;; 3.8
(let ((num 1))
  (defun f (n)
    (setf num (* num n))))

;;;; SICP Section 2.3

;;; 2.54
(defun my-equals (list1 list2)
  (cond ((and (null list1) (null list2)) t)
 ((and (consp (car list1)) (consp (car list2)))
  (and (my-equals (car list1) (car list2))
       (my-equals (cdr list1) (cdr list2))))
 (t (and (equalp (car list1) (car list2))
  (my-equals (cdr list1) (cdr list2))))))

;;; 2.55
;; ''abc => (quote (quote abc))
;; (car (quote (quote abc))) = > quote

;;; 2.56
;;; Differentiation definitions
(defun variablep (x)
  (symbolp x))

(defun same-variable-p (v1 v2)
  (and (variablep v1) (variablep v2) (equal v1 v2)))

(defun sump (x)
  (and (consp x) (equal (car x) '+)))

(defun addend (s)
  (cadr s))

(defun augend (s)
  (caddr s))

(defun productp (x)
  (and (consp x) (equal (car x) '*)))

(defun multiplier (p)
  (cadr p))

(defun multiplicand (p)
  (caddr p))

(defun =number (exp num)
  (and (numberp exp) (= exp num)))

(defun make-sum (a1 a2)
  (cond ((=number a1 0) a2)
 ((=number a2 0) a1)
 ((and (numberp a1) (numberp a2)) (+ a1 a2))
 (t (list '+ a1 a2))))

(defun make-product (m1 m2)
  (cond ((or (=number m1 0) (=number m2 0)) 0)
 ((=number m1 1) m2)
 ((=number m2 1) m1)
 ((and (numberp m1) (numberp m2)) (* m1 m2))
 (t (list '* m1 m2))))

;;; Exponent definitions
(defun exponentiationp (x)
  (and (consp x) (equal (car x) '^)))

(defun base (exp)
  (cadr exp))

(defun exponent (exp)
  (caddr exp))

(defun make-exponentiation (base exp)
  (cond ((=number exp 0) 1)
 ((=number exp 1) base)
 ((and (numberp base) (numberp exp)) (expt base exp))
 (t (list '^ base exp))))

(defun deriv (exp var)
  (cond ((numberp exp) 0)
 ((variablep exp)
  (if (same-variable-p exp var) 1 0))
 ((sump exp)
  (make-sum (deriv (addend exp) var)
     (deriv (augend exp) var)))
 ((productp exp)
  (make-sum
   (make-product (multiplier exp)
   (deriv (multiplicand exp) var))
   (make-product (deriv (multiplier exp) var)
   (multiplicand exp))))
 ((exponentiationp exp)
  (make-product
   (exponent exp)
   (make-product
    (make-exponentiation (base exp) (- (exponent exp) 1))
    (deriv (base exp) var))))
 (t "unknown expression type")))

;;; 2.57
(defun addend (s)
  (cadr s))

(defun augend (s)
  (let ((augend (cddr s)))
    (if (= 1 (length augend))
 (car augend)
 (make-sum (car augend) (cdr augend)))))

(defun multiplier (p)
  (cadr p))

(defun multiplicand (p)
  (let ((multiplicand (cddr p)))
    (if (= 1 (length multiplicand))
 (car multiplicand)
 (make-product (car multiplicand)
        (cdr multiplicand)))))

(defun make-sum (a1 a2)
  (cond ((=number a1 0) a2)
 ((=number a2 0) a1)
 ((and (numberp a1) (numberp a2)) (+ a1 a2))
 ((sump a2) (list '+ a1 (addend a2) (augend a2)))
 ((productp a2) (list '+ a1 (make-product
        (multiplier a2)
        (multiplicand a2))))
 ((and (consp a2) (> (length a2) 1))
  (list '+ a1 (make-sum (car a2) (cdr a2))))
 ((consp a2) (list '+ a1 (car a2)))
 (t (list '+ a1 a2))))

(defun make-product (m1 m2)
  (cond ((or (=number m1 0) (=number m2 0)) 0)
 ((=number m1 1) m2)
 ((=number m2 1) m1)
 ((and (numberp m1) (numberp m2)) (* m1 m2))
 ((productp m2) (list '* m1 (multiplier m2) (multiplicand m2)))
 ((sump m2) (list '* m1 (make-sum (addend m2) (augend m2))))
 ((and (consp m2) (> (length m2) 1))
  (list '* m1 (make-product (car m2) (cdr m2))))
 ((consp m2) (list '* m1 (car m2)))
 (t (list '* m1 m2))))

;;; 2.58
(defun sump (x)
  (and (consp x) (equal (cadr x) '+)))

(defun addend (s)
  (car s))

(defun augend (s)
  (caddr s))

(defun productp (x)
  (and (consp x) (equal (cadr x) '*)))

(defun multiplier (p)
  (car p))

(defun multiplicand (p)
  (caddr p))

(defun make-sum (a1 a2)
  (cond ((=number a1 0) a2)
 ((=number a2 0) a1)
 ((and (numberp a1) (numberp a2)) (+ a1 a2))
 (t (list a1 '+  a2))))

(defun make-product (m1 m2)
  (cond ((or (=number m1 0) (=number m2 0)) 0)
 ((=number m1 1) m2)
 ((=number m2 1) m1)
 ((and (numberp m1) (numberp m2)) (* m1 m2))
 (t (list m1 '* m2))))

;;; lookup b

;;; 2.59
(defun element-of-set-p (x set)
  (cond ((null set) nil)
 ((equal x (car set)) t)
 (t (element-of-set-p x (cdr set)))))

(defun adjoin-set (x set)
  (if (element-of-set-p x set)
      set
      (cons x set)))

(defun intersection-set (set1 set2)
  (cond ((or (null set1) (null set2)) nil)
 ((element-of-set-p (car set1) set2)
  (cons (car set1)
        (intersection-set (cdr set1) set2)))
 (t (intersection-set (cdr set1) set2))))

(defun union-set (set1 set2)
  (cond ((null set1) set2)
 ((null set2) set1)
 ((element-of-set-p (car set1) set2)
  (union-set (cdr set1) set2))
 (t (cons (car set1)
   (union-set (cdr set1) set2)))))

;;; 2.60
(defun adjoin-set-2 (x set)
  (cons x set))

(defun union-set-2 (set1 set2)
  (cond ((null set1) set2)
 ((null set2) set1)
 (t (cons (car set1)
   (union-set-2 (cdr set1) set2)))))

;;; 2.61
(defun adjoin-set-2 (x set)
  (let ((first (car set)))
    (cond ((null set) (list x))
   ((= x first) set)
   ((> x first) (cons first (adjoin-set-2 x (cdr set))))
   (t (cons x set)))))

;;; 2.62
(defun union-set-2 (set1 set2)
  (cond ((null set1) set2)
 ((null set2) set1)
 ((= (car set1) (car set2))
  (cons (car set1) (union-set-2 (cdr set1) (cdr set2))))
 ((> (car set1) (car set2))
  (cons (car set2) (union-set-2 set1 (cdr set2))))
 (t (cons (car set1) (union-set-2 (cdr set1) set2)))))

;;; 2.66
(defun lookup (given-key set-of-records)
  (let ((current-record (car set-of-records))
 (key (key current-record)))
    (cond ((null set-of-records) nil)
   ((= given-key key) current-record)
   ((> given-key key)
    (lookup given-key (right-tree set-of-records)))
   (t (lookup given-key (left-tree set-of-records))))))

;;; Huffman tree representation
(defun make-leaf (symbol weight)
  (list 'leaf symbol weight))

(defun leaf? (object)
  (equalp (car object) 'leaf))

(defun symbol-leaf (x) (cadr x))

(defun weight-leaf (x) (caddr x))

(defun make-code-tree (left right)
  (list left
 right
 (append (symbols left) (symbols right))
 (+ (weight left) (weight right))))

(defun left-branch (tree) (car tree))

(defun right-branch (tree) (cadr tree))

(defun symbols (tree)
  (if (leaf? tree)
      (list (symbol-leaf tree))
      (caddr tree)))

(defun weight (tree)
  (if (leaf? tree)
      (weight-leaf tree)
      (cadddr tree)))

(defun decode (bits tree)
  (defun decode-1 (bits current-branch)
    (if (null bits)
 nil
 (let ((next-branch
        (choose-branch (car bits) current-branch)))
   (if (leaf? next-branch)
       (cons (symbol-leaf next-branch)
      (decode-1 (cdr bits) tree))
       (decode-1 (cdr bits) next-branch)))))
  (decode-1 bits tree))

(defun choose-branch (bit branch)
  (cond ((= bit 0) (left-branch branch))
 ((= bit 1) (right-branch branch))
 (t (error "bad bit"))))

(defun adjoin-set (x set)
  (cond ((null set) (list x))
 ((< (weight x) (weight (car set))) (cons x set))
 (t (cons (car set) (adjoin-set x (cdr set))))))

(defun make-leaf-set (pairs)
  (if (null pairs)
      nil
      (let ((pair (car pairs)))
 (adjoin-set (make-leaf (car pair) (cadr pair))
      (make-leaf-set (cdr pairs))))))

;;; 2.67
(defparameter *sample-tree*
  (make-code-tree (make-leaf 'a 4)
    (make-code-tree
     (make-leaf 'b 2)
     (make-code-tree (make-leaf 'd 1)
       (make-leaf 'c 1)))))

(defparameter *sample-message* '(0 1 1 0 0 1 0 1 0 1 1 1 0))

(decode *sample-message* *sample-tree*) ; => (A D A B B C A)

;;; 2.68
(defun encode (message tree)
  (if (null message)
      nil
      (append (encode-symbol (car message) tree)
       (encode (cdr message) tree))))

(defun encode-symbol (symbol tree)
  (cond ((or (null tree) (leaf? tree)) nil)
 ((member symbol (symbols (left-branch tree)))
  (cons 0 (encode-symbol symbol (left-branch tree))))
 ((member symbol (symbols (right-branch tree)))
  (cons 1 (encode-symbol symbol (right-branch tree))))
 (t (error "Symbol not in tree."))))

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

(defun successive-merge (leaf-set &optional sub-tree)
  (cond ((null (cdr leaf-set))
  (make-code-tree (car leaf-set) sub-tree))
 ((null sub-tree)
  (successive-merge (cdr leaf-set) (car leaf-set)))
 (t (successive-merge (cdr leaf-set)
        (make-code-tree (car leaf-set)
          sub-tree)))))

;;; 2.70
(defparameter *lyric-huff-tree*
  (generate-huffman-tree '((a 2) (boom 1) (get 2) (job 2)
      (na 16) (sha 3) (yip 9) (wah 1))))

(defparameter *song* '(get a job sha na na na na na na na na
         get a job sha na na na na na na na
         wah yip yip yip yip yip yip yip yip
         yip Sha boom))

(length (encode *song* *lyric-huff-tree*)) ; => 86

;; 2.71
;; Most frequent = 1, least = N - 1

SICP Exercise 2.17

(defun last-pair (list)
  (if (null (cdr list))
      list
      (last-pair (cdr list))))

SICP Exercise 2.18

(defun rev (list)
  (if (null (cdr list))
      list
      (cons (car (last list))
        (rev (butlast list)))))

SICP Exercise 2.19

(defparameter *us-coins* (list 50 25 10 5 1))
(defparameter *uk-coins* (list 100 50 20 10 5 1 0.5))

(defun count-change (amount coin-values)
  (cc amount coin-values))

(defun cc (amount coin-values)
  (cond ((= amount 0) 1)
     ((or (< amount 0) (no-more-p coin-values)) 0)
     (t (+ (cc amount
           (except-first-denomination coin-values))
             (cc (- amount
               (first-denomination coin-values))
           coin-values)))))

(defun no-more-p (coin-values)
  (null coin-values))

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

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

SICP Exercise 2.20

(defun same-parity (integer &rest integers)
  (cond ((null integers) integer)
    ((evenp integer) (append (list integer)
                                 (remove-if-not #'evenp integers)))
    (t (append (list integer) (remove-if-not #'oddp integers)))))

SICP Exercise 2.21

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

(defun square-list-2 (items)
  (mapcar (lambda (x) (* x x))
   items))

SICP Exercise 2.23

(defun for-each (proc items)
  (when (consp items)
    (funcall proc (car items))
    (for-each proc (cdr items))))

SICP Exercise 2.27

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

(defun last-element (list)
  "Returns the last element of LIST."
  (car (last list)))

(defun deep-rev (list)
  (cond ((and (= 1 (length list)) (not (listp (car list)))) list)
 ((= 1 (length list)) (list (deep-rev (car list))))
 ((listp (last-element list))
  (cons (deep-rev (last-element list))
        (deep-rev (butlast list))))
 (t (cons (last-element list)
   (deep-rev (butlast list))))))

SICP Exercise 2.28

(defun fringe (list)
  (when list
    (if (atom list)
 (list list)
 (append (fringe (car list))
  (fringe (cdr list))))))

SICP Exercise 2.29

;; a.
(defun make-mobile (left right)
  (list left right))

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

(defun left-branch (mobile)
  (first mobile))

(defun right-branch (mobile)
  (second mobile))

(defun branch-length (branch)
  (first branch))

(defun branch-structure (branch)
  (second branch))

;; b.
(defun mobilep (structure)
  (listp structure))

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

(defun total-branch-weight (branch)
  (let ((branch-structure (branch-structure branch)))
    (if (mobilep branch-structure)
 (total-weight branch-structure)
 branch-structure)))

;;; c.
(defun torque (branch)
  (* (branch-length branch)
     (total-branch-weight branch)))

(defun balanced-mobile-p (mobile)
  (let ((left (left-branch mobile))
 (right (right-branch mobile)))
    (cond
      ;; Return false if the left and right torques are unequal.
      ((/= (torque left) (torque right)) nil)
      ;; The mobile is balanced at this level.  Return true if there
      ;; are no more submobiles.
      ((and (not (mobilep left))
     (not (mobilep right)))
       t)
      ;; Submobiles exist.  Check their balance.
      (t (and (if (mobilep (branch-structure left))
    (balanced-mobile-p (branch-structure left))
    t)
       (if (mobilep (branch-structure right))
    (balanced-mobile-p (branch-structure right))
    t))))))

;;; d. For section a, we need to replace the first and second
;;; functions with car and cdr respectively.  The remaining sections
;;; can be left intact.

SICP Exercise 2.30

(defun square-tree-1 (tree)
  (cond ((null tree) nil)
 ((not (listp tree)) (* tree tree))
 (t (cons (square-tree-1 (car tree))
   (square-tree-1 (cdr tree))))))

(defun square-tree-2 (tree)
  (mapcar (lambda (sub-tree)
     (if (listp sub-tree)
  (square-tree-2 sub-tree)
  (* sub-tree sub-tree)))
   tree))

SICP Exercise 2.31

(defun tree-map (proc tree)
  (mapcar (lambda (sub-tree)
     (if (listp sub-tree)
  (tree-map proc sub-tree)
  (funcall proc sub-tree)))
   tree))

(defun square (x)
  (* x x))

(defun square-tree-3 (tree)
  (tree-map #'square tree))

SICP Exercise 2.32

(defun subsets (s)
  (if (null s)
      (list nil)
      (let ((rest (subsets (cdr s))))
 (append rest (mapcar (lambda (x)
          (cons (car s) x))
        rest)))))

SICP Exercise 2.33

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

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

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

(defun my-length (sequence)
  (accumulate (lambda (x y)
  ;; Avoid style warnings by telling the compiler to
  ;; ignore X.
  (declare (ignore x))       
  (+ 1 y))
       0 sequence))

SICP Exercise 2.34

(defun horner-eval (x coefficient-sequence)
  (accumulate (lambda (this-coeff higher-terms)
  (+ this-coeff
     (* x higher-terms)))
       0
       coefficient-sequence))

SICP Exercise 2.35

(defun count-leaves (tree)
  (accumulate #'+
       0
       (mapcar (lambda (sub-tree)
   (if (listp sub-tree)
       (count-leaves sub-tree)
       1))
        tree)))

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

SICP Exercise 2.37

(defun dot-product (v w)
  (accumulate #'+ 0 (mapcar #'* v w)))

(defun matrix-*-vector (m v)
  (mapcar (lambda (row)
     (dot-product row 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)))

SICP Exercise 2.39

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

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

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

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

SICP Exercise 2.40

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

(defun enumerate-interval (x y)
  "Returns the list from X to Y"
  (loop for i from x to y collect i))

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

;;; Definitions for prime?

(defun dividesp (a b) (zerop (mod b a)))

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

(defun smallest-divisor (n)
  (find-divisor n 2))

(defun prime? (n) (= n (smallest-divisor n)))

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

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

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

SICP Exercise 2.41

(defun triples (n s)
  (remove-if-not (lambda (list) (= s (reduce #'+ list)))
   (flatmap
    (lambda (i)
      (flatmap
       (lambda (j)
         (mapcar (lambda (k) (list i j k))
          (enumerate-interval 1 (- j 1))))
       (enumerate-interval 1 (- i 1))))
    (enumerate-interval 1 n))))

SICP Exercise 2.42

(defparameter empty-board nil)

(defun board-position (row col)
  "Represents a chess piece's position on the board."
  (list row col))

(defun adjoin-position (row col set-of-positions)
  "Adjoins a new row-column position to a set of positions."
  (append set-of-positions (list (board-position row col))))

(defun get-column (position)
  "Returns the column of the board-position POSITION."
  (cadr position))

(defun get-row (position)
  "Returns the row of the board position POSITION."
  (car position))

(defun get-board-position (col positions)
  "Returns the board position in column COL."
  (car (remove-if-not (lambda (position)
   (= col (get-column position)))
        positions)))

(defun in-same-row? (col positions)
  "Returns true if the queen in column COL shares the same row with
another queen in the position set POSITIONS."
  (let ((row (get-row (get-board-position col positions))))
    (some (lambda (position)
     (and (/= col (get-column position))
   (= row (get-row position))))
   positions)))

(defun in-diagonal? (col positions)
  "Returns true if the queen in column COL resides in the diagonal 
of another queen in the position set POSITIONS."
  (let ((row (get-row (get-board-position col positions))))
    (some (lambda (position)
     (when (/= col (get-column position))
       (= 1 (abs (/ (- row (get-row position))
      (- col (get-column position)))))))
   positions)))

(defun safe? (new-queen old-queens)
  "Returns true if the NEW-QUEEN does not reside in the same row
or diagonal of any of the OLD-QUEENS."
  (cond
    ;; Return true when no OLD-QUEENS exist.
    ((null old-queens) t)
    ;; Test if NEW-QUEEN resides on the same row.
    ((in-same-row? new-queen old-queens) nil)
    ;; Test if NEW-QUEEN resides on the same diagonal.
    ((in-diagonal? new-queen old-queens) nil)
    ;; Return true if all the tests pass.
    (t t)))

(defun queens (board-size)
  (labels ((queen-cols (k)
      (if (= k 0)
   (list empty-board)
   (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)))

SICP Exercise 2.44

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

SICP Exercise 2.45

(defun split (proc1 proc2)
  (labels ((do-split (painter n)
      (if (= n 0)
   painter
   (let ((smaller (do-split painter (- n 1))))
     (funcall proc1 painter
       (funcall proc2 smaller smaller))))))
    (lambda (painter n)
      (do-split painter n))))

SICP Exercise 2.46

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

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

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

(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 v2) (ycor-vect v2))))

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

SICP Exercise 2.2
Consider the problem of representing line segments in a plane. Each segment is represented as a pair of points: a starting point and an ending point. Define a constructor make-segment and selectors start-segment and end-segment that define the representation of segments in terms of points. Furthermore, a point can be represented as a pair of numbers: the x coordinate and the y coordinate. Accordingly, specify a constructor make- point and selectors x-point and y-point that define this representation. Finally, using your selectors and constructors, define a procedure midpoint-segment that takes a line segment as argument and returns its midpoint (the point whose coordinates are the average of the coordinates of the endpoints). To try your procedures, you'll need a way to print points: (define
(print-point p)
(newline)
(display "(")
(display (x-point p))
(display ",")
(display (y-point p))
(display ")"))

;;; Utility functions
(defun average (x y)
  (/ (+ x y)
     2))

;;; Point and segment functions
(defun make-point (x y)
  (cons x y))

(defun x-point (point)
  (car point))

(defun y-point (point)
  (cdr point))

(defun make-segment (start end)
  (cons start end))

(defun start-segment (segment)
  (car segment))

(defun end-segment (segment)
  (cdr segment))

(defun midpoint-segment (segment)
  (make-point (average (x-point (start-segment segment))
                        (x-point (end-segment segment)))
       (average (y-point (start-segment segment))
               (y-point (end-segment segment)))))

(defun print-point (p)
  (format t "x=~D y=~D~%"
   (x-point p)
   (y-point p)))

SICP Exercise 2.3
Implement a representation for rectangles in a plane. (Hint: You may want to make use of exercise 2.2.) In terms of your constructors and selectors, create procedures that compute the perimeter and the area of a given rectangle. Now implement a different representation for rectangles. Can you design your system with suitable abstraction barriers, so that the same perimeter and area procedures will work using either representation?

(defun make-rec (lower-left-pt upper-right-pt)
  (cons lower-left-pt upper-right-pt))

(defun rec-upper-right (rec)
  (cdr rec))

(defun rec-lower-left (rec)
  (car rec))

(defun rec-upper-left (rec)
  (make-point (x-point (rec-lower-left rec))
               (y-point (rec-upper-right rec))))

(defun rec-lower-right (rec)
  (make-point (x-point (rec-upper-right rec))
               (y-point (rec-lower-left rec))))
 
(defun rec-len (rec)
  (- (y-point (rec-upper-left rec))
     (y-point (rec-lower-left rec))))

(defun rec-width (rec)
  (- (x-point (rec-lower-right rec))
     (x-point (rec-lower-left rec))))

(defun area-rec (rec)
  (* (rec-len rec)
      (rec-width rec)))

(defun perimeter-rec (rec)
  (* 2
     (+ (rec-len rec)
   (rec-width rec))))

;;; Alternative representation of rectangles

(defun alt-make-rec (bottom-seg left-seg)
  (cons bottom-seg left-seg))

(defun alt-upper-left (rec)
  (end-segment (cdr rec)))

(defun alt-lower-left (rec)
  (start-segment (car rec)))

(defun alt-lower-right (rec)
  (end-segment (cdr rec)))

(defun alt-upper-right (rec)
  (make-point (x-point (alt-lower-right rec))
               (y-point (alt-upper-left rec))))

SICP Exercise 2.4
Here is an alternative procedural representation of pairs. For this representation, verify that (car (cons x y)) yields x for any objects x and y.

(define (cons x y)
(lambda (m) (m x y)))
(define (car z)
(z (lambda (p q) p)))

What is the corresponding definition of cdr? (Hint: To verify that this works, make use of the substitution model of section 1.1.5.)

;;; Redefine Scheme functions in CL
(defun alt-cons (x y)
  (lambda (m) (funcall m x y)))

(defun alt-car (z)
  (funcall z (lambda (p q) p)))

(defun alt-cdr (z)
  (funcall z (lambda (p q) q)))

SICPSICP Exercise 2.5
Show that we can represent pairs of nonnegative integers using only numbers and arithmetic operations if we represent the pair a and b as the integer that is the product 2^a*3^b. Give the corresponding definitions of the procedures cons, car, and cdr.

(defun alt2-cons (a b)
  (* (expt 2 a) (expt 3 b)))

(defun alt2-car (z)
  (do ((i 0 (1+ i))
         (n z (/ n 2)))
      ((> (mod n 2) 0) i)))

(defun alt2-cdr (z)
  (do ((i 0 (1+ i))
         (n z (/ n 3)))
      ((> (mod n 3) 0) i)))

SICP Exercise 2.6
In case representing pairs as procedures wasn't mind-boggling enough, consider that, in a language that can manipulate procedures, we can get by without numbers (at least insofar as nonnegative integers are concerned) by implementing 0 and the operation of adding 1 as

(define zero (lambda (f) (lambda (x) x)))

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

This representation is known as Church numerals, after its inventor, Alonzo Church, the logician who invented the calculus. Define one and two directly (not in terms of zero and add-1). (Hint: Use substitution to evaluate (add-1 zero)). Give a direct definition of the addition procedure + (not in terms of repeated application of add-1).

;;; Redefine Scheme functions in CL
(defun zero ()
  (lambda (f)
    (lambda (x) x)))

(defun add-1 (n)
  (lambda (f)
    (lambda (x)
      (funcall f (funcall (funcall n f) x)))))

;;; Definitions of one and two
(defun one ()
  (lambda (f)
    (lambda (x)
      (funcall f x))))

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

;;; We can test our definitions of one and two with the following code:
;;; (funcall (funcall (one) #'1+) 0) => 1
;;; (funcall (funcall (two) #'1+) 0) => 2

;;; Notice the pattern for the definitions of one and two: the natural
;;; number N converts to its corresponding Church numeral by
;;; compositing the function f N times. We can abstract this by
;;; using a macro to define our Church numerals

(defun compose (times)
  (if (= times 1)
      '(funcall f x)
      `(funcall f ,(compose (1- times)))))

(defmacro def-church-numeral (name N)
  `(defun ,name ()
     (lambda (f)
       (lambda (x)
  ,(compose N)))))

;;; Now we can define new Church numerals as follows:
;;; (def-church-numeral three 3)
;;; (funcall (funcall (three) #'1+) 0) => 3

;;; To define an add function for Church numerals, implement the
;;; identity f(m + n)(x) = fm(fn(x)).  The code can look rather
;;; ugly in Common Lisp because the need for funcall, but to 
;;; understand it remember how we call the church numeral 
;;; functions, and see that the code calls the first church
;;; numeral and passes it to the second.

(defun add (m n)
  (lambda (f)
    (lambda (x)
      (funcall (funcall (funcall m) f)
           (funcall (funcall (funcall n) f) x)))))

;;; We can test the add function as follows:
;;;(funcall (funcall (add #'one #'three) #'1+) 0) => 4

SICP Exercise 2.7
Alyssa's program is incomplete because she has not specified the implementation of the interval abstraction. Here is a definition of the interval constructor:

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

Define selectors upper-bound and lower-bound to complete the implementation.

;;; Redefine the Scheme functions in CL

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

(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 dev-interval (x y)
  (mul-interval x
        (make-interval (/ 1.0 (upper-bound y))
                         (/ 1.0 (lower-bound y)))))

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

;;; End of Scheme definitions

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

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

SICP Exercise 2.8
Using reasoning analogous to Alyssa's, describe how the difference of two intervals may be computed. Define a corresponding subtraction procedure, called sub-interval.

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

SICP Exercise 2.9
The width of an interval is half of the difference between its upper and lower bounds. The width is a measure of the uncertainty of the number specified by the interval. For some arithmetic operations the width of the result of combining two intervals is a function only of the widths of the argument intervals, whereas for others the width of the combination is not a function of the widths of the argument intervals. Show that the width of the sum (or difference) of two intervals is a function only of the widths of the intervals being added (or subtracted). Give examples to show that this is not true for multiplication or division.

(defun interval-width (interval)
  (abs (/ (- (upper-bound interval) (lower-bound interval))
       2.0)))

SICP Exercise 2.11
In passing, Ben also cryptically comments: ‘‘By testing the signs of the endpoints of the intervals, it is possible to break mul-interval into nine cases, only one of which requires more than two multiplications.’’ Rewrite this procedure using Ben’s suggestion.

(defun sym-signum (n)
  "Calls signum and returns + or - instead of 1, -1, 0.  0 is
considered postive for the sake of this exercise"
  (let ((sign (signum n)))
    (cond ((eq sign 1) '+)
       ((eq sign -1) '-)
       ((eq sign 0) '+))))

(defun list-signs (lst)
  "Given a list of numbers, returns a list of the number's signs"
  (mapcar #'sym-signum lst))

(defmacro make-interval-if (signs &body body)
  "Cleans up the definition of new-mul-interval by removing lots
of repeated code"
  `(cond ,@(mapcar #'(lambda (statement)
         (let ((test-signs (first statement))
         (lower-bound (second statement))
         (upper-bound (third statement)))
    `((equal ,signs ',test-signs)
       (make-interval (* ,(first lower-bound)
                     ,(second lower-bound))
                 (* ,(first upper-bound)
                     ,(second upper-bound))))))
     body)))



(defun new-mul-interval (x y)
  (let* ((ux (upper-bound x))
     (lx (lower-bound x))
     (uy (upper-bound y))
     (ly (lower-bound y))
     (signs (list-signs (list lx ux ly uy)))
            ;; max and min are needed for the special case
     (max (max (* lx ly) (* lx uy) (* ux uy) (* ux ly)))
     (min (min (* lx ly) (* lx uy) (* ux uy) (* ux ly))))
    (make-interval-if signs
      ((+ + + +) (lx ly) (ux uy))
      ((+ + - +) (ux ly) (ux uy))
      ((+ + - -) (ux ly) (lx uy))
      ((- + + +) (uy lx) (uy ux))
      ((- + - -) (ux ly) (lx ly))
      ((- - + +) (lx uy) (ly ux))
      ((- - - +) (lx uy) (ly lx))
      ((- - - -) (ux uy) (ly lx))
      ;; special case:
      ((- + - +) (min 1) (max 1)))))

SICP Exercise 2.12
Define a constructor make-center-percent that takes a center and a percentage tolerance and produces the desired interval. You must also define a selector percent that produces the percentage tolerance for a given interval. The center selector is the same as the one shown above.

(defun make-center-percent (center percent)
  (let ((percent (/ percent 100.0)))
    (cons (- center (* center percent))
      (+ center (* center percent)))))

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

(defun percent (interval)
  (let ((center (center interval))
   (lb (lower-bound interval)))
    (* (/ (- center lb)
   center)
       100)))

SICP Exerice 1.29
Simpson's Rule is a more accurate method of numerical integration than the method illustrated above. Using Simpson's Rule, the integral of a function f between a and b is approximated as

(h/3)(y0 + 4y1 + 2y2 + 4y3 + 2y4 + ...+ 2yn-2 + 4yn-4 + yn)

where h = (b - a)/n, for some even integer n, and yk = f(a + kh). (Increasing n increases the accuracy of the approximation.) Define a procedure that takes as arguments f, a, b, and n and returns the value of the integral, computed using Simpson's Rule. Use your procedure to integrate cube between 0 and 1 (with n = 100 and n = 1000), and compare the results to those of the integral procedure shown above.

(defun cube (x) (* x x x))

(defun sum (term a next b)
  (if (> a b)
      0
      (+ (funcall term a)
         (sum term (funcall next a) next b))))

(defun integral (f a b n)
  (let ((h (/ (- b a) n)))
    (labels ((yk (k)
                (funcall f (+ a (* k h))))
              (inc2 (n) (+ n 2)))
      (* (/ h 3)
         (+ (yk 0)
            (* 4 (sum #'yk 1 #'inc2 (- n 1)))
            (* 2 (sum #'yk 2 #'inc2 (- n 2)))
            (yk n))))))

SICP Exercise 1.30
The sum procedure above generates a linear recursion. The procedure can be rewritten so that the sum is performed iteratively. Show how to do this by filling in the missing expressions in the following definition:

(define (sum term a next b)
(define (iter a result)
(if <??>
<??>
(iter <??> <??>)))
(iter <??> <??>))

(defun new-sum (term a next b)
  (labels ((iter (a result)
             (if (> a b)
                 result
                 (iter (funcall next a)
                       (+ result (funcall term a))))))
    (iter a 0)))
 
(defun inc (x) (+ x 1))

SICP Exercise 1.31
a. The sum procedure is only the simplest of a vast number of similar abstractions that can be captured as higher-order procedures.51 Write an analogous procedure called product that returns the product of the values of a function at points over a given range. Show how to define factorial in terms of product. Also use product to compute approximations to using the formula

(pie/4)=((2/3)(4/3)(4/5)(6/5)(6/7)(8/7)...)

b. If your product procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.

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

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

(defun factorial (n)
  (labels ((ident (x) x))
    (product #'ident 1 #'inc n)))

(defun my-pie (n)
  (labels ((num-term (n)
             (if (oddp n)
                 (- n 1)
                 n))
           (den-term (n)
              (if (evenp n)
                  (- n 1)
                  n)))
    (float(* 4
            (/ (product #'num-term 3 #'inc n)
            (product #'den-term 3 #'inc n))))))

SICP Exercise 1.32
a. Show that sum and product (exercise 1.31) are both special cases of a still more general notion called accumulate that combines a collection of terms, using some general accumulation function:

(accumulate combiner null-value term a next b)

Accumulate takes as arguments the same term and range specifications as sum and product, together with a combiner procedure (of two arguments) that specifies how the current term is to be combined with the accumulation of the preceding terms and a null-value that specifies what base value to use when the terms run out. Write accumulate and show how sum and product can both be defined as simple calls to accumulate.

b. If your accumulate procedure generates a recursive process,write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.

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

(defun new-accumulate (combiner null-value term a next b)
  (labels ((iter (a result)
             (if (> a b)
                 result
                 (iter (funcall next a)
                       (funcall combiner result (funcall term a))))))
    (iter a null-value)))

SICP Exercise 1.33
You can obtain an even more general version of accumulate (exercise 1.32) by introducing the notion of a filter on the terms to be combined. That is, combine only those terms derived from values in the range that satisfy a specified condition. The resulting filtered-accumulate abstraction takes the same arguments as accumulate, together with an additional predicate of one argument that specifies the filter. Write filtered-accumulate as a procedure. Show how to express the following using filtered-accumulate:

a. the sum of the squares of the prime numbers in the interval a to b (assuming that you have a prime? predicate already written)

b. the product of all the positive integers less than n that arerelatively prime to n (i.e., all positive integers i < n suchthat GCD(i,n) = 1).

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

(defun prime-squared-sum (a b)
  (accumulate-if 'primep
         '+
         0
         #'(lambda(x) (* x x))
         a
         'inc
         b))

(defun rel-prime-product (n)
  (labels ((rel-prime-p (x)
               (if (= 1 (gcd x n))
                   t)))
    (accumulate-if #'rel-prime-p
           '*
           1
           #'(lambda(x) x)
           1
           'inc
           (- n 1))))

SICP Exercise 1.35
Show that the golden ratio (section 1.2.2) is a fixed point of the transformation x - 1 + 1/x, and use this fact to compute GO by means of the fixed-point procedure.

(defconstant +tolerance+ .00001)

(defun fixed-point (f first-guess)
  (labels ((close-enough-p (v1 v2)
              (< (abs (- v1 v2)) +tolerance+))
       (try (guess)
         (let ((next (funcall f guess)))
           (if (close-enough-p guess next)
               next
              (try next)))))
    (try first-guess)))

SICP Exercise 1.36
Modify fixed-point so that it prints the sequence of approximations it generates, using the newline and display primitives shown in exercise 1.22. Then find a solution to xx = 1000 by finding a fixed point of x log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) =
0.)

(defun fixed-point-print (f first-guess)
  (labels ((close-enough-p (v1 v2)
             (< (abs (- v1 v2)) +tolerance+))
       (try (guess)
         (print guess)
         (let ((next (funcall f guess)))
           (if (close-enough-p guess next)
               next
              (try next)))))
    (try first-guess)))

SICP Exercise 1.37
a. An infinite continued fraction is an expression of the form

f = N1/(D1+(N2/(D2+(N3/(D3+...

As an example, one can show that the infinite continued fraction expansion with the Ni and the Di all equal to 1 produces 1/phi , where phi is the golden ratio (described in section 1.2.2). One way to approximate an infinite continued fraction is to truncate the expansion after a given number of terms. Such a truncation -- a so-called k-term finite continued fraction -- has the form

N1/(D1+(N2/(...+Nk/Dk)

Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating1/phi using

(cont-frac (lambda (i) 1.0)
(lambda (i) 1.0)
k)

for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.

(defun cont-frac (n d k &optional (i 1))
  (if (> i k)
      0
      (/ (funcall n i)
         (+ (funcall d i) (cont-frac n d k (+ i 1))))))

(defun cont-frac-iter (n d k &optional (i k) (result 0))
  (if (< i 1)
      result
      (cont-frac-iter n d k
              (- i 1)
              (/ (funcall n i)
                 (+ (funcall d i) result)))))

SICP Exercise 1.38
In 1737, the Swiss mathematician Leonhard Euler published a memoir De Fractionibus Continuis, which included a continued fraction expansion for e - 2, where e is the base of the natural logarithms. In this fraction, the Ni are all 1, and the Di are successively 1, 2, 1, 1, 4, 1, 1, 6, 1, 1, 8, .... Write a program that uses your cont-frac procedure from exercise 1.37 to approximate e, based on Euler's expansion.

(defun d (i)
  "The D function to pass to cont-frac"
  (cond ((= i 2) 2)
        ((zerop (mod (+ 1 i) 3)) (- i (/ i 3)))
        (t 1)))

SICP Exercise 1.39
A continued fraction representation of the tangent function was published in 1770 by the German mathematician J.H. Lambert:

tan r = r/(1-(r^2/(3-(r^2/5-....

where x is in radians. Define a procedure (tan-cf x k) that computes an approximation to the tangent function based on Lambert's formula. K specifies the number of terms to compute, as in exercise 1.37.

(defun tan-cf (x k)
  (labels ((tan-n (i)
            (if (= i 1)
                x
                (- (* x x))))
          (tan-d (i)
             (if (= i 1)
                 1
                (- (* 2 i)
                   1))))
    (cont-frac #'tan-n #'tan-d k)))

SICP Exercise 1.40
Define a procedure cubic that can be used together with the
newtons-method procedure in expressions of the form (newtons-method
(cubic a b c) 1) to approximate zeros of the cubic x3 + ax2 + bx + c.

;;; Scheme functions redefined in CL

(defconstant +tolerance+ 0.00001)

(defconstant +dx+ 0.00001)

(defun deriv (g)
  (lambda (x)
    (/ (- (funcall g (+ x +dx+)) (funcall g x))
       +dx+)))

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

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

;;; Cubic function
(defun cubic (a b c)
  (lambda (x)
    (+ (* x x x)
       (* a x x)
       (* b x)
       c)))

SICP Exercise 1.41
Define a procedure double that takes a procedure of one argumentasargument and returns a procedure that applies the original proceduretwice. For example, if inc is a procedure that adds1 to its argument,then (double inc) should be a procedure that adds 2. What value is returned by (((double (double double)) inc) 5)

(defun double (procedure)
  (lambda (x)
    (funcall procedure (funcall procedure x))))

SICP Exercise 1.42
Let f and g be two one-argument functions. The composition f afterg is defined to be the function x f(g(x)). Define a procedure compose that implements composition. For example, if inc is a procedure that adds 1 to its argument,((compose square inc) 6) 49

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

SICP Exercise 1.43
If f is a numerical function and n is a positive integer, then we can form the nth repeated application of f, which is defined to be the function whose value at x is f(f(...(f(x))...)). For example, if f is the function x x + 1, then the nth repeated application of f is the function x x + n. If f is the operation of squaring a number, then the nth repeated application of f is the function that raises its argument to the 2nth power. Write a procedure that takes as inputs a procedure that computes f and a positive integer n and returns the procedure that computes the nth repeated application of f. Your procedure should be able to be used as follows:
((repeated square 2) 5)
625

(defun repeated (f n &optional (count 1))
  (if (>= count n)
      (lambda (x) (funcall f x))
      (compose (repeated f n (+ count 1)) f)))

SICP Exercise 1.44
The idea of smoothing a function is an important concept in signal processing. If f is a function and dx is some small number, then the smoothed version of f is the function whose value at a point x is the average of f(x - dx), f(x), and f(x + dx). Write a procedure smooth that takes as input a procedure that computes f and returns a procedure that computes the smoothed f. It is sometimes valuable to repeatedly smooth a function (that is, smooth the smoothed function, and so on) to obtained the n-fold smoothed function. Show how to generate the n-fold smoothed function of any given function using smooth and repeated from exercise 1.43.

(defun smoothed (f)
  (lambda (x)
    (/ (+ (funcall f (- x +dx+))
          (funcall f x)
          (funcall f (+ x +dx+)))
        3)))

(defun n-fold-smoothed (f n)
  (repeated (smoothed f) n))

SICP Exercise 1.45
We saw in section 1.3.3 that attempting to compute square roots by naively finding a fixed point of y x/y does not converge, and that this can be fixed by average damping. The same method works for finding cube roots as fixed points of the average-damped y x/y2. Unfortunately, the process does not work for fourth roots -- a single average damp is not enough to make a fixed-point search for y x/y3 converge. On the other hand, if we average damp twice (i.e., use the average damp of the average damp of y x/y3) the fixed-point search does converge. Do some experiments to determine how many average damps are required to compute nth roots as a fixed-point search based upon repeated average damping of y x/yn-1. Use this to implement a simple procedure for computing nth roots using fixedpoint, average-damp, and the repeated procedure of exercise 1.43. Assume that any arithmetic operations you need are available as primitives.

;;; Scheme functions redefined in CL
(defun average-damp (f)
  (lambda (x) (/ (+ x (funcall f x))
                 2)))
;;; End scheme functions

(defun nth-root (x n times)
  (fixed-point (repeated (average-damp (lambda (y) 
                                         (/ (+ y
                                              (/ x (expt y (- n 1))))
                                             2)))
                         times)
                 1.0))

SICP Exercise 1.46
Several of the numerical methods described in this chapter are instances of an extremely general computational strategy known as iterative improvement. Iterative improvement says that, to compute something, we start with an initial guess for the answer, test if the guess is good enough, and otherwise improve the guess and continue the process using the improved guess as the new guess. Write a procedure iterative-improve that takes two procedures as arguments: a method for telling whether a guess is good enough and a method for improving a guess. Iterative-improve should return as its value a procedure that takes a guess as argument and keeps improving the guess until it is good enough. Rewrite the sqrt procedure of section 1.1.7 and the fixed-point procedure of section 1.3.3 in terms of iterative-improve.

(defun iterative-improve (good-enough-p improve)
  (lambda (x)
    (labels ((next-guess (guess)
              (let ((improved-guess (funcall improve guess)))
                (if (funcall good-enough-p guess improved-guess)
                    improved-guess
                    (next-guess improved-guess)))))
      (next-guess x))))

(defun sqrt-improve (x)
  (funcall (iterative-improve (lambda (guess z)
                                (let ((ratio (/ guess z)))
                                   (and (< ratio 1.001) (> ratio 0.999))))
                              (lambda (guess)
                                 (/ (+ guess (/ x guess))
                                     2)))
           1.0))

SICP Exercise 1.11
A function f is defined by the rule that f(n) = n if n<3 and f(n) = f(n - 1) + 2f(n - 2) + 3f(n - 3) if n> 3. Write a procedure that computes f by means of a recursive process. Write a procedure that computes f by means of an iterative process.

(defun f (n)
  "Recursive"
  (cond ((< n 3) n)
             (t (+ (f (- n 1))
                     (* 2 (f (- n 2)))
                     (* 3 (f (- n 3)))))))

(defun f2 (n)
  "Iterative"
  (if (< n 3)
      n
      (f2-iter n 2 1 0)))

(defun f2-iter (count &optional fn-1 fn-2 fn-3)
  (if (< count 3)
      fn-1
      (progn (psetf fn-1 (+ fn-1 (* 2 fn-2) (* 3 fn-3))
                            fn-2 fn-1
                            fn-3 fn-2)
         (f2-iter (- count 1) fn-1 fn-2 fn-3))))

SICP Exercise 1.12
Write a procedure that computes elements of Pascal's triangle by means of a recursive process.

(defun gen-row (lst)
  "Given a list of values of the above row in Pascal's triangle, 
generates the values in the current row except for the leading and
trailing 1"
  (when (> (length lst) 1)
    (cons (+ (first lst) (second lst)) (gen-row (cdr lst)))))

(defun pascal (row)
  "Returns the values in the given row number of Pascal;s triangle"
  (if (eq row 1)
      '(1)
      (append '(1) (gen-row (pascal (- row 1))) '(1))))

SICP Exercise 1.16
Design a procedure that evolves an iterative exponentiation process that uses successive squaring and uses a logarithmic number of steps, as does fast-expt. (Hint: Using the observation that (bn/2)2 = (b2)n/2, keep, along with the exponent n and the base b, an additional state variable a, and define the state transformation in such a way that the product a bn is unchanged from state to state. At the beginning of the process a is taken to be 1, and the answer is given by the value of a at the end of the process. In general, the technique of defining an invariant quantity that remains unchanged from state to state is a powerful way to think about the design of iterative algorithms.)

(defun my-expt (b n &optional (result 1))
  (cond ((zerop n) result)
        ((evenp n)  (my-expt (* b b) (/ n 2) result))
        (t (my-expt b (- n 1) (* b result)))))

SICP Exercise 1.17
The exponentiation algorithms in this section are based on performing exponentiation by means of repeated multiplication. In a similar way, one can perform integer multiplication by means of repeated addition. The following multiplication procedure (in which it is assumed that our language can only add, not multiply) is analogous to the expt procedure:
(define (* a b)
(if (= b 0)
0
(+ a (* a (- b 1)))))
This algorithm takes a number of steps that is linear in b. Now suppose we include, together with addition, operations double, which doubles an integer, and halve, which divides an (even) integer by 2. Using these, design a multiplication procedure analogous to fast-expt that uses a logarithmic number of steps.

(defun double (x) (+ x x))
(defun half (x) (/ x 2))

(defun fast-mult (a b)
  (cond ((zerop b) 0)
        ((evenp b) (double (fast-mult a (half b))))
        (t (+ a (fast-mult a (- b 1))))))

SICP Exercise 1.18
Using the results of exercises 1.16 and 1.17, devise a procedure that generates an iterative process for multiplying two integers in terms of adding, doubling, and halving and uses a logarithmic number of steps.

(defun my-mult (a b &optional (result 0))
  (cond ((zerop b) result)
        ((evenp b) (my-mult (double a) (half b)  result))
        (t (my-mult a (- b 1) (+ a result)))))

SICP Exercise 1.22
Most Lisp implementations include a primitive called runtime that returns an integer that specifies the amount of time the system has been running (measured, for example, in microseconds). The following timed-prime-test procedure, when called with an integer n, prints n and checks to see if n is prime. If n is prime, the procedure prints three asterisks followed by the amount of time used in performing the test.
(define (timed-prime-test n)
(newline)
(display n)
(start-prime-test n (runtime)))
(define (start-prime-test n start-time)
(if (prime? n)
(report-prime (- (runtime) start-time))))
(define (report-prime elapsed-time)
(display " *** ")
(display elapsed-time))
Using this procedure, write a procedure search-for-primes that checks the primality of consecutive odd integers in a specified range. Use your procedure to find the three smallest primes larger than 1000; larger than 10,000; larger than 100,000; larger than 1,000,000. Note the time needed to test each prime. Since the testing algorithm has order of growth of (n), you should expect that testing for primes around 10,000 should take about 10 times as long as testing for primes around 1000. Do your timing data bear this out? How well do the data for 100,000 and 1,000,000 support the n prediction? Is your result compatible with the notion that programs on your machine run in time proportional to the number of steps required for the computation?

;;; Redefine given functions for common lisp
(defun smallest-divisor (n)
  (find-divisor n 2))

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

(defun dividesp (a b) (zerop (mod b a)))

(defun square (x) (* x x))

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

(defun timed-prime-test (n)
  (print n)
  (start-prime-test n (get-internal-run-time)))

(defun start-prime-test (n start-time)
  (if (primep n)
      (report-prime (- (get-internal-run-time) start-time))))

(defun report-prime (elapsed-time)
  (print '***)
  (print elapsed-time))

(defun search-for-primes (start end)
  (loop for i from start to end do (timed-prime-test i)))

Exercise 1.3
Define a procedure that takes three numbers as arguments and returns the sum of the squares of the two larger numbers.

(defun square (x) (* x x))

(defun sum-of-squares (lst)
  (apply #'+ (mapcar #'square lst)))

(defun get-largest-2 (lst)
  (when (>= (length lst) 2)
    (let ((sorted-lst (sort lst #'>)))
      (list (first sorted-lst)
            (second sorted-lst)))))

;;; This does better and takes any number of arguments
(defun sum-sqr-lrgst (lst)
  (sum-of-squares (get-largest-2 lst)))

Exercise 1.8
Newton's method for cube roots is based on the fact that if y is an approximation to the cube root of x, then a better approximation is given by the value
(x/y^2 + 2y)/3
Use this formula to implement a cube-root procedure analogous to the square-root procedure.

(defconstant +tolerance+ 0.001)

(defun cube (x) (* x x x))

(defun good-enough-p (guess x)
  "Returns true if the cube of the guess differs from x by less 
than the tolerance"
  (< (abs (- (cube guess) x)) +tolerance+))

(defun improve (guess x)
  "Returns a better approximation of the cube root of x"
  (/ (+ (/ x
           (square guess))
       (* 2 guess))
     3))

(defun cube-rt-iter (guess x)
  (if (good-enough-p guess x)
      guess
      (cube-rt-iter (improve guess x) x)))

(defun cube-rt (x)
  "Calculates the cube root of x"
  (cube-rt-iter 1.0 x))

Structure and Interpretation of Computer Programs is a classic, must read computer science book. It focuses on the core ideas of computer science that can be applied to all languages. Like my Thinking in Java posts, I am going to use this blog to keep track of my progress as I read through the book again. SICP uses Scheme to illustrate the ideas, but I will mostly use Common Lisp, and maybe even a little Python just to show the differences.