SICP 2.3.4 Huffman Coding Exercises

huffman.rkt

#lang racket

;; From SICP 2.3.4

;; Leaf defintions
(define (make-leaf symbol weight)
  (list 'leaf symbol weight))
(define (leaf? object)
  (eq? (car object) 'leaf))
(define (leaf-symbol x) (cadr x))
(define (leaf-weight 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))

;; Generic method for getting the list of symbols
;; at a given tree or leaf.
(define (symbols tree)
  (if (leaf? tree)
      (list (leaf-symbol tree))
      (caddr tree)))

;; Generic method for getting a weight for a tree
;; node or leaf.
(define (weight tree)
  (if (leaf? tree)
      (leaf-weight tree)
      (cadddr tree)))

;; Given a bitstring and a huffman tree
;; traverse the tree to decode the characters
;; from the bitstring and return the decoded result.
(define (decode bits tree)
  (define (decode-1 bits current-branch)
    (if (empty? bits)
        empty
        (let ([next-branch
               (choose-branch (car bits) current-branch)])
          (if (leaf? next-branch)
              (cons (leaf-symbol next-branch)
                    (decode-1 (cdr bits) tree))
              (decode-1 (cdr bits) next-branch)))))
  (decode-1 bits tree))

(define (choose-branch bit tree)
  (cond [(= bit 0) (left-branch tree)]
        [(= bit 1) (right-branch tree)]
        [else (error "Bit must be one or zero: choose-branch" bit)]))

;; Adds an item to an ordered set
;; NOTE: Could probably optimize this to return early if x
;; is found in the set.
(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 (element-of-set? x set)
  (cond [(empty? set) false]
        [(eq? x (car set)) true]
        [else (element-of-set? x (cdr set))]))

;; Given a list of lists, return an ordered set of leaf
;; objects.
(define (make-leaf-set pairs)
  (if (empty? pairs)
      empty
      (let ([pair (car pairs)])
        (adjoin-set (make-leaf (car pair)
                               (cadr pair))
                    (make-leaf-set (cdr pairs))))))

(define (encode message tree)
    (if (empty? message)
        empty
        (append (encode-symbol (car message) tree)
                (encode (cdr message) tree))))

;; Given a letter, return a bitstring from the huffman encoding tree
;; Should error if the symbol doesn't exist in the tree
;;
;; If the symbol is in the symbols of the left branch (cons 0 (encode-symbol letter (left-branch tree))
(define (encode-symbol letter tree)
  (if (leaf? tree)
      empty
      (let ([left (left-branch tree)]
        [right (right-branch tree)])
        (cond [(element-of-set? letter (symbols left))
               (cons 0 (encode-symbol letter left))]
              [(element-of-set? letter (symbols right))
               (cons 1 (encode-symbol letter right))]
              [else (error "letter does not exist in tree")]))))

(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))

;; Find the two smallest weight things and replace them with a merged version
;; of the two leafs
(define (successive-merge leaf-set)
  (if (empty? (cdr leaf-set))
      (car leaf-set)
      (successive-merge
       (adjoin-set (make-code-tree (car leaf-set)
                                   (cadr leaf-set))
                   (cddr leaf-set)))))

;; 2.70

(define song-alphabet '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1)))
(define song-tree (generate-huffman-tree song-alphabet))
(define song '(GET A JOB SHA 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))

(define encoded-song (encode song song-tree))
(decode encoded-song song-tree)


;; Bonus
;; Get frequency distribution
;; Make something that takes the text and turns it into a symbol list
;; trim out non alphabet characters

(define allstar-alphabet
  '((A 114) (B 22) (C 29) (D 67) (E 175) (F 22) (G 74) (H 84) (I 83) (J 1) (K 21) (L 93) (M 38) (N 108) (O 163) (P 20) (R 91) (S 103) (T 165) (U 58) (V 7) (W 40) (Y 61)))
(define allstar-string "SOMEBODYONCETOLDMETHEWORLDISGONNAROLLMEIAINTTHESHARPESTTOOLINTHESHEDSHEWASLOOKINGKINDOFDUMBWITHHERFINGERANDHERTHUMBINTHESHAPEOFANLONHERFOREHEADWELLTHEYEARSSTARTCOMINGANDTHEYDONTSTOPCOMINGFEDTOTHERULESANDIHITTHEGROUNDRUNNINGDIDNTMAKESENSENOTTOLIVEFORFUNYOURBRAINGETSSMARTBUTYOURHEADGETSDUMBSOMUCHTODOSOMUCHTOSEESOWHATSWRONGWITHTAKINGTHEBACKSTREETSYOULLNEVERKNOWIFYOUDONTGOYOULLNEVERSHINEIFYOUDONTGLOWHEYNOWYOUREANALLSTARGETYOURGAMEONGOPLAYHEYNOWYOUREAROCKSTARGETTHESHOWONGETPAIDANDALLTHATGLITTERSISGOLDONLYSHOOTINGSTARSBREAKTHEMOLDITSACOOLPLACEANDTHEYSAYITGETSCOLDERYOUREBUNDLEDUPNOWWAITTILLYOUGETOLDERBUTTHEMETEORMENBEGTODIFFERJUDGINGBYTHEHOLEINTHESATELLITEPICTURETHEICEWESKATEISGETTINGPRETTYTHINTHEWATERSGETTINGWARMSOYOUMIGHTASWELLSWIMMYWORLDSONFIREHOWABOUTYOURSTHATSTHEWAYILIKEITANDINEVERGETBOREDHEYNOWYOUREANALLSTARGETYOURGAMEONGOPLAYHEYNOWYOUREAROCKSTARGETTHESHOWONGETPAIDALLTHATGLITTERSISGOLDONLYSHOOTINGSTARSBREAKTHEMOLDHEYNOWYOUREANALLSTARGETYOURGAMEONGOPLAYHEYNOWYOUREAROCKSTARGETTHESHOWONGETPAIDANDALLTHATGLITTERSISGOLDONLYSHOOTINGSTARSSOMEBODYONCEASKEDCOULDISPARESOMECHANGEFORGASINEEDTOGETMYSELFAWAYFROMTHISPLACEISAIDYEPWHATACONCEPTICOULDUSEALITTLEFUELMYSELFANDWECOULDALLUSEALITTLECHANGEWELLTHEYEARSSTARTCOMINGANDTHEYDONTSTOPCOMINGFEDTOTHERULESANDIHITTHEGROUNDRUNNINGDIDNTMAKESENSENOTTOLIVEFORFUNYOURBRAINGETSSMARTBUTYOURHEADGETSDUMBSOMUCHTODOSOMUCHTOSEESOWHATSWRONGWITHTAKINGTHEBACKSTREETSYOULLNEVERKNOWIFYOUDONTGOGOYOULLNEVERSHINEIFYOUDONTGLOWHEYNOWYOUREANALLSTARGETYOURGAMEONGOPLAYHEYNOWYOUREAROCKSTARGETTHESHOWONGETPAIDANDALLTHATGLITTERSISGOLDONLYSHOOTINGSTARSBREAKTHEMOLDANDALLTHATGLITTERSISGOLDONLYSHOOTINGSTARSBREAKTHEMOLD")

(define allstar-song
  (map string->symbol
       (filter (λ (character) (not (string=? "" character)))
               (string-split allstar-string ""))))
(define allstar-tree (generate-huffman-tree allstar-alphabet))
(length (encode allstar-song allstar-tree))