ハフマン符号。面倒だなーって思ってたら前やった奴みつけたからそれを流用。
前準備
(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 (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) ; symbol (cadr pair)) ; frequency (make-leaf-set (cdr pairs))))))
2.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))))) (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)
2.68
(define (encode message tree) (if (null? message) '() (append (encode-symbol (car message) tree) (encode (cdr message) tree)))) (define (encode-symbol symbol tree) (if (leaf? tree) (if (eq? symbol (symbol-leaf tree)) '() #f) (let ((left-symbols (encode-symbol symbol (left-branch tree)))) (if left-symbols (cons 0 left-symbols) (let ((right-symbols (encode-symbol symbol (right-branch tree)))) (if right-symbols (cons 1 right-symbols) #f) )))))
2.69
(define (generate-huffman-tree pairs) (successive-merge (make-leaf-set pairs))) (define (successive-merge leaf-set) (if (= (length leaf-set) 1) (car leaf-set) (let ((merged-tree (make-code-tree (car leaf-set) (cadr leaf-set))) (rest (cddr leaf-set))) (successive-merge (cond ((eq? rest '()) (list merged-tree)) ((< (weight merged-tree) (weight (car rest))) (append (list merged-tree) rest)) (else (append (list (car rest)) (list merged-tree) (cdr rest)))) ))))
2.70
(define rock-symbols '((NA 16) (YIP 9) (SHA 3) (A 2) (GET 2) (JOB 2) (BOOM 1) (WAH 1))) (define rock-tree (generate-huffman-tree rock-symbols)) (encode '(GET A JOB) rock-tree) ; => (1 1 1 1 0 1 1 1 0 1 1 1 1 1 0) (encode '(SHA NA NA NA NA NA NA NA NA) rock-tree) ; => (1 1 0 0 0 0 0 0 0 0 0)
2.71
(encode '(A B C D E) (generate-huffman-tree '((A 16) (B 8) (C 4) (D 2) (E 1)))) ; => (1 0 1 0 0 1 0 0 0 1 0 0 0 0) (encode '(A B C D E F G H I J) (generate-huffman-tree '((A 512) (B 256) (C 128) (D 64) (E 32) (F 16) (G 8) (H 4) (I 2) (J 1)))) ; => (1 0 1 0 0 1 0 0 0 1 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0)