Retour au sommaire.
Exemple : l'algorithme de Floyd-Wharshall, une orgie de foncteurs.
À titre d'exemple d'utilisation des foncteurs, on peut considérer l'algorithme de Floyd-Warshall. L'un de ses avatars permet de calculer les distances entre toute paire de sommets d'un graphe. Mais l'algorithme est plus général: il permet aussi de calculer le langage reconnu par un automate, de résoudre des systèmes d'équations linéaires, etc.
La version générale travaille sur une matrice dont les coefficients sont dans une algèbre de Kleene, c'est-à-dire un semi-anneau auquel on ajoute un opérateur *. On commence donc pour poser des interfaces pour ces deux notions :
module type Semiring = sig
type t
val zero : t
val one : t
val add : t -> t -> t
val mult : t -> t -> t
val pp : Format.formatter -> t -> unit
end
module type KleeneAlgebra = sig
module S : Semiring
val star : S.t -> S.t
end
Dans Semiring, on ajoute une fonction pp de pretty-printing. Cela permettra plus tard de créer automatiquement les pretty-printers pour les matrices. Dans KleeneAlgebra, nous aurions pu plutôt inclure Semiring (avec include Semiring). Nous aurons cependant plus tard besoin de faire directement référence à la restriction au semi-anneau d'une algèbre de Kleene, donc nous utilisons un sous-module.
Nous pouvons maintenant définir l'interface d'une matrice carrée. Dans cet exemple nous allons fixé la dimension en utilisant un module de paramétrage. Ainsi des matrices de dimensions différentes appartiendront à des modules différents. Un avantage est qu'on garanti ainsi que les additions et les multiplications matricielles sont toujours définis : pas de risque d'additionner des matrices de dimensions différentes, l'inférence de type ne l'acceptera pas.
module type MatrixDim = sig
val dim : int
end
module type Matrix = sig
type t
type coefficient
module D : MatrixDim
val create : (int -> int -> S.t) -> t
val get_coef : t -> int -> int -> S.t
val pp : Format.formatter -> t -> unit
end
On se contente d'avoir la dimension, une fonction de construction et une fonction d'accès aux coefficients. Pour créer une représentation, il nous faut un type pour les coefficients ayant aussi une fonction de pretty-printing. On va donc définir une interface pour un type pretty-printable. Par ailleurs, on peut facilement représenter une matrice comme une fonction des paires d'entiers vers les coefficients. Pour plus d'efficacité, on va néanmoins stocker les coefficients dans une structure de données : un dictionnaire des paires d'entiers vers les coefficients. Il faut donc définir cela :
module type PrintableType = sig
type t
val pp : Format.formatter -> t -> unit
end
module IntPair = struct
type t = int * int
let compare (x1,y1) (x2,y2) = if x1 = x2 then y1 - y2 else x1 - x2
end
module IPMap = Map.Make(IntPair)
module MakeMatrix :
functor (D : MatrixDim) ->
functor (Coef : PrintableType) -> Matrix with type coefficients = Coef.t
=
functor (D : MatrixDim) ->
functor (Coef : PrintableType) ->
struct
type t = Coef.t IPMap.t
type coefficients = Coef.t
module D = D
let get_coef mat i j = IPMap.find (i,j) mat
let indices = List.range ~stop:`inclusive 1 D.dim
let positions = List.cartesian_product indices indices
let create fct =
List.fold_left
~f:(fun map (i,j) -> IPMap.add (i,j) (fct i j) map)
~init:IPMap.empty
positions
let pp_line mat ppf line =
let open Format in
fprintf ppf "@[<h 0>%a@]"
(pp_print_list ~pp_sep:(fun ppf () -> pp_print_break ppf 3 0) Coef.pp)
(List.map ~f:(get_coef mat line) indices)
let pp ppf mat =
let open Format in
fprintf ppf "@[<v 0>%a@]"
(pp_print_list ~pp_sep:pp_print_cut (pp_line mat))
indices
end
Ce qui est intéressant avec les matrices est qu'elles forment elles-mêmes un semi-anneau, si les coefficients forment un semi-anneau. On peut le prouver en donnant un foncteur, prenant une représentation des matrices, un semi-anneau sur les coefficients, et produisant un semi-anneau des matrices. Autrement dit, on va écrire l'addition et la multiplication matricielle.
module type MatrixSemiring =
sig
include Matrix
module S : Semiring with type t = coefficients
val zero : t
val one : t
val add : t -> t -> t
val mult : t -> t -> t
end
module MakeMatrixSemiring :
functor (M : Matrix) ->
functor (S : Semiring with type t = M.coefficients) ->
MatrixSemiring
with module D = M.D
and type t = M.t
and type coefficients = M.coefficients
=
functor (M : Matrix) ->
functor (S : Semiring with type t = M.coefficients) ->
struct
include M
module S = S
let (+) = S.add
let ( * ) = S.mult
let zero = create (fun i j -> S.zero)
let one = create (fun i j -> if i = j then S.one else S.zero)
let add mat1 mat2 =
create (fun i j -> get_coef mat1 i j + get_coef mat2 i j)
let mult mat1 mat2 =
create @@ fun i j ->
List.range ~stop:`inclusive 1 D.dim
|> List.map ~f:(fun k -> get_coef mat1 i k * get_coef mat2 k j)
|> List.reduce ~f:(+)
|> Core.Std.Option.value ~default:S.zero
end
Ceci dit, nous n'avons pas besoin des opérateurs sur les matrices pour l'algorithme de Floyd-Warshall. Nous avons simplement besoin d'une matrice et d'une algèbre de Kleene sur les coefficients de cette matrice. Nous pouvons donc écrire un autre foncteur pour obtenir l'algorithme (on l'appelle close car il calcule une fermeture transitive).
module MakeFloydWarshall :
functor (K : KleeneAlgebra) ->
functor (M : Matrix with type coefficients = K.S.t) ->
sig
val close : M.t -> M.t
end
= functor (K : KleeneAlgebra) ->
functor (M : Matrix with type coefficients = K.S.t) ->
struct
let (+) = K.S.add
let ( * ) = K.S.mult
let define succ_k mat_k i j =
M.get_coef mat_k i j
+ M.get_coef mat_k i succ_k
* K.star (M.get_coef mat_k succ_k succ_k)
* M.get_coef mat_k succ_k j
let close matrix =
List.fold_left
~f:(fun mat_k succ_k ->
M.create (define succ_k mat_k)
)
~init:matrix
(List.range ~stop:`inclusive 1 M.D.dim)
end
Voilà pour la partie algorithmique : en présence de semi-anneaux ou d'algèbres de Kleene, on peut dériver des matrices avec MakeMatrix, puis un semi-anneau matriciel avec MakeMatrixSemiring ou un algorithme de Floyd-Warshall avec MakeFloydWarshall.
Essayons avec plusieurs algèbres de Kleene. Commençons par un calcul de distance dans un graphe orienté :
module MinPlus =
struct
type t = Infty | Int of int
let zero = Infty
let one = Int 0
let add i j = match i, j with
| Int i, Int j -> Int (min i j)
| Infty, _ -> j
| _, Infty -> i
let mult i j = match i, j with
| Int i, Int j -> Int (i+j)
| _ -> Infty
let pp ppf = function
| Int i -> Format.fprintf ppf "%3d" i
| Infty -> Format.pp_print_string ppf "+oo"
end
module KleeneMinPlus =
struct
module S = MinPlus
let star i = S.Int 0
end
module D8 = struct
let dim = 8
end
On utilise le semi-anneau $(\min,+)$ : on veut calculer le minimum de la somme des longueurs de chaque chemin. L'étoile est utilisée pour boucler sur un sommet, dans cette application, boucler sur un sommet ne coûte rien : cela veut dire faire du sur-place. On applique maintenant les foncteurs :
module MatrixMinPlus8 = MakeMatrix(D8)(MinPlus)
module SemiringMinPlus8 = MakeMatrixSemiring(MatrixMinPlus8)(MinPlus)
module FWMinPlus8 = MakeFloydWarshall(KleeneMinPlus)(MatrixMinPlus8)
Testons en écrivant une fonction de génération aléatoire d'une matrice. Il suffit d'une fonction aléatoire pour les coefficients, et d'appeler MatrixMinPlus8.create avec.
let random_MinPlus_coef p =
if Random.float 1. < p then MinPlus.Int 1 else MinPlus.Infty
let random_mat p =
MatrixMinPlus8.create (fun i j -> random_MinPlus_coef p)
let mat = random_mat 0.3
let mat_close = FWMinPlus8.close mat
On installe le formatteur pour les matrices, puis on teste :
# #install_printer MatrixMinPlus8.pp;;
# let mat = random_mat 0.3;;
val mat : MatrixMinPlus8.t =
+oo 1 1 +oo +oo +oo +oo +oo
+oo +oo 1 +oo +oo +oo +oo +oo
1 1 +oo +oo 1 +oo +oo +oo
1 +oo +oo +oo 1 +oo +oo 1
1 +oo +oo 1 +oo +oo +oo +oo
+oo 1 +oo 1 +oo +oo +oo +oo
+oo 1 +oo +oo +oo +oo +oo +oo
+oo +oo +oo +oo +oo +oo +oo +oo
# let mat_close = FWMinPlus8.close mat;;
val mat_close : MatrixMinPlus8.t =
2 1 1 3 2 +oo +oo 4
2 2 1 3 2 +oo +oo 4
1 1 2 2 1 +oo +oo 3
1 2 2 2 1 +oo +oo 1
1 2 2 1 2 +oo +oo 2
2 1 2 1 2 +oo +oo 2
3 1 2 4 3 +oo +oo 5
+oo +oo +oo +oo +oo +oo +oo +oo
Un dessin permet ensuite de vérifier que le résultat est bien la matrice des distances du graphe. Il serait néanmoins plus intéressant de connaître aussi les plus courts chemins. Pour cela, il suffit de changer de semi-anneau. Profitons-en pour généraliser l'algorithme pour le cas où les arêtes possèdent des longueurs arbitraires positives. Pour ne pas choisir entre des longueurs entières ou flottantes, on peut à nouveau introduire un foncteur :
module MakeMinPlusPath = functor (SR : Semiring) ->
struct
module S =
struct
let (<=) x y = SR.add x y = x
type t =
| NoPath
| Path of SR.t * (int * int) list
let zero = NoPath
let one = Path (SR.one, [])
let add p1 p2 =
match p1, p2 with
| Path (len1,_), Path (len2, _) when len1 <= len2 -> p1
| Path _, Path _ -> p2
| NoPath,_ -> p2
| _,NoPath -> p1
let mult p1 p2 =
match p1, p2 with
| Path (len1,p1), Path (len2,p2) -> Path (SR.mult len1 len2, p1 @ p2)
| _ -> NoPath
let pp_edge ppf (i,j) = Format.fprintf ppf "(%d,%d)" i j
let pp_edges ppf list =
let open Format in
pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";") pp_edge ppf list
let pp ppf = function
| NoPath -> Format.pp_print_string ppf "ø"
| Path (len,list) ->
Format.fprintf ppf "%a:[%a]" SR.pp len pp_edges list
end
let star p = S.one
end
Pour l'instancier sur des longueurs flottantes, on crée un semi-anneau
$(\min,+)$ des flottants, et on applique le foncteur MakeMinPlusPath.
module FloatSR =
struct
type t = float
let zero = infinity
let one = 0.
let add = min
let mult = (+.)
let pp = Format.pp_print_float
end
module MinPlusPath = MakeMinPlusPath(FloatSR)
Nous sommes prêt à produire les matrices et l'algorithme de Floyd-Warshall :
module D5 = struct let dim = 5 end
module MatrixMinPlusPath5 = MakeMatrix(D5)(MinPlusPath.S)
module SemiringMinPlusPath5 =
MakeMatrixSemiring(MatrixMinPlusPath5)(MinPlusPath.S)
module FWMinPlusPath5 = MakeFloydWarshall(MinPlusPath)(MatrixMinPlusPath5)
De nouveau, on ajoute un générateur aléatoire et on teste sur un exemple.
let random_MinPlusPath_coef p i j =
if i = j then
MinPlusPath.S.(Path (0.,[]))
else if Random.float 1. < p then
MinPlusPath.S.(Path (Random.float 10., [(i,j)]))
else
MinPlusPath.S.NoPath
let random_float_mat p =
MatrixMinPlusPath5.create (random_MinPlusPath_coef p)
# #install_printer MatrixMinPlusPath5.pp;;
# let mat = random_float_mat 0.4;;
val mat : MatrixMinPlusPath5.t =
0.:[] ø ø 0.819736241165:[(1,4)] ø
0.407159120634:[(2,1)] 0.:[] ø ø 5.61633446903:[(2,5)]
6.9831845109:[(3,1)] ø 0.:[] ø ø
ø 2.61599931405:[(4,2)] ø 0.:[] ø
ø ø 2.13522490529:[(5,3)] ø 0.:[]
# let mat_close = FWMinPlusPath5.close mat;;
val mat_close : MatrixMinPlusPath5.t =
0.:[]
3.43573555521:[(1,4);(4,2)]
11.1872949295:[(1,4);(4,2);(2,5);(5,3)]
0.819736241165:[(1,4)]
9.05207002424:[(1,4);(4,2);(2,5)]
0.407159120634:[(2,1)]
0.:[]
7.75155937432:[(2,5);(5,3)]
1.2268953618:[(2,1);(1,4)]
5.61633446903:[(2,5)]
6.9831845109:[(3,1)]
10.4189200661:[(3,1);(1,4);(4,2)]
0.:[]
7.80292075206:[(3,1);(1,4)]
16.0352545351:[(3,1);(1,4);(4,2);(2,5)]
3.02315843468:[(4,2);(2,1)]
2.61599931405:[(4,2)]
10.3675586884:[(4,2);(2,5);(5,3)]
0.:[]
8.23233378308:[(4,2);(2,5)]
9.11840941618:[(5,3);(3,1)]
12.5541449714:[(5,3);(3,1);(1,4);(4,2)]
2.13522490529:[(5,3)]
9.93814565735:[(5,3);(3,1);(1,4)]
0.:[]
On termine avec un exemple sensiblement différent : construire l'expression régulière reconnue par un automate fini. Pour cela, il suffit d'utiliser Floyd-Warshall sur l'algèbre de Kleene usuelle sur les langages réguliers. Cette application a un problème : les expressions régulières générées peuvent être extrêmement longues. Pour éviter cela, nous allons regarder des automates tout petits et utiliser des règles de simplification sur les expressions régulières. Cela rend la définition des expressions régulières assez complexes. Par ailleurs, on ne veut pas imposer le type des lettres de l'alphabet, donc nous allons encore ajouter un foncteur !
module type Alphabet =
sig
type letter
val pp : Format.formatter -> letter -> unit
end
On ajoute quelques fonctions utilitaires puis le foncteur pour créer le type des expressions régulières sur un alphabet :
type 'elt at_least_two_elts_list =
('elt * 'elt list * 'elt)
type 'elt list_ends =
| No_ends
| Single_end of 'elt
| Double_ends of 'elt * 'elt list * 'elt
let rec insert_ends head tail =
match observe_list_ends tail with
| No_ends -> Single_end head
| Single_end last -> Double_ends (head,[],last)
| Double_ends (snd,middle,last) -> Double_ends (head,snd::middle,last)
and observe_list_ends = function
| [] -> No_ends
| head::tail -> insert_ends head tail
module MakeRegexp :
functor (A : Alphabet) ->
sig
type regexp =
| Empty
| Epsilon
| Letter of A.letter
| Or of regexp at_least_two_elts_list
| Concat of regexp at_least_two_elts_list
| Star of regexp
include KleeneAlgebra with type S.t = regexp
end
= functor (A : Alphabet) ->
struct
type regexp =
| Empty
| Epsilon
| Letter of A.letter
| Or of regexp at_least_two_elts_list
| Concat of regexp at_least_two_elts_list
| Star of regexp
let zero = Empty
let one = Epsilon
let to_or list =
match observe_list_ends list with
| No_ends -> Empty
| Single_end elt -> elt
| Double_ends (head,middle,last) -> Or (head, middle, last)
let of_triple (head,middle,last) =
head :: middle @ [last]
let to_concat list =
match observe_list_ends list with
| No_ends -> Epsilon
| Single_end elt -> elt
| Double_ends (head,middle,last) -> Concat (head,middle,last)
let merge = List.merge ~cmp:compare
let rec contains regexp1 regexp2 =
regexp1 = regexp2 ||
match regexp1, regexp2 with
| _, Star e when contains regexp1 e -> true
| Star e1, Star e2 -> contains e1 regexp2
| _, Or (head,middle,tail) ->
List.exists ~f:(contains regexp1) (head::tail::middle)
| don't_know -> false
let rec insert e = function
| head::tail when contains head e -> e::tail
| head::tail as list when contains e head -> list
| head::tail when head < e -> head :: insert e tail
| list -> e::list
let rec add_concat ((head1,mid1,tail1) as re1) ((head2,mid2,tail2) as re2) =
if head1 = head2 then
mult head1 (add (to_concat (mid1@[tail1])) (to_concat (mid2@[tail2])))
else if tail1 = tail2 then
mult (add (to_concat (head1::mid1)) (to_concat (head2::mid2))) tail1
else Or (Concat re1,[],Concat re2)
and add e1 e2 = match e1, e2 with
| Empty, e
| e, Empty -> e
| Epsilon, Star e
| Star e, Epsilon -> Star e
| Epsilon, Concat (Star e1,[],e2) when e1 = e2 -> Star e1
| Epsilon, Concat (e1,[],Star e2) when e1 = e2 -> Star e1
| Concat (e1,[],Star e2), Epsilon when e1 = e2 -> Star e1
| Concat (Star e2,[],e1), Epsilon when e1 = e2 -> Star e1
| e, Concat (head,middle,last) when e = head ->
mult e (add Epsilon (to_concat (middle@[last])))
| e, Concat (head,middle,last) when e = last ->
mult (add Epsilon (to_concat (head::middle))) e
| Concat (head,middle,last), e when e = head ->
mult e (add Epsilon (to_concat (middle@[last])))
| Concat (head,middle,last), e when e = last ->
mult (add Epsilon (to_concat (head::middle))) e
| e1, e2 when e1 = e2 -> e1
| Or regexps1, Or regexps2 ->
to_or (merge (of_triple regexps1) (of_triple regexps2))
| e, Or regexps
| Or regexps, e -> to_or (insert e (of_triple regexps))
| Concat regexps1, Concat regexps2 -> add_concat regexps1 regexps2
| _, _ -> Or (e1,[],e2)
and mult e1 e2 = match e1, e2 with
| Epsilon, e
| e, Epsilon -> e
| Empty, _
| _, Empty -> Empty
| Concat (head1,mid1,last1), Concat (head2,mid2,last2) ->
Concat (head1,mid1 @ [last1; head2] @ mid2,last2)
| Concat (head,mid,last), e -> Concat (head,mid@[last],e)
| Star e1, Star e2 when contains e1 e2 -> Star e2
| Star e1, Star e2 when contains e2 e1 -> Star e1
| _ -> Concat (e1,[],e2)
and star = function
| Empty -> Epsilon
| Epsilon -> Epsilon
| e -> Star e
let rec pp_re ppf = function
| Or regexps ->
Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "@,|")
pp_re
ppf
(of_triple regexps)
| e -> pp_term ppf e
and pp_term ppf = function
| Concat regexps ->
Format.pp_print_list
pp_term
ppf
(of_triple regexps)
| e -> pp_factor ppf e
and pp_factor ppf = function
| Empty -> Format.pp_print_string ppf "ø"
| Epsilon -> Format.pp_print_string ppf "e"
| Letter a -> A.pp ppf a
| Star e -> Format.fprintf ppf "@[%a*@]" pp_factor e
| e -> Format.fprintf ppf "@[(%a)@]" pp_re e
module S = struct
type t = regexp
let zero = zero
let one = one
let add = add
let mult = mult
let pp = pp_re
end
end
Maintenant, on utilise les différents foncteurs pour obtenir notre instance de l'algorithme de Floyd-Warshall, appliqué aux expressions régulières sur un alphabet à deux lettres :
module D2 = struct
let dim = 2
end
module AB = struct
type letter = A | B
let pp ppf = function
| A -> Format.pp_print_string ppf "a"
| B -> Format.pp_print_string ppf "b"
end
module ReAB = MakeRegexp(AB)
module Automata = MakeMatrix(D2)(ReAB.S)
module FWAutomata = MakeFloydWarshall(ReAB)(Automata)
On crée un automate, et on teste :
# #install_printer Automata.pp;;
# let aut1 =
Automata.create
(fun i j -> match i,j with
| 1,1 -> ReAB.Letter AB.A
| 1,2 -> ReAB.Letter AB.B
| 2,1 -> ReAB.Empty
| 2,2 -> ReAB.(S.add (Letter AB.A) (Letter AB.B))
| _ -> ReAB.Empty
);;
val aut1 : Automata.t =
a b
ø a|b
# let aut2 = FWAutomata.close aut1;;
val aut2 : Automata.t =
aa* a*b(a|b)*
ø (a|b)(a|b)*
Avec des automates aléatoires :
let random_arc i j =
match Random.int 5 with
| 0 -> ReAB.Letter AB.A
| 1 -> ReAB.Letter AB.B
| 2 -> ReAB.S.add (ReAB.Letter AB.A) (ReAB.Letter AB.B)
| 3 -> ReAB.Epsilon
| _ -> ReAB.Empty
let random_automaton () =
Automata.create random_arc
# let aut3 = random_automaton ();;
val aut3 : Automata.t =
e ø
b a
# let aut4 = FWAutomata.close aut3;;
val aut4 : Automata.t =
e ø
a*b aa*
# let aut5 = random_automaton ();;
val aut5 : Automata.t =
e a|b
a|b b
# let aut6 = FWAutomata.close aut5;;
val aut6 : Automata.t =
e|(a|b)(b|(a|b)(a|b))*(a|b) (a|b)(b|(a|b)(a|b))*
(b|(a|b)(a|b))*(a|b) (b|(a|b)(a|b))(b|(a|b)(a|b))*
Impeccable: chaque coefficient $c_{i,j}$ est une expression régulière pour le language des mots permettant d'aller de l'état $i$ vers l'état
$j$, comme attendu.
Retour au sommaire.