143 lines
4.2 KiB
Common Lisp
143 lines
4.2 KiB
Common Lisp
;; my code for the Huffman Encoding section
|
|
;; 2.3.4 of SICP.
|
|
;; at this point I've started grouping an entire
|
|
;; section together instead of doing exercises in
|
|
;; separate files, because I need to translate a good chunk
|
|
;; of code into common lisp anyway.
|
|
|
|
;; this automatically defines:
|
|
;; make-leaf
|
|
;; leaf-p
|
|
;; leaf-symbol and leaf-weight
|
|
(defstruct leaf symbol weight)
|
|
|
|
;; I decided to use the name trunk
|
|
;; for non-leaves.
|
|
(defstruct trunk left right symbols weight)
|
|
|
|
(defun symbols (n)
|
|
(if (leaf-p n)
|
|
(list (leaf-symbol n))
|
|
(trunk-symbols n)))
|
|
(defun weight (n)
|
|
(if (leaf-p n)
|
|
(leaf-weight n)
|
|
(trunk-weight n)))
|
|
|
|
(defun trunk-new (left right)
|
|
(make-trunk :left left
|
|
:right right
|
|
:symbols (append (symbols left)
|
|
(symbols right))
|
|
:weight (+ (weight left) (weight right))))
|
|
|
|
(defun choose-branch (bit tree)
|
|
(cond
|
|
((= bit 0) (trunk-left tree))
|
|
((= bit 1) (trunk-right tree))
|
|
(t (error "unknown bit lmao"))))
|
|
(defun decode (bits tree)
|
|
"interesting. I used an iterative style with loop instead.
|
|
funnily enough, this ended up being fairly concise as well.
|
|
usually loop tends to be really dirty."
|
|
(let ((result nil)
|
|
(branch tree))
|
|
(loop for i in bits do
|
|
(setf branch (choose-branch i branch))
|
|
(when (leaf-p branch)
|
|
(push (leaf-symbol branch) result)
|
|
(setf branch tree)))
|
|
(reverse result)))
|
|
|
|
|
|
(defparameter test-coding
|
|
(trunk-new (make-leaf :symbol 'A :weight 10)
|
|
(trunk-new (make-leaf :symbol 'B :weight 6)
|
|
(trunk-new (make-leaf :symbol 'C :weight 0)
|
|
(make-leaf :symbol 'D :weight 0)))))
|
|
|
|
; ex. 2.68
|
|
(defun search-tree (sym tree)
|
|
(cond
|
|
((leaf-p tree)
|
|
nil)
|
|
((member sym (symbols (trunk-left tree)) :test #'eql)
|
|
(cons 0 (search-tree sym (trunk-left tree))))
|
|
((member sym (symbols (trunk-right tree)) :test #'eql)
|
|
(cons 1 (search-tree sym (trunk-right tree))))
|
|
(t (error "what the fuck"))))
|
|
(defun encode-symbol (sym tree)
|
|
(search-tree sym tree))
|
|
|
|
(defun encode (message tree)
|
|
(if (null message)
|
|
nil
|
|
(append
|
|
(encode-symbol (car message) tree)
|
|
(encode (cdr message) tree))))
|
|
; ex 2.69
|
|
;; okay, not being able to copy/paste actually kinda sucks.
|
|
;; I'm just gonna define `define` as a macro, then copy.
|
|
(defmacro define (n &body body)
|
|
(if (listp n)
|
|
`(defun ,(first n) ,(rest n) ,@body)
|
|
`(defparameter ,n ,@body)))
|
|
|
|
(defun weight (x)
|
|
(if (trunk-p x)
|
|
(trunk-weight x)
|
|
(leaf-weight x)))
|
|
(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))))))
|
|
|
|
(defun make-leaf-set (pairs)
|
|
(let ((res nil))
|
|
(loop for i in pairs do
|
|
(setf res (adjoin-set (make-leaf :symbol (car i) :weight (cadr i))
|
|
res)))
|
|
res))
|
|
;; I already got bored of copy-pasting. The code just looks out of place
|
|
;; when it's written with a lot of scheme-isms
|
|
(defun successive-merge (set)
|
|
(loop while (< 1 (length set)) do
|
|
(setf set
|
|
(adjoin-set (apply #'trunk-new (reverse (list (pop set) (pop set))))
|
|
set)))
|
|
(car set))
|
|
(defun successive-merge-functional (set)
|
|
"This is one area where I like the functional solution more than the
|
|
imperative one. Seriously."
|
|
(cond
|
|
((>= 1 (length set)) (car set))
|
|
(t (successive-merge-functional
|
|
(print (adjoin-set (trunk-new (second set) (first set))
|
|
(cddr set)))))))
|
|
; ex 2.70
|
|
(define (generate-huffman-tree pairs)
|
|
(successive-merge-functional (make-leaf-set pairs)))
|
|
|
|
; ex 2.71
|
|
(defparameter *song-tree* (generate-huffman-tree
|
|
'((A 2) (GET 2) (SHA 3) (WAH 1) (BOOM 1) (JOB 2) (NA 16) (YIP 9))))
|
|
|
|
(defparameter *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))
|
|
|
|
;; the song takes 84 bits to encode.
|
|
;; fixed length code would require 8 unique symbols, so 3 bits per element -
|
|
;; which is 108 bits. Pretty good, we saved roughly ~20% with this
|
|
;; though the efficiency does rely on our analysis of the average message.
|
|
;; we could just as easily lose efficiency if we measure wrong.
|
|
|
|
(defclass mytest1 ()
|
|
((a :accessor slota)))
|
|
(defclass mytest2 ()
|
|
((a :accessor slota)))
|