久しぶりなのでハフマン木のところを復習してみた。
時間を決めて、コードを書いてみた。
関数を作る度にテストしていったら、とても楽に進められた。
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