哈弗曼编码解码

#lang scheme

( define nil '() )

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

( define ( leaf? obj )
   ( eq? ( car obj ) '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 )
   ( cond [ ( leaf? tree )
            ( list ( symbol-leaf tree ) ) ]
          [ else ( caddr tree ) ] ) )

( define ( weight tree )
   ( cond [ ( leaf? tree )
            ( weight-leaf tree ) ]
          [ else ( cadddr tree ) ] ) )  

( define ( decode bits tree )
   ( define ( decode-1 bits cur-branch )
      ( cond [ ( null? bits ) nil ]
             [ else ( let ( [ next-branch 
                              ( choose-branch ( car bits ) cur-branch ) ] )
                       ( cond [ ( 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 "Pass" ) ] ) )

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