type 'a tree =
Leaf of 'a
| Node of 'a tree * 'a tree
;;
let rec sub_tree = fun
tree [] -> tree
| (Leaf _) _ -> invalid_arg "path"
| (Node(left, right)) (hd :: tl) -> sub_tree (if hd then right else left) tl
;;
let rec read = fun
(Leaf x) w -> (x, w)
| (Node _) [] -> invalid_arg "read"
| (Node(left, right)) (hd :: tl) -> read (if hd then right else left) tl
;;
let rec decode tree = function
[] -> ""
| w -> let (c, w') = read tree w in (string_of_char c) ^ (decode tree w')
;;
let rec insert x = function
[] -> [x]
| hd :: tl -> if x < hd then x :: hd :: tl else hd :: insert x tl
;;
let rec merge = function
[] -> invalid_arg "merge"
| [n, tree] -> tree
| (n1, tree1) :: (n2, tree2) :: tl -> merge (insert (n1+n2, Node(tree1, tree2)) tl)
;;
let count str =
let rec aux e = function
[] -> [e, 1]
| (k, v) :: tl when k=e -> (k, v+1) :: tl
| hd :: tl -> hd :: aux e tl
in
let acc = ref []
in
for i = 0 to string_length str -1 do
acc := aux str.[i] !acc
done;
!acc
;;
let rec huffman str =
merge (map (function k, v -> v, Leaf k) (sort__sort (prefix <) (count str)))
;;
let rec add b = function
[] -> []
| (c, w) :: tl -> (c, b ::w) :: (add b tl)
;;
let rec extract = function
Leaf c -> [(c, [])]
| Node(left, right) -> (add false (extract left)) @ (add true (extract right))
;;
let code tree str =
let table = extract tree in
let result = ref [] in
for i = string_length str - 1 downto 0 do
result := (assoc str.[i] table) @ !result;
done;
!result
;;
let tree = huffman "abcdefghijklmnopqrstvuwxyz ";;
let encoded = code tree "wikipedia is a good encyclopedia";;
decode tree encoded;;
let int_of_bool = function
false -> 0
| true -> 1
;;
let prefix << = prefix lsl;;
1 << 4;;
(*
let encode = function
[] -> []
| [a] -> [(int_of_bool a) lsl 8]
;;
*)