(* Calcul de la distance d'édition entre deux mots *) (* par programmation dynamique *) (* $Id: levenstein.ml,v 1.1 2003/01/12 15:33:00 berke Exp $ *) (* Berke Durak *) (* 20000817 *) (* Modulification 20010528 *) (* distance_d'edition d s t *) (* calcule la distance d'edition entre les deux mots s et t *) (* les mots sont représentés par des tableaux de type arbitraire *) (* d est la fonction de cout des opérations de base (sur les lettres) *) (* s et t sont du type 'a array *) (* d doit etre du type 'a option -> 'a option -> int *) (* m est la longueur du mot s, n est la longueur du mot t, et l'algorithme *) (* s'éxécute en un temps d'ordre O(m.n) et bouffe de l'espace d'ordre O(m.n) *) (* algorithme : *) (* le tableau a représente une matrice de m + 1 lignes et de n + 1 colonnes a acceder *) (* via "koy" (mettre, en turc) et "al" (prendre) *) (* si i est un entier s_i représente le mot s_1 ... s_i *) (* (i.e. le mot s tronqué à ses i premières lettres de s) *) (* on note par D la distance de levenstein definie sur A^* ou A est l'ensemble *) (* des lettres (i.e. les valeurs du type 'a) *) (* *) (* alors avec tout ça : *) (* *) (* 1) a_{i,j} = D(s_i,t_j) *) (* 2) si on sait passer de s_i à t_{j+1} en un coût x grâce à la séquence d'édition T *) (* on peut passer de s_{i+1} à t_{j+1} en un cout x + d(s(i+1), rien) avec OpDeletion(i+1).T *) (* 3) si on sait passer de s_{i+1} à t_j en un coût x grâce à la séquence d'édition T *) (* on peut passer de s_{i+1} à t_{j+1} en un cout x + d(rien, t(j+1)) avec T.OpInsertion (t(j+1),j) *) (* 4) si on sait passer de s_i à t_j en un coût x grâce à la séquence d'édition T *) (* alors on peut passer de s_{i+1} à t_{j+1} en un cout x + d(s(i+1), t(j+1)) *) (* avec T.OpSubtitution (t(j+1),j+1) *) (* 5) par conséquent on a la relation suivantes : *) (* a_{i+1,j+1} = min (a_{i,j+1} + d(s(i+1), rien), *) (* a_{i+1,j} + d(rien, t(j+1)) *) (* a_{i,j} + d(s(i+1), t(j+1) *) (* 6) on a aussi a_{0,0} = 0 *) (* 7) et a_{i+1,0} = a_{i,0} + d(s_{i+1}, rien) *) (* 8) et a_{0,j+1} = a_{j,0} + d(rien, t_{j+1}) *) module type COSTS = sig type t val min : t -> t -> t val sum : t -> t -> t val zero : t end module type WORDS = sig module K:COSTS type t type letter val length : t -> int val get : t -> int -> letter val distance : letter option -> letter option -> K.t end module Levenstein(A:WORDS) = struct module K = A.K let distance s t = let m = A.length s and n = A.length t in let a = Array.make ((m + 1) * (n + 1)) K.zero in let koy i j x = begin assert (0 <= i && i <= m && 0 <= j && j <= n); a.((n + 1) * i + j) <- x end and al i j = begin assert (0 <= i && i <= m && 0 <= j && j <= n); a.((n + 1) * i + j) end in begin koy 0 0 K.zero; for i = 1 to m do koy i 0 (K.sum (al (i - 1) 0) (A.distance None (Some(A.get s (i - 1))))) done; for j = 1 to n do koy 0 j (K.sum (al 0 (j - 1)) (A.distance (Some(A.get t (j - 1))) None)) done; for i = 0 to m - 1 do for j = 0 to n - 1 do let x1 = K.sum (al i (j + 1)) (A.distance (Some (A.get s i)) None) and x2 = K.sum (al (i + 1) j ) (A.distance (Some (A.get t j)) None) and x3 = K.sum (al i j ) (A.distance (Some (A.get s i)) (Some (A.get t j))) in let x = K.min x1 (K.min x2 x3) in koy (i + 1) (j + 1) x done done; al m n end end let row y0 x0 w u1 u2 = let m = String.length u1 in let r = ref [] in for i = 0 to m - 1 do r := (y0, x0 +. (float_of_int i) *. w, 0.0, u1.[i])::!r; r := (y0, x0 +. (float_of_int i) *. w, 1.0, u2.[i])::!r done; !r let qwerty_description = List.concat [ row 0.0 0.0 1.7461 "`1234567890-=" "~!@#$%^&*()_+"; [1.5,1.0,0.0,'\t']; row 1.5 2.8 1.7461 "qwertyuiop[]" "QWERTYUIOP{}"; row 3.0 3.4 1.7461 "asdfghjkl;'\\" "ASDFGHJKL:\"|"; row 4.5 2.8 1.7461 "ZXCVBNM<>?"; [6.0,12.5,0.0,' '] ] let qwerty_dummy = (20.0,4.0,0.5) let qwerty_map = let a = Array.make 256 qwerty_dummy in List.iter (fun (x,y,z,c) -> a.(Char.code c) <- (x,y,z)) qwerty_description; a let euclidian_distance_squared (x1,y1,z1) (x2,y2,z2) = let f a1 a2 = (a1 -. a2) *. (a1 -. a2) in sqrt ((f x1 x2) +. (f y1 y2) +. (f z1 z2)) let qwerty_insertion_cost = 7.0 let qwerty_deletion_cost = 5.0 let qwerty_distance c1 c2 = let p c = qwerty_map.(Char.code c) in match (c1,c2) with None,None -> 0.0 | Some(_),None -> qwerty_deletion_cost | None,Some(_) -> qwerty_insertion_cost | Some(c1),Some(c2) -> euclidian_distance_squared (p c1) (p c2) module Float_cost = struct type t = float let min = min let sum = (+.) let zero = 0.0 end module String_words = struct module K = Float_cost type t = string type letter = char let length = String.length let get = String.get let distance = qwerty_distance end module Levenstein_string = Levenstein(String_words) let char_stream_to_word_stream s = let b = Buffer.create 16 in let rec state0 = parser [< 'c; s >] -> (match c with (' '|'\n'|'\t') -> state0 s | _ -> Buffer.add_char b c; state1 s) | [< >] -> [< >] and state1 = parser [< 'c; s >] -> (match c with (' '|'\n'|'\t') -> let w = Buffer.contents b in Buffer.clear b; [< 'w; state0 s >] | _ -> Buffer.add_char b c; state1 s) | [< >] -> [< '(Buffer.contents b) >] in state0 s let ticker delta = let u = ref 1000 and a = Unix.gettimeofday () and t = ref 0 in let l = ref a and c = ref 0 and w = ref 0 (* last width *) in (fun f -> incr c; if !t = 0 then begin let l' = Unix.gettimeofday () in if l' -. !l > (2.0 *. delta) then u := max 10 ((!u * 3) / 4) else if l' -. !l < (0.5 *. delta) then u := min 1000000 ((!u * 5) / 4); let msg = Printf.sprintf "Iteration %d (%f iterations / sec) [%s]." !c (if !l -. a > 0.0 then (float_of_int !c) /. (!l -. a) else 1.0) (f ()) in output_char stderr '\r'; output_string stderr msg; for i = 1 to max 0 (!w - String.length msg) do output_char stderr ' ' done; flush stderr; w := String.length msg; l := l' end; incr t; if !t >= !u then t := 0), (fun () -> t := 0; c := 0; u := 1000) let slurp t s = let rec loop r = parser [< 'w; s >] -> t (fun () -> w); loop (w::r) s | [< >] -> r in loop [] s let maximum_likelihood t wl u = let best_d = ref None and best_w = ref "" in List.iter (fun v -> let d = Levenstein_string.distance u v in t (fun () -> match !best_d with None -> "---" | Some(d') -> Printf.sprintf "%s/%f" !best_w d'); if (match !best_d with None -> true | Some(d') -> d < d') then begin best_d := Some(d); best_w := v end) wl; match !best_d with None -> raise Not_found | Some(_) -> !best_w let _ = let (ti,rst) = ticker 1.0 in let wl = slurp ti (char_stream_to_word_stream (Stream.of_channel stdin)) in rst (); for i = 1 to Array.length Sys.argv - 1 do (* Printf.printf "%f\n" (Levenstein_string.distance Sys.argv.(1) Sys.argv.(2)) *) try Printf.printf "%s -> %s\n" Sys.argv.(i) (maximum_likelihood ti wl Sys.argv.(i)) with Not_found -> Printf.printf "%s -> ?\n" Sys.argv.(i) done