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