(sicp26)m2.67〜m2.69
2.68でmemqを使ってしまった。
(後でまじめにparseする方法を考える)
(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 ((= 0 bit) (left-branch branch)) ((= 1 bit) (right-branch branch)) (else (error "bad bit -- CHOOSE-BRANCH" bit)))) (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)))))) ;;m 2.67 ;;such as ((A 4) (B 2) (C 1) (D 1)) (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 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) ;; 33:user> => (A D A B B C A) ;;2.68 ;;木でなければerrorを返す必要がある。 ;;最後に2.67の通信文と同じかテストする。 (define (encode message tree) (if (null? message) '() (append (encode-symbol (car message) tree) (encode (cdr message) tree)))) ;;木を自力でparseするのは面倒だなー ;;left-branch , right-branchがあることを忘れていた。 ;;sybolsがあることを忘れていた。 (symbols (left-branch sample-tree)) (define (encode-symbol sym tree) (if (leaf? tree) (if (eq? sym (symbol-leaf tree)) '() (error sym "is not defined")) (if (memq sym (left-branch tree)) (cons 0 (encode-symbol sym (left-branch tree))) (cons 1 (encode-symbol sym (right-branch tree)))))) (encode '(A D A B B C A) sample-tree) ;;user> => (0 1 1 0 0 1 0 1 0 1 1 1 0) (equal? (encode '(A D A B B C A) sample-tree) sample-message) ;;user> => #t ;;すごい時間がかかりました>< ;;2.69 (define (generate-huffman-tree pairs) (successive-marge (make-leaf-set pairs))) (define (successive-marge pairs) (if (null? (cdr pairs)) (car pairs) (successive-marge (adjoin-set (make-code-tree (car pairs) (cadr pairs)) (cddr pairs))))) ;;問題の出現頻度と同じもの. (let ((sample-pairs (zip (symbols sample-tree) '(4 2 1 1)))) (print sample-tree) (print (generate-huffman-tree sample-pairs))) 115:user> ((leaf A 4) ((leaf B 2) ((leaf D 1) (leaf C 1) (D C) 2) (B D C) 4) (A B D C) 8) ((leaf A 4) ((leaf B 2) ((leaf C 1) (leaf D 1) (C D) 2) (B C D) 4) (A B C D) 8) => #<undef>