Huffman Coding

Whatever is on your mind, whether Lisp related or not.

Huffman Coding

Postby Pixel_Outlaw » Sun Nov 03, 2013 1:02 am

Well I've made a little Huffman encoder thanks to the help I've received here with classes and the notion of them pointing to each other.


Huffman coding is a cool way to compress data by using binary search trees.
It lets you use fractional bytes for characters instead of whole bytes.

My program simply outputs the binary string for each character.
I believe it to be accurate from some simple testing...
You could probably make a simple GUI interface for saving and loading strings as bytes.
This was just for fun. :)

Code: Select all
(defclass node ()
  ((child-0
    :accessor child-a
    :initform nil
    :initarg :child-a)
   (child-1
    :accessor child-b
    :initform nil
    :initarg :child-b)
   (parent
    :accessor parent
    :initform nil
    :initarg :parent)
   (value
    :accessor value
    :initform nil
    :initarg :value)
   (frequency
    :accessor frequency
    :initform nil
    :initarg :frequency)))

(defun compare-nodes (node-a node-b)
  "Sorts the nodes from least appearing to most freqent"
  (< (slot-value node-a 'frequency)
     (slot-value node-b 'frequency)))

(defun get-two-lowest-nodes (list)
  "Return the two least occuring Nodes in a list"
  (let (( a (sort list #'compare-nodes)))
    (list (car a) (cadr a))))

(defun make-connecting-parent(node-a node-b)
  "Create parent node from children's attributes and attach children"
  (let ((child-0 nil)
   (child-1 nil)
   (f (+ (slot-value node-a 'frequency) (slot-value node-b 'frequency)))
   (new-parent (make-instance 'node)))

    ;; Ensure branch 0 is the lowest of the two
    (when (< (slot-value node-a 'frequency) (slot-value node-b 'frequency))
      (setf child-0 node-a)
      (setf child-1 node-b))
    (when (>= (slot-value node-a 'frequency) (slot-value node-b 'frequency))
      (setf child-0 node-b)
      (setf child-1 node-a))

    ;; Set up the new parent node
    (setf (slot-value new-parent 'child-0) child-0)
    (setf (slot-value new-parent 'child-1) child-1)
    (setf (slot-value new-parent 'frequency) f)
   
    ;; Connect the child nodes to the parent
    (setf (slot-value node-a 'parent) new-parent)
    (setf (slot-value node-b 'parent) new-parent)

    ;; Return our little princess
    (return-from make-connecting-parent new-parent)))

(defun merge-2-nodes-in-list(nodes node-a node-b)
  "Returns a new list of nodes with the lowest appearing merged into one"
  (remove node-b
     (remove node-a
        (cons (make-connecting-parent node-a node-b) nodes))))

(defun find-leaf-values (node &optional path-str)
  "This is a naughty function, it is dangerous because it is recursive"
  (when (and (equal (slot-value node 'child-0) nil)
        (equal (slot-value node 'child-1) nil))
    (format t "Node ~a Frequency: ~a Binary Path ~a~%"
       (slot-value node 'value)
       (slot-value node 'frequency)
       path-str)
    (return-from find-leaf-values))
 
  (if (slot-value node 'child-0)
    (find-leaf-values (slot-value node 'child-0)
            (concatenate 'string path-str "0")))
  (if (slot-value node 'child-1)
    (find-leaf-values (slot-value node 'child-1)
            (concatenate 'string path-str "1"))))
   
(defparameter *nodes-list* nil)

(defparameter *words*
  "Farewell and adieu to you, Spanish Ladies
Farewell and adieu to you, ladies of Spain
For we've received orders for to sail for old England
But we hope in a short time to see you again")

(setf *words* (coerce *words* 'list))

(setf *nodes-list*
      (sort (loop for i in (remove-duplicates *words*)
          collect (make-instance 'node :value i
                  :frequency (count i *words*)))
       #'compare-nodes))

;;; TEST
(dotimes (i (- (length *nodes-list*) 1))
  (setf *nodes-list* (sort (merge-2-nodes-in-list *nodes-list*
                   (car *nodes-list*)
                   (cadr *nodes-list*))
            #'compare-nodes)))

(find-leaf-values (car *nodes-list*))

Pixel_Outlaw
 
Posts: 38
Joined: Mon Aug 26, 2013 9:24 pm

Return to The Lounge

Who is online

Users browsing this forum: No registered users and 0 guests

cron