5d5018e0b82b

--- a/package.lisp	Mon Aug 22 20:39:20 2016 +0000
+++ b/package.lisp	Tue Aug 23 00:22:20 2016 +0000
@@ -113,3 +113,15 @@
     #:sand.utils)
   (:export
     ))
+
+(defpackage #:sand.huffman-trees
+  (:use
+    #:cl
+    #:cl-arrows
+    #:losh
+    #:iterate
+    #:sand.graphviz
+    #:sand.quickutils
+    #:sand.utils)
+  (:export
+    ))

--- a/sand.asd	Mon Aug 22 20:39:20 2016 +0000
+++ b/sand.asd	Tue Aug 23 00:22:20 2016 +0000
@@ -40,6 +40,7 @@
                  (:file "markov")
                  (:file "dijkstra-maps")
                  (:file "binary-decision-diagrams")
+                 (:file "huffman-trees")
                  (:module "terrain"
                   :serial t
                   :components ((:file "diamond-square")))

--- a/src/binary-decision-diagrams.lisp	Mon Aug 22 20:39:20 2016 +0000
+++ b/src/binary-decision-diagrams.lisp	Tue Aug 23 00:22:20 2016 +0000
@@ -91,6 +91,6 @@
               (2 (3 0 1) 1))))
 
 
-(evaluate-bdd *maj* 1 0 1)
+; (evaluate-bdd *maj* 1 0 1)
 
-(draw-bdd *maj* t)
+; (draw-bdd *maj* t)

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/huffman-trees.lisp	Tue Aug 23 00:22:20 2016 +0000
@@ -0,0 +1,79 @@
+(in-package #:sand.huffman-trees)
+
+(defstruct huffman-tree)
+
+(defstruct (leaf (:include huffman-tree)
+                 (:constructor make-leaf (symbol weight)))
+  (symbol (required-argument))
+  (weight (required-argument) :type real))
+
+(defstruct (node (:include huffman-tree)
+                 (:constructor %make-node))
+  (left (required-argument) :type huffman-tree)
+  (right (required-argument) :type huffman-tree)
+  (symbols (required-argument) :type list)
+  (weight (required-argument) :type real))
+
+
+(defun huffman-tree-symbols (tree)
+  (etypecase tree
+    (leaf (list (leaf-symbol tree)))
+    (node (node-symbols tree))))
+
+(defun huffman-tree-weight (tree)
+  (etypecase tree
+    (leaf (leaf-weight tree))
+    (node (node-weight tree))))
+
+
+(defun make-node (left right)
+  (%make-node :left left
+              :right right
+              :weight (+ (huffman-tree-weight left)
+                         (huffman-tree-weight right))
+              :symbols (append (huffman-tree-symbols left)
+                               (huffman-tree-symbols right))))
+
+
+(defun decode (bits tree)
+  (flet ((choose-branch (bit tree)
+           (ecase bit
+             (0 (node-left tree))
+             (1 (node-right tree)))))
+    (recursively ((bits bits)
+                  (current tree))
+      (when bits
+        (let ((next-branch (choose-branch (first bits) current)))
+          (etypecase next-branch
+            (leaf (cons (leaf-symbol next-branch)
+                        (recur (rest bits) tree)))
+            (node (recur (rest bits) next-branch))))))))
+
+
+(defun adjoin-set (tree set)
+  (cond
+    ((null set)
+     (list tree))
+    ((< (huffman-tree-weight tree) (huffman-tree-weight (first set)))
+     (cons tree set))
+    (t
+     (cons (first set)
+           (adjoin-set tree (rest set))))))
+
+(defun make-leaf-set (pairs)
+  (if (null pairs)
+    '()
+    (destructuring-bind (symbol weight)
+        (first pairs)
+      (adjoin-set (make-leaf symbol weight)
+                  (make-leaf-set (rest pairs))))))
+
+
+(defparameter *sample-tree*
+  (make-node (make-leaf 'a 4)
+             (make-node (make-leaf 'b 2)
+                        (make-node (make-leaf 'D 1)
+                                   (make-leaf 'C 1)))))
+
+
+; (decode '(0 1 1 0 0 1 0 1 0 1 1 1 0) *sample-tree*)

--- a/vendor/make-quickutils.lisp	Mon Aug 22 20:39:20 2016 +0000
+++ b/vendor/make-quickutils.lisp	Tue Aug 23 00:22:20 2016 +0000
@@ -13,6 +13,7 @@
                :riffle
                :tree-collect
                :ensure-gethash
+               :required-argument
                ; :switch
                ; :while
                ; :ensure-boolean

--- a/vendor/quickutils.lisp	Mon Aug 22 20:39:20 2016 +0000
+++ b/vendor/quickutils.lisp	Tue Aug 23 00:22:20 2016 +0000
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY :COMPOSE :CURRY :RCURRY :N-GRAMS :DEFINE-CONSTANT :RIFFLE :TREE-COLLECT :ENSURE-GETHASH) :ensure-package T :package "SAND.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY :COMPOSE :CURRY :RCURRY :N-GRAMS :DEFINE-CONSTANT :RIFFLE :TREE-COLLECT :ENSURE-GETHASH :REQUIRED-ARGUMENT) :ensure-package T :package "SAND.QUICKUTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "SAND.QUICKUTILS")
@@ -18,7 +18,7 @@
                                          :ENSURE-FUNCTION :COMPOSE :CURRY
                                          :RCURRY :TAKE :N-GRAMS
                                          :DEFINE-CONSTANT :RIFFLE :TREE-COLLECT
-                                         :ENSURE-GETHASH))))
+                                         :ENSURE-GETHASH :REQUIRED-ARGUMENT))))
 
   (deftype string-designator ()
     "A string designator type. A string designator is either a string, a symbol,
@@ -279,8 +279,16 @@
            (values value ok)
            (values (setf (gethash ,key ,hash-table) ,default) nil))))
   
+
+  (defun required-argument (&optional name)
+    "Signals an error for a missing argument of `name`. Intended for
+use as an initialization form for structure and class-slots, and
+a default value for required keyword arguments."
+    (error "Required argument ~@[~S ~]missing." name))
+  
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (export '(with-gensyms with-unique-names once-only compose curry rcurry
-            n-grams define-constant riffle tree-collect ensure-gethash)))
+            n-grams define-constant riffle tree-collect ensure-gethash
+            required-argument)))
 
 ;;;; END OF quickutils.lisp ;;;;