type 'a erat=
|  Eps
| L of 'a
| Plus of 'a erat * 'a erat
| Conc of 'a erat * 'a erat
| Etoile of 'a erat
;;

let rec contient_eps e=match e with
  | Eps | Etoile _ -> true
  | L _ -> false
  | Plus (a,b) -> contient_eps a || contient_eps b
  | Conc (a,b) -> contient_eps a && contient_eps b
;;

let supprime_doublons l=
  let rec aux acc q=match q with
    | [] -> acc
    | x::p when List.mem x acc -> aux acc p
    | x::p -> aux (x::acc) p
  in aux [] l
;;

let union l1 l2 = supprime_doublons (l1@l2) ;;

let pcar l1 l2=
  let rec aux acc q=match q with
    | [] -> acc
    | x::p -> aux ((List.map (function y -> (x,y)) l2)@acc) p
  in (aux [] l1)
;;

let rec calcule_car e=match e with
  | Eps -> [], [], [], true
  | L x -> [x], [x], [], false
  | Plus (f, g) -> let p1,s1,f1, b1=calcule_car f and p2,s2,f2,b2=calcule_car g in 
                 (union p1 p2),(union s1 s2),(union f1 f2), b1 || b2
  | Conc (f, g) -> let p1,s1,f1,b1=calcule_car f and p2,s2,f2,b2=calcule_car g in begin match b1,b2 with
    | false, false -> p1, s2, union f1 (union f2 (pcar s1 p2)), false
    | false, true -> p1, union s1 s2, union f1 (union f2 (pcar s1 p2)), false
    | true, false -> union p1 p2, s2, union f1 (union f2 (pcar s1 p2)), false
    | true, true -> union p1 p2, union s1 s2, union f1 (union f2 (pcar s1 p2)), true
  end
  | Etoile f -> let p, s, f, _=calcule_car f in p, s, union f (pcar s p), true
;;  

let linearisation e=
  let rec aux f p liste=match f with
    | Eps -> Eps,p,liste
    | L a -> (L p), (p+1), ((p,a)::liste)
    | Plus (a,b) -> let a2,q,l2=aux a p liste in let b2,r,l3=aux b q l2 in (Plus (a2,b2)), r, l3
    | Conc (a,b) -> let a2,q,l2=aux a p liste in let b2,r,l3=aux b q l2 in (Conc (a2,b2)), r, l3
    | Etoile a -> let a2,q,l2=aux a p liste in (Etoile a2), q, l2
  in let e2,p,l2=aux e 0 [] in e2, (List.rev l2)
;;

let e=Plus (Conc (Plus (L 'a', L 'b'), Etoile (L 'c')), Conc (Etoile (L 'a'), L 'b')) ;;
linearisation e ;;


type ('a,'b) automate={init: 'a list ; finaux: 'a list ; delta: (('a * 'b) * 'a) list } ;;

(* états: les entiers de 0 à n-1, les transitions naturelles obtenues par multiplication par 10 + rajout du nombre lu, état final 0 *)

let gen_automate_div n=
  let t=ref [] in
  for i=0 to n-1 do
    for j=0 to 9 do
      t:=((i,j),(i*10+j) mod n):: !t
    done 
  done ;
  {init=[0] ; finaux=[0] ; delta= !t}
;;

let accepte a m=
  let q= ref (List.hd a.init) and liste=ref m in
  try
    while !liste <> [] do
      q:=List.assoc (!q,(List.hd !liste)) a.delta ;
      liste:= List.tl !liste ;
    done ;
  List.mem !q a.finaux
  with Not_found -> false
;;

let accepte2 a m=
  try
  let rec aux q liste=match liste with
    | [] -> List.mem q a.finaux
    | x::p -> aux (List.assoc (q,x) a.delta) p
  in aux (List.hd a.init) m
  with Not_found -> false
;;

let separe_entier n=
  let rec aux acc m=match m with
    | 0 -> acc
    | _ -> aux ((m mod 10)::acc) (m/10)
  in aux [] n
;;

let rajoute_sans_doublon x l=
  if List.mem x l then l else x::l 
;;


let alphabet a=
  let rec aux acc liste=match liste with
    | [] -> acc
    | ((b,x),c)::q when List.mem x acc -> aux acc q
    | ((b,x),c)::q  -> aux (x::acc) q
  in aux [] a.delta
;;

let rec fission q=match q with
  | [] | [_] -> q,[]
  | x::y::p -> let q1,q2=fission p in x::q1, y::q2 
;;

let rec fusion q1 q2=match (q1, q2) with
  | [],_ | _,[] -> q1@q2
  | x::p1, y::_ when x<=y -> x::(fusion p1 q2)
  | _,y::p -> y::(fusion q1 p)
;;

let rec tri_fusion q=match q with
  | [] | [_] -> q
  | _ -> let q1,q2=fission q in fusion (tri_fusion q1) (tri_fusion q2)
;;

let delta2 aut partie x=
  (* aut afnd, partie un ensemble d'état, x une lettre *)
  let rec aux acc liste_t=match liste_t with
    | [] -> acc
    | ((b,y),c)::p when y=x && List.mem b partie -> aux (rajoute_sans_doublon c acc) p
    | _::p -> aux acc p
  in tri_fusion(aux [] aut.delta)
;;
  
let delta3 aut partie alph=
  let f x=(partie,x),(delta2 aut partie x) in List.map f alph
;;

let extrait_atteints t=
  List.map snd t
;;

let rec intersect q1 q2=match q1 with
  | [] -> []
  | x::p -> if List.mem x q2 then x::(intersect p q2) else intersect p q2
;;

let contient_final a parties=
  let fin=a.finaux in
  let rec aux acc listeP=match listeP with
    | [] -> acc
    | x::q when intersect x fin = [] -> aux acc q
    | x::q -> aux (x::acc) q
  in aux [] parties
;;

(* v2 plutot version parties vraiment *)
let automate_des_parties a=
  let etat_initial=a.init and alph=alphabet a in
  let rec aux dejavu acc voir=match voir with
    | [] -> dejavu,acc
    | partie::q when List.mem partie dejavu -> aux dejavu acc q 
    | partie::q -> let nouveaux=delta3 a partie alph in aux (partie::dejavu) (union nouveaux acc) ((extrait_atteints nouveaux)@q)
  in 
  let etats,trans= aux [] [] [etat_initial] in
  {init=[etat_initial] ; finaux=contient_final a etats ; delta=trans}
;;


let automate_miroir a=
  let rec aux acc liste=match liste with
    | [] -> acc
    | ((b,x),d)::p -> aux (((d,x),b)::acc) p
  in
  {init=a.finaux ; finaux=a.init ; delta= aux [] a.delta }
;;
  

let gen_automate_div_inv n=
  automate_des_parties (automate_miroir (gen_automate_div n))
;;

(* gen_automate_div 2 ;; *)

let separe_entier_rev n=
  List.rev (separe_entier n)
;;

(* let print_bool x=print_string (string_of_bool x) ;;
 * 
 * let a=gen_automate_div_inv 6 in
 * for i=0 to 20 do
 *   print_int i ; print_string "\t" ; print_bool (accepte a (separe_entier_rev i)) ; print_newline ()
 * done ;; *)

let cherche a l=
  try 
    let _=List.assoc a l in true
  with Not_found -> false
;;
  

let automate_lin p s f=
  let rec aux acc liste=match liste with
    | [] -> acc
    | (a,b)::q -> aux (((a,b),b)::acc) q
  in 
  let rec aux2 acc liste=match liste with
    | [] -> acc
    | a::q -> aux2 (((-1, a),a)::acc) q in
{init=[-1] ; finaux=s ; delta=aux2 (aux [] f) p}
;;

let remplacer aut liste=
  {init=aut.init ; finaux=aut.finaux ; delta=List.map (function ((b,x),d) -> ((b,List.assoc x liste),d)) aut.delta}
;;

let berry_sethi e=
  let e2,liste_correspondances=linearisation e in
  let p,s,f,_=calcule_car e2 in
  let a=automate_lin p s f in
  let b=remplacer a liste_correspondances in
  automate_des_parties b
;;

let a=berry_sethi e ;;
accepte a ['a';'a'; 'b'] ;;
accepte a ['b'; 'a';'a'; 'b'] ;;
accepte a ['b'; 'c';'c'; 'b'] ;;
accepte a ['b'; 'c';'c'; 'c'] ;;

(* dernière chose à faire, émonder un automate déterministe *)

let accessibles a q=
  let rec aux acc l=match l with
    | [] -> acc
    | ((b,_),d)::p when b=q && (not (List.mem d acc))-> aux (d::acc) p
    | x::p -> aux acc p
  in aux [] a.delta
;;

let etats_accessibles a=
  let rec aux deja_vus voir=match voir with
    | [] -> deja_vus
    | x::p when List.mem x deja_vus -> aux deja_vus p
    | x::p -> aux (x::deja_vus) ((accessibles a x)@p)
  in aux [] a.init
;;

etats_accessibles a ;;
    
(* accessibles renvoie simplement les etats depuis lesquels on peut acceder à q *)
let coaccessibles a q=
  let rec aux acc l=match l with
    | [] -> acc
    | ((b,_),d)::p when d=q && (not (List.mem b acc))-> aux (b::acc) p
    | x::p -> aux acc p
  in aux [] a.delta
;;

let etats_coaccessibles a=
  let rec aux deja_vus voir=match voir with
    | [] -> deja_vus
    | x::p when List.mem x deja_vus -> aux deja_vus p
    | x::p -> aux (x::deja_vus) ((coaccessibles a x)@p)
  in aux [] a.finaux
;;

(* pour l'emondage on suppose que le langage reconnu est non vide i.e l'etat initial est co-accessible *)
let emondage a=
  let ac=etats_accessibles a and coac=etats_coaccessibles a in
  let agarder= intersect ac coac in
  let rec aux acc l=match l with
    | [] -> acc
    | ((b,x),c)::p when (List.mem b agarder && List.mem c agarder) -> aux (((b,x),c)::acc) p
    | x::p -> aux acc p
  in  
  {init=a.init ; finaux=intersect a.finaux agarder ; delta=aux [] a.delta}
;;

emondage (berry_sethi e) ;;  

let e2,_=linearisation e ;;
let p, s, f,_=calcule_car e2;;

delta3 (gen_automate_div 3) [0;1] [0; 1; 2; 3; 4; 5; 6; 7; 8; 9] ;;