(* Correction du TP 2 : Algorithmes gloutons et dynamiques *) (************) (* 1 Oups ! *) (************) (* Question 1 *) let v = make_vect 4 (make_vect 2 0);; v.(0).(0) <- 1;; v;; (* - : int vect vect = [|[|1; 0|]; [|1; 0|]; [|1; 0|]; [|1; 0|]|] *) (* Il y a deux appels à make_vect, donc deux vecteurs de créés. * Le vecteur de taille 2 est utilisé pour initialiser les cases du vecteur de taille 4. * v.(0) et v.(1) référencent donc le même vecteur. *) let make_matrix h w x = let v = make_vect h [||] in for i=0 to h-1 do v.(i) <- make_vect w x done; v;; (* Pour s'assurer de la différence entre les deux codes, on pourra utiliser l'opérateur == qui vérifie l'égalité physique (à ne pas confondre avec l'opérateur = qui vérifie l'égalité structurelle.) *) v.(0)==v.(1);; (* - : bool = true *) let w = make_matrix 4 2 0;; w.(0)==w.(1);; (* - : bool = false *) (*****************) (* 2 Bin Packing *) (*****************) (* Question 2 *) let sum l = it_list (prefix +) 0 l;; let frac_pack objets boite = let total = sum objets in total/boite + if total mod boite = 0 then 0 else 1;; (* Question 3 *) let pack remplissage boite objet = let rec aux remplissage acc = match remplissage with | [] -> if objet <= boite then rev ((objet, [objet])::acc) else failwith "Impossible" | (hv, hl) as h::t -> if hv+objet <= boite then (rev acc)@((hv+objet, objet::hl)::t) else aux t (h::acc) in aux remplissage [];; (* Question 4 *) let bin_pack1 boite objets = it_list (fun remplissage objet -> pack remplissage boite objet) [] objets;; (* Question 5 *) (* Avec cet algorithme glouton, il est impossible d'avoir deux boîtes remplies à moitié (l'algorithme n'aurait pas utilisé deux boîtes s'il était possible de mettre le contenue de l'une dans l'autre.) *) (* Ce qui explique le rapport de 2. *) (* Question 6 *) let rec tri_selection = function | [] -> [] | h :: t -> let rec extract_max m acc = function | [] -> m, acc | h :: t when h > m -> extract_max h (m::acc) t | h :: t -> extract_max m (h::acc) t in let h, t = extract_max h [] t in h :: tri_selection t;; (* Question 7 *) let bin_pack2 boite objets = bin_pack1 boite (tri_selection objets);; (* Les fonctions bin_pack1 et tri_selection sont toutes les deux en O(n^2), la fonction bin_pack2 a donc une complexité quadratique. *) (*************************************) (* 3 Sous-chaines et sous-séquences *) (*************************************) (* Question 8 *) (* Complexité temps : O(n^2) *) (* Complexité mémoire : O(n) *) (* Il existe un algorithme linéaire en temps, celui ci utilise un arbre de suffixe *) let plus_longue_sous_chaine_commune l1 l2 = let best (v1, l1) (v2, l2) = if v1>v2 then (v1,l1) else (v2,l2) (* Fonction auxiliaire calculant la plus longue sous chaine commençant au même indice *) in let rec comparer l1 l2 (cv, cl) acc = match l1, l2 with | [], _ -> best acc (cv, cl) | _, [] -> best acc (cv, cl) | h1::t1, h2::t2 when h1=h2 -> comparer t1 t2 (cv+1, h1::cl) acc | _::t1, _::t2 -> comparer t1 t2 (0,[]) (best (cv,cl) acc) (* Fonction auxiliaire calculant la plus longue sous chaine en faisant glisser une liste par rapport à l'autre *) in let rec glisser dynamique statique acc = match dynamique with | [] -> let (v, l)=acc in (v, rev l) | h::t -> glisser t statique (comparer dynamique statique (0,[]) acc) in best (glisser l1 l2 (0,[])) (glisser l2 l1 (0,[]));; (* Question 9 *) (* Complexité temps : O(n^2) *) (* Complexité mémoire : O(n^2) *) let rec last l = match l with | [] -> failwith "last sur liste vide" | [x] -> x | h::t -> last t;; let repeat n x = let rec aux n acc = if n=0 then acc else aux (n-1) (x::acc) in aux n [];; let plus_longue_sous_sequence_commune l1 l2 = let best (v1, l1) (v2, l2) = if v1>v2 then (v1,l1) else (v2,l2) (* Calcule une ligne de la matrice. *) (* statique est l'élément de la première liste correspondant à la ligne courante. *) (* dynamique est la seconde liste correspondant aux colonnes (visitées une à une.) *) (* precedente est la ligne précédente, acc la ligne courante (renversée), pour calculer la ligne suivante, il suffira de mettre acc à la place de precedente. *) (* derniere (v,l) correspond à la valeur (i-1, j-1) c'est la valeur à regarder si les éléments sont égaux. *) in let rec calculer_ligne statique dynamique precedente (dernierev, dernierel) acc = match dynamique, precedente with | [], [] -> tl (rev acc) (* Si les derniers éléments sont égaux, on allonge la sous-séquence calculé en supprimant le dernier élément de chaque liste. *) | dh::dt, ph::pt when dh=statique -> calculer_ligne statique dt pt ph ((1+dernierev, dh::dernierel)::acc) (* Si les derniers éléments sont différents, il faut supprimer l'un d'eux. *) | dh::dt, ph::pt when dh<>statique -> calculer_ligne statique dt pt ph (best ph (hd acc)::acc) | _ -> failwith "Impossible" (* Appelle la fonction calculer_ligne sur chaque ligne. *) in let rec calculer_matrice l precedente = match l with | [] -> precedente | h::t -> calculer_matrice t (calculer_ligne h l1 precedente (0,[]) [(0, [])]) in (fun (v,l) -> v, rev l) (last(calculer_matrice l2 (repeat (list_length l1) (0,[]))));; (* Question 10 *) (* L'algorithme de la question 8 est bien linéaire en mémoire. * * L'algorithme de la question 9 est quadratique en mémoire car il est nécessaire de conserver les n listes correspondants aux cases de la ligne en cours de calcul. * Hors, chaque liste peut être potentiellement de longueur n (e.g. LCS sur [1;1;1;1;...] [1;1;1;1;....]). * En supprimant les listes calculées, on obtient bien un algorithme linéaire en mémoire, mais il est alors impossible de reconstruire la plus longue sous-séquence commune. * Pour avoir la plus longue sous-séquence en mémoire linéaire, il faudra utiliser l'algorithme de Hirschberg. *) (* Question 11 *) (* Première méthode en O(n^2) * #open "sort";; * let plus_longue_sous_sequence_croissante l = plus_longue_sous_sequence_commune l (sort (prefix <) l);; * Mais il est possible de faire mieux, méthode en O(n log n) : *) let plus_longue_sous_sequence_croissante l = let pile_tops = make_vect (list_length l) [] in let bsearch_piles x len = let rec aux lo hi = if lo > hi then lo else let mid = (lo + hi) / 2 in if hd pile_tops.(mid) < x then aux (mid+1) hi else aux lo (mid-1) in aux 0 (len-1) in let f len x = let i = bsearch_piles x len in begin pile_tops.(i) <- x :: if i = 0 then [] else pile_tops.(i-1); if i = len then len+1 else len end in let len = it_list f 0 l in rev pile_tops.(len-1);; (********************************) (* 4 Levenshtein est paresseux *) (********************************) (* Question 12 *) let levenshtein a b = let n = string_length a and m = string_length b in let t = make_matrix 2 (m + 1) 0 in begin for i=0 to n-1 do for j=1 to m do t.(i mod 2).(j) <- min (min (t.((i+1) mod 2).(j) + 1) (t.(i mod 2).(j-1) + 1)) (t.((i+1) mod 2).(j-1) + if a.[i] = b.[j-1] then 0 else 1) done done; t.((n + 1) mod 2).(m); end;; (* Question 13 *) (* Le coin supérieur droit et le coin inférieur gauche ont pour valeur n (la taille des chaines.) * De même une case à distance d de la diagonale contiendra au moins la valeur d. * Il suffit donc de calculer un vecteur de taille 2*d+1 autour de la diagonale. * Si la distance réelle est supérieure à d, l'algorithme retournera une valeur quelconque. *) let bounded_levenshtein a b d = let n = string_length a and m = string_length b in let t = make_vect (2*d + 1) d in begin t.(d) <- 0; for i=0 to n-1 do for j=0 to 2*d do t.(j) <- min (min (if j>0 then t.(j-1) + 1 else d) (if j<2*d then t.(j+1) + 1 else d)) (t.(j) + if j+i-d>=0 && j+i-d=0 && d+m-n<=2*d then t.(d+m-n) else d; end;; (* Question 14 *) (* On commence par définir quelques fonctions utiles. *) (* Sélectionne le i élément d'une liste *) let rec select l i = match l with | [] -> None | h::t -> if i=0 then Some h else select t (i-1);; (* Opérateur "iota", 3++7 = [3;4;5;6;7] *) let iota b e = let rec aux f t acc = if f==t then f::acc else aux f (t-1) (t::acc) in aux b e [];; #infix "iota";; (* Finalement *) let lazy_levenshtein a b = let n = string_length a and m = string_length b in let diags = ( map (function i -> (-i, ref [i])) (1 iota n), (* Les diagonales inférieures *) (0, ref [0]), (* La diagonale partant de (0,0) *) map (function i -> (i, ref [i])) (1 iota m)) (* Les diagonales supérieures *) in let value_d main index = if list_length !main > index then select !main (list_length !main - index - 1) else None in let west ((lh::lt, (d,m), u), i) = ((lt, lh, (d,m)::u), if d<=0 then i-1 else i) and north ((l, (d,m), uh::ut), i) = (((d,m)::l, uh, ut), if d>=0 then i-1 else i) in let rec wind i (l, m, u) = match l, u with | lh::lt,_ when i<0 -> wind (i+1) (lt, lh, m::u) | _,uh::ut when i>0 -> wind (i-1) (m::l, uh, ut) | _, _ when i=0 -> (l,m,u) | _,_ -> failwith "Error in wind" in let rec compute (lowers, (diag, main), uppers) index = let diags=(lowers, (diag, main), uppers) and x = if diag<=0 then index - 1 else diag + index - 1 and y = if diag<0 then -diag + index -1 else index - 1 in match value_d main index with | Some v -> v | None -> let lazy_min3 (xd,xi) (yd,yi) (zd,zi) = (* Version lazy de min3 *) if compute xd xi < compute yd yi then compute xd xi else min (compute yd yi) (compute zd zi) in let lazy_min3 (xd,xi) (yd,yi) (zd,zi) = (* Version non-lazy de min3 *) min (compute xd xi) (min (compute yd yi) (compute zd zi)) in let val = if a.[y]=b.[x] then compute diags (index - 1) else let (first, second) = if diag<0 then (north, west) else (west, north) in 1+lazy_min3 (diags, index - 1) (first (diags, index)) (second (diags, index)) in begin main := val :: !main; val; end in compute (wind (m - n) diags) (min n m);; (* La version récursive terminale est laissé comme exercice. (bonne chance) *)