type regexp =
  | Mot of string
  | Ou of regexp * regexp
  | Et of regexp * regexp
  | Etoile of regexp;;

(* QUESTION 1 ============================================================== *)

let non_consecutif =
  Et ( Etoile ( Ou ( Mot "ba", 
                     Mot "a" 
                   )
              ),
       Ou ( Mot "b", 
            Mot "" 
          )
     );;

let ab_ou_ba =
  Et ( Etoile ( Ou ( Mot "a",
                     Mot "b" 
                   )
              ),
       Ou ( Mot "ab", 
            Mot "ba"
          )
     );;

(* QUESTION 2 ============================================================== *)

type auto_ndet =
    {
      etats : int;
      char : (char * int * int) list;
      epsilon : (int * int) list;
    };; 
      
let make_auto n char epsilon =
  {
    etats = n;
    char = char;
    epsilon = epsilon;
  };;

let auto_non_consecutif =
  make_auto 3
    [ `a`, 0, 0; `b`, 0, 1; 
      `a`, 1, 0 ]
    [ 0, 2; 1, 2 ];;

let auto_ab_ou_ba =
  make_auto 4
    [ `a`, 0, 0; `b`, 0, 0;
      `a`, 0, 1; `b`, 0, 2;
      `b`, 1, 3; `a`, 2, 3 ]
    [];;

(* QUESTION 3 ============================================================== *)

let decaler auto n =
  {
    etats = auto.etats + n;
    char = map (fun (c,i,j) -> (c,i+n,j+n)) auto.char;
    epsilon = map (fun (i,j) -> (i+n,j+n)) auto.epsilon;
  };;

let fusionner n a b liens =
  {
    etats = n;
    char = a.char @ b.char;
    epsilon = liens @ a.epsilon @ b.epsilon;
  };;

let et a b = 
  let na = a.etats and nb = b.etats in
  fusionner 
    (na + nb) a (decaler b na) [ na-1, na ];;

let ou a b =
  let na = a.etats and nb = b.etats in
  fusionner
    (na + nb) a (decaler b na) [ 0, na; na-1, na+nb-1 ];;

let etoile a =
  let na = a.etats in 
  {
    etats = na;
    char = a.char;
    epsilon = (0,na-1) :: (na-1,0) :: a.epsilon;
  };;


(* QUESTION 4 ============================================================== *)

let mot w = 
  let n = string_length w in
  let rec char i = 
    if i = n 
    then [] 
    else (w.[i],i,i+1) :: char (i+1)
  in
  { etats = n+1; char = char 0; epsilon = [] };;

let rec transforme = function
  | Mot w -> mot w
  | Ou (a,b) -> ou (transforme a) (transforme b)
  | Et (a,b) -> et (transforme a) (transforme b)
  | Etoile a -> etoile (transforme a);;

(* QUESTION 5 ============================================================== *)

let rec insere e = function
  | [] -> [e]
  | t::q -> 
      if t = e then t :: q 
      else if t < e then t :: insere e q
      else e :: t :: q;;

let applique_epsilon etats transitions =
  let rec etape vieux = function
    | [] -> vieux
    | (i,j)::q ->
        let t = etape vieux q in
        if mem i vieux then insere j t else t
  in
        
  let rec pointfixe vieux = 
    let nouveau = etape vieux transitions in
    if nouveau <> vieux 
    then pointfixe nouveau 
    else nouveau
  in

  pointfixe etats;;

let rec applique_transition c etats = function
  | [] -> []
  | (c',i,j) :: t ->
      let t = applique_transition c etats t in
      if c = c' && mem i etats then insere j t else t;;

let reconnaitre auto mot =
  let etats = ref [0] in
  for i = 0 to string_length mot - 1 do
    etats := 
      applique_transition mot.[i]
        (applique_epsilon !etats auto.epsilon) auto.char
  done;
  mem (auto.etats - 1) (applique_epsilon !etats auto.epsilon);;

(* QUESTION DIFFICILE ====================================================== *)

type auto_d =
    {
      transitions : (char * int) list vect;
      initial : int;
      final : bool vect;
    };;

let append v x = 
  init_vect 
    (vect_length v + 1) 
    (fun i -> if i = vect_length v then x else v.(i));;

let determiniser alphabet auto =
  
  (* On utilise une fonction de travail récursif qui prend en argument
       - états : un tableau associant à chaque indice (état de l'automate
         déterministe) une liste d'entiers triée (état de 
       - transitions : les transitions sortantes des états calculés
         pour l'instant.
       - final : l'état de finalité des états vus pour l'instant.
       - (dernier,i) : le prochain état pour lequel on doit 
         effectuer un traitement. i représente la prochaine lettre
         de l'alphabet à traiter pour cet état.
  *)
  let rec travail etats transitions final (dernier,i) = 
    if dernier = vect_length etats then 
      (* On a fini: tous les états ont été traités. *)
      {
        transitions = transitions;
        final = final;
        initial = 0;
      }

    else if (i >= string_length alphabet) then
      (* On a épuisé toutes les lettres pour cet état. on a donc
         fini de le traiter, et on peut passer à l'état suivant *)
      travail etats transitions final (dernier+1,0)

    else begin
      (* On traite une lettre de l'alphabet: partant du dernier
         état, on trouve vers quel état on va. *)
      let lettre = alphabet.[i] in
      let destination = 
        applique_epsilon 
          (applique_transition lettre etats.(dernier) auto.char)
          auto.epsilon
      in

      (* Puis, on ajoute l'état destination s'il n'existe pas, sinon 
         on extrait son indice. *)
      let (cible,etats,transitions,final) = 

        let cible = ref 0 in
        while 
          !cible < vect_length etats && 
          etats.(!cible) <> destination 
        do 
          incr cible 
        done;
        let cible = !cible in

        if (cible < vect_length etats) then 
          (* La cible fait partie des états connus *)
          (cible, etats, transitions, final)

        else 
          (* Agrandir les états connus pour y incorporer la cible. *)
          (cible, 
          (append etats destination),
          (append transitions []),
          (append final (mem (auto.etats - 1) destination)))
      in

      transitions.(dernier) <- (lettre,cible) :: transitions.(dernier);
      travail etats transitions final (dernier,i+1)
    end
  in

  let initial = applique_epsilon [0] auto.epsilon in

  travail 
    [| initial |] 
    [| [] |] 
    [| mem (auto.etats - 1) initial |] 
    (0,0);;

(* Bonus: une fonction de dessin qui sort les graphes au 
   format compatible dot. 

   Voir: http://www.graphviz.org/
*)

let print e = 
  print_string "digraph G {\n rankdir = LR;\n  node [shape = circle]; \n";
  do_list (fun (c,i,j) -> 
    printf__printf "  {edge [label = \"%c\"]; %d -> %d; }\n"
      c i j)
    e.char ;
  do_list (fun (i,j) ->
    printf__printf "  {edge [arrowhead = onormal]; %d -> %d; }\n"
      i j)
    e.epsilon;
  print_string "}\n\n";;

let print_det e =
  print_string "digraph G {\n rankdir = LR;\n";
  let n = vect_length e.final in
  for i = 0 to n - 1 do
    printf__printf "  { node [shape = %s]; %d; }\n"
      (if e.final.(i) then "doublecircle" else "circle")
      i
  done;
  for i = 0 to n - 1 do
    do_list (fun (c,j) ->
      printf__printf "  { edge [label = \"%c\"]; %d -> %d; }\n"
        c i j) e.transitions.(i)
  done;
  print_string "}\n\n";;
  
print_det (determiniser "ab" (transforme non_consecutif));;