(* ESIM 97 : solution des questions de programmation par Daniel GENOUD Lyc‚e La MartiniŠre-Monplaisir LYON *) (* Types et valeurs globales *) let txt = ref ("GHFFBBBBCCCCDDDDAAAAAAAAEEEEEEEE");; type paire = {poids:int; chaine:string};; type arbre = | nil | noeud of arbre*paire*arbre;; let nbcar_max = 80;; let car = make_vect nbcar_max ` ` and frequence = make_vect nbcar_max 0 and huff_code = make_vect nbcar_max "" and sf_code = make_vect nbcar_max "" and nbcar = ref (0) and texte_code = ref ("") and texte_decode = ref ("") and huff = ref (nil) and code = ref ("");; let initialisations = let lg = string_length !txt and j = ref (0) in for i=0 to lg-1 do j := 0; while !j < !nbcar && !txt.[i] <> car.(!j) do j := !j + 1 done; if !j < !nbcar then frequence.(!j) <- frequence.(!j) + 1 else ( frequence.(!j) <- 1; car.(!j) <- !txt.[i]; nbcar := ! nbcar + 1) done;; let appartient c ch = (* it‚rative *) let trouve = ref (false) and i = ref (0) in while not(!trouve) && !i < string_length ch do if ch.[!i] = c then trouve := true; i := !i + 1 done; !trouve;; let appartient c ch = (* r‚cursive *) let rec aux i = if i < 0 then false else ch.[i]=c || aux (i-1) in aux (string_length ch - 1);; let rec insere a liste = match liste with | [] -> [a] | t::q -> match (a,t) with | (noeud(_,ap,_),noeud(_,tp,_)) -> if ap.poids < tp.poids then a::liste else t::(insere a q) | (nil,_) | _ -> failwith "Erreur";; let creer_liste = let liste = ref ([]) in for i=0 to !nbcar -1 do let feuille = noeud(nil, { poids=frequence.(i); chaine=char_for_read car.(i)}, nil) in liste := insere feuille !liste done; !liste;; let fusion a1 a2 = match (a1,a2) with | (noeud(_,p1,_),noeud(_,p2,_)) -> noeud(a1,{poids=p1.poids+p2.poids; chaine=p1.chaine^p2.chaine},a2) | _ -> failwith "Erreur";; let rec creer_arbre liste = match liste with | [] -> failwith "Erreur" | [a] -> [a] | a1::a2::q -> creer_arbre (insere (fusion a1 a2) q);; huff := hd(creer_arbre creer_liste);; let code_char c = let test a = match a with | noeud(_,p,_) -> appartient c p.chaine | _ -> failwith "Erreur" in let rec parcours a accu = match a with | noeud(nil, _, nil) -> accu | noeud(fg, _, fd) -> if test fg then parcours fg (accu^(char_for_read `0`)) else parcours fd (accu^(char_for_read `1`)) | _ -> failwith "Erreur" in parcours !huff "";; let codage ch = let txt_code = ref ("") in for i=0 to string_length ch - 1 do txt_code := !txt_code ^ (code_char ch.[i]) done; !txt_code;; let decodage chc = let chc0=chc^"0" in (* pour traiter le dernier caractŠre de chc *) let lg = string_length chc0 and txt_decode = ref ("") in let a = ref (!huff) and i = ref (0) in while !i < lg do match !a with | nil -> failwith "Erreur" | noeud(nil,p,nil) -> txt_decode := !txt_decode ^ p.chaine; a:= !huff; | noeud(fg,_,fd) -> if chc0.[!i]=`0` then a := fg else a := fd; i := !i + 1; done; !txt_decode;; (* essai : decodage "11111001011111101";; --> string = "HACHE" *) let recherche c = (* sachant d'avance que c est dans le tableau *) let rec dicho i j = if i=j then i else let k = (i+j)/2 in if c <= car.(k) then dicho i k else dicho (k+1) j in dicho 0 (!nbcar-1);; let parcours = (* infixe *) let rec aux a = match a with | nil -> failwith "Impossible" | noeud(nil,p,nil) -> let i= recherche (p.chaine.[0]) in huff_code.(i) <- !code; | noeud(fg,_,fd) -> let svg = !code in code := svg ^"0"; aux fg; code := svg ^"1"; aux fd; in aux !huff;; let codage2 ch = let txt_code = ref ("") in for i=0 to string_length ch - 1 do txt_code := !txt_code ^ huff_code.(recherche ch.[i]) done; !txt_code;; (*-------------------------------------------------------------------------*) (* Code de SHANNON-FANO *) let txt = ref ("BCDEFGAAAA");; let nbcar_max = 80;; let car = make_vect nbcar_max ` ` and frequence = make_vect nbcar_max 0 and sf_code = make_vect nbcar_max "" and nbcar = ref (0);; let sf_initialisations = let lg = string_length !txt and j = ref (0) in for i=0 to lg-1 do j := 0; while !j < !nbcar && !txt.[i] <> car.(!j) do j := !j + 1 done; if !j < !nbcar then frequence.(!j) <- frequence.(!j) + 1 else ( frequence.(!j) <- 1; car.(!j) <- !txt.[i]; nbcar := ! nbcar + 1) done;; let partage d f = let s = ref (0) and k = ref (f) and mini = ref (0) in for i=d to f do s := !s + frequence.(i) done; while !s > 0 && !k >= d do (* on va de droite … gauche *) mini := !s; s := !s - 2 * frequence.(!k); k := !k - 1; done; if !mini > - !s then !k else !k+1;; let shannon_fano = let rec dicho d f = if d < f then begin let k = partage d f in for i = d to k do sf_code.(i) <- sf_code.(i)^"0" done; for i = k+1 to f do sf_code.(i) <- sf_code.(i)^"1" done; dicho d k; dicho (k+1) f; end in dicho 0 (!nbcar-1);; let cherche c = let i = ref (0) in while car.(!i) <> c do i := !i + 1 done; !i;; let sf_codage ch = let txt_code = ref ("") in for i=0 to string_length ch - 1 do txt_code := !txt_code ^ sf_code.(cherche ch.[i]) done; !txt_code;; let essai = sf_codage "AAAABCDEFG";; type sf_arbre = | nil | bin of sf_arbre * sf_arbre | feuille of char;; let construit_sf_arbre = let separe d f i = let k = ref(d) in while sf_code.(!k).[i] = `0` do k := !k + 1 done; !k in let rec aux d f i = if d=f then feuille (car.(d)) else let k = separe d f i in bin(aux d (k-1) (i+1),aux k f (i+1)) in aux 0 (!nbcar-1) 0;; let sf = construit_sf_arbre;; let sf_decodage chc = let chc0=chc^"0" in (* pour traiter le dernier caractŠre de chc *) let lg = string_length chc0 and txt_decode = ref ("") in let a = ref (sf) and i = ref (0) in while !i < lg do match !a with | nil -> failwith "Erreur" | feuille(c) -> txt_decode := !txt_decode ^char_for_read c; a:= sf; | bin(ag,ad) -> if chc0.[!i]=`0` then a := ag else a := ad; i := !i + 1; done; !txt_decode;; (* FIN *)