Family Day update

Task/Huffman-coding/Factor/huffman-coding.factor

@@ -0,0 +1,132 @@
+USING: kernel sequences combinators accessors assocs math hashtables math.order
+sorting.slots classes formatting prettyprint ;
+
+IN: huffman
+
+! -------------------------------------
+! CLASSES -----------------------------
+! -------------------------------------
+
+TUPLE: huffman-node
+    weight element encoding left right ;
+
+! For nodes
+: <huffman-tnode> ( left right -- huffman )
+    huffman-node new [ left<< ] [ swap >>right ] bi ;
+
+! For leafs
+: <huffman-node> ( element -- huffman )
+    1 swap f f f huffman-node boa ;
+
+
+! --------------------------------------
+! INITIAL HASHTABLE --------------------
+! --------------------------------------
+
+<PRIVATE
+
+! Increment node if it already exists
+! Else make it and add it to the hash-table
+: huffman-gen ( element nodes  -- )
+    2dup at
+    [ [ [ 1 + ] change-weight ] change-at ]
+    [ [ dup <huffman-node> swap ] dip set-at ] if ;
+
+! Curry node-hash.  Then each over the seq
+! to get the weighted values
+: (huffman) ( nodes seq --  nodes )
+    dup [ [ huffman-gen ] curry each ] dip ;
+
+! ---------------------------------------
+! TREE GENERATION -----------------------
+! ---------------------------------------
+
+: (huffman-weight) ( node1 node2 -- weight )
+    [ weight>> ] dup bi* + ;
+
+! Combine two nodes into the children of a parent
+! node which has a weight equal to their collective
+! weight
+: (huffman-combine) ( node1 node2 -- node3 )
+    [ (huffman-weight) ]
+    [ <huffman-tnode> ] 2bi
+    swap >>weight ;
+
+! Generate a tree by combining nodes
+! in the priority queue until we're
+! left with the root node
+: (huffman-tree) ( nodes -- tree )
+    dup rest empty?
+    [ first ] [
+        { { weight>> <=> } } sort-by
+        [ rest rest ] [ first ]
+        [ second ] tri
+        (huffman-combine) prefix
+        (huffman-tree)
+    ] if  ; recursive
+
+! --------------------------------------
+! ENCODING -----------------------------
+! --------------------------------------
+
+: (huffman-leaf?) ( node -- bool )
+    [ left>>  huffman-node instance? ]
+    [ right>> huffman-node instance? ] bi and not ;
+
+: (huffman-leaf) ( leaf bit -- )
+    swap encoding<< ;
+
+DEFER: (huffman-encoding)
+
+! Recursively walk the nodes left and right
+: (huffman-node) ( bit nodes -- )
+    [ 0 suffix ] [ 1 suffix ] bi
+    [ [ left>> ] [ right>> ] bi ] 2dip
+    [ swap ] dip
+    [ (huffman-encoding) ] 2bi@ ;
+
+: (huffman-encoding) ( bit nodes -- )
+    over (huffman-leaf?)
+    [ (huffman-leaf) ]
+    [ (huffman-node) ] if ;
+
+PRIVATE>
+
+! -------------------------------
+! USER WORDS --------------------
+! -------------------------------
+
+: huffman-print ( nodes -- )
+    "Element" "Weight" "Code" "\n%10s\t%10s\t%6s\n" printf
+    { { weight>> >=< } } sort-by
+    [  [ encoding>> ] [ element>> ] [ weight>> ] tri
+       "%8c\t%7d\t\t" printf  pprint "\n" printf ] each ;
+
+: huffman ( sequence -- nodes )
+    H{ } clone (huffman) values
+    [ (huffman-tree) { } (huffman-encoding) ] keep ;
+
+! ---------------------------------
+! USAGE ---------------------------
+! ---------------------------------
+
+! { 1 2 3 4 } huffman huffman-print
+! "this is an example of a huffman tree" huffman huffman-print
+
+! Element   Weight	  Code
+!      	      7		{ 0 0 0 }
+!     a	      4		{ 1 1 1 }
+!     e	      4		{ 1 1 0 }
+!     f	      3		{ 0 0 1 0 }
+!     h	      2		{ 1 0 1 0 }
+!     i	      2		{ 0 1 0 1 }
+!     m	      2		{ 0 1 0 0 }
+!     n	      2		{ 0 1 1 1 }
+!     s	      2		{ 0 1 1 0 }
+!     t	      2		{ 0 0 1 1 }
+!     l	      1		{ 1 0 1 1 1 }
+!     o	      1		{ 1 0 1 1 0 }
+!     p	      1		{ 1 0 0 0 1 }
+!     r	      1		{ 1 0 0 0 0 }
+!     u	      1		{ 1 0 0 1 1 }
+!     x	      1		{ 1 0 0 1 0 }

Task/Huffman-coding/Ol/huffman-coding-1.ol

@@ -0,0 +1,38 @@
+(define phrase "this is an example for huffman encoding")
+
+; prepare initial probabilities table
+(define table (ff->list
+   (fold (lambda (ff x)
+            (put ff x (+ (ff x 0) 1)))
+      {}
+      (string->runes phrase))))
+
+; just sorter...
+(define (resort l)
+   (sort (lambda (x y) (< (cdr x) (cdr y))) l))
+; ...to sort table
+(define table (resort table))
+
+; build huffman tree
+(define tree
+   (let loop ((table table))
+      (if (null? (cdr table))
+         (car table)
+         (loop (resort (cons
+            (cons
+               { 1 (car table) 0 (cadr table)}
+               (+ (cdar table) (cdadr table)))
+            (cddr table)))))))
+
+; huffman codes
+(define codes
+   (map (lambda (i)
+         (call/cc (lambda (return)
+            (let loop ((prefix #null) (tree tree))
+               (if (ff? (car tree))
+                  (begin
+                     (loop (cons 0 prefix) ((car tree) 0))
+                     (loop (cons 1 prefix) ((car tree) 1)))
+                  (if (eq? (car tree) i)
+                     (return (reverse prefix))))))))
+      (map car table)))

Task/Huffman-coding/Ol/huffman-coding-2.ol

@@ -0,0 +1,10 @@
+(print "weights: ---------------------------")
+(for-each (lambda (ch)
+      (print (string (car ch)) ": " (cdr ch)))
+   (reverse table))
+
+(print "codes: -----------------------------")
+(map (lambda (char code)
+      (print (string char) ": " code))
+   (reverse (map car table))
+   (reverse codes))