DataMuseum.dk

top - download

    Length: 2982 (0xba6)
    Types: TextFile
    Names: »ps4.scm«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/psets/ps4.scm« 

TextFile

;;;this is the file PSETS:HUFFMAN.SCM

;;representation for leaves

(define (make-leaf symbol weight)
  (list 'leaf symbol weight))

(define (leaf? object)
  (and (not (atom? object))
       (eq? (car object) 'leaf)))

(define (symbol-leaf x) (cadr x))

(define (weight-leaf x) (caddr x))

;;representation for trees

(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)))

\f


;;decoding messages 

(define (decode bits tree)
  (decode-1 bits tree tree))

(define (decode-1 bits tree current-branch)
  (cond ((null? bits) nil)
        (else
         (let ((next-branch (choose-branch (car bits) current-branch)))
           (if (leaf? next-branch)
               (cons (symbol-leaf next-branch)
                     (decode-1 (cdr bits) tree tree))
               (decode-1 (cdr bits) tree next-branch))))))

(define (choose-branch bit branch)
  (cond ((= bit 0) (left-branch branch))
        ((= bit 1) (right-branch branch))
        (else (error "bad bit -- choose-branch"
                     bit))))

;;top level of encoding procedure
(define (encode message tree)
  (if (null? message)
      nil
      (append (encode-symbol (car message) tree)
              (encode (cdr message) tree))))

;;top level of tree-generating procedure
(define (generate-huffman-tree pairs)
  (car (successive-merge (make-leaf-set pairs))))

;;procedure for handling ordered 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))))))

;;transfrom a list of symbol-frequency pairs into an ordered set of
;;leaves 

(define (make-leaf-set pairs)
  (if (null? pairs)
      nil
      (adjoin-set (make-leaf (caar pairs)      ;symbol
                             (cadar pairs))    ;frequency
                  (make-leaf-set (cdr pairs)))))
\f


;;sample data

(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 rock-pairs
'((a  2) (na 16) (boom 1) (sha 3) (get 2) (yip 10) (job 2) (wah 1)))

(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
    wah yip yip yip yip yip yip yip yip yip
    sha boom))

;fix print-breadth so that long lists are printed (If you don't understand
;why this is here--Don't worry about it.  It's not important) -ls.steve
(print-breadth 300)