1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
#!/usr/bin/env fsharpi

(* This construct is for ML compatibility. The syntax '(typ,...,typ) ident'
   is not used in F# code. Consider using 'ident<typ,...,typ>' instead. *)
#nowarn "62"

[<RequireQualifiedAccess>]
module Huffman =

  type tree =
    | Leaf of frecuency * char
    | Node of frecuency * tree * tree
  and frecuency = int
  
  let frecuency : tree -> frecuency * tree = function
    | Leaf (f,_)   as t -> f,t
    | Node (f,_,_) as t -> f,t
  
  let encoding : string -> tree =
    fun text ->
      let rec aux : tree Set -> tree =
        fun acc0 ->
          if Set.isEmpty acc0 then
            failwith "Set is empty"
          else if Set.count acc0 = 1 then
            Set.minElement acc0
          else
            let (f1,x) = acc0 |> Set.minElement |> frecuency
            let (acc1) = acc0 |> Set.remove x
            let (f2,y) = acc1 |> Set.minElement |> frecuency
            let (acc2) = acc1 |> Set.remove y
            
            acc2 |> Set.add (Node (f1+f2,x,y))  |> aux
      text
      |> Seq.groupBy id
      |> Seq.map (fun (x,xs) -> xs |> Seq.length,x)
      |> Set.ofSeq
      |> Set.map Leaf
      |> aux
  
  let tree2charmap : tree -> (char, int list) Map =
    fun t ->
      let rec aux acc : tree -> (char, int list) Map = function
        | Leaf (_,c)   -> Map.empty |> Map.add c (List.rev acc)
        | Node (_,l,r) ->
          let ml = aux (0::acc) l
          let mr = aux (1::acc) r
          ml |> Map.fold(fun a k v -> a |> Map.add k v) mr
      aux [] t
  
  let table : (char, int list) Map -> string =
    fun map ->
      map
      |> Map.toList
      |> List.map (fun (k,v) -> sprintf "'%c': %A\n" k v)
      |> List.fold (fun a x -> a + x) ""
  
  let tree2codemap : tree -> (int list, char) Map =
    fun t ->
      let rec aux acc : tree -> (int list, char) Map = function
        | Leaf (_,c)   -> Map.empty |> Map.add (List.rev acc) c
        | Node (_,l,r) ->
          let ml = aux (0::acc) l
          let mr = aux (1::acc) r
          ml |> Map.fold(fun a k v -> a |> Map.add k v) mr
      aux [] t
  
  let compress : (char, int list) Map -> string -> string =
    fun map text ->
      text
      |> Seq.map (fun c -> map |> Map.find c)
      |> Seq.collect id
      |> Seq.fold (fun a x -> a + (string x)) ""
  
  let decompress : (int list, char) Map -> string -> string =
    fun map code ->
      let rec aux acc code = function
        | [     ] -> acc |> List.rev
        | x :: xs ->
          let code'       = code @ [x]
          let copt        = map |> Map.tryFind code'
          let acc',code'' =
            match copt with
              | Some c -> c::acc, [   ]
              | None   ->    acc, code'
          aux acc' code'' xs
      let xs = code |> Seq.map (string >> int) |> Seq.toList
      aux [] [] xs |> List.fold (fun a x -> a + (string x)) ""

module Huffman = begin
  type tree =
    | Leaf of frecuency * char
    | Node of frecuency * tree * tree
  and frecuency = int
  val frecuency : _arg1:tree -> frecuency * tree
  val encoding : text:string -> tree
  val tree2charmap : t:tree -> Map<char,int list>
  val table : map:Map<char,int list> -> string
  val tree2codemap : t:tree -> Map<int list,char>
  val compress : map:Map<char,int list> -> text:string -> string
  val decompress : map:Map<int list,char> -> code:string -> string
end

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
let text = """this is an example of a huffman tree"""

let encoding =
  text
  |> Huffman.encoding

let tree2charmap =
  encoding
  |> Huffman.tree2charmap

let tree2codemap =
  encoding
  |> Huffman.tree2codemap

let table =
  tree2charmap
  |> Huffman.table

let compressed =
  text
  |> Huffman.compress tree2charmap

let decompressed =
  compressed
  |> Huffman.decompress tree2codemap

printfn "* Text:\n«%s»\n"         text
printfn "* Table:\n%s"            table
printfn "* Compressed:\n%s\n"     compressed
printfn "* Decompressed:\n«%s»\n" decompressed

mon@razerRamon:~/tmp$ ./HuffmanCoding.fsx

* Text:
«this is an example of a huffman tree»

* Table:
' ': [1; 1; 1]
'a': [0; 0; 1]
'e': [1; 1; 0]
'f': [0; 0; 0]
'h': [1; 0; 1; 1; 0]
'i': [1; 0; 1; 1; 1]
'l': [1; 0; 0; 0; 0]
'm': [0; 1; 0; 0]
'n': [0; 1; 0; 1]
'o': [1; 0; 0; 0; 1]
'p': [1; 0; 0; 1; 0]
'r': [1; 0; 0; 1; 1]
's': [0; 1; 1; 0]
't': [0; 1; 1; 1]
'u': [1; 0; 1; 0; 0]
'x': [1; 0; 1; 0; 1]

* Compressed:
0111101101011101101111011101101110010101111110101010010100100101000011011110001000111001111101101010000000001000010101111011110011110110

* Decompressed:
«this is an example of a huffman tree»