diff --git a/ex-2-59.lisp b/ex-2-59.lisp index 203ed5d..04891c5 100644 --- a/ex-2-59.lisp +++ b/ex-2-59.lisp @@ -108,5 +108,7 @@ ((null s1) s2) ((null s2) s1) (t (union-set-tree (union-set-tree (btree-left s1) (btree-right s2)) - (adjoin-set-tree s2 (btree-elt s1)))))) + s (adjoin-set-tree s2 (btree-elt s1)))))) ;; yeah, okay. this looks good enough, didn't test it at all, but whatevs. + + diff --git a/sec-2-3-4-huffman.lisp b/sec-2-3-4-huffman.lisp new file mode 100644 index 0000000..51fd2f3 --- /dev/null +++ b/sec-2-3-4-huffman.lisp @@ -0,0 +1,142 @@ +;; 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)))