Code : Compression de texte

Run-Length Encoding¶

In [1]:

let rle_code s =
    let ind = ref s.[0] in
    let nb = ref 1 in
    let l = ref [] in
    for i = 1 to String.length s - 1 do
        if !ind <> s.[i] then (
            l := (!ind, !nb)::!l;
            ind := s.[i];
            nb := 1
        )
        else incr nb
    done;
    List.rev ((!ind, !nb)::!l)

let rle_code s = let ind = ref s.[0] in let nb = ref 1 in let l = ref [] in for i = 1 to String.length s - 1 do if !ind <> s.[i] then ( l := (!ind, !nb)::!l; ind := s.[i]; nb := 1 ) else incr nb done; List.rev ((!ind, !nb)::!l)

Out[1]:

val rle_code : string -> (char * int) list = <fun>

In [2]:

let rec rle_decode = function
    | [] -> ""
    | (c, n)::q -> (String.make n c)^rle_decode q

let rec rle_decode = function | [] -> "" | (c, n)::q -> (String.make n c)^rle_decode q

Out[2]:

val rle_decode : (char * int) list -> string = <fun>

Codage de Huffman¶

Construction de l'arbre de Huffman¶

In [3]:

let get_frequences text =
    let freq = Array.make 256 0 in
    for i = 0 to String.length text - 1 do
        freq.(Char.code text.[i]) <- freq.(Char.code text.[i]) + 1
    done;
    freq

let get_frequences text = let freq = Array.make 256 0 in for i = 0 to String.length text - 1 do freq.(Char.code text.[i]) <- freq.(Char.code text.[i]) + 1 done; freq

Out[3]:

val get_frequences : string -> int array = <fun>

In [4]:

type 'a tree = F of 'a | N of 'a tree * 'a tree

type 'a tree = F of 'a | N of 'a tree * 'a tree

Out[4]:

type 'a tree = F of 'a | N of 'a tree * 'a tree

On va utiliser la file de priorité suivante :

In [5]:

module Q = struct
  type 'a t = E | N of 'a * 'a t * 'a t
  let empty () = ref E
  let is_empty t = !t = E
  let add x t =
    let rec aux = function
      | E -> N(x, E, E)
      | N(r, g, d) -> if x < r then N(r, aux g, d) else N(r, g, aux d) in
    t := aux !t
  let take_min t = 
    let rec aux = function
      | E -> failwith "take_min"
      | N(r, g, d) -> if g = E then r, d 
                      else 
                        let m, g = aux g in
                        m, N(r, g, d) in
    let m, t_ = aux !t in 
    t := t_;
    m
end

module Q = struct type 'a t = E | N of 'a * 'a t * 'a t let empty () = ref E let is_empty t = !t = E let add x t = let rec aux = function | E -> N(x, E, E) | N(r, g, d) -> if x < r then N(r, aux g, d) else N(r, g, aux d) in t := aux !t let take_min t = let rec aux = function | E -> failwith "take_min" | N(r, g, d) -> if g = E then r, d else let m, g = aux g in m, N(r, g, d) in let m, t_ = aux !t in t := t_; m end

Out[5]:

module Q :
  sig
    type 'a t = E | N of 'a * 'a t * 'a t
    val empty : unit -> 'a t ref
    val is_empty : 'a t ref -> bool
    val add : 'a -> 'a t ref -> unit
    val take_min : 'a t ref -> 'a
  end

In [6]:

let make_huffman_tree freq =
    let q = Q.empty () in
    let n = ref 0 in
    for i = 0 to 255 do 
        if freq.(i) > 0 then (
            incr n;
            Q.add (freq.(i), F(Char.chr i)) q
        )
    done;
    for _ = 0 to !n - 2 do
        let f1, t1 = Q.take_min q in
        let f2, t2 = Q.take_min q in
        Q.add (f1 + f2, N(t1, t2)) q
    done;
    snd (Q.take_min q)

let make_huffman_tree freq = let q = Q.empty () in let n = ref 0 in for i = 0 to 255 do if freq.(i) > 0 then ( incr n; Q.add (freq.(i), F(Char.chr i)) q ) done; for _ = 0 to !n - 2 do let f1, t1 = Q.take_min q in let f2, t2 = Q.take_min q in Q.add (f1 + f2, N(t1, t2)) q done; snd (Q.take_min q)

Out[6]:

val make_huffman_tree : int array -> char tree = <fun>

In [7]:

let make_table t =
    let codes = Array.make 256 [] in
    let rec aux path = function
        | F(c) -> codes.(Char.code c) <- List.rev path
        | N(g, d) -> aux (0::path) g; aux (1::path) d in
    aux [] t;
    codes

let make_table t = let codes = Array.make 256 [] in let rec aux path = function | F(c) -> codes.(Char.code c) <- List.rev path | N(g, d) -> aux (0::path) g; aux (1::path) d in aux [] t; codes

Out[7]:

val make_table : char tree -> int list array = <fun>

Compression¶

In [8]:

let compress_huffman text = (* renvoyé le texte codé et l'arbre de Huffman *)
    let freq = get_frequences text in
    let t = make_huffman_tree freq in
    let table = make_table t in
    let rec aux i = 
        if i = String.length text then []
        else table.(Char.code text.[i]) @ aux (i + 1) in
    aux 0, t

let compress_huffman text = (* renvoyé le texte codé et l'arbre de Huffman *) let freq = get_frequences text in let t = make_huffman_tree freq in let table = make_table t in let rec aux i = if i = String.length text then [] else table.(Char.code text.[i]) @ aux (i + 1) in aux 0, t

Out[8]:

val compress_huffman : string -> int list * char tree = <fun>

In [9]:

let text = "Un algorithme est une suite finie et non ambiguë d'instructions et d'opérations permettant de résoudre une classe de problèmes. Le mot algorithme vient d'Al-Khwârizmî (en arabe : الخوارزمي)2, nom d'un mathématicien persan du IXe siècle. Le domaine qui étudie les algorithmes est appelé l'algorithmique. On retrouve aujourd'hui des algorithmes dans de nombreuses applications telles que le fonctionnement des ordinateurs3, la cryptographie, le routage d'informations, la planification et l'utilisation optimale des ressources, le traitement d'images, le traitement de textes, la bio-informatique, etc. ";;
let coded_text, t = compress_huffman text;;

let text = "Un algorithme est une suite finie et non ambiguë d'instructions et d'opérations permettant de résoudre une classe de problèmes. Le mot algorithme vient d'Al-Khwârizmî (en arabe : الخوارزمي)2, nom d'un mathématicien persan du IXe siècle. Le domaine qui étudie les algorithmes est appelé l'algorithmique. On retrouve aujourd'hui des algorithmes dans de nombreuses applications telles que le fonctionnement des ordinateurs3, la cryptographie, le routage d'informations, la planification et l'utilisation optimale des ressources, le traitement d'images, le traitement de textes, la bio-informatique, etc. ";; let coded_text, t = compress_huffman text;;

Out[9]:

val text : string =
  "Un algorithme est une suite finie et non ambiguë d'instructions et d'opérations permettant de résoudre une classe de problèmes. Le mot algorithme vient d'Al-Khwârizmî (en arabe : الخوارزمي)2, nom d'un mathématicien persan du IXe siècle. Le domaine qui étudie les algorithmes est ap"... (* string length 620; truncated *)

Out[9]:

val coded_text : int list =
  [0; 0; 1; 0; 1; 1; 0; 0; 1; 0; 0; 1; 1; 1; 0; 0; 0; 1; 1; 0; 1; 1; 1; 0; 1;
   0; 1; 1; 1; 1; 0; 0; 0; 0; 0; 1; 1; 1; 1; 1; 1; 0; 1; 1; 1; 1; 0; 1; 0; 1;
   1; 1; 1; 1; 1; 1; 0; 0; 1; 0; 1; 0; 1; 0; 0; 0; 1; 0; 0; 0; 0; 1; 1; 1; 0;
   1; 1; 0; 0; 1; 1; 1; 0; 0; 0; 0; 1; 1; 0; 1; 0; 1; 0; 0; 0; 0; 0; 1; 1; 1;
   1; 0; 0; 1; 0; 1; 1; 1; 1; 0; 1; 0; 1; 0; 1; 0; 0; 1; 1; 0; 0; 0; 0; 1; 1;
   0; 1; 1; 0; 0; 1; 1; 1; 0; 1; 1; 0; 1; 0; 1; 0; 0; 0; 1; 0; 1; 1; 0; 1; 1;
   0; 0; 0; 0; 1; 1; 0; 0; 0; 0; 0; 0; 1; 1; 1; 0; 0; 0; 1; 1; 0; 1; 1; 0; 0;
   1; 1; 1; 0; 0; 0; 0; 0; 1; 0; 1; 1; 0; 1; 1; 1; 1; 0; 1; 1; 1; 0; 0; 1; 0;
   1; 0; 1; 1; 0; 1; 1; 1; 0; 0; 1; 0; 1; 1; 0; 0; 1; 0; 1; 0; 0; 0; 1; 1; 1;
   0; 1; 1; 0; 1; 1; 0; 0; 1; 1; 0; 0; 0; 1; 1; 1; 0; 1; 1; 1; 1; 1; 1; 1; 1;
   1; 0; 0; 1; 0; 1; 0; 1; 0; 1; 1; 0; 1; 1; 0; 1; 1; 0; 0; 0; 0; 0; 0; 1; 1;
   0; 0; 0; 1; 1; 0; 0; 0; 1; 0; 1; 1; 0; 1; 1; 0; 0; 1; 0; 1; 0; 0; 0; 1;
   ...]
val t : char tree =
  N
   (N
     (N (N (F 'o', F 's'),
       N
        (N
          (N (N (F '\217', N (F '-', F 'L')),
            N (N (F 'v', F '\167'), N (F '\168', F '\174'))),
          N
           (N (N (N (F '(', F ')'), N (F '2', F '3')),
             N (N (F ':', F 'A'), N (F 'I', F 'K'))),
           N (N (N (F 'O', F 'U'), N (F 'X', F 'j')),
            N (N (F 'w', F 'x'), N (F 'y', F 'z'))))),
        F 'n')),
     N (F 'e',
      N (F 'a',
       N
        (N
          (N (N (N (F '\132', F '\133'), N (F '\136', F '\138')),
            N (N (F '\162', F '\171'), N (F '\177', F '\178'))),
          F '\''),
        N (F 'g', F 'h'))))),
   N (N (F ' ', N (N (F 'd', N (F 'c', F '\195')), F 'i')),
    N (N (N (N (N (F 'b', F 'f'), N (F '\169', F '\216')), F 'm'), F 't'),
     N (N (F 'u', F 'l'), N (N (F 'p', N (F ',', N (F '.', F 'q'))), F 'r')))))

In [10]:

(List.length coded_text) / 8 (* nombre d'octets du texte compressé *)

(List.length coded_text) / 8 (* nombre d'octets du texte compressé *)

Out[10]:

- : int = 358

In [11]:

String.length "Un algorithme est une suite finie et non ambiguë d'instructions et d'opérations permettant de résoudre une classe de problèmes. Le mot algorithme vient d'Al-Khwârizmî (en arabe : الخوارزمي)2, nom d'un mathématicien persan du IXe siècle. Le domaine qui étudie les algorithmes est appelé l'algorithmique. On retrouve aujourd'hui des algorithmes dans de nombreuses applications telles que le fonctionnement des ordinateurs3, la cryptographie, le routage d'informations, la planification et l'utilisation optimale des ressources, le traitement d'images, le traitement de textes, la bio-informatique, etc. "

String.length "Un algorithme est une suite finie et non ambiguë d'instructions et d'opérations permettant de résoudre une classe de problèmes. Le mot algorithme vient d'Al-Khwârizmî (en arabe : الخوارزمي)2, nom d'un mathématicien persan du IXe siècle. Le domaine qui étudie les algorithmes est appelé l'algorithmique. On retrouve aujourd'hui des algorithmes dans de nombreuses applications telles que le fonctionnement des ordinateurs3, la cryptographie, le routage d'informations, la planification et l'utilisation optimale des ressources, le traitement d'images, le traitement de textes, la bio-informatique, etc. "

Out[11]:

- : int = 620

On est passé à une taille de 620 octets à 358, soit un gain de $\approx 42$% :

In [12]:

1. -. 358./.620.

1. -. 358./.620.

Out[12]:

- : float = 0.422580645161290347

Décompression¶

In [13]:

let rec decode_huffman t code =
    let rec read_char t l = match t, l with
        | F(c), _ -> c, l
        | N(g, d), 0::q -> read_char g q
        | N(g, d), 1::q -> read_char d q
        | _ -> failwith "codage incorrect" in
    if code = [] then ""
    else let c, l = read_char t code in
    (String.make 1 c)^decode_huffman t l

let rec decode_huffman t code = let rec read_char t l = match t, l with | F(c), _ -> c, l | N(g, d), 0::q -> read_char g q | N(g, d), 1::q -> read_char d q | _ -> failwith "codage incorrect" in if code = [] then "" else let c, l = read_char t code in (String.make 1 c)^decode_huffman t l

Out[13]:

val decode_huffman : char tree -> int list -> string = <fun>

In [14]:

decode_huffman t coded_text

decode_huffman t coded_text

Out[14]:

- : string =
"Un algorithme est une suite finie et non ambiguë d'instructions et d'opérations permettant de résoudre une classe de problèmes. Le mot algorithme vient d'Al-Khwârizmî (en arabe : الخوارزمي)2, nom d'un mathématicien persan du IXe siècle. Le domaine qui étudie les algorithmes est ap"... (* string length 620; truncated *)

Sérialisation¶

Pour pouvoir décompresser, il faut aussi stocker l'arbre de Huffman dans un fichier, en le sérialisant (transformation en chaîne de caractères) :

In [15]:

let rec serialize_tree = function
| F c -> ['*'; c]
| N (g, d) -> '#'::(serialize_tree g)@serialize_tree d

let rec serialize_tree = function | F c -> ['*'; c] | N (g, d) -> '#'::(serialize_tree g)@serialize_tree d

Out[15]:

val serialize_tree : char tree -> char list = <fun>

In [16]:

let t_serial = serialize_tree t

let t_serial = serialize_tree t

Out[16]:

val t_serial : char list =
  ['#'; '#'; '#'; '#'; '*'; 'o'; '*'; 's'; '#'; '#'; '#'; '#'; '*'; '\217';
   '#'; '*'; '-'; '*'; 'L'; '#'; '#'; '*'; 'v'; '*'; '\167'; '#'; '*';
   '\168'; '*'; '\174'; '#'; '#'; '#'; '#'; '*'; '('; '*'; ')'; '#'; '*';
   '2'; '*'; '3'; '#'; '#'; '*'; ':'; '*'; 'A'; '#'; '*'; 'I'; '*'; 'K'; '#';
   '#'; '#'; '*'; 'O'; '*'; 'U'; '#'; '*'; 'X'; '*'; 'j'; '#'; '#'; '*'; 'w';
   '*'; 'x'; '#'; '*'; 'y'; '*'; 'z'; '*'; 'n'; '#'; '*'; 'e'; '#'; '*'; 'a';
   '#'; '#'; '#'; '#'; '#'; '*'; '\132'; '*'; '\133'; '#'; '*'; '\136'; '*';
   '\138'; '#'; '#'; '*'; '\162'; '*'; '\171'; '#'; '*'; '\177'; '*'; '\178';
   '*'; '\''; '#'; '*'; 'g'; '*'; 'h'; '#'; '#'; '*'; ' '; '#'; '#'; '*';
   'd'; '#'; '*'; 'c'; '*'; '\195'; '*'; 'i'; '#'; '#'; '#'; '#'; '#'; '*';
   'b'; '*'; 'f'; '#'; '*'; '\169'; '*'; '\216'; '*'; 'm'; '*'; 't'; '#';
   '#'; '*'; 'u'; '*'; 'l'; '#'; '#'; '*'; 'p'; '#'; '*'; ','; '#'; '*'; '.';
   '*'; 'q'; '*'; 'r']

In [17]:

let deserialize l = 
    let rec read_tree = function
        | '*'::c::q -> F(c), q
        | '#'::q -> let g, q1 = read_tree q in
                    let d, q2 = read_tree q1 in
                    N(g, d), q2 
        | _ -> failwith "deserialize" in
    fst (read_tree l) in
deserialize t_serial

let deserialize l = let rec read_tree = function | '*'::c::q -> F(c), q | '#'::q -> let g, q1 = read_tree q in let d, q2 = read_tree q1 in N(g, d), q2 | _ -> failwith "deserialize" in fst (read_tree l) in deserialize t_serial

Out[17]:

- : char tree =
N
 (N
   (N (N (F 'o', F 's'),
     N
      (N
        (N (N (F '\217', N (F '-', F 'L')),
          N (N (F 'v', F '\167'), N (F '\168', F '\174'))),
        N
         (N (N (N (F '(', F ')'), N (F '2', F '3')),
           N (N (F ':', F 'A'), N (F 'I', F 'K'))),
         N (N (N (F 'O', F 'U'), N (F 'X', F 'j')),
          N (N (F 'w', F 'x'), N (F 'y', F 'z'))))),
      F 'n')),
   N (F 'e',
    N (F 'a',
     N
      (N
        (N (N (N (F '\132', F '\133'), N (F '\136', F '\138')),
          N (N (F '\162', F '\171'), N (F '\177', F '\178'))),
        F '\''),
      N (F 'g', F 'h'))))),
 N (N (F ' ', N (N (F 'd', N (F 'c', F '\195')), F 'i')),
  N (N (N (N (N (F 'b', F 'f'), N (F '\169', F '\216')), F 'm'), F 't'),
   N (N (F 'u', F 'l'), N (N (F 'p', N (F ',', N (F '.', F 'q'))), F 'r')))))

LZW¶

In [18]:

let lzw_code s =
  let n = String.length s in
  let d = Hashtbl.create 13 in
  let dinv = Hashtbl.create 13 in
  let max_code = ref 0 in
  let add_code k v =
      Hashtbl.add d k v;
      Hashtbl.add dinv v k in
  for i = 0 to n - 1 do (* initialize d *)
    if not (Hashtbl.mem d (String.sub s i 1)) then (
      add_code (String.sub s i 1) !max_code;
      incr max_code
    )
  done;
  let rec aux i = (* returns compression of s[i:] *)
    if i >= String.length s then []
    else
      let rec max_suffix j =
        if j = n || not (Hashtbl.mem d (String.sub s i (j - i + 1))) then j
        else max_suffix (j + 1) in
      let j = max_suffix i in
      let w = String.sub s i (j - i) in
      if j < n then (
        let w' = String.sub s i (j - i + 1) in
        add_code w' (!max_code + 1);
        incr max_code;
      );
      (Hashtbl.find d w)::aux j
  in
  aux 0, dinv

let lzw_code s = let n = String.length s in let d = Hashtbl.create 13 in let dinv = Hashtbl.create 13 in let max_code = ref 0 in let add_code k v = Hashtbl.add d k v; Hashtbl.add dinv v k in for i = 0 to n - 1 do (* initialize d *) if not (Hashtbl.mem d (String.sub s i 1)) then ( add_code (String.sub s i 1) !max_code; incr max_code ) done; let rec aux i = (* returns compression of s[i:] *) if i >= String.length s then [] else let rec max_suffix j = if j = n || not (Hashtbl.mem d (String.sub s i (j - i + 1))) then j else max_suffix (j + 1) in let j = max_suffix i in let w = String.sub s i (j - i) in if j < n then ( let w' = String.sub s i (j - i + 1) in add_code w' (!max_code + 1); incr max_code; ); (Hashtbl.find d w)::aux j in aux 0, dinv

Out[18]:

val lzw_code : string -> int list * (int, string) Hashtbl.t = <fun>

In [19]:

let rec lzw_decode dinv = function
    | [] -> ""
    | e::q -> (Hashtbl.find dinv e)^lzw_decode dinv q

let rec lzw_decode dinv = function | [] -> "" | e::q -> (Hashtbl.find dinv e)^lzw_decode dinv q

Out[19]:

val lzw_decode : ('a, string) Hashtbl.t -> 'a list -> string = <fun>

In [20]:

let code, dinv = lzw_code text

let code, dinv = lzw_code text

Out[20]:

val code : int list =
  [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 2; 12; 13; 9; 2; 14; 1; 70; 13;
   14; 66; 70; 15; 8; 1; 8; 70; 12; 74; 1; 6; 59; 3; 11; 16; 8; 5; 14; 17;
   18; 2; 19; 20; 84; 73; 7; 14; 21; 9; 8; 91; 13; 71; 74; 102; 6; 22; 17;
   23; 7; 3; 109; 111; 2; 22; 12; 7; 69; 9; 9; 3; 1; 114; 70; 7; 118; 13; 6;
   14; 19; 7; 70; 76; 70; 21; 4; 3; 13; 13; 70; 19; 70; 22; 7; 6; 16; 4; 17;
   24; 69; 13; 25; 2; 26; 70; 11; 6; 74; 61; 63; 65; 67; 69; 2; 27; 86; 132;
   101; 20; 28; 4; 29; 30; 10; 31; 17; 32; 65; 33; 11; 17; 34; 2; 35; 12; 92;
   120; 16; 70; 36; 2; 37; 38; 39; 40; 37; 34; 39; 41; 202; 37; 42; 37; 43;
   39; 44; 39; 45; 46; 47; 48; 2; 90; 11; 178; 76; 2; 11; 121; 10; 118; 228;
   109; 21; 176; 124; 126; 13; 131; 101; 14; 2; 49; 50; 78; 8; 158; 145; 12;
   162; 164; 101; 6; 228; 84; 70; 51; 80; 2; 118; 9; 139; 86; 2; 4; 72; 60;
   62; 64; 66; 68; 266; 72; 168; 22; 125; 157; 23; 264; 20; 169; 269; 172; 8;
   257; 249; 2; 52; 59; 141; 9; 154; 14; 27; 70; 3; 14; 53; 138; 7; 102; 10;
   258; 151; 112; 281; 171; 271; 112; 19; 131; 309; 70; 223; 16; 141; 14;
   149; 305; 275; 4; 8; 21; 121; 110; 1; 112; 9; 12; 4; 265; 112; 285; 264;
   82; 91; 108; 325; 77; 69; 177; 304; 2; 64; 19; 84; 121; 12; 14; 7; 13; 54;
   221; 146; 2; 21; ...]
val dinv : (int, string) Hashtbl.t = <abstr>

In [21]:

lzw_decode dinv code

lzw_decode dinv code

Out[21]:

- : string =
"Un algorithme est une suite finie et non ambiguë d'instructions et d'opérations permettant de résoudre une classe de problèmes. Le mot algorithme vient d'Al-Khwârizmî (en arabe : الخوارزمي)2, nom d'un mathématicien persan du IXe siècle. Le domaine qui étudie les algorithmes est ap"... (* string length 620; truncated *)

In [22]:

List.length code

List.length code

Out[22]:

- : int = 385

Le facteur de compression est cette fois de $\approx 38\%$ (soit légèrement moins bien que la compression de Huffman) :

In [23]:

1. -. 385./.620.

1. -. 385./.620.

Out[23]:

- : float = 0.379032258064516125