(* Traduction d'une expression régulière en un automate *)

#open "genlex";;

(* Transformation d'une chaîne en liste de caractères *)
let listchar_of_string = 
  let rec aux i s =
    if (i = string_length s)
    then []
    else (Char s.[i])::(aux (i+1) s)
  in aux 0;;

(* Transformation d'un flux en liste *)
let rec list_of_stream = function
  | [< 'Ident s; list_of_stream q >] -> (listchar_of_string s)@q
  | [< 't; list_of_stream q >] -> t::q
  | [< >] -> []
;;

(* Transformation d'une expression régulière en liste de token *)
let toklist_of_regexp re = 
  list_of_stream (make_lexer ["*";"[";"]"] (stream_of_string re));;

(* Transformation d'une liste de tokens en une chaîne *)
let rec string_of_toklist = function
  | [] -> ""
  | (Kwd s)::q -> s^(string_of_toklist q)
  | (Ident s)::q -> s^(string_of_toklist q)
  | (Int n)::q -> (string_of_int n)^(string_of_toklist q)
  | (Float f)::q -> (string_of_float f)^(string_of_toklist q)
  | (String s)::q -> s^(string_of_toklist q)
  | (Char c)::q -> (char_for_read c)^(string_of_toklist q)
;;

(* On cherche à transformer une expression rationnelle en un automate. Il faut
   donc déterminer à partir de la chaîne de caractères en argument la liste des
   transitions, ainsi que l'état final. 

   Une expression régulière sera composé de caractères et d'un certain nombre de
   terminaux : '*', '[' et ']'. '*' a sa signification normale : répétition d'au
   moins zéro fois le caractère précédent. Les crochets dénotent l'union :
   "[ab]" signifie 'a' ou 'b'. La concaténation est une simple juxtaposition.
   
   Exemple : "abc*[ab]*c"
*)
let rec liste_trans last_chars curr_state accu = function
  |[] -> 
     begin
       match last_chars with
	      | [] -> accu, curr_state
	      | _ -> 
	          let new_trans = map (function c -> ((curr_state, c), curr_state+1)) last_chars
	          in (accu@new_trans), curr_state+1
     end
  |(Kwd "[")::q -> 
     let (new_trans, new_state) = 
       (match last_chars with
	       |[] -> [], curr_state
	       | _ -> map (function c -> ((curr_state, c), curr_state+1)) last_chars, curr_state+1
       )
     and (new_chars, reste) = lit_union [] q
     in liste_trans new_chars new_state (accu@new_trans) reste
  |(Kwd "*")::q -> 
     let new_trans = 
       (match last_chars with
	       | [] -> failwith "* mal placé"
	       | _ -> map (function c -> ((curr_state, c), curr_state)) last_chars
       )
     in liste_trans [] curr_state (accu@new_trans) q
  |(Char c)::q -> 
     let (new_trans, new_state) = 
       (match last_chars with
	       |[] -> [], curr_state
	       | _ -> map (function c -> ((curr_state, c), curr_state+1)) last_chars, curr_state+1
       )
     in liste_trans [c] new_state (accu@new_trans) q
  | _ as l -> failwith ("Expression incorrecte à partir de '"^(string_of_toklist l)^"'")
and lit_union accu = function
  |[] -> failwith "Pas de crochet fermant"
  |(Kwd "]")::q -> (accu, q)
  |(Kwd c)::_ -> failwith "Pas de crochet fermant"
  |(Char c)::q -> lit_union (c::accu) q
  | _ as l -> failwith ("Expression incorrecte à partir de '"^(string_of_toklist l)^"'")
;;

liste_trans [] 1 [] (toklist_of_regexp "ab*c[ab]*c");;
liste_trans [] 1 [] (toklist_of_regexp "*c[ab]*c");;
liste_trans [] 1 [] (toklist_of_regexp "ab* *[ab]*c");;
liste_trans [] 1 [] (toklist_of_regexp "ab*c[ab*d");;
liste_trans [] 1 [] (toklist_of_regexp  "ab*cab]*c");;

(* Automate. Les états sont codés comme des entiers. *)
type Etat == int;;
type automate = { initial: Etat;
		            trans: (Etat * char) -> Etat ;
		            final: Etat };;

(* Transformation de l'expression en un automate. L'état 1 est l'état
   initial. On se réserve l'état zéro comme puits en cas de non-existence d'une
   transition. *)
let automate_of_regexp expr =
  let (transitions, last_state) = liste_trans [] 1 [] (toklist_of_regexp expr)
  in {initial = 1 ;
      trans = (function (e,c) -> try assoc (e,c) transitions with Not_found -> 0) ;
      final = last_state }
;;

automate_of_regexp "ab*c[ab]*c";;

(* Test final : on exécute un automate sur une chaîne et on rend le résultat
   comme vrai ou faux, selon que l'état d'arrivé est final ou non. *)
let execute auto str = 
  let rec aux i etat = 
    if i = (string_length str)
    then etat = auto.final
    else aux (i+1) (auto.trans (etat, str.[i]))
  in aux 0 auto.initial;;

execute (automate_of_regexp "ab*c[ab]*c") "abcabc";;
execute (automate_of_regexp "ab*c[ab]*c") "acabc";;
execute (automate_of_regexp "ab*c[ab]*c") "abcacbc";;
execute (automate_of_regexp "[abc]*") "";;