More recent additions, some exercises and huffman encoding chapter

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.
+
+

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