June 2018 Update

Task/Huffman-coding/Red/huffman-coding.red

@@ -0,0 +1,91 @@
+Red [file: %huffy.red]
+
+;; message to encode:
+msg: "this is an example for huffman encoding"
+
+;;map to collect leave knots  per uniq character of message
+m: make map! []	
+
+knot: make object! [
+	left: right: none    ;; pointer to left/right sibling
+	code: none        ;; first holds char for debugging, later binary code
+	count: depth: 1     ;;occurence of character - length of branch
+]
+
+;;-----------------------------------------
+set-code: func  ["recursive function to generate binary code sequence"
+			wknot
+			wcode [string!]] [
+;;-----------------------------------------
+	either wknot/left = none [
+		wknot/code:  wcode
+	] [
+		set-code wknot/left rejoin [wcode "1"]
+		set-code wknot/right rejoin [wcode "0"]
+	]
+]	;;-- end func
+
+;-------------------------------
+merge-2knots: func ["function to merge 2 knots into 1 new"
+	t [block!]][
+;-------------------------------
+	nknot: copy knot      ;; create new knot
+	nknot/count:  t/1/count + t/2/count
+	nknot/right: t/1
+	nknot/left: t/2
+	nknot/depth: t/1/depth + 1
+	tab: remove/part t 2	;; delete first 2 knots
+	insert t nknot  ;; insert new generated knot
+]	;;-- end func
+
+;; count occurence of characters, save in map: m
+foreach chr msg [
+	either k:  select/case m chr [
+			k/count: k/count + 1	
+	][
+		put/case m chr nknot: copy knot
+		nknot/code: chr
+	]
+]
+
+;; create sortable block (=tab) for use as prio queue
+foreach k  keys-of m [	append tab: []  :m/:k ]
+
+;; build tree
+while [ 1 <  length? tab][
+	sort/compare tab function [a b] [
+					a/count  <  b/count
+		  or (   a/count = b/count and ( a/depth > b/depth ) )
+	]
+	merge-2knots tab	;; merge 2 knots with lowest count / max depth
+]
+
+set-code tab/1 ""		;; generate binary codes, save at leave knot
+
+;;  display codes
+foreach k sort keys-of m [
+	print [k " = " m/:k/code]	
+	append codes: "" m/:k/code	
+]
+
+;; encode orig message string
+foreach chr msg [
+	k: select/case m chr
+	 append msg-new: ""   k/code
+]
+
+print [ "length of encoded msg "  length? msg-new]
+print [ "length of (binary) codes "  length? codes ]
+
+print ["orig. message: "  msg newline "encoded message: " "^/" msg-new]
+prin "decoded: "
+
+;; decode message (destructive! ):
+while [ not empty? msg-new ][
+  foreach [k v] body-of   m [
+    if  t: find/match msg-new v/code   [
+      prin k
+      msg-new: t
+    ]
+  ]
+ ]