Premières définitions :

type etat = int;;
type liste_etats = etat list;;

type symbole = int;;
type mot = symbole list;;

type afnd = { initiaux : liste_etats;
              terminaux : liste_etats;
              delta : liste_etats array array };;

Union/intersection (complexité quadratique, sans garantir l'ordre)

let rec union lst1 lst2 = match lst2 with
  | [] -> lst1
  | t::q when List.mem t lst1 -> union lst1 q
  | t::q -> t::union lst1 q;;

let rec intersection lst1 lst2 = match lst2 with
  | [] -> []
  | t::q when List.mem t lst1 -> t::intersection lst1 q
  | t::q -> intersection lst1 q;;

Union/intersection (complexité linéaire, garantissant l'ordre)

let rec union lst1 lst2 = match lst1, lst2 with
  | _, [] -> lst1
  | [], _ -> lst2
  | t1::q1, t2::q2 when t1<t2 -> t1::union q1 lst2
  | t1::q1, t2::q2 when t2<t1 -> t2::union lst1 q2
  | t1::q1, t2::q2 -> t1::union q1 q2;;

let rec intersection lst1 lst2 = match lst1, lst2 with
  | _, [] -> []
  | [], _ -> []
  | t1::q1, t2::q2 when t1<t2 -> intersection q1 lst2
  | t1::q1, t2::q2 when t2<t1 -> intersection lst1 q2
  | t1::q1, t2::q2 -> t1::union q1 q2;;

Pour lire un caractère

let rec lit_car automate etats c = match etats with
  | [] -> []
  | t::q -> union automate.delta.(t).(c) (lit_car automate q c);;

Pour lire un mot, deux possibilités

let rec lit_mot automate etats w = match w with
  | [] -> etats
  | t::q -> lit_mot automate (lit_car automate etats t) q;;

let lit_mot automate = List.fold_left (lit_car automate);;

Pour tester l'appartenance d'un mot au langage

let teste automate w =
  intersection (lit_mot automate automate.initiaux w) automate.terminaux
    <> [];;

Pour construire l'automate local

let construit_local p ens_p ens_s ens_f =
  let automate = { initiaux=[p]; terminaux=ens_s;
                   delta=Array.make_matrix (p+1) p [] } in
  List.iter (fun e -> automate.delta.(p).(e) <- [e]) ens_p;
  List.iter (fun (u, v) -> automate.delta.(u).(v) <- [v]) ens_f;
  automate;;

On teste :

let p1 = [1; 2] and s1 = [0]
and f1 = [(0,1); (0,2); (1,0); (1,2); (2,0); (2,1)];;

let automate1 = construit_local 3 p1 s1 f1;;

teste automate1 [1;2;1;0;2;2;1;0];;

Expressions régulières et fonctions fournies

type regexp =
  | Constante of int list
  | Etoile of regexp
  | Concatenation of regexp * regexp
  | Choix of regexp * regexp;;

let rec contientMotVide = function
  | Constante [] -> true
  | Constante _ -> false
  | Etoile e -> true
  | Concatenation (e,f) -> contientMotVide e && contientMotVide f
  | Choix (e,f) -> contientMotVide e || contientMotVide f;;

let rec prefixes = function
  | Constante [] -> []
  | Constante lst -> [ List.hd lst ]
  | Etoile e -> prefixes e
  | Concatenation (e,f) when contientMotVide e -> prefixes e @ prefixes f
  | Concatenation (e,f) -> prefixes e
  | Choix (e,f) -> prefixes e @ prefixes f;;

let rec suffixes = function
  | Constante [] -> []
  | Constante lst -> [ List.hd (List.rev lst) ]
  | Etoile e -> suffixes e
  | Concatenation (e,f) when contientMotVide f -> suffixes e @ suffixes f
  | Concatenation (e,f) -> suffixes f
  | Choix (e,f) -> suffixes e @ suffixes f;;

let rec produit = function
  | ([], _) -> []
  | (_, []) -> []
  | (t::q, lst) -> List.map (fun c -> (t, c)) lst @ (produit (q, lst));;

let rec facteurs2 = function
  | Constante lst -> let rec paires = function
                       | t1::t2::q -> (t1, t2)::paires (t2::q)
                       | _ -> []
                     in paires lst
  | Etoile e -> (facteurs2 e) @ (produit (suffixes e, prefixes e))
  | Concatenation (e,f) -> (facteurs2 e) @ ((facteurs2 f)
                           @ (produit (suffixes e, prefixes f)))
  | Choix (e,f) -> (facteurs2 e) @ (facteurs2 f);;

Pour compiler une expression régulière

let compile_regex r =
  let rec max_s = function
    | Constante lst -> List.fold_left max 0 lst
    | Etoile r -> max_s r
    | Concatenation (r1, r2)
    | Choix (r1, r2) -> max (max_s r1) (max_s r2)
  in construit_local (max_s r + 1) (prefixes r)
                     (suffixes r) (facteurs2 r);;

Testons !

let r2 = Concatenation (Etoile (Choix (Constante [0], Constante [1; 2])),
                        Concatenation (Etoile (Constante [3]), (Constante [4])));;

let automate2 = compile_regex r2;;

teste automate2 [0;0;1;2;0;1;2;3;3;3;4];;

Un type pour les automates finis déterministes

type afd = { initial : etat;
             terminaux : liste_etats;
             delta : etat array array };;

La déterminisation utilise un dictionnaire qui, à tout ensemble d'états dans l'AFND, associe l'identifiant dans l'AFD que l'on construit et la liste des transitions partant de cet état. Ce dictionnaire est construit par une exploration en profondeur dans l'AFND (fonction récursive explore, qui ultimement renvoie l'identifiant associé à la liste d'états passé en argument). Précisons que la ligne avec List.sort n'est utile que si l'invariant d'ordre des états dans les listes d'état n'est pas garanti, elle est inutile sinon.

let determinise automate =
  let initiaux = automate.initiaux in
  let p = Array.length automate.delta.(0) in (* Nombre de symboles *)
  let d = Hashtbl.create 42 in (* liste_etats => (int, int array)
                                                 (ident., transitions) *)
  let rec explore (etats:liste_etats) = (* liste_etats -> int (ident.) *)
    let etats = List.sort compare etats in
    if Hashtbl.mem d etats
      then fst (Hashtbl.find d etats)
      else begin
             let transitions = Array.make p (-1) in
             let i = Hashtbl.length d in
             Hashtbl.add d etats (i, transitions);
             for c = 0 to p-1 do
               transitions.(c) <- explore (lit_car automate etats c)
             done;
             i
           end
  in let initial = explore initiaux in
     let delta = Array.make (Hashtbl.length d) [||] in
     let terminaux = ref [] in
     Hashtbl.iter (fun etats (i, transitions) 
                   -> delta.(i) <- transitions; 
                      if intersection etats automate.terminaux <> []
                        then terminaux := i::!terminaux)
                  d;
     { initial=initial; terminaux= !terminaux; delta=delta };;

On teste

let teste_afd automate mot =
  List.mem (List.fold_left (fun q c -> automate.delta.(q).(c)) automate.initial mot)
           automate.terminaux;;

let automate3 = determinise (automate2);;

teste_afd automate3 [0;0;1;2;0;1;2;3;3;3;4];;