# HG changeset patch # User Steve Losh # Date 1471911740 0 # Node ID 5d5018e0b82bffc2f9b14ade8adbcff8bc66f1d2 # Parent 1d59a2656cfc0ad01d7f62cf835c3ce7f41c14a5 Start the SICP Huffman trees diff -r 1d59a2656cfc -r 5d5018e0b82b package.lisp --- 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 + )) diff -r 1d59a2656cfc -r 5d5018e0b82b sand.asd --- 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"))) diff -r 1d59a2656cfc -r 5d5018e0b82b src/binary-decision-diagrams.lisp --- 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) diff -r 1d59a2656cfc -r 5d5018e0b82b src/huffman-trees.lisp --- /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*) diff -r 1d59a2656cfc -r 5d5018e0b82b vendor/make-quickutils.lisp --- 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 diff -r 1d59a2656cfc -r 5d5018e0b82b vendor/quickutils.lisp --- 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 ;;;;