久しぶりなのでハフマン木のところを復習してみた。

時間を決めて、コードを書いてみた。
関数を作る度にテストしていったら、とても楽に進められた。
1時間ちょっとでハフマン木の部分の問題が全部解けた（と思う。計算量みつもりとか以外）

書いたコード

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

(define (symbol-leaf leaf)  (cadr leaf))
(define (weight-leaf leaf) (caddr leaf))
(define (leaf? leaf) (equal? (car leaf) 'leaf))

(define (make-code-tree left right)
  (list left right
        (append (symbols left) (symbols right))
        (+ (weights left) (weights 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 (weights tree)
  (if (leaf? tree) (weight-leaf tree) (cadddr tree)))

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

(define (choose-branch bit tree)
  (cond ((= 0 bit) (left-branch tree))
        ((= 1 bit) (right-branch tree))
        (else (error "invalid argument"))))

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

(define (make-leaf-set pairs)
  (fold-right
   (lambda (pair leaf-set)
     (adjoin-set (make-leaf (car pair) (cadr pair))
                 leaf-set))
   '() pairs))

;;encode
(define (encode message tree)
  (fold-right (lambda (symbol rest-message)
                (append (encode-symbol symbol tree)
                        rest-message))
              '() message))

(define (encode-symbol symbol tree)
  (when (memq symbol (symbols tree))
  (let encode1 ((current-branch tree) (result '()))
      (cond ((and (leaf? current-branch)
                  (equal? symbol (symbol-leaf current-branch)))
             (reverse result))
            ((memq symbol (symbols (left-branch current-branch)))
             (encode1 (left-branch current-branch)
                      (cons 0 result)))
            (else
             (encode1 (right-branch current-branch)
                      (cons 1 result)))))))
;;generate-huffman
(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))

(define (single? l)
  (and (null? (cdr l)) (pair? l)))

;;これじゃだめだ。;;深くまで調べてないし
;; (define (successive-merge set)
;;   (if (single? set)
;;       (car set)
;;       (let ((1st (car set)) (2nd (cadr set)) (rest (cddr set)))
;;         (let ((temp-tree
;;                (if (> (weights 1st) (weights 2nd))
;;                    (make-code-tree 1st 2nd)
;;                    (make-code-tree 2nd 1st))))
;;           (successive-merge (cons temp-tree rest))))))

;;そう言えばadjoin-setがあった
(define (successive-merge set)
  (if (single? set)
      (car set)
      (let ((1st (car set)) (2nd (cadr set)) (rest (cddr set)))
        (successive-merge 
         (adjoin-set (make-code-tree 1st 2nd)
                     rest)))))

実行結果（時々こちらのファイルに移動して関数の挙動を調べる）

(define l (make-leaf 'a 4))
(leaf-symbol l); => a
(leaf-weight l); => 4
(leaf? l); => #t

(define l2 (make-leaf 'b 10))
(define t (make-code-tree l l2))

(left-branch t); => (leaf a 4)
(right-branch t); => (leaf b 10)
(weights t);; => 14
(symbols t);; => (a b)

(decode '(0 1 0 1 1  0 0 0 1) t); => (a b a b b a a a b)
(left-branch t); => (leaf a 4)

(define t2
  (adjoin-set (make-leaf 'c 12) (list t)))
(decode '(0 1 0 0 0 1 1 1 0 0 1 1) t2)

(make-leaf-set '((a 3) (b 7) (c 1)));; => ((leaf c 1) (leaf a 3) (leaf b 7))

;;e2.67
(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)))))
(memq 'A (symbols sample-tree)); => (A B D C)
(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)

;;e2.68
(encode-symbol 'B sample-tree)
(equal? (encode '(A D A B B C A) sample-tree)
        sample-message); => #t

;;huffman
(single? 3)
(single? '(3)); => #t
(single? '(3 . 4)); => #f
(single? '(3 4)); => #f

(make-leaf-set '((a 3) (b 7) (c 1)));; => ((leaf c 1) (leaf a 3) (leaf b 7))
(define pairs '((a 3) (b 7) (c 1)))

(weight-pair (car pairs)); => 3

(define t3 (generate-huffman-tree pairs))
(left-branch t3)
(right-branch t3)
(decode '(0) t3)
(decode '(0 1 0 1 1) t3)

(define sample-pairs
  '((A 2) (NA 16) (BOOM 1) (SHA 3) (GET 2) (YIP 9) (JOB 2) (WAH 1)))
(define sample-song 
  '(GET A JOB SHA NA NA NA NA NA NA NA NA GET A JOB SHA NA NA NA NA NA NA NA NA WAH YIP YIP YIP YIP YIP YIP YIP YIP YIP SHA BOOM))

(let1 t (generate-huffman-tree sample-pairs)
  (print t)
  (equal? sample-song  (decode (encode sample-song t) t)));; => #t