Exercice 1 : Manipulations de listes (4 points)
Implémenter les 4 fonctions suivantes : sum_list, reverse_even_length, pairing, int_map_of_list. Vous pouvez utiliser les fonctions de la librairie standard si vous le voulez.
Indice : pour int_map_of_list, vous pouvez utiliser List.mapi.
val sum_list : int list -> int list -> int list = <fun>
val reverse_even_length : 'a list list -> 'a list list = <fun>
val pairing : int list -> int list = <fun>
module Int = struct type t = int let compare a b = a - b end
module IMap = Map.Make(Int)
val int_map_of_list : 'a list -> 'a IMap.t
let map = int_map_of_list ["salade";"brebis";"loup"]
let res = [IMap.find 0 map; IMap.find 1 map; IMap.find 2 map]
Solution :
let sum_list left right =
List.combine left right
|> List.map (fun (l,r) -> l+r)
let reverse_even_length lists =
let reverse_if_even list =
if List.length list mod 2 = 0 then List.rev list else list
in
List.map reverse_if_even lists
let rec pairing = function
| [] -> []
| one::two::more -> (one + two) :: pairing more
| [single] -> [single]
let int_map_of_list list =
list
|> List.mapi (fun i elt -> (i,elt))
|> List.fold_left (fun map (i,elt) -> IMap.add i elt map) IMap.empty
Exercice 2 : Substitutions (6 points)
Évaluer par substitutions successives les quatre expressions suivantes. Vous utiliserez la règle selon laquelle List.map f [e1;...en] --> [f e1; ... f en].
let rec insert pos elt list =
match list with
| _ when pos = 0 -> elt::list
| [] -> [elt]
| head::tail -> head :: insert (pos - 1) elt tail
let evaluer_1 = insert 4 42 [1;9;2;8;7;5;4]
let rec merge left right =
match left, right with
| l::eft, r::ight when l <= r -> l :: merge eft right
| l::eft, r::ight -> r :: merge left ight
| l, [] | [], l -> l
let evaluer_2 = merge [1;4;6;8] [2;3;5]
let add_head head lists = lists @ List.map (fun l -> head::l) lists
let rec sublists list =
match list with
| [] -> [[]]
| head::tail -> add_head head (sublists tail)
let evaluer_3 = sublists [1;2]
type position = L | M | R
let rec hanoi from_pos to_pos ignore_pos order =
match order with
| 0 -> []
| n ->
hanoi from_pos ignore_pos to_pos (n-1)
@ [(from_pos, to_pos)]
@ hanoi ignore_pos to_pos from_pos (n-1)
let evaluer_4 = hanoi L M R 2
Solution :
insert 4 42 [1;9;2;8;7;5;4]
--> 1 :: insert 3 42 [9;2;8;7;5;4]
--> 1 :: 9 :: insert 2 42 [2;8;7;5;4]
--> 1 :: 9 :: 2 :: insert 1 42 [8;7;5;4]
--> 1 :: 9 :: 2 :: 8 :: insert 0 42 [7;5;4]
--> [ 1; 9; 2; 8; 42; 7; 5; 4]
merge [1;4;6;8] [2;3;5]
--> 1 :: merge [4;6;8] [2;3;5]
--> 1 :: 2 :: merge [4;6;8] [3;5]
--> 1 :: 2 :: 3 :: merge [4;6;8] [5]
--> 1 :: 2 :: 3 :: 4 :: merge [6;8] [5]
--> 1 :: 2 :: 3 :: 4 :: 5 :: merge [6;8] []
--> [ 1; 2; 3; 4; 5; 6; 8 ]
sublists [1;2]
--> add_head 1 (sublists [2])
--> add_head 1 (add_head 2 (sublists []))
--> add_head 1 (add_head 2 [[]]
--> add_head 1 ([[]] @ List.map (fun l -> 2::l) [[]])
--> add_head 1 [ []; [2] ]
--> [ []; [2]] @ List.map (fun l -> 1::l) [ []; [2] ]
--> [ []; [2]; [1]; [1;2] ]
hanoi L M R 2
--> (hanoi L R M 1) @ [(L,M)] @ (hanoi R M L 1)
--> (hanoi L R M 1) @ [(L,M)] @ (hanoi R L M 0) @ [(R,M)] @ (hanoi L M R 0)
--> (hanoi L R M 1) @ [(L,M)] @ (hanoi R L M 0) @ [(R,M)] @ []
--> (hanoi L R M 1) @ [(L,M)] @ [] @ [(R,M)] @ []
--> (hanoi L M R 0) @ [(L,R)] @ (hanoi R M L 0) @ [(L,M)] @ [] @ [(R,M)] @ []
--> (hanoi L M R 0) @ [(L,R)] @ [] @ [(L,M)] @ [] @ [(R,M)] @ []
--> [] @ [(L,R)] @ [] @ [(L,M)] @ [] @ [(R,M)] @ []
--> [(L,R); (L,M); (R,M)]
Exercice 3 : Exercice de style (4 points)
La fonction suivante fut écrite n'importe comment. Réécrivez-la de façon lisible. Ensuite, réécrivez-la sans récursion en utilisant les fonctionnelles de listes.
let rec bad f q r = match q
with | y1::x1 -> ( match r with
| y2::x2 ->
bad f q
x2 @ bad f x1
[y2] @ [ (f y1
y2) ]
| [] ->
[]) | [] -> []
Solution :
let rec bad f q r =
match q with
| y1::x1 ->
( match r with
| y2::x2 -> bad f q x2 @ bad f x1 [y2] @ [ (f y1 y2) ]
| [] -> []
)
| [] -> []
let map_product f list1 list2 =
let rec loop accu list1 list2 =
match list1, list2 with
| head1::tail1, head2::tail2 ->
loop (loop (f head1 head2 :: accu) tail1 [head2]) list1 tail2
| [], _
| _, [] -> accu
in loop [] list1 list2
let map_product f list1 list2 =
let (>>=) list g = List.map g list |> List.flatten in
List.rev (
list1 >>= fun x1 ->
list2 >>= fun x2 -> [ f x1 x2 ]
)
Exercice 4 : Timsort (6 points)
L'algorithme Timsort est un algorithme de tri, utilisé notamment par Python. En début d'année 2015 , des chercheurs ont voulu démontrer formellement la correction de son implémentation en Java, et se sont rendus compte que les implémentations dans différents langages, dont Java, Python et Haskell, étaient fausses.
Nous allons écrire une version correcte d'une version allégée de Timsort.
Nous commençons par le tri de listes d'entiers uniquement.
Couper un préfixe monotone croissant
Timsort utilise les séquences déjà triées de la liste pour aller plus vite. L'algorithme suivant trouve le plus long préfixe d'une liste qui est une séquence croissante.
let rec cut_increasing_prefix accu list =
match list with
| one::two::more when one <= two ->
cut_increasing_prefix (one::accu) (two::more)
| one::more -> (List.rev (one::accu), more)
| [] -> (List.rev accu, [])
Utilisez-le pour évaluer par substitution l'expression suivante :
let _ = cut_increasing_prefix [] [1;3;6;7;5;2;4;8;9]
Solution :
cut_increasing_prefix [] [1;3;6;7;5;2;4;8;9]
--> cut_increasing_prefix [1] [3;6;7;5;2;4;8;9]
--> cut_increasing_prefix [3;1] [6;7;5;2;4;8;9]
--> cut_increasing_prefix [6;3;1] [7;5;2;4;8;9]
--> (List.rev [7;6;3;1], [3;6;7;5;2;4;8;9])
--> ([1;3;6;7], [3;6;7;5;2;4;8;9])
Couper un plus long préfixe monotone
Sur le même principe, écrire une fonction trouvant le plus long préfixe décroissant, et le retournant trié par ordre croissant.
Solution :
let rec cut_decreasing_prefix accu list =
match list with
| one::two::more when one >= two ->
cut_decreasing_prefix (one::accu) (two::more)
| one::more -> (one::accu, more)
| [] -> (accu,[])
Découper une liste en séquences croissantes
Maintenant, écrivez une fonction qui prend une liste d'entiers, et partitionne cette liste en séquence monotone.
val monotonic_partition : int list -> int list list
Solution :
let rec monotonic_partition incseqs list =
match list with
| one::two::more when one <= two ->
let (prefix,suffix) = cut_increasing_prefix [] list in
monotonic_partition (prefix::incseqs) suffix
| one::two::more ->
let (prefix,suffix) = cut_decreasing_prefix [] list in
monotonic_partition (prefix::incseqs) suffix
| [single] -> [single] :: incseqs
| [] -> incseqs
Fusionner deux listes
Donnez une fonction pour fusionner deux listes croissantes en une seule liste croissante.
Solution :
On utilise la librairie standard.
let merge = List.merge (fun a b -> a - b)
Insérer une séquence dans la pile.
Il suffit maintenant de fusionner toutes les listes. Malheureusement, si nous les fusionnons dans un ordre arbitraire, la complexité dans le pire des cas sera $O(n^2)$ pour $n$ éléments. La clé pour obtenir une complexité de $O(n \log n)$ est de fusionner uniquement des listes dont les longueurs sont proches, par exemple, qui diffèrent d'un facteur au plus 2 .
Voilà comment nous allons procéder : nous construisons une liste de séquences croissantes, que nous appellons la pile. De plus la pile est triée par longueur de séquences croissantes, et ne contient pas deux séquences de longueurs proches.
Précisement, si la pile contient les séquences $s_1, s_2, \ldots s_k$(rappelons que $s_i$ est une liste d'entiers triés par ordre croissant), de longueurs $l_1,\ldots,l_k$, alors les propriétés suivantes doivent être vraies :
$l_1 \leq l_2 \leq l_3 \leq \ldots \leq l_k$,
$l_i + l_{i+1} < l_{i+2}$ pour tout $i \in {1,2,\ldots,k-2}$.
(En effet, si le second invariant est faux pour $i$, alors $l_{i+2}
\leq l_{i+1} + l_i \leq 2 l_{i+1}$, donc $s_{i+1}$ et $s_{i+2}$ ont des longueurs proches.)
Nous commençons par coder une fonction qui ajoute une séquence dans la pile. Pour ne pas recalculer systématiquement les longueurs des listes, la pile contient des couples (liste d'entiers croissante, longueur de la liste). Pour ajouter une séquence, nous l'insérons en tête de liste, puis nous vérifions les invariants, dans cet ordre :
Si le premier invariant est violé, on retire les deux premiers éléments, puis on réinsère le premier, puis le deuxième (en revérifiant les invariants à chaque fois).
Si le deuxième invariant est violé, on retire les trois premiers éléments, puis on insère la fusion du deuxième et du troisième, puis on insère le premier (en revérifiant les invariants à chaque fois).
Programmez cet algorithme avec deux fonctions mutuellement récursives :
let rec check_invariant stack =
and insert_sequence seq stack = check_invariant (seq::stack)
val check_invariant : (int list * int) list -> (int list * int) list
val insert_sequence :
int list * int -> (int list * int) list -> (int list * int) list
Solution :
let rec check_invariant stack =
match stack with
| (seq1,len1)::(seq2,len2)::others when len1 > len2 ->
others
|> insert_sequence (seq1,len1)
|> insert_sequence (seq2,len2)
| (seq1,len1)::(seq2,len2)::(seq3,len3)::others when len1 + len2 >= len3 ->
others
|> insert_sequence (merge seq2 seq3, len2 + len3)
|> insert_sequence (seq1,len1)
| _ -> stack
and insert_sequence seq stack = check_invariant (seq::stack)
Écrire l'algorithme
Nous avons maintenant tous les ingrédients pour écrire Timsort. Il faut :
partitionner la liste en séquences croissantes,
calculer la longueur de chacune,
les insérer une-par-une dans une pile initialement vide,
ensuite, fusionner les listes de la pile restante, par ordre de longueur croissante, (en pensant à oublier les indications de longueurs),
retourner le résultat.
En utilisant l'opérateur (|>) et les fonctions écrites, écrire le code de Timsort (7 lignes suffisent).
val timsort : int list -> int list
Solution :
let timsort list =
list
|> monotonic_partition []
|> List.map (fun seq -> (seq, List.length seq))
|> List.fold_left (fun st seq -> insert_sequence seq st) []
|> List.map fst
|> List.fold_left (List.merge compare) []
Généraliser
Sans écrire de code, décrivez comment vous feriez pour rendre notre algorithme polymorphe.
Solution :Pour suivre l'interface du module de listes de la librairie standard, notre fonction de tri devrait prendre en argument un opérateur de comparaison. Il faudrait aussi le passer aux fonctions effectuant des comparaisons.
Une autre possibilité est de créer un foncteur qui prend un module de type ordonné et crée un module contenant la fonction de tri des listes de ce type. Dans ce cas, pas besoin d'ajouter l'opérateur de comparaison en argument, mais seulement remplacer toutes les comparaisons par celle définies dans le module en param^etre du foncteur.
Éléments de langage
Fonctions utiles de la librairie standard :
val max : 'a -> 'a -> 'a
val sqrt : float -> float
val ( ** ) : float -> float -> float
val (@) : 'a list -> 'a list -> 'a list
type 'elt option =
| Some of 'elt
| None
Fonctions utiles du module List :
val hd : 'elt list -> 'elt
val tl : 'elt list -> 'elt list
val length : 'a list -> int
val nth : 'a list -> int -> 'a
val rev : 'a list -> 'a list
val flatten : 'a list list -> 'a list
val map : ('a -> 'b) -> 'a list -> 'b list
val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
val for_all : ('a -> bool) -> 'a list -> bool
val exists : ('a -> bool) -> 'a list -> bool
val mem : 'a -> 'a list -> bool
val filter : ('a -> bool) -> 'a list -> 'a list
val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list
Exemples de syntaxe :
type ratio = int * int
let rec euclid a b =
if b = 0 then a
else euclid b (a mod b)
let pgcd a b = euclid (abs a) (abs b)
let ratio p q =
let d = pgcd p q in
if q < 0 then (-p / d, q / d)
else (p/d, q/d)
let (+/) (a,b) (c,d) = ratio (a*d + b*c) (b*d)
let (++) (a,b) (c,d) = ratio (a+c) (b+d)
module Queue =
struct
type 'a t =
Queue of ('a list) * ('a list)
exception Empty
let empty = Queue ([],[])
let is_empty = function
| Queue ([],[]) -> true
| _ -> false
let queue = function
| Queue ([],l) -> Queue(List.rev l,[])
| x -> x
let snoc (Queue (l1,l2)) ele =
queue (Queue (l1,ele::l2))
let head = function
| Queue ([],_) -> raise Empty
| Queue (l,_) -> List.hd l
let tail = function
| Queue ([],_) -> raise Empty
| Queue (l1,l2) -> queue (Queue (List.tl l1,l2))
end
