## February 6, 2010

at Saturday, February 06, 2010 Labels: , , Posted by Billy

```;;;; 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 augend (s)

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

(defun multiplier (p)

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

(defun exponent (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)
(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 augend (s)
(let ((augend (cddr s)))
(if (= 1 (length augend))
(car augend)
(make-sum (car augend) (cdr augend)))))

(defun multiplier (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) '+)))

(car s))

(defun augend (s)

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

(defun multiplier (p)
(car p))

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

(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
(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
(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 make-code-tree (left right)
(list left
right
(append (symbols left) (symbols right))
(+ (weight left) (weight right))))

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

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

(defun weight (tree)
(if (leaf? tree)
(weight-leaf 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))

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

```