(**************************************************************************)
(* Calcul du plus long complément *)
(**************************************************************************)
type etiquette = Mot of string
| Prefixe of string
;;
type arbre = Noeud of etiquette * (char * arbre) list ;;
(* char_list_of_string : string -> char list *)
let char_list_of_string s =
let rec aux acc = function
-1 -> acc
| i -> aux ((String.get s i)::acc) (pred i)
in
aux [] (String.length s - 1)
;;
(* string_of_char_list : char list -> string *)
let string_of_char_list cl =
let n = List.length cl in
let s = String.create n in
let rec aux i = function
[] -> s
| c::l -> String.set s i c ; aux (succ i) l
in aux 0 cl
;;
(* change_assoc : ('a * 'b) list -> 'a -> 'b -> ('a * 'b) list *)
let change_assoc l a b =
let rec change_rec = function
[] -> []
| (a',b')::l -> if a=a' then (a',b)::l else (a',b')::(change_rec l)
in
if List.mem_assoc a l then change_rec l else (a,b)::l
;;
(* insere_mot : arbre -> string -> arbre
* Ajoute un mot dans un arbre pour donner un nouvel arbre. *)
let insere_mot arbre mot =
let rec insere_rec chemin z e =
match (z, e) with
((Noeud (Prefixe _,b)), []) -> Noeud (Mot mot, b)
| (a, []) -> a
| ((Noeud (e,b)), (c::l)) ->
if List.mem_assoc c b then
let fils = insere_rec (c::chemin) (List.assoc c b) l in
Noeud (e, change_assoc b c fils)
else
let prefixe = string_of_char_list (List.rev (c::chemin)) in
let fils = Noeud (Prefixe prefixe,[]) in
Noeud (e, (c, insere_rec (c::chemin) fils l)::b)
in insere_rec [] arbre (char_list_of_string mot)
;;
(* construit : string list -> arbre
* Construit l'arbre correspondant à une liste de mots *)
let rec construit_arbre = function
[] -> Noeud (Prefixe "",[])
| m::l -> insere_mot (construit_arbre l) m
;;
(* Exemple : *)
let a = construit_arbre [ "caml" ; "cafe" ; "cafes" ; "java" ];;
(* descente : arbre -> char list -> arbre
* Descend dans un arbre le long d'une liste de caractères
* et renvoie l'arbre où l'on est arrivé.
* Lève une exception Failure "ce n'est pas un prefixe" si la liste
* ne correspond pas à un chemin dans l'arbre. *)
let rec descente a l =
match (a, l) with
(a, []) -> a
| ((Noeud (e,b)), (c::l)) ->
if List.mem_assoc c b then
descente (List.assoc c b) l
else
failwith "ce n'est pas un prefixe"
;;
(* complete : arbre -> string -> string
* Trouve le plus grand complément dans l'arbre d'un mot donné *)
let complete a mot =
let rec cherche_complement p = function
[c, Noeud (Mot m, b)] -> m
| [c, Noeud (Prefixe _, b)] -> cherche_complement (c::p) b
| _ -> string_of_char_list (List.rev p)
in
match descente a (char_list_of_string mot) with
(Noeud (Prefixe p,b)) -> cherche_complement (List.rev (char_list_of_string p)) b
| (Noeud (Mot m,_)) -> m
;;
(* trouve_mots : arbre -> string list
* Renvoie tous les mots contenus dans l'arbre *)
let applati l = List.fold_right (@) l [];;
let rec trouve_mots = function
Noeud (Mot m, b) -> m::(applati (List.map (fun (c,a) -> trouve_mots a) b))
| Noeud (Prefixe _,b) -> (applati (List.map (fun (c,a) -> trouve_mots a) b))
;;
(* trouve_complements : arbre -> string -> string list
* Trouve tous les mots de l'arbre dont p est un préfixe. *)
let trouve_complements a mot =
let a' = descente a (char_list_of_string mot) in
trouve_mots a'
;;
(**************************************************************************)
(* Optimisation *)
(**************************************************************************)
(* On optimise en notant sur chaque noeud le plus grand prefixe
* pour un mot aboutissant sur ce noeud-la, au lieu de noter seulement
* le mot sur lequel on est rendu. *)
let rec optimise a = match a with
Noeud (Prefixe p, b) ->
let p' = complete a "" in
Noeud(Prefixe p', List.map (fun (c,f) -> c,optimise f) b)
| Noeud (Mot m, b) ->
Noeud(Mot m, List.map (fun (c,f) -> c,optimise f) b)
;;
let rec complete_opt a mot =
match descente a (char_list_of_string mot) with
(Noeud (Prefixe m,_)) -> m
| (Noeud (Mot m ,_)) -> m
;;