sicp/2_67.rkt

154 lines
4.4 KiB
Racket

#lang sicp
;;;SECTION 2.3.3
;; representing
(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)))
;; decoding
(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))))
;; sets
(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 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))
(define (memq item x)
(cond ((null? x) false)
((eq? item (car x)) x)
(else (memq item (cdr x)))))
(define (encode-branch symbol tree)
(let ((left-sym (symbols (left-branch tree)))
(right-sym (symbols (right-branch tree))))
(cond ((memq symbol left-sym) (cons 0 (left-branch tree)))
((memq symbol right-sym) (cons 1 (right-branch tree)))
(else (cons '() '())))))
(define (encode-symbol symbol tree)
(if (null? tree) '()
(let ((code (car (encode-branch symbol tree)))
(branch (cdr (encode-branch symbol tree))))
(if (not (null? code))
(if (leaf? branch)
(list code)
(cons code (encode-symbol symbol branch)))
(error symbol "not in tree")))))
(define (encode message tree)
(if (null? message)
'()
(append (encode-symbol (car message) tree)
(encode (cdr message) tree))))
;; EXERCISE 2.69
(define (successive-merge leaf-set)
(if (null? (cdr leaf-set))
(car leaf-set)
(let ((element1 (car leaf-set))
(element2 (cadr leaf-set)))
(successive-merge
(adjoin-set (make-code-tree element1 element2)
(cddr leaf-set))))))
(define (generate-huffman-tree pairs)
(successive-merge (make-leaf-set pairs)))
;; 2.70
(define song-pairs '((a 2) (get 2) (sha 3) (wah 1) (boom 1) (job 2) (na 16) (yip 9)))
(define song-tree (generate-huffman-tree song-pairs))
(define 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 sha yip yip yip yip yip yip yip yip yip sha boom))
(define encoded-length (length (encode song song-tree))) ;; 83 bits
;; Song is 36 symobls long. A fixed-length code would require 3-bits per symbol (8 symbols). So the
;; song would need 36*3=108 bits.
;; 2.71
(define pairs-5 '((a 1) (b 2) (c 4) (d 8) (e 16)))
(define pairs-10 (append pairs-5
'((f 32) (g 64) (h 128) (i 256) (j 512))))
;; To encode the most frequent symbol requires 1 bit. To encode the most frequent symbol requires
;; n-1 bits (where there are n symbols with weights 1,...,2^{n-1}). The resulting huffman tree in this
;; case is the most unbalanced tree possible, so is n-1 deep.
;; 2.72
;; To encode the most frequent symbol requires a single lookup into n-1 symbols plus a lookup of
;; 1 symbol. The tree is only 1 deep for this case, so O(n).
;; For the least frequent symbol, we need to look up from (n-1) symbols and 1 symbol, then (n-2) symbols
;; and one symbol. This repeats n times, so O(n^2).