#lang racket (define (memq item x) (cond ((null? x) #f) ((eq? item (car x)) x) (else (memq item (cdr x))))) ;; leaf nodes (define (make-leaf leaf weight) (list 'leaf leaf weight)) (define (leaf? object) (eq? (car object) 'leaf)) (define (symbol-leaf object) (cadr object)) (define (weight-leaf object) (caddr object)) ;;;; constructors and selectors ;; tree node consists of a list which has left branch, right branch ;; set of symbols in left and right and total weight (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))) ;; now 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 tree) (cond [(= bit 0) (left-branch tree)] [(= bit 1) (right-branch tree)] [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) (cadr pair)) (make-leaf-set (cdr pairs)))))) (provide make-code-tree make-leaf decode leaf? symbol-leaf left-branch right-branch symbols make-leaf-set adjoin-set)