このファイルをsymdiffとする. 以下の問題で読み込む
(define (deriv exp var)
  (cond ((number? exp) 0)
        ((variable? exp)
         (if (same-variable? exp var) 1 0))
        ((sum? exp)
         (make-sum (deriv (addend exp) var)
                   (deriv (augend exp) var)))
        ((product? exp)
         (make-sum
           (make-product (multiplier exp)
                         (deriv (multiplicand exp) var))
           (make-product (deriv (multiplier exp) var)
                         (multiplicand exp))))
        (else
         (error "unknown expression type -- DERIV" exp))))

(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (make-sum a1 a2) (list '+ a1 a2))
(define (make-product m1 m2) (list '* m1 m2))
(define (sum? x)
  (and (pair? x) (eq? (car x) '+)))
(define (addend s) (cadr s))
(define (augend s) (caddr s))
(define (product? x)
  (and (pair? x) (eq? (car x) '*)))
(define (multiplier p) (cadr p))
(define (multiplicand p) (caddr p))
(display (deriv '(+ x 3) 'x)) (newline)
(display (deriv '(* x y) 'x)) (newline)
(display (deriv '(* (* x y) (+ x 3)) 'x)) (newline)
(define (make-sum a1 a2)
  (cond ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2)) (+ a1 a2))
        (else (list '+ a1 a2))))
(define (=number? exp num)
  (and (number? exp) (= exp num)))
(define (make-product m1 m2)
  (cond ((or (=number? m1 0) (=number? m2 0)) 0)
        ((=number? m1 1) m2)
        ((=number? m2 1) m1)
        ((and (number? m1) (number? m2)) (* m1 m2))
        (else (list '* m1 m2))))
(display (deriv '(+ x 3) 'x)) (newline)
(display (deriv '(* x y) 'x)) (newline)
(display (deriv '(* (* x y) (+ x 3)) 'x)) (newline)

(list 'a 'b 'c) ==> (a b c)

(list (list 'george)) ==> ((george))

(cdr '((x1 x2) (y1 y2))) ==> ((y1 y2))

(cadr '((x1 x2) (y1 y2))) ==> (y1 y2)

(pair? (car '(a short list))) ==> ()

(memq 'red '((red shoes) (blue socks))) ==> ()

(define (equal? a b)
  (or (and (not (pair? a)) (not (pair? b)) (eq? a b))
      (and (pair? a) (pair? b)
           (equal? (car a) (car b)) (equal? (cdr a) (cdr b)))))

(load "symdiff.sch") ;; 記号微分のファイルを読む

(define (make-exponentiation base exponent)
  (cond ((=number? exponent 0) 1)
        ((=number? exponent 1) base)
        (else (list '** base exponent))))

(define (exponentiation? x)
  (and (pair? x) (eq? (car x) '**)))

(define (base e) (cadr e))

(define (exponet e) (caddr e))

(define (deriv exp var)
  (cond ((number? exp) 0)
        ((variable? exp)
         (if (same-variable? exp var) 1 0))
        ((sum? exp)
         (make-sum (deriv (addend exp) var)
                   (deriv (augend exp) var)))
        ((product? exp)
         (make-sum
           (make-product (multiplier exp)
                         (deriv (multiplicand exp) var))
           (make-product (deriv (multiplier exp) var)
                         (multiplicand exp))))
        ((exponentiation? exp)
         (make-product (exponet exp)
                       (make-product 
                         (make-exponentiation 
                           (base exp) (- (exponet exp) 1))
                         (deriv (base exp) var))))
        (else
         (error "unknown expression type -- DERIV" exp))))

(deriv '(+ (** x 3) (+ (** x 2) (+ x 1))) 'x)

(define (augend s)
  (if (null? (cdddr s))
      (caddr s)
      (cons '+ (cddr s))))
(define (multiplicand p)
  (if (null? (cdddr p))
      (caddr p)
      (cons '* (cddr p))))

a.

87ページの構成子と選択子を変更する. 

(define (make-sum a1 a2) (list a1 '+ a2))

(define (make-product m1 m2) (list m1 '* m2))

(define (sum? x)
  (and (pair? x) (eq? (cadr x) '+)))

(define (addend s) (car s))

(define (augend s) (caddr s)) ;変更なし

(define (product? x)
  (and (pair? x) (eq? (cadr x) '*)))

(define (multiplier p) (car p))

(define (multiplicand p) (caddr p)) ;変更なし

b. compilerを書く必要がある. 

(define (compile exp)
 (cond ((symbol? exp) exp)
       ((number? exp) exp)
       ((eq? (car exp) '+) exp)
       ((eq? (car exp) '*) exp)
       ((= (length exp) 3)
        (list (cadr exp) (compile (car exp)) (compile (caddr exp))))
       ((> (length exp) 4)
        (cond ((eq? (cadr exp) (cadddr exp)) 
               (compile (cons (list (cadr exp) (compile (car exp))
                                    (compile (caddr exp)))
                              (cdddr exp))))
              ((and (eq? (cadr exp) '+) (eq? (cadddr exp) '*))
               (let ((a (car exp)) (b (cadr exp)) (c (caddr exp))
                     (d (cadddr exp)) (e (list-ref exp 4))
                     (f (list-tail exp 5)))
                 (compile (cons a (cons b (cons 
                       (list d (compile c) (compile e)) f))))))))))

;テスト

(compile '(x + 3 * (x + y + 2)))
;==> (+ x (* 3 (+ (+ x y) 2)))

(define (union-set set1 set2)
  (cond ((null? set1) set2)
        ((element-of-set? (car set1) set2)
         (union-set (cdr set1) set2))
        (else (cons (car set1)
                    (union-set (cdr set1) set2)))))

(define (element-of-set? x set)
  (cond ((null? set) false)
        ((equal? x (car set)) true)
        (else (element-of-set? x (cdr set)))))

(define (adjoin-set x set)
  (cons x set)))

(define (union-set set1 set2)
  (append set1 set2))

(define (intersection-set set1 set2)
  (cond ((or (null? set1) (null? set2)) '())
        ((element-of-set? (car set1) set2)        
         (cons (car set1)
               (intersection-set (cdr set1) set2)))
        (else (intersection-set (cdr set1) set2))))

(define (adjoin-set x set)
 (cond ((null? set) (list x))
       ((= x (car set)) set)
       ((< x (car set)) (cons x set))
       (else (cons (car set) (adjoin-set x (cdr set))))))

(define set '(2 4 6))

(adjoin-set 1 set) ==> (1 2 4 6)
(adjoin-set 3 set) ==> (2 3 4 6)
(adjoin-set 7 set) ==> (2 4 6 7)

(define (union-set set1 set2)
 (cond ((null? set1) set2)
       ((null? set2) set1)
       (else (let ((x1 (car set1)) (x2 (car set2)))
                  (cond ((= x1 x2) (cons x1 (union-set (cdr set1) (cdr set2))))
                        ((< x1 x2) (cons x1 (union-set (cdr set1) set2)))
                        ((> x1 x2) (cons x2 (union-set set1 (cdr set2)))))))))

(union-set '(1 2 3) '(4 5 6)) ==> (1 2 3 4 5 6)
(union-set '(1 2 3) '(1 2 3)) ==> (1 2 3)
(union-set '() '(1 2)) ==> (1 2)
(union-set '(1 2) '()) ==> (1 2)
(display (union-set '() '())) (newline)
(display (union-set '(1 3 5) '(2 4 6))) (newline)

(define (tree->list-1 tree)
(display "1")
  (if (null? tree)
      '()
      (append (tree->list-1 (left-branch tree))
              (cons (entry tree)
                    (tree->list-1 (right-branch tree))))))

(define (tree->list-2 tree)
  (define (copy-to-list tree result-list)
(display "2")
    (if (null? tree)
        result-list
        (copy-to-list (left-branch tree)
                      (cons (entry tree)
                            (copy-to-list (right-branch tree)
                                          result-list)))))
  (copy-to-list tree '()))

a. 二つの手続きとも, 同じリストを生成する. 

(define (list->tree elements)
  (car (partial-tree elements (length elements))))

(define (partial-tree elts n)
  (if (= n 0)
      (cons '() elts)
      (let ((left-size (quotient (- n 1) 2)))
        (let ((left-result (partial-tree elts left-size)))
          (let ((left-tree (car left-result))
                (non-left-elts (cdr left-result))
                (right-size (- n (+ left-size 1))))
            (let ((this-entry (car non-left-elts))
                  (right-result (partial-tree (cdr non-left-elts)
                                              right-size)))
              (let ((right-tree (car right-result))
                    (remaining-elts (cdr right-result)))
                (cons (make-tree this-entry left-tree right-tree)
                      remaining-elts))))))))

(define (make-tree entry left right)
 (list entry left right))

(list->tree (list 1 3 5 7 9 11)) ==> (5 (1 () (3 () ())) (9 (7 () ()) (11 () ())))

partial-treeの働き:

eltsはソートしてあると仮定．

n = 0 の時 (() . elts) を返す．
n > 0 の時 (eltsの最左n個の釣り合った二進木 . eltsの残り) を返す．
  n個のうち左部分木になる個数 left-size (n - 1)/2 (1はthis-entryのための数
  でpartial-treeを呼ぶ 
  (左部分木 ．残り) が返る．左部分木をleft-treeに記憶．残りをnon-left-tree
  とする．non-left-treeの先頭をthis-entryとして記憶．その残りからright-size
  個の右部分木を作りに行く
  (右部分木 ．残り) が返る．右部分木をright-treeに記憶．残りを remaining-elts
  とする．
  make-treeを使い，((this-entry left-tree right-tree) . remaining-elts)
  を返す．

(1 3 5 7 9 11)をpartial-treeにかける．長さは6だから，left-sizeは2．
次のleft-sizeは0．(() . (1 3 5 7 9 11)) が返る．right-sizeは1で
(1 () (3 () ())) が左部分木．5がthis-entryになり，(7 9 11)のpartial-tree
の結果は (9 (7 () ()) (11 () ()))
そこで全体は
(5 (1 () (3 () ())) (9 (7 () ()) (11 () ())))

問題2.63, 2.64でtree->list-1, list->treeはθ(n)であることが
分かったので, それを使う. union-setとintersection-setは, 順序
つけられたリストとしての集合で定義したθ(n)の手続きである. 
(intersection-set p.90, union-set 問題2.62)

(define (union-set-tree tree1 tree2)
  (list->tree (union-set (tree->list-1 tree1)
                         (tree->list-1 tree2))))

(define (intersection-set-tree tree1 tree2)
  (list->tree (intersection-set (tree->list-1 tree1)
                                (tree->list-1 tree2))))

(define (look-up given-key set-of-record)
  (cond ((null? set-of-record) false)
        ((equal? given-key (key (car set-of-record)))
         (car set-of-record))
        ((< (order given-key) (order (key (car set-of-record))))
         (look-up given-key (cadr set-of-record)))
        (else (look-up given-key (caddr set-of-record)))))

keyはrecordからキーの部分を取り出す. 
orderはキーを数値比較が出来るように変換する. 

(define (make-leaf symbol weight)
  (list 'leaf symbol weight))

(define (leaf? object)
  (eq? (car object) 'leaf))

(define (symbol-leaf x) (cadr x))

(define (weight-leaf x) (caddr x))

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

(define (left-branch tree) (car tree))

(define (right-branch tree) (cadr tree))

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

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

(define (decode bits tree)
  (define (decode-1 bits current-branch)
    (if (null? bits)
        '()
        (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))

(define (choose-branch bit branch)
  (cond ((= bit 0) (left-branch branch))
        ((= bit 1) (right-branch branch))
        (else (error "bad bit -- CHOOSE-BRANCH" bit))))

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

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

(define (make-leaf symbol weight)
  (list 'leaf symbol weight))

(define (leaf? object)
  (eq? (car object) 'leaf))

(define (symbol-leaf x) (cadr x))

(define (weight-leaf x) (caddr x))

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

(define (left-branch tree) (car tree))

(define (right-branch tree) (cadr tree))

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

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

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

(define (encode message tree)
  (if (null? message)
      '()
      (append (encode-symbol (car message) tree)
              (encode (cdr message) tree))))

(define (element-of-set? x set)
  (cond ((null? set) false)
        ((equal? x (car set)) true)
        (else (element-of-set? x (cdr set)))))

(define (encode-symbol symbol tree)
  (if (leaf? tree) '()
      (let ((lb (left-branch tree)) (rb (right-branch tree)))
        (cond ((element-of-set? symbol (symbols lb))
               (cons 0 (encode-symbol symbol lb)))
              ((element-of-set? symbol (symbols rb))
               (cons 1 (encode-symbol symbol rb)))))))

(encode '(a d a b b c a) sample-tree) ;; ==> (0 1 1 0 0 1 0 1 0 1 1 1 0)

(define (make-leaf symbol weight)
  (list 'leaf symbol weight))

(define (leaf? object)
  (eq? (car object) 'leaf))

(define (symbol-leaf x) (cadr x))

(define (weight-leaf x) (caddr x))

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

(define (left-branch tree) (car tree))

(define (right-branch tree) (cadr tree))

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

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

(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))

(define (adjoin-set x set)
  (cond ((null? set) (list x))
        ((< (weight x) (weight (car set))) (cons x set))
        (else (cons (car set)
                    (adjoin-set x (cdr set))))))

(define (make-leaf-set pairs)
  (if (null? pairs)
      '()
      (let ((pair (car pairs)))
        (adjoin-set (make-leaf (car pair)  
                               (cadr pair))
                    (make-leaf-set (cdr pairs))))))

(define (successive-merge set)
 (if (= (length set) 1) (car set)
     (let ((sorted-set (sort set (lambda (x y) (< (weight x) (weight y))))))
       (successive-merge 
        (cons (make-code-tree (car sorted-set) (cadr sorted-set))
              (cddr sorted-set))))))


(define sample-pairs '((a 8) (b 3) (c 1) (d 1) (e 1) (f 1) (g 1) (h 1)))

(generate-huffman-tree sample-pairs)

;; ==> ((leaf a 8)
;;      ((((leaf c 1) (leaf d 1) (c d) 2) 
;;        ((leaf h 1) (leaf g 1) (h g) 2) (c d h g) 4) 
;;       (((leaf f 1) (leaf e 1) (f e) 2)
;;        (leaf b 3) (f e b) 5) (c d h g f e b) 9)
;;      (a c d h g f e b) 17)

Huffman木

((leaf na 16)
 ((leaf yip 9)
  (((leaf a 2) ((leaf wah 1) (leaf boom 1) (wah boom) 2) (a wah boom) 4)
   ((leaf sha 3) ((leaf job 2) (leaf get 2) (job get) 4) (sha job get) 7)
   (a wah boom sha job get)
   11)
  (yip a wah boom sha job get)
  20)
 (na yip a wah boom sha job get)
 36)


符号化
(1 1 1 1 1 1 1 0 0 1 1 1 1 0 1 1 1 0 0 0 
 0 0 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 1 1 0 
 1 1 1 0 0 0 0 0 0 0 0 0 1 1 0 1 0 1 0 1 
 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 1 1 0 1 
 1 0 1 1)

Huffman符号では 84ビット

固定長符号では 36*3= 108ビット

(generate-huffman-tree '((a 1) (b 2) (c 4) (d 8) (e 16))) ==>

(((((leaf a 1) (leaf b 2) (a b) 3) (leaf c 4) (a b c) 7)
  (leaf d 8)
  (a b c d)
  15)
 (leaf e 16)
 (a b c d e)
 31)

(generate-huffman-tree '((a 1) (b 2) (c 4) (d 8) (e 16) 
                         (f 32) (g 64) (h 128) (i 256) (j 512))) ==>

((((((((((leaf a 1) (leaf b 2) (a b) 3) (leaf c 4) (a b c) 7)
       (leaf d 8)
       (a b c d)
       15)
      (leaf e 16)
      (a b c d e)
      31)
     (leaf f 32)
     (a b c d e f)
     63)
    (leaf g 64)
    (a b c d e f g)
    127)
   (leaf h 128)
   (a b c d e f g h)
   255)
  (leaf i 256)
  (a b c d e f g h i)
  511)
 (leaf j 512)
 (a b c d e f g h i j)
 1023)

最高頻度 1ビット
最低頻度 n-1ビット

問題2.71の頻度だと上のようなHuffman木ができる．

したがって最高頻度の記号は
encode-symbol     2回
element-of-set? n+1回

最低頻度の記号は
encode-symbol     n回
element-of-set? n-1回