(*  Title:      HOL/MicroJava/BV/JVM.thy

    Author:     Gerwin Klein
    Copyright   2000 TUM

*)

section \<open> The JVM Type System as Semilattice \<close>

theory JVM_SemiType imports SemiType begin

type_synonym ty\<^sub>l = "ty err list"
type_synonym ty\<^sub>s = "ty list"
type_synonym ty\<^sub>i = "ty\<^sub>s \<times> ty\<^sub>l"
type_synonym ty\<^sub>i' = "ty\<^sub>i option"
type_synonym ty\<^sub>m = "ty\<^sub>i' list"
type_synonym ty\<^sub>P = "mname \<Rightarrow> cname \<Rightarrow> ty\<^sub>m"

definition stk_esl :: "'c prog \<Rightarrow> nat \<Rightarrow> ty\<^sub>s esl"
where
  "stk_esl P mxs \<equiv> upto_esl mxs (SemiType.esl P)"

definition loc_sl :: "'c prog \<Rightarrow> nat \<Rightarrow> ty\<^sub>l sl"
where
  "loc_sl P mxl \<equiv> Listn.sl mxl (Err.sl (SemiType.esl P))"

definition sl :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err sl"
where
  "sl P mxs mxl \<equiv>
  Err.sl(Opt.esl(Product.esl (stk_esl P mxs) (Err.esl(loc_sl P mxl))))"

definition states :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err set"
where "states P mxs mxl \<equiv> fst(sl P mxs mxl)"

definition le :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err ord"
where
  "le P mxs mxl \<equiv> fst(snd(sl P mxs mxl))"

definition sup :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err binop"
where
  "sup P mxs mxl \<equiv> snd(snd(sl P mxs mxl))"

definition sup_ty_opt :: "['c prog,ty err,ty err] \<Rightarrow> bool"
    ("_ \<turnstile> _ \<le>\<^sub>\<top> _" [71,71,71] 70)
where
  "sup_ty_opt P \<equiv> Err.le (subtype P)"

definition sup_state :: "['c prog,ty\<^sub>i,ty\<^sub>i] \<Rightarrow> bool"
    ("_ \<turnstile> _ \<le>\<^sub>i _" [71,71,71] 70)
where
  "sup_state P \<equiv> Product.le (Listn.le (subtype P)) (Listn.le (sup_ty_opt P))"

definition sup_state_opt :: "['c prog,ty\<^sub>i',ty\<^sub>i'] \<Rightarrow> bool"
    ("_ \<turnstile> _ \<le>'' _" [71,71,71] 70)
where
  "sup_state_opt P \<equiv> Opt.le (sup_state P)"

abbreviation
  sup_loc :: "['c prog,ty\<^sub>l,ty\<^sub>l] \<Rightarrow> bool"  ("_ \<turnstile> _ [\<le>\<^sub>\<top>] _"  [71,71,71] 70)
  where "P \<turnstile> LT [\<le>\<^sub>\<top>] LT' \<equiv> list_all2 (sup_ty_opt P) LT LT'"

notation (ASCII)
  sup_ty_opt  ("_ |- _ <=T _" [71,71,71] 70) and
  sup_state  ("_ |- _ <=i _"  [71,71,71] 70) and
  sup_state_opt  ("_ |- _ <=' _"  [71,71,71] 70) and
  sup_loc  ("_ |- _ [<=T] _"  [71,71,71] 70)

subsection "Unfolding"

lemma JVM_states_unfold:
  "states P mxs mxl \<equiv> err(opt((Union {nlists n (types P) |n. n <= mxs}) \<times>
                                 nlists mxl (err(types P))))"
(*<*)
  apply (unfold states_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
  apply simp
  done
(*>*)

lemma JVM_le_unfold:
 "le P m n \<equiv>
  Err.le(Opt.le(Product.le(Listn.le(subtype P))(Listn.le(Err.le(subtype P)))))"
(*<*)
  apply (unfold le_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
  apply simp
  done
(*>*)

lemma sl_def2:
  "JVM_SemiType.sl P mxs mxl \<equiv>
  (states P mxs mxl, JVM_SemiType.le P mxs mxl, JVM_SemiType.sup P mxs mxl)"
(*<*) by (unfold JVM_SemiType.sup_def states_def JVM_SemiType.le_def) simp (*>*)

lemma JVM_le_conv:
  "le P m n (OK t1) (OK t2) = P \<turnstile> t1 \<le>' t2"
(*<*) by (simp add: JVM_le_unfold Err.le_def lesub_def sup_state_opt_def
                sup_state_def sup_ty_opt_def) (*>*)

lemma JVM_le_Err_conv:
  "le P m n = Err.le (sup_state_opt P)"
(*<*) by (unfold sup_state_opt_def sup_state_def
             sup_ty_opt_def JVM_le_unfold) simp (*>*)

lemma err_le_unfold [iff]:
  "Err.le r (OK a) (OK b) = r a b"
(*<*) by (simp add: Err.le_def lesub_def) (*>*)

subsection \<open> Semilattice \<close>
lemma order_sup_state_opt' [intro, simp]:
  "wf_prog wf_mb P \<Longrightarrow>
      order (sup_state_opt P) (opt ((\<Union> {nlists n (types P) |n. n \<le> mxs} ) \<times> nlists (Suc (length Ts + mxl\<^sub>0)) (err (types P))))"
(*<*)
  apply (unfold sup_state_opt_def sup_state_def sup_ty_opt_def  )
  apply (blast intro:order_le_prodI) \<comment>\<open> use Listn.thy.order_listI2  \<close>
  done
(*<*)
lemma order_sup_state_opt'' [intro, simp]:
  "wf_prog wf_mb P \<Longrightarrow>
      order (sup_state_opt P) (opt ((\<Union> {nlists n (types P) |n. n \<le> mxs} ) \<times> nlists ((length Ts + mxl\<^sub>0)) (err (types P))))"
(*<*)
  apply (unfold sup_state_opt_def sup_state_def sup_ty_opt_def  )
  apply (blast intro:order_le_prodI) \<comment>\<open> use Listn.thy.order_listI2  \<close>
  done
(*<*)
(*
lemma order_sup_state_opt [intro, simp]:
  "wf_prog wf_mb P \<Longrightarrow> order (sup_state_opt P)"
(*<*) by (unfold sup_state_opt_def sup_state_def sup_ty_opt_def) blast (*>*)
*)

lemma semilat_JVM [intro?]:
  "wf_prog wf_mb P \<Longrightarrow> semilat (JVM_SemiType.sl P mxs mxl)"
(*<*)
  apply (unfold JVM_SemiType.sl_def stk_esl_def loc_sl_def)
  apply (blast intro: err_semilat_Product_esl err_semilat_upto_esl
                      Listn_sl err_semilat_JType_esl)
  done
(*>*)

subsection \<open> Widening with @{text "\<top>"} \<close>

lemma subtype_refl[iff]: "subtype P t t" (*<*) by (simp add: fun_of_def) (*>*)

lemma sup_ty_opt_refl [iff]: "P \<turnstile> T \<le>\<^sub>\<top> T"
(*<*)
  apply (unfold sup_ty_opt_def)
  apply (fold lesub_def)
  apply (rule le_err_refl)
  apply (simp add: lesub_def)
  done
(*>*)

lemma Err_any_conv [iff]: "P \<turnstile> Err \<le>\<^sub>\<top> T = (T = Err)"
(*<*) by (unfold sup_ty_opt_def) (rule Err_le_conv [simplified lesub_def]) (*>*)

lemma any_Err [iff]: "P \<turnstile> T \<le>\<^sub>\<top> Err"
(*<*) by (unfold sup_ty_opt_def) (rule le_Err [simplified lesub_def]) (*>*)

lemma OK_OK_conv [iff]:
  "P \<turnstile> OK T \<le>\<^sub>\<top> OK T' = P \<turnstile> T \<le> T'"
(*<*) by (simp add: sup_ty_opt_def fun_of_def) (*>*)

lemma any_OK_conv [iff]:
  "P \<turnstile> X \<le>\<^sub>\<top> OK T' = (\<exists>T. X = OK T \<and> P \<turnstile> T \<le> T')"
(*<*)
  apply (unfold sup_ty_opt_def)
  apply (rule le_OK_conv [simplified lesub_def])
  done
(*>*)

lemma OK_any_conv:
 "P \<turnstile> OK T \<le>\<^sub>\<top> X = (X = Err \<or> (\<exists>T'. X = OK T' \<and> P \<turnstile> T \<le> T'))"
(*<*)
  apply (unfold sup_ty_opt_def)
  apply (rule OK_le_conv [simplified lesub_def])
  done
(*>*)

lemma sup_ty_opt_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a \<le>\<^sub>\<top> b; P \<turnstile> b \<le>\<^sub>\<top> c\<rbrakk> \<Longrightarrow> P \<turnstile> a \<le>\<^sub>\<top> c"
(*<*) by (auto intro: widen_trans
           simp add: sup_ty_opt_def Err.le_def lesub_def fun_of_def
           split: err.splits) (*>*)

subsection "Stack and Registers"

lemma stk_convert:
  "P \<turnstile> ST [\<le>] ST' = Listn.le (subtype P) ST ST'"
(*<*) by (simp add: Listn.le_def lesub_def) (*>*)

lemma sup_loc_refl [iff]: "P \<turnstile> LT [\<le>\<^sub>\<top>] LT"
(*<*) by (rule list_all2_refl) simp (*>*)

lemmas sup_loc_Cons1 [iff] = list_all2_Cons1 [of "sup_ty_opt P"] for P

lemma sup_loc_def:
  "P \<turnstile> LT [\<le>\<^sub>\<top>] LT' \<equiv> Listn.le (sup_ty_opt P) LT LT'"
(*<*) by (simp add: Listn.le_def lesub_def) (*>*)

lemma sup_loc_widens_conv [iff]:
  "P \<turnstile> map OK Ts [\<le>\<^sub>\<top>] map OK Ts' = P \<turnstile> Ts [\<le>] Ts'"
(*<*)
  by (simp add: list_all2_map1 list_all2_map2)
(*>*)

lemma sup_loc_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a [\<le>\<^sub>\<top>] b; P \<turnstile> b [\<le>\<^sub>\<top>] c\<rbrakk> \<Longrightarrow> P \<turnstile> a [\<le>\<^sub>\<top>] c"
(*<*) by (rule list_all2_trans, rule sup_ty_opt_trans) (*>*)

subsection "State Type"

lemma sup_state_conv [iff]:
  "P \<turnstile> (ST,LT) \<le>\<^sub>i (ST',LT') = (P \<turnstile> ST [\<le>] ST' \<and> P \<turnstile> LT [\<le>\<^sub>\<top>] LT')"
(*<*) by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_def) (*>*)

lemma sup_state_conv2:
  "P \<turnstile> s1 \<le>\<^sub>i s2 = (P \<turnstile> fst s1 [\<le>] fst s2 \<and> P \<turnstile> snd s1 [\<le>\<^sub>\<top>] snd s2)"
(*<*) by (cases s1, cases s2) simp (*>*)

lemma sup_state_refl [iff]: "P \<turnstile> s \<le>\<^sub>i s"
(*<*) by (auto simp add: sup_state_conv2) (*>*)

lemma sup_state_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a \<le>\<^sub>i b; P \<turnstile> b \<le>\<^sub>i c\<rbrakk> \<Longrightarrow> P \<turnstile> a \<le>\<^sub>i c"
(*<*) by (auto intro: sup_loc_trans widens_trans simp add: sup_state_conv2) (*>*)

lemma sup_state_opt_None_any [iff]:
  "P \<turnstile> None \<le>' s"
(*<*) by (simp add: sup_state_opt_def Opt.le_def) (*>*)

lemma sup_state_opt_any_None [iff]:
  "P \<turnstile> s \<le>' None = (s = None)"
(*<*) by (simp add: sup_state_opt_def Opt.le_def) (*>*)

lemma sup_state_opt_Some_Some [iff]:
  "P \<turnstile> Some a \<le>' Some b = P \<turnstile> a \<le>\<^sub>i b"
(*<*) by (simp add: sup_state_opt_def Opt.le_def lesub_def) (*>*)

lemma sup_state_opt_any_Some:
  "P \<turnstile> (Some s) \<le>' X = (\<exists>s'. X = Some s' \<and> P \<turnstile> s \<le>\<^sub>i s')"
(*<*) by (simp add: sup_state_opt_def Opt.le_def lesub_def) (*>*)

lemma sup_state_opt_refl [iff]: "P \<turnstile> s \<le>' s"
(*<*) by (simp add: sup_state_opt_def Opt.le_def lesub_def) (*>*)

lemma sup_state_opt_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a \<le>' b; P \<turnstile> b \<le>' c\<rbrakk> \<Longrightarrow> P \<turnstile> a \<le>' c"
(*<*)
  apply (unfold sup_state_opt_def Opt.le_def lesub_def)
  apply (simp del: split_paired_All)
  apply (rule sup_state_trans, assumption+)
  done
(*>*)

lemma sup_state_opt_err  : "(Err.le (sup_state_opt P)) s s"
  apply (unfold JVM_le_unfold Product.le_def Opt.le_def Err.le_def lesssub_def lesub_def Listn.le_def)
  apply (auto split: err.splits)
  done

lemma Cons_less_Conss1 [simp]:
  "x#xs [\<sqsubset>\<^bsub>subtype P\<^esub>] y#ys = (x \<sqsubset>\<^bsub>subtype P\<^esub> y \<and> xs [\<sqsubseteq>\<^bsub>subtype P\<^esub>] ys \<or> x = y \<and> xs [\<sqsubset>\<^bsub>subtype P\<^esub>] ys)"
  apply (unfold lesssub_def )
  apply auto
  apply (simp add:lesssub_def lesub_def) \<comment>\<open>widen_refl, subtype_refl \<close>
  done

lemma Cons_less_Conss2 [simp]:
  "x#xs [\<sqsubset>\<^bsub>Err.le (subtype P)\<^esub>] y#ys = (x \<sqsubset>\<^bsub>Err.le (subtype P)\<^esub> y \<and> xs [\<sqsubseteq>\<^bsub>Err.le (subtype P)\<^esub>] ys \<or> x = y \<and> xs [\<sqsubset>\<^bsub>Err.le (subtype P)\<^esub>] ys)"
  apply (unfold lesssub_def )
  apply auto
  apply (simp add:lesssub_def lesub_def Err.le_def split: err.splits)
  done

lemma acc_le_listI1 [intro!]:
  " acc (subtype P) \<Longrightarrow> acc (Listn.le (subtype P))"
  (*<*)
apply (unfold acc_def)
apply (subgoal_tac
 "wf(UN n. {(ys,xs). size xs = n \<and> size ys = n \<and> xs <_(Listn.le (subtype P)) ys})")
   apply (erule wf_subset)

 apply (blast intro: lesssub_lengthD)
apply (rule wf_UN)
 prefer 2
 apply (rename_tac m n)
 apply (case_tac "m=n")
  apply simp
 apply (fast intro!: equals0I dest: not_sym)
apply (rename_tac n)
apply (induct_tac n)
 apply (simp add: lesssub_def cong: conj_cong)
apply (rename_tac k)
apply (simp add: wf_eq_minimal)
apply (simp (no_asm) add: length_Suc_conv cong: conj_cong)
apply clarify
apply (rename_tac M m)
apply (case_tac "\<exists>x xs. size xs = k \<and> x#xs \<in> M")
 prefer 2
 apply (erule thin_rl)
 apply (erule thin_rl)
 apply blast
apply (erule_tac x = "{a. \<exists>xs. size xs = k \<and> a#xs:M}" in allE)
apply (erule impE)
 apply blast
apply (thin_tac "\<exists>x xs. P x xs" for P)
apply clarify
apply (rename_tac maxA xs)
apply (erule_tac x = "{ys. size ys = size xs \<and> maxA#ys \<in> M}" in allE)
apply (erule impE)
 apply blast
apply clarify
apply (thin_tac "m \<in> M")
apply (thin_tac "maxA#xs \<in> M")
apply (rule bexI)
 prefer 2
 apply assumption
apply clarify
apply simp
apply blast
  done

lemma acc_le_listI2 [intro!]:
  " acc (Err.le (subtype P)) \<Longrightarrow> acc (Listn.le (Err.le (subtype P)))"
    (*<*)
apply (unfold acc_def)
apply (subgoal_tac
 "wf(UN n. {(ys,xs). size xs = n \<and> size ys = n \<and> xs <_(Listn.le (Err.le (subtype P))) ys})")
   apply (erule wf_subset)

 apply (blast intro: lesssub_lengthD)
apply (rule wf_UN)
 prefer 2
 apply (rename_tac m n)
 apply (case_tac "m=n")
  apply simp
 apply (fast intro!: equals0I dest: not_sym)
apply (rename_tac n)
apply (induct_tac n)
 apply (simp add: lesssub_def cong: conj_cong)
apply (rename_tac k)
apply (simp add: wf_eq_minimal)
apply (simp (no_asm) add: length_Suc_conv cong: conj_cong)
apply clarify
apply (rename_tac M m)
apply (case_tac "\<exists>x xs. size xs = k \<and> x#xs \<in> M")
 prefer 2
 apply (erule thin_rl)
 apply (erule thin_rl)
 apply blast
apply (erule_tac x = "{a. \<exists>xs. size xs = k \<and> a#xs:M}" in allE)
apply (erule impE)
 apply blast
apply (thin_tac "\<exists>x xs. P x xs" for P)
apply clarify
apply (rename_tac maxA xs)
apply (erule_tac x = "{ys. size ys = size xs \<and> maxA#ys \<in> M}" in allE)
apply (erule impE)
 apply blast
apply clarify
apply (thin_tac "m \<in> M")
apply (thin_tac "maxA#xs \<in> M")
apply (rule bexI)
 prefer 2
 apply assumption
apply clarify
apply simp
apply blast
  done

lemma acc_JVM [intro]:
  "wf_prog wf_mb P \<Longrightarrow> acc (JVM_SemiType.le P mxs mxl)"
(*<*) by (unfold JVM_le_unfold) blast (*>*)  \<comment>\<open> use acc_listI1, acc_listI2 \<close>

end


(*  Title:      ZF/AC/WO2_AC16.thy
    Author:     Krzysztof Grabczewski

The proof of WO2 \<Longrightarrow> AC16(k #+ m, k)

The main part of the proof is the inductive reasoning concerning
properties of constructed family T_gamma.
The proof deals with three cases for ordinals: 0, succ and limit ordinal.
The first instance is trivial, the third not difficult, but the second
is very complicated requiring many lemmas.
We also need to prove that at any stage gamma the set
(s - \<Union>(...) - k_gamma)   (Rubin & Rubin page 15)
contains m distinct elements (in fact is equipollent to s)
*)

theory WO2_AC16 imports AC_Equiv AC16_lemmas Cardinal_aux begin

(**** A recursive definition used in the proof of WO2 \<Longrightarrow> AC16 ****)

definition
  recfunAC16 :: "[i,i,i,i] \<Rightarrow> i"  where
    "recfunAC16(f,h,i,a) \<equiv>
         transrec2(i, 0,
              \<lambda>g r. if (\<exists>y \<in> r. h`g \<subseteq> y) then r
                    else r \<union> {f`(\<mu> i. h`g \<subseteq> f`i \<and>
                         (\<forall>b<a. (h`b \<subseteq> f`i \<longrightarrow> (\<forall>t \<in> r. \<not> h`b \<subseteq> t))))})"

(* ********************************************************************** *)
(* Basic properties of recfunAC16                                         *)
(* ********************************************************************** *)

lemma recfunAC16_0: "recfunAC16(f,h,0,a) = 0"
by (simp add: recfunAC16_def)

lemma recfunAC16_succ:
     "recfunAC16(f,h,succ(i),a) =
      (if (\<exists>y \<in> recfunAC16(f,h,i,a). h ` i \<subseteq> y) then recfunAC16(f,h,i,a)
       else recfunAC16(f,h,i,a) \<union>
            {f ` (\<mu> j. h ` i \<subseteq> f ` j \<and>
             (\<forall>b<a. (h`b \<subseteq> f`j
              \<longrightarrow> (\<forall>t \<in> recfunAC16(f,h,i,a). \<not> h`b \<subseteq> t))))})"
apply (simp add: recfunAC16_def)
done

lemma recfunAC16_Limit: "Limit(i)
        \<Longrightarrow> recfunAC16(f,h,i,a) = (\<Union>j<i. recfunAC16(f,h,j,a))"
by (simp add: recfunAC16_def transrec2_Limit)

(* ********************************************************************** *)
(* Monotonicity of transrec2                                              *)
(* ********************************************************************** *)

lemma transrec2_mono_lemma [rule_format]:
     "\<lbrakk>\<And>g r. r \<subseteq> B(g,r);  Ord(i)\<rbrakk>
      \<Longrightarrow> j<i \<longrightarrow> transrec2(j, 0, B) \<subseteq> transrec2(i, 0, B)"
apply (erule trans_induct)
apply (rule Ord_cases, assumption+, fast)
apply (simp (no_asm_simp))
apply (blast elim!: leE)
apply (simp add: transrec2_Limit)
apply (blast intro: OUN_I ltI Ord_in_Ord [THEN le_refl]
             elim!: Limit_has_succ [THEN ltE])
done

lemma transrec2_mono:
     "\<lbrakk>\<And>g r. r \<subseteq> B(g,r); j\<le>i\<rbrakk>
      \<Longrightarrow> transrec2(j, 0, B) \<subseteq> transrec2(i, 0, B)"
apply (erule leE)
apply (rule transrec2_mono_lemma)
apply (auto intro: lt_Ord2 )
done

(* ********************************************************************** *)
(* Monotonicity of recfunAC16                                             *)
(* ********************************************************************** *)

lemma recfunAC16_mono:
       "i\<le>j \<Longrightarrow> recfunAC16(f, g, i, a) \<subseteq> recfunAC16(f, g, j, a)"
  unfolding recfunAC16_def
apply (rule transrec2_mono, auto)
done

(* ********************************************************************** *)
(* case of limit ordinal                                                  *)
(* ********************************************************************** *)

lemma lemma3_1:
    "\<lbrakk>\<forall>y<x. \<forall>z<a. z<y | (\<exists>Y \<in> F(y). f(z)<=Y) \<longrightarrow> (\<exists>! Y. Y \<in> F(y) \<and> f(z)<=Y);
        \<forall>i j. i\<le>j \<longrightarrow> F(i) \<subseteq> F(j); j\<le>i; i<x; z<a;
        V \<in> F(i); f(z)<=V; W \<in> F(j); f(z)<=W\<rbrakk>
     \<Longrightarrow> V = W"
apply (erule asm_rl allE impE)+
apply (drule subsetD, assumption, blast)
done

lemma lemma3:
    "\<lbrakk>\<forall>y<x. \<forall>z<a. z<y | (\<exists>Y \<in> F(y). f(z)<=Y) \<longrightarrow> (\<exists>! Y. Y \<in> F(y) \<and> f(z)<=Y);
        \<forall>i j. i\<le>j \<longrightarrow> F(i) \<subseteq> F(j); i<x; j<x; z<a;
        V \<in> F(i); f(z)<=V; W \<in> F(j); f(z)<=W\<rbrakk>
     \<Longrightarrow> V = W"
apply (rule_tac j=j in Ord_linear_le [OF lt_Ord lt_Ord], assumption+)
apply (erule lemma3_1 [symmetric], assumption+)
apply (erule lemma3_1, assumption+)
done

lemma lemma4:
     "\<lbrakk>\<forall>y<x. F(y) \<subseteq> X \<and>
                (\<forall>x<a. x < y | (\<exists>Y \<in> F(y). h(x) \<subseteq> Y) \<longrightarrow>
                 (\<exists>! Y. Y \<in> F(y) \<and> h(x) \<subseteq> Y));
         x < a\<rbrakk>
      \<Longrightarrow> \<forall>y<x. \<forall>z<a. z < y | (\<exists>Y \<in> F(y). h(z) \<subseteq> Y) \<longrightarrow>
                       (\<exists>! Y. Y \<in> F(y) \<and> h(z) \<subseteq> Y)"
apply (intro oallI impI)
apply (drule ospec, assumption, clarify)
apply (blast elim!: oallE )
done

lemma lemma5:
     "\<lbrakk>\<forall>y<x. F(y) \<subseteq> X \<and>
               (\<forall>x<a. x < y | (\<exists>Y \<in> F(y). h(x) \<subseteq> Y) \<longrightarrow>
                (\<exists>! Y. Y \<in> F(y) \<and> h(x) \<subseteq> Y));
         x < a; Limit(x); \<forall>i j. i\<le>j \<longrightarrow> F(i) \<subseteq> F(j)\<rbrakk>
      \<Longrightarrow> (\<Union>x<x. F(x)) \<subseteq> X \<and>
          (\<forall>xa<a. xa < x | (\<exists>x \<in> \<Union>x<x. F(x). h(xa) \<subseteq> x)
                \<longrightarrow> (\<exists>! Y. Y \<in> (\<Union>x<x. F(x)) \<and> h(xa) \<subseteq> Y))"
apply (rule conjI)
apply (rule subsetI)
apply (erule OUN_E)
apply (drule ospec, assumption, fast)
apply (drule lemma4, assumption)
apply (rule oallI)
apply (rule impI)
apply (erule disjE)
apply (frule ospec, erule Limit_has_succ, assumption)
apply (drule_tac A = a and x = xa in ospec, assumption)
apply (erule impE, rule le_refl [THEN disjI1], erule lt_Ord)
apply (blast intro: lemma3 Limit_has_succ)
apply (blast intro: lemma3)
done

(* ********************************************************************** *)
(* case of successor ordinal                                              *)
(* ********************************************************************** *)

(*
  First quite complicated proof of the fact used in the recursive construction
  of the family T_gamma (WO2 \<Longrightarrow> AC16(k #+ m, k)) - the fact that at any stage
  gamma the set (s - \<Union>(...) - k_gamma) is equipollent to s
  (Rubin & Rubin page 15).
*)

(* ********************************************************************** *)
(* dbl_Diff_eqpoll_Card                                                   *)
(* ********************************************************************** *)

lemma dbl_Diff_eqpoll_Card:
      "\<lbrakk>A\<approx>a; Card(a); \<not>Finite(a); B\<prec>a; C\<prec>a\<rbrakk> \<Longrightarrow> A - B - C\<approx>a"
by (blast intro: Diff_lesspoll_eqpoll_Card)

(* ********************************************************************** *)
(* Case of finite ordinals                                                *)
(* ********************************************************************** *)

lemma Finite_lesspoll_infinite_Ord:
      "\<lbrakk>Finite(X); \<not>Finite(a); Ord(a)\<rbrakk> \<Longrightarrow> X\<prec>a"
  unfolding lesspoll_def
apply (rule conjI)
apply (drule nat_le_infinite_Ord [THEN le_imp_lepoll], assumption)
  unfolding Finite_def
apply (blast intro: leI [THEN le_imp_subset, THEN subset_imp_lepoll]
                    ltI eqpoll_imp_lepoll lepoll_trans)
apply (blast intro: eqpoll_sym [THEN eqpoll_trans])
done

lemma Union_lesspoll:
     "\<lbrakk>\<forall>x \<in> X. x \<lesssim> n \<and> x \<subseteq> T; well_ord(T, R); X \<lesssim> b;
         b<a; \<not>Finite(a); Card(a); n \<in> nat\<rbrakk>
      \<Longrightarrow> \<Union>(X)\<prec>a"
apply (case_tac "Finite (X)")
apply (blast intro: Card_is_Ord Finite_lesspoll_infinite_Ord
                    lepoll_nat_imp_Finite Finite_Union)
apply (drule lepoll_imp_ex_le_eqpoll)
apply (erule lt_Ord)
apply (elim exE conjE)
apply (frule eqpoll_imp_lepoll [THEN lepoll_infinite], assumption)
apply (erule eqpoll_sym [THEN eqpoll_def [THEN def_imp_iff, THEN iffD1],
                         THEN exE])
apply (frule bij_is_surj [THEN surj_image_eq])
apply (drule image_fun [OF bij_is_fun subset_refl])
apply (drule sym [THEN trans], assumption)
apply (blast intro: lt_Ord UN_lepoll lt_Card_imp_lesspoll
                    lt_trans1 lesspoll_trans1)
done

(* ********************************************************************** *)
(* recfunAC16_lepoll_index                                                *)
(* ********************************************************************** *)

lemma Un_sing_eq_cons: "A \<union> {a} = cons(a, A)"
by fast

lemma Un_lepoll_succ: "A \<lesssim> B \<Longrightarrow> A \<union> {a} \<lesssim> succ(B)"
apply (simp add: Un_sing_eq_cons succ_def)
apply (blast elim!: mem_irrefl intro: cons_lepoll_cong)
done

lemma Diff_UN_succ_empty: "Ord(a) \<Longrightarrow> F(a) - (\<Union>b<succ(a). F(b)) = 0"
by (fast intro!: le_refl)

lemma Diff_UN_succ_subset: "Ord(a) \<Longrightarrow> F(a) \<union> X - (\<Union>b<succ(a). F(b)) \<subseteq> X"
by blast

lemma recfunAC16_Diff_lepoll_1:
     "Ord(x)
      \<Longrightarrow> recfunAC16(f, g, x, a) - (\<Union>i<x. recfunAC16(f, g, i, a)) \<lesssim> 1"
apply (erule Ord_cases)
  apply (simp add: recfunAC16_0 empty_subsetI [THEN subset_imp_lepoll])
(*Limit case*)
prefer 2 apply (simp add: recfunAC16_Limit Diff_cancel
                          empty_subsetI [THEN subset_imp_lepoll])
(*succ case*)
apply (simp add: recfunAC16_succ
                 Diff_UN_succ_empty [of _ "\<lambda>j. recfunAC16(f,g,j,a)"]
                 empty_subsetI [THEN subset_imp_lepoll])
apply (best intro: Diff_UN_succ_subset [THEN subset_imp_lepoll]
                   singleton_eqpoll_1 [THEN eqpoll_imp_lepoll] lepoll_trans)
done

lemma in_Least_Diff:
     "\<lbrakk>z \<in> F(x); Ord(x)\<rbrakk>
      \<Longrightarrow> z \<in> F(\<mu> i. z \<in> F(i)) - (\<Union>j<(\<mu> i. z \<in> F(i)). F(j))"
by (fast elim: less_LeastE elim!: LeastI)

lemma Least_eq_imp_ex:
     "\<lbrakk>(\<mu> i. w \<in> F(i)) = (\<mu> i. z \<in> F(i));
         w \<in> (\<Union>i<a. F(i)); z \<in> (\<Union>i<a. F(i))\<rbrakk>
      \<Longrightarrow> \<exists>b<a. w \<in> (F(b) - (\<Union>c<b. F(c))) \<and> z \<in> (F(b) - (\<Union>c<b. F(c)))"
apply (elim OUN_E)
apply (drule in_Least_Diff, erule lt_Ord)
apply (frule in_Least_Diff, erule lt_Ord)
apply (rule oexI, force)
apply (blast intro: lt_Ord Least_le [THEN lt_trans1])
done

lemma two_in_lepoll_1: "\<lbrakk>A \<lesssim> 1; a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a=b"
by (fast dest!: lepoll_1_is_sing)

lemma UN_lepoll_index:
     "\<lbrakk>\<forall>i<a. F(i)-(\<Union>j<i. F(j)) \<lesssim> 1; Limit(a)\<rbrakk>
      \<Longrightarrow> (\<Union>x<a. F(x)) \<lesssim> a"
apply (rule lepoll_def [THEN def_imp_iff [THEN iffD2]])
apply (rule_tac x = "\<lambda>z \<in> (\<Union>x<a. F (x)). \<mu> i. z \<in> F (i) " in exI)
  unfolding inj_def
apply (rule CollectI)
apply (rule lam_type)
apply (erule OUN_E)
apply (erule Least_in_Ord)
apply (erule ltD)
apply (erule lt_Ord2)
apply (intro ballI)
apply (simp (no_asm_simp))
apply (rule impI)
apply (drule Least_eq_imp_ex, assumption+)
apply (fast elim!: two_in_lepoll_1)
done

lemma recfunAC16_lepoll_index: "Ord(y) \<Longrightarrow> recfunAC16(f, h, y, a) \<lesssim> y"
apply (erule trans_induct3)
(*0 case*)
apply (simp (no_asm_simp) add: recfunAC16_0 lepoll_refl)
(*succ case*)
apply (simp (no_asm_simp) add: recfunAC16_succ)
apply (blast dest!: succI1 [THEN rev_bspec]
             intro: subset_succI [THEN subset_imp_lepoll] Un_lepoll_succ
                    lepoll_trans)
apply (simp (no_asm_simp) add: recfunAC16_Limit)
apply (blast intro: lt_Ord [THEN recfunAC16_Diff_lepoll_1] UN_lepoll_index)
done

lemma Union_recfunAC16_lesspoll:
     "\<lbrakk>recfunAC16(f,g,y,a) \<subseteq> {X \<in> Pow(A). X\<approx>n};
         A\<approx>a;  y<a;  \<not>Finite(a);  Card(a);  n \<in> nat\<rbrakk>
      \<Longrightarrow> \<Union>(recfunAC16(f,g,y,a))\<prec>a"
apply (erule eqpoll_def [THEN def_imp_iff, THEN iffD1, THEN exE])
apply (rule_tac T=A in Union_lesspoll, simp_all)
apply (blast intro!: eqpoll_imp_lepoll)
apply (blast intro: bij_is_inj Card_is_Ord [THEN well_ord_Memrel]
                    well_ord_rvimage)
apply (erule lt_Ord [THEN recfunAC16_lepoll_index])
done

lemma dbl_Diff_eqpoll:
     "\<lbrakk>recfunAC16(f, h, y, a) \<subseteq> {X \<in> Pow(A) . X\<approx>succ(k #+ m)};
         Card(a); \<not> Finite(a); A\<approx>a;
         k \<in> nat;  y<a;
         h \<in> bij(a, {Y \<in> Pow(A). Y\<approx>succ(k)})\<rbrakk>
      \<Longrightarrow> A - \<Union>(recfunAC16(f, h, y, a)) - h`y\<approx>a"
apply (rule dbl_Diff_eqpoll_Card, simp_all)
apply (simp add: Union_recfunAC16_lesspoll)
apply (rule Finite_lesspoll_infinite_Ord)
apply (rule Finite_def [THEN def_imp_iff, THEN iffD2])
apply (blast dest: ltD bij_is_fun [THEN apply_type], assumption)
apply (blast intro: Card_is_Ord)
done

(* back to the proof *)

lemmas disj_Un_eqpoll_nat_sum =
    eqpoll_trans [THEN eqpoll_trans,
                  OF disj_Un_eqpoll_sum sum_eqpoll_cong nat_sum_eqpoll_sum]

lemma Un_in_Collect: "\<lbrakk>x \<in> Pow(A - B - h`i); x\<approx>m;
        h \<in> bij(a, {x \<in> Pow(A) . x\<approx>k}); i<a; k \<in> nat; m \<in> nat\<rbrakk>
        \<Longrightarrow> h ` i \<union> x \<in> {x \<in> Pow(A) . x\<approx>k #+ m}"
by (blast intro: disj_Un_eqpoll_nat_sum
          dest:  ltD bij_is_fun [THEN apply_type])

(* ********************************************************************** *)
(* Lemmas simplifying assumptions                                         *)
(* ********************************************************************** *)

lemma lemma6:
     "\<lbrakk>\<forall>y<succ(j). F(y)<=X \<and> (\<forall>x<a. x<y | P(x,y) \<longrightarrow> Q(x,y)); succ(j)<a\<rbrakk>
      \<Longrightarrow> F(j)<=X \<and> (\<forall>x<a. x<j | P(x,j) \<longrightarrow> Q(x,j))"
by (blast intro!: lt_Ord succI1 [THEN ltI, THEN lt_Ord, THEN le_refl])

lemma lemma7:
     "\<lbrakk>\<forall>x<a. x<j | P(x,j) \<longrightarrow> Q(x,j);  succ(j)<a\<rbrakk>
      \<Longrightarrow> P(j,j) \<longrightarrow> (\<forall>x<a. x\<le>j | P(x,j) \<longrightarrow> Q(x,j))"
by (fast elim!: leE)

(* ********************************************************************** *)
(* Lemmas needed to prove ex_next_set, which means that for any successor *)
(* ordinal there is a set satisfying certain properties                   *)
(* ********************************************************************** *)

lemma ex_subset_eqpoll:
     "\<lbrakk>A\<approx>a; \<not> Finite(a); Ord(a); m \<in> nat\<rbrakk> \<Longrightarrow> \<exists>X \<in> Pow(A). X\<approx>m"
apply (rule lepoll_imp_eqpoll_subset [of m A, THEN exE])
 apply (rule lepoll_trans, rule leI [THEN le_imp_lepoll])
  apply (blast intro: lt_trans2 [OF ltI nat_le_infinite_Ord] Ord_nat)
apply (erule eqpoll_sym [THEN eqpoll_imp_lepoll])
apply (fast elim!: eqpoll_sym)
done

lemma subset_Un_disjoint: "\<lbrakk>A \<subseteq> B \<union> C; A \<inter> C = 0\<rbrakk> \<Longrightarrow> A \<subseteq> B"
by blast

lemma Int_empty:
     "\<lbrakk>X \<in> Pow(A - \<Union>(B) -C); T \<in> B; F \<subseteq> T\<rbrakk> \<Longrightarrow> F \<inter> X = 0"
by blast

(* ********************************************************************** *)
(* equipollent subset (and finite) is the whole set                       *)
(* ********************************************************************** *)

lemma subset_imp_eq_lemma:
     "m \<in> nat \<Longrightarrow> \<forall>A B. A \<subseteq> B \<and> m \<lesssim> A \<and> B \<lesssim> m \<longrightarrow> A=B"
apply (induct_tac "m")
apply (fast dest!: lepoll_0_is_0)
apply (intro allI impI)
apply (elim conjE)
apply (rule succ_lepoll_imp_not_empty [THEN not_emptyE], assumption)
apply (frule subsetD [THEN Diff_sing_lepoll], assumption+)
apply (frule lepoll_Diff_sing)
apply (erule allE impE)+
apply (rule conjI)
prefer 2 apply fast
apply fast
apply (blast elim: equalityE)
done

lemma subset_imp_eq: "\<lbrakk>A \<subseteq> B; m \<lesssim> A; B \<lesssim> m; m \<in> nat\<rbrakk> \<Longrightarrow> A=B"
by (blast dest!: subset_imp_eq_lemma)

lemma bij_imp_arg_eq:
     "\<lbrakk>f \<in> bij(a, {Y \<in> X. Y\<approx>succ(k)}); k \<in> nat; f`b \<subseteq> f`y; b<a; y<a\<rbrakk>
      \<Longrightarrow> b=y"
apply (drule subset_imp_eq)
apply (erule_tac [3] nat_succI)
  unfolding bij_def inj_def
apply (blast intro: eqpoll_sym eqpoll_imp_lepoll
             dest:  ltD apply_type)+
done

lemma ex_next_set:
     "\<lbrakk>recfunAC16(f, h, y, a) \<subseteq> {X \<in> Pow(A) . X\<approx>succ(k #+ m)};
         Card(a); \<not> Finite(a); A\<approx>a;
         k \<in> nat; m \<in> nat; y<a;
         h \<in> bij(a, {Y \<in> Pow(A). Y\<approx>succ(k)});
         \<not> (\<exists>Y \<in> recfunAC16(f, h, y, a). h`y \<subseteq> Y)\<rbrakk>
      \<Longrightarrow> \<exists>X \<in> {Y \<in> Pow(A). Y\<approx>succ(k #+ m)}. h`y \<subseteq> X \<and>
                (\<forall>b<a. h`b \<subseteq> X \<longrightarrow>
                (\<forall>T \<in> recfunAC16(f, h, y, a). \<not> h`b \<subseteq> T))"
apply (erule_tac m1=m in dbl_Diff_eqpoll [THEN ex_subset_eqpoll, THEN bexE],
       assumption+)
apply (erule Card_is_Ord, assumption)
apply (frule Un_in_Collect, (erule asm_rl nat_succI)+)
apply (erule CollectE)
apply (rule rev_bexI, simp)
apply (rule conjI, blast)
apply (intro ballI impI oallI notI)
apply (drule subset_Un_disjoint, rule Int_empty, assumption+)
apply (blast dest: bij_imp_arg_eq)
done

(* ********************************************************************** *)
(* Lemma ex_next_Ord states that for any successor                        *)
(* ordinal there is a number of the set satisfying certain properties     *)
(* ********************************************************************** *)

lemma ex_next_Ord:
     "\<lbrakk>recfunAC16(f, h, y, a) \<subseteq> {X \<in> Pow(A) . X\<approx>succ(k #+ m)};
         Card(a); \<not> Finite(a); A\<approx>a;
         k \<in> nat; m \<in> nat; y<a;
         h \<in> bij(a, {Y \<in> Pow(A). Y\<approx>succ(k)});
         f \<in> bij(a, {Y \<in> Pow(A). Y\<approx>succ(k #+ m)});
         \<not> (\<exists>Y \<in> recfunAC16(f, h, y, a). h`y \<subseteq> Y)\<rbrakk>
      \<Longrightarrow> \<exists>c<a. h`y \<subseteq> f`c \<and>
                (\<forall>b<a. h`b \<subseteq> f`c \<longrightarrow>
                (\<forall>T \<in> recfunAC16(f, h, y, a). \<not> h`b \<subseteq> T))"
apply (drule ex_next_set, assumption+)
apply (erule bexE)
apply (rule_tac x="converse(f)`X" in oexI)
apply (simp add: right_inverse_bij)
apply (blast intro: bij_converse_bij bij_is_fun [THEN apply_type] ltI
                    Card_is_Ord)
done

(* ********************************************************************** *)
(* Lemma simplifying assumptions                                          *)
(* ********************************************************************** *)

lemma lemma8:
     "\<lbrakk>\<forall>x<a. x<j | (\<exists>xa \<in> F(j). P(x, xa))
         \<longrightarrow> (\<exists>! Y. Y \<in> F(j) \<and> P(x, Y)); F(j) \<subseteq> X;
         L \<in> X; P(j, L) \<and> (\<forall>x<a. P(x, L) \<longrightarrow> (\<forall>xa \<in> F(j). \<not>P(x, xa)))\<rbrakk>
      \<Longrightarrow> F(j) \<union> {L} \<subseteq> X \<and>
          (\<forall>x<a. x\<le>j | (\<exists>xa \<in> (F(j) \<union> {L}). P(x, xa)) \<longrightarrow>
                 (\<exists>! Y. Y \<in> (F(j) \<union> {L}) \<and> P(x, Y)))"
apply (rule conjI)
apply (fast intro!: singleton_subsetI)
apply (rule oallI)
apply (blast elim!: leE oallE)
done

(* ********************************************************************** *)
(* The main part of the proof: inductive proof of the property of T_gamma *)
(* lemma main_induct                                                      *)
(* ********************************************************************** *)

lemma main_induct:
     "\<lbrakk>b < a; f \<in> bij(a, {Y \<in> Pow(A) . Y\<approx>succ(k #+ m)});
         h \<in> bij(a, {Y \<in> Pow(A) . Y\<approx>succ(k)});
         \<not>Finite(a); Card(a); A\<approx>a; k \<in> nat; m \<in> nat\<rbrakk>
      \<Longrightarrow> recfunAC16(f, h, b, a) \<subseteq> {X \<in> Pow(A) . X\<approx>succ(k #+ m)} \<and>
          (\<forall>x<a. x < b | (\<exists>Y \<in> recfunAC16(f, h, b, a). h ` x \<subseteq> Y) \<longrightarrow>
          (\<exists>! Y. Y \<in> recfunAC16(f, h, b, a) \<and> h ` x \<subseteq> Y))"
apply (erule lt_induct)
apply (frule lt_Ord)
apply (erule Ord_cases)
(* case 0 *)
apply (simp add: recfunAC16_0)
(* case Limit *)
prefer 2  apply (simp add: recfunAC16_Limit)
          apply (rule lemma5, assumption+)
          apply (blast dest!: recfunAC16_mono)
(* case succ *)
apply clarify
apply (erule lemma6 [THEN conjE], assumption)
apply (simp (no_asm_simp) split del: split_if add: recfunAC16_succ)
apply (rule conjI [THEN split_if [THEN iffD2]])
 apply (simp, erule lemma7, assumption)
apply (rule impI)
apply (rule ex_next_Ord [THEN oexE],
       assumption+, rule le_refl [THEN lt_trans], assumption+)
apply (erule lemma8, assumption)
 apply (rule bij_is_fun [THEN apply_type], assumption)
 apply (erule Least_le [THEN lt_trans2, THEN ltD])
  apply (erule lt_Ord)
 apply (erule succ_leI)
apply (erule LeastI)
apply (erule lt_Ord)
done

(* ********************************************************************** *)
(* Lemma to simplify the inductive proof                                  *)
(*   - the desired property is a consequence of the inductive assumption  *)
(* ********************************************************************** *)

lemma lemma_simp_induct:
     "\<lbrakk>\<forall>b. b<a \<longrightarrow> F(b) \<subseteq> S \<and> (\<forall>x<a. (x<b | (\<exists>Y \<in> F(b). f`x \<subseteq> Y))
                                   \<longrightarrow> (\<exists>! Y. Y \<in> F(b) \<and> f`x \<subseteq> Y));
         f \<in> a->f``(a); Limit(a);
         \<forall>i j. i\<le>j \<longrightarrow> F(i) \<subseteq> F(j)\<rbrakk>
        \<Longrightarrow> (\<Union>j<a. F(j)) \<subseteq> S \<and>
            (\<forall>x \<in> f``a. \<exists>! Y. Y \<in> (\<Union>j<a. F(j)) \<and> x \<subseteq> Y)"
apply (rule conjI)
apply (rule subsetI)
apply (erule OUN_E, blast)
apply (rule ballI)
apply (erule imageE)
apply (drule ltI, erule Limit_is_Ord)
apply (drule Limit_has_succ, assumption)
apply (frule_tac x1="succ(xa)" in spec [THEN mp], assumption)
apply (erule conjE)
apply (drule ospec)
(** LEVEL 10 **)
apply (erule leI [THEN succ_leE])
apply (erule impE)
apply (fast elim!: leI [THEN succ_leE, THEN lt_Ord, THEN le_refl])
apply (drule apply_equality, assumption)
apply (elim conjE ex1E)
(** LEVEL 15 **)
apply (rule ex1I, blast)
apply (elim conjE OUN_E)
apply (erule_tac i="succ(xa)" and j=aa
       in Ord_linear_le [OF lt_Ord lt_Ord], assumption)
prefer 2
apply (drule spec [THEN spec, THEN mp, THEN subsetD], assumption+, blast)
(** LEVEL 20 **)
apply (drule_tac x1=aa in spec [THEN mp], assumption)
apply (frule succ_leE)
apply (drule spec [THEN spec, THEN mp, THEN subsetD], assumption+, blast)
done

(* ********************************************************************** *)
(* The target theorem                                                     *)
(* ********************************************************************** *)

theorem WO2_AC16: "\<lbrakk>WO2; 0<m; k \<in> nat; m \<in> nat\<rbrakk> \<Longrightarrow> AC16(k #+ m,k)"
  unfolding AC16_def
apply (rule allI)
apply (rule impI)
apply (frule WO2_infinite_subsets_eqpoll_X, assumption+)
apply (frule_tac n="k #+ m" in WO2_infinite_subsets_eqpoll_X, simp, simp)
apply (frule WO2_imp_ex_Card)
apply (elim exE conjE)
apply (drule eqpoll_trans [THEN eqpoll_sym,
                           THEN eqpoll_def [THEN def_imp_iff, THEN iffD1]],
       assumption)
apply (drule eqpoll_trans [THEN eqpoll_sym,
                           THEN eqpoll_def [THEN def_imp_iff, THEN iffD1]],
       assumption+)
apply (elim exE)
apply (rename_tac h)
apply (rule_tac x = "\<Union>j<a. recfunAC16 (h,f,j,a) " in exI)
apply (rule_tac P="\<lambda>z. Y \<and> (\<forall>x \<in> z. Z(x))"  for Y Z
       in bij_is_surj [THEN surj_image_eq, THEN subst], assumption)
apply (rule lemma_simp_induct)
apply (blast del: conjI notI
             intro!: main_induct eqpoll_imp_lepoll [THEN lepoll_infinite] )
apply (blast intro: bij_is_fun [THEN surj_image, THEN surj_is_fun])
apply (erule eqpoll_imp_lepoll [THEN lepoll_infinite,
                                THEN infinite_Card_is_InfCard,
                                THEN InfCard_is_Limit],
       assumption+)
apply (blast dest!: recfunAC16_mono)
done

end


section \<open>Product Machines\<close>

text \<open>This theory defines the construction of product machines.
      A product machine of two finite state machines essentially represents all possible parallel
      executions of those two machines.\<close>

theory Product_FSM
imports FSM
begin

lift_definition product :: "('a,'b,'c) fsm \<Rightarrow> ('d,'b,'c) fsm \<Rightarrow> ('a \<times> 'd,'b,'c) fsm" is FSM_Impl.product
proof -
  fix A :: "('a,'b,'c) fsm_impl"
  fix B :: "('d,'b,'c) fsm_impl"
  assume "well_formed_fsm A" and "well_formed_fsm B"

  then have p1a: "fsm_impl.initial A \<in> fsm_impl.nodes A"
        and p2a: "finite (fsm_impl.nodes A)"
        and p3a: "finite (fsm_impl.inputs A)"
        and p4a: "finite (fsm_impl.outputs A)"
        and p5a: "finite (fsm_impl.transitions A)"
        and p6a: "(\<forall>t\<in>fsm_impl.transitions A.
            t_source t \<in> fsm_impl.nodes A \<and>
            t_input t \<in> fsm_impl.inputs A \<and> t_target t \<in> fsm_impl.nodes A \<and>
                                             t_output t \<in> fsm_impl.outputs A)"
        and p1b: "fsm_impl.initial B \<in> fsm_impl.nodes B"
        and p2b: "finite (fsm_impl.nodes B)"
        and p3b: "finite (fsm_impl.inputs B)"
        and p4b: "finite (fsm_impl.outputs B)"
        and p5b: "finite (fsm_impl.transitions B)"
        and p6b: "(\<forall>t\<in>fsm_impl.transitions B.
            t_source t \<in> fsm_impl.nodes B \<and>
            t_input t \<in> fsm_impl.inputs B \<and> t_target t \<in> fsm_impl.nodes B \<and>
                                             t_output t \<in> fsm_impl.outputs B)"
    by simp+

  let ?P = "FSM_Impl.product A B"

  have "fsm_impl.initial ?P \<in> fsm_impl.nodes ?P"
    using p1a p1b by auto
  moreover have "finite (fsm_impl.nodes ?P)"
    using p2a p2b by auto
  moreover have "finite (fsm_impl.inputs ?P)"
    using p3a p3b by auto
  moreover have "finite (fsm_impl.outputs ?P)"
    using p4a p4b by auto
  moreover have "finite (fsm_impl.transitions ?P)"
    using p5a p5b unfolding product_code_naive by auto
  moreover have "(\<forall>t\<in>fsm_impl.transitions ?P.
            t_source t \<in> fsm_impl.nodes ?P \<and>
            t_input t \<in> fsm_impl.inputs ?P \<and> t_target t \<in> fsm_impl.nodes ?P \<and>
                                             t_output t \<in> fsm_impl.outputs ?P)"
    using p6a p6b by auto

  ultimately show "well_formed_fsm (FSM_Impl.product A B)"
    by blast
qed

abbreviation "left_path p \<equiv> map (\<lambda>t. (fst (t_source t), t_input t, t_output t, fst (t_target t))) p"
abbreviation "right_path p \<equiv> map (\<lambda>t. (snd (t_source t), t_input t, t_output t, snd (t_target t))) p"
abbreviation "zip_path p1 p2 \<equiv> (map (\<lambda> t . ((t_source (fst t), t_source (snd t)), t_input (fst t), t_output (fst t), (t_target (fst t), t_target (snd t))))
                                     (zip p1 p2))"

lemma product_simps[simp]:
  "initial (product A B) = (initial A, initial B)"
  "nodes (product A B) = (nodes A) \<times> (nodes B)"
  "inputs (product A B) = inputs A \<union> inputs B"
  "outputs (product A B) = outputs A \<union> outputs B"
  by (transfer; simp)+

lemma product_transitions_def :
  "transitions (product A B) = {((qA,qB),x,y,(qA',qB')) | qA qB x y qA' qB' . (qA,x,y,qA') \<in> transitions A \<and> (qB,x,y,qB') \<in> transitions B}"
  by (transfer; simp)+

lemma product_transitions_alt_def :
  "transitions (product A B) = {((t_source tA, t_source tB),t_input tA, t_output tA, (t_target tA, t_target tB)) | tA tB . tA \<in> transitions A \<and> tB \<in> transitions B \<and> t_input tA = t_input tB \<and> t_output tA = t_output tB}"
  (is "?T1 = ?T2")
proof -
  have "\<And> t . t \<in> ?T1 \<Longrightarrow> t \<in> ?T2"
  proof -
    fix tt assume "tt \<in> ?T1"
    then obtain qA qB x y qA' qB' where "tt = ((qA,qB),x,y,(qA',qB'))" and "(qA,x,y,qA') \<in> transitions A" and "(qB,x,y,qB') \<in> transitions B"
      unfolding product_transitions_def by blast
    then have "((t_source (qA,x,y,qA'), t_source (qB,x,y,qB')),t_input (qA,x,y,qA'), t_output (qA,x,y,qA'), (t_target (qA,x,y,qA'), t_target (qB,x,y,qB'))) \<in> ?T2"
      by auto
    then show "tt \<in> ?T2"
      unfolding \<open>tt = ((qA,qB),x,y,(qA',qB'))\<close> fst_conv snd_conv by assumption
  qed
  moreover have "\<And> t . t \<in> ?T2 \<Longrightarrow> t \<in> ?T1"
  proof -
    fix tt assume "tt \<in> ?T2"
    then obtain tA tB where "tt = ((t_source tA, t_source tB),t_input tA, t_output tA, (t_target tA, t_target tB))"
                        and "tA \<in> transitions A" and "tB \<in> transitions B" and "t_input tA = t_input tB" and "t_output tA = t_output tB"
      by blast
    then have "(t_source tA, t_input tA, t_output tA, t_target tA) \<in> transitions A"
         and  "(t_source tB, t_input tA, t_output tA, t_target tB) \<in> transitions B"
      by (metis prod.collapse)+
    then show "tt \<in> ?T1"
      unfolding product_transitions_def \<open>tt = ((t_source tA, t_source tB),t_input tA, t_output tA, (t_target tA, t_target tB))\<close> by blast
  qed
  ultimately show ?thesis by blast
qed

lemma zip_path_last : "length xs = length ys \<Longrightarrow> (zip_path (xs @ [x]) (ys @ [y])) = (zip_path xs ys)@(zip_path [x] [y])"
  by (induction xs ys rule: list_induct2; simp)

lemma product_path_from_paths :
  assumes "path A (initial A) p1"
      and "path B (initial B) p2"
      and "p_io p1 = p_io p2"
    shows "path (product A B) (initial (product A B)) (zip_path p1 p2)"
      and "target (initial (product A B)) (zip_path p1 p2) = (target (initial A) p1, target (initial B) p2)"
proof -
  have "initial (product A B) = (initial A, initial B)" by auto
  then have "(initial A, initial B) \<in> nodes (product A B)"
    by (metis fsm_initial)

  have "length p1 = length p2" using assms(3)
    using map_eq_imp_length_eq by blast
  then have c: "path (product A B) (initial (product A B)) (zip_path p1 p2)
                \<and> target (initial (product A B)) (zip_path p1 p2) = (target (initial A) p1, target (initial B) p2)"
    using assms proof (induction p1 p2 rule: rev_induct2)
    case Nil

    then have "path (product A B) (initial (product A B)) (zip_path [] [])"
      using \<open>initial (product A B) = (initial A, initial B)\<close> \<open>(initial A, initial B) \<in> nodes (product A B)\<close>
      by (metis Nil_is_map_conv path.nil zip_Nil)
    moreover have "target (initial (product A B)) (zip_path [] []) = (target (initial A) [], target (initial B) [])"
      using \<open>initial (product A B) = (initial A, initial B)\<close> by auto
    ultimately show ?case by fast
  next
    case (snoc x xs y ys)

    have "path A (initial A) xs" using snoc.prems(1) by auto
    moreover have "path B (initial B) ys" using snoc.prems(2) by auto
    moreover have "p_io xs = p_io ys" using snoc.prems(3) by auto
    ultimately have *:"path (product A B) (initial (product A B)) (zip_path xs ys)"
                and **:"target (initial (product A B)) (zip_path xs ys) = (target (initial A) xs, target (initial B) ys)"
      using snoc.IH by blast+
    then have "(target (initial A) xs, target (initial B) ys) \<in> nodes (product A B)"
      by (metis (no_types, lifting) path_target_is_node)
    then have "(t_source x, t_source y) \<in> nodes (product A B)"
      using snoc.prems(1-2)  by (metis path_cons_elim path_suffix)

    have "x \<in> transitions A" using snoc.prems(1) by auto
    moreover have "y \<in> transitions B" using snoc.prems(2) by auto
    moreover have "t_input x = t_input y" using snoc.prems(3) by auto
    moreover have "t_output x = t_output y" using snoc.prems(3) by auto
    ultimately have "((t_source x, t_source y), t_input x, t_output x, (t_target x, t_target y)) \<in> transitions (product A B)"
      unfolding product_transitions_alt_def by blast

    moreover have "t_source x = target (initial A) xs" using snoc.prems(1) by auto
    moreover have "t_source y = target (initial B) ys" using snoc.prems(2) by auto
    ultimately have "((target (initial A) xs, target (initial B) ys), t_input x, t_output x, (t_target x, t_target y)) \<in> transitions (product A B)"
      using \<open>(t_source x, t_source y) \<in> nodes (product A B)\<close>
      by simp
    then have ***: "path (product A B) (initial (product A B)) ((zip_path xs ys)@[((target (initial A) xs, target (initial B) ys), t_input x, t_output x, (t_target x, t_target y))])"
      using * **
      by (metis (no_types, lifting) fst_conv path_append_transition)

    have "t_target x = target (initial A) (xs@[x])" by auto
    moreover have "t_target y = target (initial B) (ys@[y])" by auto
    ultimately have ****: "target (initial (product A B)) ((zip_path xs ys)@[((target (initial A) xs, target (initial B) ys), t_input x, t_output x, (t_target x, t_target y))])
                            = (target (initial A) (xs@[x]), target (initial B) (ys@[y]))"
      by fastforce

    have "(zip_path [x] [y]) = [((target (initial A) xs, target (initial B) ys), t_input x, t_output x, (t_target x, t_target y))]"
      using \<open>t_source x = target (initial A) xs\<close> \<open>t_source y = target (initial B) ys\<close> by auto
    moreover have "(zip_path (xs @ [x]) (ys @ [y])) = (zip_path xs ys)@(zip_path [x] [y])"
      using zip_path_last[of xs ys x y, OF snoc.hyps]  by assumption
    ultimately have *****:"(zip_path (xs@[x]) (ys@[y]))
                            = (zip_path xs ys)@[((target (initial A) xs, target (initial B) ys), t_input x, t_output x, (t_target x, t_target y))]"
      by auto
    then have "path (product A B) (initial (product A B)) (zip_path (xs@[x]) (ys@[y]))"
      using *** by presburger
    moreover have "target (initial (product A B)) (zip_path (xs@[x]) (ys@[y]))
                      = (target (initial A) (xs@[x]), target (initial B) (ys@[y]))"
      using **** ***** by auto
    ultimately show ?case by linarith
  qed

  from c show "path (product A B) (initial (product A B)) (zip_path p1 p2)"
    by auto
  from c show "target (initial (product A B)) (zip_path p1 p2)
                  = (target (initial A) p1, target (initial B) p2)"
    by auto
qed

lemma paths_from_product_path :
  assumes "path (product A B) (initial (product A B)) p"
  shows   "path A (initial A) (left_path p)"
      and "path B (initial B) (right_path p)"
      and "target (initial A) (left_path p) = fst (target (initial (product A B)) p)"
      and "target (initial B) (right_path p) = snd (target (initial (product A B)) p)"
proof -
  have "path A (initial A) (left_path p)
            \<and> path B (initial B) (right_path p)
            \<and> target (initial A) (left_path p) = fst (target (initial (product A B)) p)
            \<and> target (initial B) (right_path p) = snd (target (initial (product A B)) p)"
  using assms proof (induction p rule: rev_induct)
    case Nil
    then show ?case by auto
  next
    case (snoc t p)
    then have "path (product A B) (initial (product A B)) p" by fast
    then have "path A (initial A) (left_path p)"
      and "path B (initial B) (right_path p)"
      and "target (initial A) (left_path p) = fst (target (initial (product A B)) p)"
      and "target (initial B) (right_path p) = snd (target (initial (product A B)) p)"
      using snoc.IH  by fastforce+

    then have "t_source t = (target (initial A) (left_path p), target (initial B) (right_path p))"
      using snoc.prems by (metis (no_types, lifting) path_cons_elim path_suffix prod.collapse)

    have ***: "target (initial A) (left_path (p@[t]))= fst (target (initial (product A B)) (p@[t]))"
      by fastforce
    have ****: "target (initial B) (right_path (p@[t]))= snd (target (initial (product A B)) (p@[t]))"
      by fastforce

    have "t \<in> transitions (product A B)" using snoc.prems by auto

    then have "(fst (t_source t), t_input t, t_output t, fst (t_target t)) \<in> transitions A"
      unfolding product_transitions_alt_def by force
    moreover have "target (initial A) (left_path p) = fst (t_source t)"
      using \<open>t_source t = (target (initial A) (left_path p), target (initial B) (right_path p))\<close> by auto
    ultimately have "path A (initial A) ((left_path p)@[(fst (t_source t), t_input t, t_output t, fst (t_target t))])"
      by (simp add: \<open>path A (initial A) (map (\<lambda>t. (fst (t_source t), t_input t, t_output t, fst (t_target t))) p)\<close> path_append_transition)
    then have *: "path A (initial A) (left_path (p@[t]))" by auto

    have "(snd (t_source t), t_input t, t_output t, snd (t_target t)) \<in> transitions B"
      using \<open>t \<in> transitions (product A B)\<close> unfolding product_transitions_alt_def by auto
    moreover have "target (initial B) (right_path p) = snd (t_source t)"
      using \<open>t_source t = (target (initial A) (left_path p), target (initial B) (right_path p))\<close> by auto
    ultimately have "path B (initial B) ((right_path p)@[(snd (t_source t), t_input t, t_output t, snd (t_target t))])"
      by (simp add: \<open>path B (initial B) (map (\<lambda>t. (snd (t_source t), t_input t, t_output t, snd (t_target t))) p)\<close> path_append_transition)
    then have **: "path B (initial B) (right_path (p@[t]))" by auto

    show ?case using * ** *** **** by blast
  qed

  then show "path A (initial A) (left_path p)"
      and "path B (initial B) (right_path p)"
      and "target (initial A) (left_path p) = fst (target (initial (product A B)) p)"
      and "target (initial B) (right_path p) = snd (target (initial (product A B)) p)" by linarith+
qed

lemma zip_path_left_right[simp] :
  "(zip_path (left_path p) (right_path p)) = p" by (induction p; auto)

lemma product_reachable_node_paths :
  assumes "(q1,q2) \<in> reachable_nodes (product A B)"
obtains p1 p2
  where "path A (initial A) p1"
  and   "path B (initial B) p2"
  and   "target (initial A) p1 = q1"
  and   "target (initial B) p2 = q2"
  and   "p_io p1 = p_io p2"
  and   "path (product A B) (initial (product A B)) (zip_path p1 p2)"
  and   "target (initial (product A B)) (zip_path p1 p2) = (q1,q2)"
proof -
  let ?P = "product A B"
  from assms obtain p where "path ?P (initial ?P) p" and "target (initial ?P) p = (q1,q2)"
    unfolding reachable_nodes_def by auto

  have "path A (initial A) (left_path p)"
   and "path B (initial B) (right_path p)"
   and "target (initial A) (left_path p) = q1"
   and "target (initial B) (right_path p) = q2"
    using paths_from_product_path[OF \<open>path ?P (initial ?P) p\<close>] \<open>target (initial ?P) p = (q1,q2)\<close> by auto

  moreover have "p_io (left_path p) = p_io (right_path p)" by auto
  moreover have "path (product A B) (initial (product A B)) (zip_path (left_path p) (right_path p))"
    using \<open>path ?P (initial ?P) p\<close> by auto
  moreover have "target (initial (product A B)) (zip_path (left_path p) (right_path p)) = (q1,q2)"
    using \<open>target (initial ?P) p = (q1,q2)\<close> by auto
  ultimately show ?thesis using that by blast
qed

lemma product_reachable_nodes[iff] :
  "(q1,q2) \<in> reachable_nodes (product A B) \<longleftrightarrow> (\<exists> p1 p2 . path A (initial A) p1 \<and> path B (initial B) p2 \<and> target (initial A) p1 = q1 \<and> target (initial B) p2 = q2 \<and> p_io p1 = p_io p2)"
proof
  show "(q1,q2) \<in> reachable_nodes (product A B) \<Longrightarrow> (\<exists> p1 p2 . path A (initial A) p1 \<and> path B (initial B) p2 \<and> target (initial A) p1 = q1 \<and> target (initial B) p2 = q2 \<and> p_io p1 = p_io p2)"
    using product_reachable_node_paths[of q1 q2 A B] by blast
  show "(\<exists> p1 p2 . path A (initial A) p1 \<and> path B (initial B) p2 \<and> target (initial A) p1 = q1 \<and> target (initial B) p2 = q2 \<and> p_io p1 = p_io p2) \<Longrightarrow> (q1,q2) \<in> reachable_nodes (product A B)"
  proof -
    assume "(\<exists> p1 p2 . path A (initial A) p1 \<and> path B (initial B) p2 \<and> target (initial A) p1 = q1 \<and> target (initial B) p2 = q2 \<and> p_io p1 = p_io p2)"
    then obtain p1 p2 where "path A (initial A) p1 \<and> path B (initial B) p2 \<and> target (initial A) p1 = q1 \<and> target (initial B) p2 = q2 \<and> p_io p1 = p_io p2"
      by blast
    then show ?thesis
      using product_path_from_paths[of A p1 B p2] unfolding reachable_nodes_def
      by (metis (mono_tags, lifting) mem_Collect_eq)
  qed
qed

lemma left_path_zip : "length p1 = length p2 \<Longrightarrow> left_path (zip_path p1 p2) = p1"
  by (induction p1 p2 rule: list_induct2; simp)

lemma right_path_zip : "length p1 = length p2 \<Longrightarrow> p_io p1 = p_io p2 \<Longrightarrow> right_path (zip_path p1 p2) = p2"
  by (induction p1 p2 rule: list_induct2; simp)

lemma zip_path_append_left_right : "length p1 = length p2 \<Longrightarrow> zip_path (p1@(left_path p)) (p2@(right_path p)) = (zip_path p1 p2)@p"
proof (induction p1 p2 rule: list_induct2)
  case Nil
  then show ?case by (induction p; simp)
next
  case (Cons x xs y ys)
  then show ?case by simp
qed

lemma product_path:
  "path (product A B) (q1,q2) p \<longleftrightarrow> (path A q1 (left_path p) \<and> path B q2 (right_path p))"
proof (induction p arbitrary: q1 q2)
  case Nil
  then show ?case by auto
next
  case (Cons t p)

  have "path (Product_FSM.product A B) (q1, q2) (t # p) \<Longrightarrow> (path A q1 (left_path (t # p)) \<and> path B q2 (right_path (t # p)))"
  proof -
    assume "path (Product_FSM.product A B) (q1, q2) (t # p)"
    then obtain x y qA' qB' where "t = ((q1,q2),x,y,(qA',qB'))" using prod.collapse
      by (metis path_cons_elim)
    then have "((q1,q2),x,y,(qA',qB')) \<in> transitions (product A B)"
      using \<open>path (Product_FSM.product A B) (q1, q2) (t # p)\<close> by auto
    then have "(q1, x, y, qA') \<in> FSM.transitions A" and "(q2, x, y, qB') \<in> FSM.transitions B"
      unfolding product_transitions_def by blast+
    moreover have "(path A qA' (left_path p) \<and> path B qB' (right_path p))"
      using Cons.IH[of qA' qB'] \<open>path (Product_FSM.product A B) (q1, q2) (t # p)\<close> unfolding \<open>t = ((q1,q2),x,y,(qA',qB'))\<close> by auto
    ultimately show ?thesis
      unfolding \<open>t = ((q1,q2),x,y,(qA',qB'))\<close>
      by (simp add: path_prepend_t)
  qed

  moreover have "path A q1 (left_path (t # p)) \<Longrightarrow> path B q2 (right_path (t # p)) \<Longrightarrow> path (Product_FSM.product A B) (q1, q2) (t # p)"
  proof -
    assume "path A q1 (left_path (t # p))" and "path B q2 (right_path (t # p))"
    then obtain x y qA' qB' where "t = ((q1,q2),x,y,(qA',qB'))" using prod.collapse
      by (metis (no_types, lifting) fst_conv list.simps(9) path_cons_elim)
    then have "(q1, x, y, qA') \<in> FSM.transitions A" and "(q2, x, y, qB') \<in> FSM.transitions B"
      using \<open>path A q1 (left_path (t # p))\<close> \<open>path B q2 (right_path (t # p))\<close> by auto
    then have "((q1,q2),x,y,(qA',qB')) \<in> transitions (product A B)"
      unfolding product_transitions_def by blast
    moreover have "path (Product_FSM.product A B) (qA', qB') p"
      using Cons.IH[of qA' qB'] \<open>path A q1 (left_path (t # p))\<close> \<open>path B q2 (right_path (t # p))\<close> unfolding \<open>t = ((q1,q2),x,y,(qA',qB'))\<close> by auto
    ultimately show "path (Product_FSM.product A B) (q1, q2) (t # p)"
      unfolding \<open>t = ((q1,q2),x,y,(qA',qB'))\<close>
      by (simp add: path_prepend_t)
  qed

  ultimately show ?case by force
qed

lemma product_path_rev:
  assumes "p_io p1 = p_io p2"
  shows "path (product A B) (q1,q2) (zip_path p1 p2) \<longleftrightarrow> (path A q1 p1 \<and> path B q2 p2)"
proof -
  have "length p1 = length p2" using assms
    using map_eq_imp_length_eq by blast
  then have "(map (\<lambda> t . (fst (t_source t), t_input t, t_output t, fst (t_target t))) (map (\<lambda> t . ((t_source (fst t), t_source (snd t)), t_input (fst t), t_output (fst t), (t_target (fst t), t_target (snd t)))) (zip p1 p2))) = p1"
    by (induction p1 p2 arbitrary: q1 q2 rule: list_induct2; auto)

  moreover have "(map (\<lambda> t . (snd (t_source t), t_input t, t_output t, snd (t_target t))) (map (\<lambda> t . ((t_source (fst t), t_source (snd t)), t_input (fst t), t_output (fst t), (t_target (fst t), t_target (snd t)))) (zip p1 p2))) = p2"
    using \<open>length p1 = length p2\<close> assms by (induction p1 p2 arbitrary: q1 q2 rule: list_induct2; auto)

  ultimately show ?thesis using product_path[of A B q1 q2 "(map (\<lambda> t . ((t_source (fst t), t_source (snd t)), t_input (fst t), t_output (fst t), (t_target (fst t), t_target (snd t)))) (zip p1 p2))"]
    by auto
qed

lemma product_language_state :
  shows "LS (product A B) (q1,q2) = LS A q1 \<inter> LS B q2"
proof
  show "LS (product A B) (q1, q2) \<subseteq> LS A q1 \<inter> LS B q2"
  proof
    fix io assume "io \<in> LS (product A B) (q1, q2)"
    then obtain p where "io = p_io p"
                    and "path (product A B) (q1,q2) p"
      by auto
    then obtain p1 p2 where "path A q1 p1"
                        and "path B q2 p2"
                        and "io = p_io p1"
                        and "io = p_io p2"
      using product_path[of A B q1 q2 p] by fastforce
    then show "io \<in> LS A q1 \<inter> LS B q2"
      unfolding LS.simps by blast
  qed

  show "LS A q1 \<inter> LS B q2 \<subseteq> LS (product A B) (q1, q2)"
  proof
    fix io assume "io \<in> LS A q1 \<inter> LS B q2"
    then obtain p1 p2 where "path A q1 p1"
                        and "path B q2 p2"
                        and "io = p_io p1"
                        and "io = p_io p2"
                        and "p_io p1 = p_io p2"
      by auto

    let ?p = "zip_path p1 p2"

    have "length p1 = length p2"
      using \<open>p_io p1 = p_io p2\<close> map_eq_imp_length_eq by blast
    moreover have "p_io ?p = p_io (map fst (zip p1 p2))" by auto
    ultimately have "p_io ?p = p_io p1" by auto

    then have "p_io ?p = io"
      using \<open>io = p_io p1\<close> by auto
    moreover have "path (product A B) (q1, q2) ?p"
      using product_path_rev[OF \<open>p_io p1 = p_io p2\<close>, of A B q1 q2] \<open>path A q1 p1\<close> \<open>path B q2 p2\<close> by auto
    ultimately show "io \<in> LS (product A B) (q1, q2)"
      unfolding LS.simps by blast
  qed
qed

lemma product_language : "L (product A B) = L A \<inter> L B"
  unfolding product_simps product_language_state by blast

lemma product_transition_split_ob :
  assumes "t \<in> transitions (product A B)"
  obtains t1 t2
  where "t1 \<in> transitions A \<and> t_source t1 = fst (t_source t) \<and> t_input t1 = t_input t \<and> t_output t1 = t_output t \<and> t_target t1 = fst (t_target t)"
    and "t2 \<in> transitions B \<and> t_source t2 = snd (t_source t) \<and> t_input t2 = t_input t \<and> t_output t2 = t_output t \<and> t_target t2 = snd (t_target t)"
  using assms unfolding product_transitions_alt_def
  by auto

lemma product_transition_split :
  assumes "t \<in> transitions (product A B)"
  shows "(fst (t_source t), t_input t, t_output t, fst (t_target t)) \<in> transitions A"
    and "(snd (t_source t), t_input t, t_output t, snd (t_target t)) \<in> transitions B"
  using product_transition_split_ob[OF assms] prod.collapse by fastforce+

lemma  product_target_split:
  assumes "target (q1,q2) p = (q1',q2')"
  shows "target q1 (left_path p) = q1'"
    and "target q2 (right_path p) = q2'"
using assms by (induction p arbitrary: q1 q2; force)+

lemma target_single_transition[simp] : "target q1 [(q1, x, y, q1')] = q1'"
  by auto

lemma product_undefined_input :
  assumes "\<not> (\<exists> t \<in> transitions (product (from_FSM M q1) (from_FSM M q2)).
               t_source t = qq \<and> t_input t = x)"
  and "q1 \<in> nodes M"
  and "q2 \<in> nodes M"
shows "\<not> (\<exists> t1 \<in> transitions M. \<exists> t2 \<in> transitions M.
                 t_source t1 = fst qq \<and>
                 t_source t2 = snd qq \<and>
                 t_input t1 = x \<and> t_input t2 = x \<and> t_output t1 = t_output t2)"
proof
  assume "\<exists> t1 \<in> transitions M. \<exists> t2 \<in> transitions M.
                 t_source t1 = fst qq \<and>
                 t_source t2 = snd qq \<and>
                 t_input t1 = x \<and> t_input t2 = x \<and> t_output t1 = t_output t2"
  then obtain t1 t2 where "t1 \<in> transitions M"
                      and "t2 \<in> transitions M"
                      and "t_source t1 = fst qq"
                      and "t_source t2 = snd qq"
                      and "t_input t1 = x"
                      and "t_input t1 = t_input t2"
                      and "t_output t1 = t_output t2"
    by force

  have "((t_source t1, t_source t2), t_input t1, t_output t1, t_target t1, t_target t2) \<in> transitions (product (from_FSM M q1) (from_FSM M q2))"
    unfolding product_transitions_alt_def
    unfolding from_FSM_simps[OF assms(2)]
    unfolding from_FSM_simps[OF assms(3)]
    using \<open>t1 \<in> transitions M\<close> \<open>t2 \<in> transitions M\<close> \<open>t_input t1 = t_input t2\<close> \<open>t_output t1 = t_output t2\<close> by blast
  then show False
    unfolding \<open>t_source t1 = fst qq\<close> \<open>t_source t2 = snd qq\<close> \<open>t_input t1 = x\<close> prod.collapse
    using assms(1) by auto
qed

subsection \<open>Product Machines and Changing Initial States\<close>

lemma product_from_reachable_next :
  assumes "((q1,q2),x,y,(q1',q2')) \<in> transitions (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
  shows   "(from_FSM (product (from_FSM M q1) (from_FSM M q2)) (q1', q2')) = (product (from_FSM M q1') (from_FSM M q2'))"
          (is "?P1 = ?P2")
proof -
  have "(q1,x,y,q1') \<in> transitions (from_FSM M q1)"
  and  "(q2,x,y,q2') \<in> transitions (from_FSM M q2)"
    using assms(1) unfolding product_transitions_def by blast+
  then have "q1' \<in> nodes (from_FSM M q1)" and "q2' \<in> nodes (from_FSM M q2)"
    using fsm_transition_target by auto

  have "q1' \<in> nodes (from_FSM M q1')" and "q1' \<in> nodes M" and "q1 \<in> nodes M"
    using \<open>q1' \<in> FSM.nodes (FSM.from_FSM M q1)\<close> assms(2) reachable_node_is_node by fastforce+
  have "q2' \<in> nodes (from_FSM M q2')" and "q2' \<in> nodes M" and "q2 \<in> nodes M"
    using \<open>q2' \<in> FSM.nodes (FSM.from_FSM M q2)\<close> assms(3) reachable_node_is_node by fastforce+

  have "initial ?P1 = initial ?P2"
  and  "nodes ?P1 = nodes ?P2"
  and  "inputs ?P1 = inputs ?P2"
  and  "outputs ?P1 = outputs ?P2"
  and  "transitions ?P1 = transitions ?P2"
    using from_FSM_simps[OF fsm_transition_target[OF assms(1)]]
    unfolding snd_conv
    unfolding product_simps
    unfolding product_transitions_def
    unfolding from_FSM_simps[OF \<open>q1' \<in> nodes M\<close>] from_FSM_simps[OF \<open>q2' \<in> nodes M\<close>]
    unfolding from_FSM_simps[OF \<open>q1 \<in> nodes M\<close>] from_FSM_simps[OF \<open>q2 \<in> nodes M\<close>]
    by auto

  then show ?thesis by (transfer; auto)
qed

lemma from_FSM_product_inputs :
  assumes "q1 \<in> nodes M" and "q2 \<in> nodes M"
shows "(inputs (product (from_FSM M q1) (from_FSM M q2))) = (inputs M)"
  by (simp add: assms(1) assms(2))

lemma from_FSM_product_outputs :
  assumes "q1 \<in> nodes M" and "q2 \<in> nodes M"
shows "(outputs (product (from_FSM M q1) (from_FSM M q2))) = (outputs M)"
  by (simp add: assms(1) assms(2))

lemma from_FSM_product_initial :
  assumes "q1 \<in> nodes M" and "q2 \<in> nodes M"
shows "initial (product (from_FSM M q1) (from_FSM M q2)) = (q1,q2)"
  by (simp add: assms(1) assms(2))

lemma product_from_reachable_next' :
  assumes "t \<in> transitions (product (from_FSM M (fst (t_source t))) (from_FSM M (snd (t_source t))))"
  and     "fst (t_source t) \<in> nodes M"
  and     "snd (t_source t) \<in> nodes M"
shows "(from_FSM (product (from_FSM M (fst (t_source t))) (from_FSM M (snd (t_source t)))) (fst (t_target t),snd (t_target t))) = (product (from_FSM M (fst (t_target t))) (from_FSM M (snd (t_target t))))"
proof -
  have "((fst (t_source t), snd (t_source t)), t_input t, t_output t, fst (t_target t), snd (t_target t)) = t"
    by simp
  then show ?thesis
    by (metis (no_types) assms(1) assms(2) assms(3) product_from_reachable_next)
qed

lemma product_from_reachable_next'_path :
  assumes "t \<in> transitions (product (from_FSM M (fst (t_source t))) (from_FSM M (snd (t_source t))))"
  and     "fst (t_source t) \<in> nodes M"
  and     "snd (t_source t) \<in> nodes M"
  shows "path (from_FSM (product (from_FSM M (fst (t_source t))) (from_FSM M (snd (t_source t)))) (fst (t_target t),snd (t_target t))) (fst (t_target t),snd (t_target t)) p = path (product (from_FSM M (fst (t_target t))) (from_FSM M (snd (t_target t)))) (fst (t_target t),snd (t_target t)) p"
    (is "path ?P1 ?q p = path ?P2 ?q p")
proof -
  have i1: "initial ?P1 = ?q"
    using assms(1) fsm_transition_target by fastforce
  have i2: "initial ?P2 = ?q"
  proof -
    have "((fst (t_source t), snd (t_source t)), t_input t, t_output t, fst (t_target t), snd (t_target t)) = t"
      by auto
    then show ?thesis
      by (metis (no_types) assms(1) assms(2) assms(3) i1 product_from_reachable_next)
  qed

  have h12: "transitions ?P1 = transitions ?P2" using product_from_reachable_next'[OF assms] by simp

  show ?thesis proof (induction p rule: rev_induct)
    case Nil
    then show ?case
      by (metis (full_types) i1 i2 fsm_initial path.nil)
  next
    case (snoc t p)
    show ?case
      by (metis h12 path_append_transition path_append_transition_elim(1) path_append_transition_elim(2) path_append_transition_elim(3) snoc.IH)
  qed
qed

lemma product_from_transition:
  assumes "(q1',q2') \<in> nodes (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
shows "transitions (product (from_FSM M q1') (from_FSM M q2')) = transitions (product (from_FSM M q1) (from_FSM M q2))"
proof -
  have "q1' \<in> nodes M" and "q2' \<in> nodes M"
    using assms(1) unfolding product_simps from_FSM_simps[OF assms(2)] from_FSM_simps[OF assms(3)] by auto
  show ?thesis
    unfolding product_transitions_def from_FSM_simps[OF \<open>q1 \<in> nodes M\<close>] from_FSM_simps[OF \<open>q1' \<in> nodes M\<close>] from_FSM_simps[OF \<open>q2 \<in> nodes M\<close>] from_FSM_simps[OF \<open>q2' \<in> nodes M\<close>] by blast
qed

lemma product_from_path:
  assumes "(q1',q2') \<in> nodes (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
      and "path (product (from_FSM M q1') (from_FSM M q2')) (q1',q2') p"
    shows "path (product (from_FSM M q1) (from_FSM M q2)) (q1',q2') p"
  by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) from_FSM_path_initial from_FSM_simps(5) from_from mem_Sigma_iff product_path product_simps(2))

lemma product_from_path_previous :
  assumes "path (product (from_FSM M (fst (t_target t)))
                         (from_FSM M (snd (t_target t))))
                (t_target t) p"                                           (is "path ?Pt (t_target t) p")
      and "t \<in> transitions (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
    shows "path (product (from_FSM M q1) (from_FSM M q2)) (t_target t) p" (is "path ?P (t_target t) p")
  by (metis assms(1) assms(2) assms(3) assms(4) fsm_transition_target prod.collapse product_from_path)

lemma product_from_transition_shared_node :
  assumes "t \<in> transitions (product (from_FSM M q1') (from_FSM M q2'))"
  and     "(q1',q2') \<in> nodes (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
shows "t \<in> transitions (product (from_FSM M q1) (from_FSM M q2))"
  by (metis assms product_from_transition)

lemma product_from_not_completely_specified :
  assumes "\<not> completely_specified_state (product (from_FSM M q1) (from_FSM M q2)) (q1',q2')"
  and     "(q1',q2') \<in> nodes (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
    shows  "\<not> completely_specified_state (product (from_FSM M q1') (from_FSM M q2')) (q1',q2')"
proof -
  have "q1' \<in> nodes M" and "q2' \<in> nodes M"
    using assms(2) unfolding product_simps from_FSM_simps[OF assms(3)] from_FSM_simps[OF assms(4)] by auto
  show ?thesis

    using from_FSM_product_inputs[OF assms(3) assms(4)]
    using from_FSM_product_inputs[OF \<open>q1' \<in> nodes M\<close> \<open>q2' \<in> nodes M\<close> ]
  proof -
    have "FSM.transitions (Product_FSM.product (FSM.from_FSM M q1') (FSM.from_FSM M q2')) = FSM.transitions (Product_FSM.product (FSM.from_FSM M q1) (FSM.from_FSM M q2))"
      by (metis (no_types) \<open>(q1', q2') \<in> FSM.nodes (Product_FSM.product (FSM.from_FSM M q1) (FSM.from_FSM M q2))\<close> assms(3) assms(4) product_from_transition)
    then show ?thesis
      using \<open>FSM.inputs (Product_FSM.product (FSM.from_FSM M q1') (FSM.from_FSM M q2')) = FSM.inputs M\<close> \<open>FSM.inputs (Product_FSM.product (FSM.from_FSM M q1) (FSM.from_FSM M q2)) = FSM.inputs M\<close> \<open>\<not> completely_specified_state (Product_FSM.product (FSM.from_FSM M q1) (FSM.from_FSM M q2)) (q1', q2')\<close> by fastforce
  qed
qed

lemma from_product_initial_paths_ex :
  assumes "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
shows  "(\<exists>p1 p2.
         path (from_FSM M q1) (initial (from_FSM M q1)) p1 \<and>
         path (from_FSM M q2) (initial (from_FSM M q2)) p2 \<and>
         target (initial (from_FSM M q1)) p1 = q1 \<and>
         target (initial (from_FSM M q2)) p2 = q2 \<and> p_io p1 = p_io p2)"
proof -
  have "path (from_FSM M q1) (initial (from_FSM M q1)) []" by blast
  moreover have "path (from_FSM M q2) (initial (from_FSM M q2)) []" by blast
  moreover have "
         target (initial (from_FSM M q1)) [] = q1 \<and>
         target (initial (from_FSM M q2)) [] = q2 \<and> p_io [] = p_io []"
    unfolding from_FSM_simps[OF assms(1)] from_FSM_simps[OF assms(2)] by auto
  ultimately show ?thesis by blast
qed

lemma product_observable :
  assumes "observable M1"
  and     "observable M2"
shows "observable (product M1 M2)" (is "observable ?P")
proof -
  have "\<And> t1 t2 . t1 \<in> transitions ?P \<Longrightarrow> t2 \<in> transitions ?P \<Longrightarrow> t_source t1 = t_source t2 \<Longrightarrow> t_input t1 = t_input t2 \<Longrightarrow> t_output t1 = t_output t2 \<Longrightarrow> t_target t1 = t_target t2"
  proof -
    fix t1 t2 assume "t1 \<in> transitions ?P" and "t2 \<in> transitions ?P" and "t_source t1 = t_source t2" and "t_input t1 = t_input t2" and "t_output t1 = t_output t2"

    let ?t1L = "(fst (t_source t1), t_input t1, t_output t1, fst (t_target t1))"
    let ?t1R = "(snd (t_source t1), t_input t1, t_output t1, snd (t_target t1))"
    let ?t2L = "(fst (t_source t2), t_input t2, t_output t2, fst (t_target t2))"
    let ?t2R = "(snd (t_source t2), t_input t2, t_output t2, snd (t_target t2))"

    have "t_target ?t1L = t_target ?t2L"
      using product_transition_split(1)[OF \<open>t1 \<in> transitions ?P\<close>]
            product_transition_split(1)[OF \<open>t2 \<in> transitions ?P\<close>]
            \<open>observable M1\<close>
            \<open>t_source t1 = t_source t2\<close>
            \<open>t_input t1 = t_input t2\<close>
            \<open>t_output t1 = t_output t2\<close> by auto
    moreover have "t_target ?t1R = t_target ?t2R"
      using product_transition_split(2)[OF \<open>t1 \<in> transitions ?P\<close>]
            product_transition_split(2)[OF \<open>t2 \<in> transitions ?P\<close>]
            \<open>observable M2\<close>
            \<open>t_source t1 = t_source t2\<close>
            \<open>t_input t1 = t_input t2\<close>
            \<open>t_output t1 = t_output t2\<close> by auto
    ultimately show "t_target t1 = t_target t2"
      by (metis prod.exhaust_sel snd_conv)
  qed
  then show ?thesis unfolding observable.simps by blast
qed

lemma product_observable_self_transitions :
  assumes "q \<in> reachable_nodes (product M M)"
  and     "observable M"
shows "fst q = snd q"
proof -
  let ?P = "product M M"

  have "\<And> p . path ?P (initial ?P) p \<Longrightarrow> fst (target (initial ?P) p) = snd (target (initial ?P) p)"
  proof -
    fix p assume "path ?P (initial ?P) p"
    then show "fst (target (initial ?P) p) = snd (target (initial ?P) p)"
    proof (induction p rule: rev_induct)
      case Nil
      then show ?case by simp
    next
      case (snoc t p)

      have "path ?P (initial ?P) p" and "path ?P (target (initial ?P) p) [t]"
        using path_append_elim[of ?P "initial ?P" p "[t]", OF \<open>path (product M M) (initial (product M M)) (p @ [t])\<close>] by blast+
      then have "t \<in> transitions ?P"
        by blast
      have "t_source t = target (initial ?P) p"
        using snoc.prems by fastforce

      let ?t1 = "(fst (t_source t), t_input t, t_output t, fst (t_target t))"
      let ?t2 = "(snd (t_source t), t_input t, t_output t, snd (t_target t))"
      have "?t1 \<in> transitions M" and "?t2 \<in> transitions M"
        using product_transition_split[OF \<open>t \<in> transitions ?P\<close>] by auto
      moreover have "t_source ?t1 = t_source ?t2"
        using \<open>t_source t = target (initial ?P) p\<close> snoc.IH[OF \<open>path ?P (initial ?P) p\<close>]
        by (metis fst_conv)
      moreover have "t_input ?t1 = t_input ?t2"
        by auto
      moreover have "t_output ?t1 = t_output ?t2"
        by auto
      ultimately have "t_target ?t1 = t_target ?t2"
        using \<open>observable M\<close> unfolding observable.simps by blast
      then have "fst (t_target t) = snd (t_target t)"
        by auto
      then show ?case unfolding target.simps visited_nodes.simps
      proof -
        show "fst (last (initial (product M M) # map t_target (p @ [t]))) = snd (last (initial (product M M) # map t_target (p @ [t])))"
          using \<open>fst (t_target t) = snd (t_target t)\<close> last_map last_snoc length_append_singleton length_map by force
      qed
    qed
  qed

  then show ?thesis
    using assms(1) unfolding reachable_nodes_def
    by blast
qed

lemma zip_path_eq_left :
  assumes "length xs1 = length xs2"
  and     "length xs2 = length ys1"
  and     "length ys1 = length ys2"
  and     "zip_path xs1 xs2 = zip_path ys1 ys2"
shows "xs1 = ys1"
  using assms by (induction xs1 xs2 ys1 ys2 rule: list_induct4; auto)

lemma zip_path_eq_right :
  assumes "length xs1 = length xs2"
  and     "length xs2 = length ys1"
  and     "length ys1 = length ys2"
  and     "p_io xs2 = p_io ys2"
  and     "zip_path xs1 xs2 = zip_path ys1 ys2"
shows "xs2 = ys2"
  using assms by (induction xs1 xs2 ys1 ys2 rule: list_induct4; auto)

lemma zip_path_merge :
  "(zip_path (left_path p) (right_path p)) = p"
  by (induction p; auto)

lemma product_from_reachable_path' :
  assumes "path (product (from_FSM M q1) (from_FSM M q2)) (q1', q2') p"
  and     "q1 \<in> reachable_nodes M"
  and     "q2 \<in> reachable_nodes M"
shows "path (product (from_FSM M q1') (from_FSM M q2')) (q1', q2') p"
  by (meson assms(1) assms(2) assms(3) from_FSM_path from_FSM_path_rev_initial product_path reachable_node_is_node)

lemma product_from :
  assumes "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
shows "product (from_FSM M q1) (from_FSM M q2) = from_FSM (product M M) (q1,q2)" (is "?PF = ?FP")
proof -
  have "(q1,q2) \<in> nodes (product M M)"
    using assms unfolding product_simps by auto

  have "initial ?FP = initial ?PF"
  and  "inputs ?FP = inputs ?PF"
  and  "outputs ?FP = outputs ?PF"
  and  "nodes ?FP = nodes ?PF"
  and  "transitions ?FP = transitions ?PF"
    unfolding product_simps
              from_FSM_simps[OF assms(1)]
              from_FSM_simps[OF assms(2)]
              from_FSM_simps[OF \<open>(q1,q2) \<in> nodes (product M M)\<close>]
              product_transitions_def
    by auto
  then show ?thesis by (transfer; auto)
qed

lemma product_from_from :
  assumes "(q1',q2') \<in> nodes (product (from_FSM M q1) (from_FSM M q2))"
  and     "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
shows "(product (from_FSM M q1') (from_FSM M q2')) = (from_FSM (product (from_FSM M q1) (from_FSM M q2)) (q1',q2'))"
  using product_from
  by (metis (no_types, lifting) assms(1) assms(2) assms(3) from_FSM_simps(5) from_from mem_Sigma_iff product_simps(2))

lemma submachine_transition_product_from :
  assumes "is_submachine S (product (from_FSM M q1) (from_FSM M q2))"
  and     "((q1,q2),x,y,(q1',q2')) \<in> transitions S"
  and     "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
 shows "is_submachine (from_FSM S (q1',q2')) (product (from_FSM M q1') (from_FSM M q2'))"
proof -
  have "((q1,q2),x,y,(q1',q2')) \<in> transitions (product (from_FSM M q1) (from_FSM M q2))"
    using assms(1) assms(2) by auto
  have "(q1',q2') \<in> nodes S" using fsm_transition_target assms(2) by auto
  show ?thesis
    using product_from_reachable_next[OF \<open>((q1,q2),x,y,(q1',q2')) \<in> transitions (product (from_FSM M q1) (from_FSM M q2))\<close> assms(3,4)]
          submachine_from[OF assms(1) \<open>(q1',q2') \<in> nodes S\<close>]
    by simp
qed

lemma submachine_transition_complete_product_from :
  assumes "is_submachine S (product (from_FSM M q1) (from_FSM M q2))"
      and "completely_specified S"
      and "((q1,q2),x,y,(q1',q2')) \<in> transitions S"
  and     "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
 shows "completely_specified (from_FSM S (q1',q2'))"
proof -
  let ?P = "(product (from_FSM M q1) (from_FSM M q2))"
  let ?P' = "(product (from_FSM M q1') (from_FSM M q2'))"
  let ?F = "(from_FSM S (q1',q2'))"

  have "initial ?P = (q1,q2)"
    by (simp add: assms(4) assms(5) reachable_node_is_node)

  then have "initial S = (q1,q2)"
    using assms(1) by (metis is_submachine.simps)
  then have "(q1',q2') \<in> nodes S"
    using assms(3)
    using fsm_transition_target by fastforce
  then have "nodes ?F = nodes S"
    using from_FSM_simps(5) by simp
  moreover have "inputs ?F = inputs S"
    using from_FSM_simps(2) \<open>(q1',q2') \<in> nodes S\<close> by simp
  ultimately show "completely_specified ?F"
    using assms(2) unfolding completely_specified.simps
    by (meson assms(2) completely_specified.elims(2) from_FSM_completely_specified)
qed

subsection \<open>Calculating Acyclic Intersection Languages\<close>

lemma acyclic_product :
  assumes "acyclic B"
  shows "acyclic (product A B)"
proof -
  show "acyclic (product A B)"
  proof (rule ccontr)
    assume "\<not> FSM.acyclic (Product_FSM.product A B)"
    then obtain p where "path (product A B) (initial (product A B)) p" and "\<not> distinct (visited_nodes (initial (product A B)) p)"
      by auto

    have "path B (initial B) (right_path p)"
      using product_path[of A B] \<open>path (product A B) (initial (product A B)) p\<close>
      unfolding product_simps
      by auto

    moreover have "\<not> distinct (visited_nodes (initial B) (right_path p))"
    proof -
      obtain i j where "i < j" and "j < length ((initial A, initial B) # map t_target p)" and "((initial A, initial B) # map t_target p) ! i = ((initial A, initial B) # map t_target p) ! j"
        using \<open>\<not> distinct (visited_nodes (initial (product A B)) p)\<close>
        unfolding visited_nodes.simps product_simps
        using non_distinct_repetition_indices by blast

      then have "snd (((initial A, initial B) # map t_target p) ! i) = snd (((initial A, initial B) # map t_target p) ! j)"
        by simp

      have * :"i < length ((initial B) # map t_target (right_path p))"
      and  **:"j < length ((initial B) # map t_target (right_path p))"
        using \<open>i < j\<close> \<open>j < length ((initial A, initial B) # map t_target p)\<close> by auto

      have right_nth: "\<And> i . i < length ((initial B) # map t_target (right_path p)) \<Longrightarrow> ((initial B) # map t_target (right_path p)) ! i = snd (((initial A, initial B) # map t_target p) ! i)"
      proof -
        have "((initial B) # map t_target (right_path p)) ! 0 = snd (((initial A, initial B) # map t_target p) ! 0)"
          by simp
        moreover have "\<And> i . Suc i < length ((initial B) # map t_target (right_path p)) \<Longrightarrow> ((initial B) # map t_target (right_path p)) ! Suc i = snd (((initial A, initial B) # map t_target p) ! Suc i)"
          by auto
        ultimately show "\<And> i . i < length ((initial B) # map t_target (right_path p)) \<Longrightarrow> ((initial B) # map t_target (right_path p)) ! i = snd (((initial A, initial B) # map t_target p) ! i)"
          using less_Suc_eq_0_disj by auto
      qed

      have "((initial B) # map t_target (right_path p)) ! i = ((initial B) # map t_target (right_path p)) ! j"
        using \<open>snd (((initial A, initial B) # map t_target p) ! i) = snd (((initial A, initial B) # map t_target p) ! j)\<close>
        unfolding right_nth[OF *] right_nth[OF **]
        by assumption
      then show ?thesis
        unfolding visited_nodes.simps product_simps
        using non_distinct_repetition_indices_rev[OF \<open>i < j\<close> **] by blast
    qed
    ultimately show "False"
      using \<open>acyclic B\<close> unfolding acyclic.simps by blast
  qed
qed

lemma acyclic_product_path_length :
  assumes "acyclic B"
  and     "path (product A B) (initial (product A B)) p"
shows "length p < size B"
proof -
  have *:"path B (initial B) (right_path p)"
    using product_path[of A B] \<open>path (product A B) (initial (product A B)) p\<close>
    unfolding product_simps
    by auto
  then have **: "distinct (visited_nodes (initial B) (right_path p))"
    using assms unfolding acyclic.simps by blast

  have "length (right_path p) < size B"
    using acyclic_path_length_limit[OF * **] by assumption
  then show "length p < size B"
    by auto
qed

lemma acyclic_language_alt_def :
  assumes "acyclic A"
  shows "image p_io (acyclic_paths_up_to_length A (initial A) (size A - 1)) = L A"
proof -
  let ?ps = "acyclic_paths_up_to_length A (initial A) (size A - 1)"
  have "\<And> p . path A (initial A) p \<Longrightarrow> length p \<le> FSM.size A - 1"
    using acyclic_path_length_limit assms unfolding acyclic.simps
    by fastforce
  then have "?ps = {p. path A (initial A) p}"
    using assms unfolding acyclic_paths_up_to_length.simps acyclic.simps by blast
  then show ?thesis unfolding LS.simps by blast
qed

definition acyclic_language_intersection :: "('a,'b,'c) fsm \<Rightarrow> ('d,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set" where
  "acyclic_language_intersection M A = (let P = product M A in image p_io (acyclic_paths_up_to_length P (initial P) (size A - 1)))"

lemma acyclic_language_intersection_completeness :
  assumes "acyclic A"
  shows "acyclic_language_intersection M A = L M \<inter> L A"
proof -
  let ?P = "product M A"
  let ?ps = "acyclic_paths_up_to_length ?P (initial ?P) (size A - 1)"

  have "L ?P = L M \<inter> L A"
    using product_language by blast

  have "\<And> p . path ?P (initial ?P) p \<Longrightarrow> length p \<le> FSM.size A - 1"
    using acyclic_product_path_length[OF assms]
    by fastforce
  then have "?ps = {p. path ?P (initial ?P) p}"
    using acyclic_product[OF assms] unfolding acyclic_paths_up_to_length.simps acyclic.simps by blast
  then have "image p_io ?ps = L ?P"
    unfolding LS.simps by blast
  then show ?thesis
    using product_language unfolding acyclic_language_intersection_def Let_def by blast
qed

end


theory Exercise7p6
imports Bigstep_sseefried
begin

abbreviation DoWhile :: "com \<Rightarrow> bexp \<Rightarrow> com" ("(DO _/ WHILE _)"  [0, 61] 61) where
  "DoWhile c b \<equiv> c;; WHILE b DO c"

fun dewhile :: "com \<Rightarrow> com" where
    "dewhile SKIP = SKIP"
  | "dewhile (Assign v aexp) = Assign v aexp"
  | "dewhile (Seq c1 c2)     = Seq (dewhile c1) (dewhile c2)"
  | "dewhile (If b c1 c2)    = If b (dewhile c1) (dewhile c2)"
  | "dewhile (While b c)     = IF b THEN (DO c WHILE b) ELSE SKIP"

print_theorems

(* c \<sim> c' \<equiv> \<forall>s s'. (c,s) \<Rightarrow> s' = (c',s) \<Rightarrow> s' *)

lemma "dewhile c \<sim> c"
proof -
  { fix s t
    have "(dewhile c, s) \<Rightarrow> t \<Longrightarrow> (c, s) \<Rightarrow> t"
    proof (induction c arbitrary: s t)
      case (Seq c1 c2)
      hence "\<exists>s'. (dewhile c1, s) \<Rightarrow> s' \<and> (dewhile c2, s') \<Rightarrow> t" by auto
      then obtain s' where l: "(dewhile c1, s) \<Rightarrow> s'" and r: "(dewhile c2, s') \<Rightarrow> t" by blast
      hence "(c1, s) \<Rightarrow> s'" and "(c2, s') \<Rightarrow> t" using Seq.IH by auto
      thus "(c1;;c2, s) \<Rightarrow> t" by blast
    qed auto+ -- "other cases are trivial"
  } note forward = this
  { fix s t
    have "(c,s) \<Rightarrow> t \<Longrightarrow> (dewhile c, s) \<Rightarrow> t"
    proof (induction c arbitrary: s t)
      case (Seq c1 c2)
      hence "\<exists>s'. (c1, s) \<Rightarrow> s' \<and> (c2, s') \<Rightarrow> t" by auto
      then obtain s' where "(c1, s) \<Rightarrow> s'" and "(c2, s') \<Rightarrow> t" by blast
      hence "(dewhile c1, s) \<Rightarrow> s'" and "(dewhile c2, s') \<Rightarrow> t" using Seq.IH by auto
      hence "(dewhile c1;; dewhile c2, s) \<Rightarrow> t" by blast
      thus  "(dewhile (c1 ;; c2), s) \<Rightarrow> t" by auto
    next
      case (While b c)
      thus "(dewhile (WHILE b DO c), s) \<Rightarrow> t" using while_if_equiv by auto
    qed auto+
  } note backward = this
  show ?thesis using forward backward by blast
qed

end


section "Example: Computing Maximum with a while-Loop"

theory example_loop_max
  imports
    program_verification_tactics
    unique_ids
    program_proof_rules_loops
    app_verification_helpers
    unique_ids_loops
begin

datatype val =
    Nat (nat_value:nat)
  | Bool (bool_value:bool)
  | Undef
  | ListVal (list_value:"val list")

instance val :: countable
  by countable_datatype

instantiation val :: valueType begin
definition [simp]: "uniqueIds_val \<equiv> \<lambda>x::val. {}::uniqueId set"
definition [simp]: "default_val \<equiv> Undef"

instance by (standard, auto)
end

instantiation val :: natConvert begin
definition[simp]: "fromNat \<equiv> Nat"
instance proof (standard, simp)
  show "inj Nat"
    using injI by force
qed
end

type_synonym operation = unit

datatype proc =
    PMax "nat list"

definition "only_store_changed PS_old PS \<equiv> \<exists>store'. PS = PS_old\<lparr>ps_store := store'\<rparr>"

lemma show_only_store_changed:
  assumes "only_store_changed PS_old PS"
    and "PS' = PS\<lparr>ps_store := x\<rparr>"
  shows "only_store_changed PS_old PS'"
  using assms by (auto simp add: only_store_changed_def)

definition loop_inv :: "nat list ref \<Rightarrow> nat ref \<Rightarrow> nat list \<Rightarrow> (proc, val, unit) proof_state \<Rightarrow> (proc, val, unit) proof_state \<Rightarrow> bool" where
"loop_inv listR resR p_list PS_old PS \<equiv>
 \<exists>li re li_done.
          iref resR \<noteq> iref listR
        \<and> (iref listR) \<in> dom (ps_store PS)
        \<and> (iref resR) \<in> dom (ps_store PS)
        \<and> li ::= s_read (ps_store PS) listR
        \<and> re ::= s_read (ps_store PS) resR
        \<and> p_list ::= li_done @ li
        \<and> (if li_done = [] then re = 0 else re = Max (set li_done))
        \<and> (only_store_changed PS_old PS)"

definition max_impl :: "nat list \<Rightarrow> (val,operation,val) io" where
"max_impl p_list \<equiv>
   do {
      listR \<leftarrow> makeRef p_list;
      resR \<leftarrow> makeRef 0;
      while_a (loop_inv listR resR p_list) (do {
        list \<leftarrow> read listR;
        res \<leftarrow> read resR;
        if list = [] then
          return True
        else do {
          let x = hd list;
          listR :\<leftarrow> tl list;
          resR :\<leftarrow> max x res;
          return False
        }
      });
      res \<leftarrow> read resR;
      return (Nat res)
   }"

instance proc :: countable
  by countable_datatype

instantiation proc :: valueType begin
definition [simp]: "uniqueIds_proc (proc::proc) \<equiv> ({} :: uniqueId set)"

definition [simp]: "default_proc \<equiv> PMax []"

instance by (standard, auto)
end

type_synonym localState = "val store  \<times> uniqueId set \<times> (val, operation, val) io"

definition procedures :: "proc \<Rightarrow> (localState \<times> (localState, operation, val) procedureImpl)" where
  "procedures invoc \<equiv>
  case invoc of
    PMax n \<Rightarrow> toImpl' invoc (max_impl n)
"

definition inv1 where
"inv1 op res \<equiv> \<forall>i list r.
    op i \<triangleq> PMax list
  \<and> list \<noteq> []
  \<and> res i \<triangleq> r
  \<longrightarrow> (r = Nat (Max (set list)))
"

definition inv :: "(proc, operation, val) invContext \<Rightarrow> bool" where
  "inv ctxt \<equiv>
    inv1 (invocOp ctxt) (invocRes ctxt) "

definition "crdtSpec c op r = False"

definition "crdtSpec' op Cs Ops  Hb C_out r = False"

lemma crdtSpec_rel:
  shows "crdt_spec_rel crdtSpec crdtSpec'"
  by (rule show_crdt_spec_rel')
   (auto simp add: crdtSpec_def crdtSpec'_def)

definition progr :: "(proc, localState, operation, val) prog" where
  "progr \<equiv> \<lparr>
  querySpec = crdtSpec,
  procedure = procedures,
  invariant = inv
\<rparr>"

lemma progr_wf[simp]: "program_wellFormed progr"
proof (auto simp add: program_wellFormed_def)
  show "invocations_cannot_guess_ids progr"
  proof (rule invocations_cannot_guess_ids_io)

    show "impl = impl_language_loops.toImpl \<and> localKnown = uniqueIds proc"
      if c0: "procedure progr proc = ((store, localKnown, cmd), impl)"
      for  proc store localKnown cmd impl
      using that by (auto simp add: progr_def procedures_def split: proc.splits)
  qed

  show "queries_cannot_guess_ids crdtSpec"
  proof (auto simp add:  crdtSpec_def queries_cannot_guess_ids_def split: )

    show "\<And>opr. query_cannot_guess_ids (uniqueIds opr) (crdtSpec opr)"
      by (simp add: crdtSpec_def query_cannot_guess_ids_def2)
  qed
qed

theorem correct: "programCorrect progr"
proof M_show_programCorrect

  case invariant_initial_state
  show "invariant_all' (initialState progr)"
    by (simp add: inv_def initialState_def invContextH2_calls inv1_def  invContextH2_happensBefore invContextH2_i_invocOp progr_def)

  case (procedure_correct S i)

  show "procedureCorrect S i"
  proof (rule Initial_Label, rule show_initial_state_prop[OF procedure_correct], rule DC_final2, casify)
    case (show_P S_pre proc initState impl1)
    have "invocOp S i \<triangleq> proc"
      using show_P by auto
    have "invocRes S i = None"
      using show_P apply auto
      using state_wellFormed_invocation_before_result by blast

    have "uniqueIds proc \<subseteq> knownIds S"
      using show_P by auto

    note show_P[simp]

    show "procedureCorrect S i"
    proof (cases proc)
      case (PMax list)

      show "procedureCorrect S i"
      proof M_show_procedureCorrect
        case after_invocation
         show ?case
           using show_P.invariant_pre  show_P.i_fresh
           by (auto simp add:  inv_def inv1_def  invContextH2_simps wf_result_after_invocation)

      next
        case execution

        have ls: "localState S i \<triangleq> (Map.empty, {}, max_impl list)"
            by (auto simp add: PMax procedures_def )

        show "execution_s_correct S i"
          using ls procedure_correct.in_initial_state
        proof (fuzzy_rule execution_s_check_sound4)
          show "currentProc S i \<triangleq> toImpl"
            by (auto simp add:  PMax procedures_def )

          show "invocOp S i \<triangleq> PMax list"
            using PMax \<open>invocOp S i \<triangleq> proc\<close> by blast

          note max_impl_def[simp]

          show "program_wellFormed (prog S)"
            by (auto simp add: show_P)

          from `invariant_all' S`
          show "invariant_all' S" .

          show "crdt_spec_rel (querySpec progr) crdtSpec'"
            using crdtSpec_rel progr_def by simp

          show "program_proof_rules_loops.execution_s_check (invariant progr) crdtSpec' \<lparr>
                  calls = s_calls,
                  happensBefore = s_happensBefore,
                  callOrigin = s_callOrigin,
                  txOrigin = s_txOrigin,
                  knownIds = s_knownIds,
                  invocOp = (s_invocOp(i \<mapsto> PMax list)),
                  invocRes = (s_invocRes(i := None)),
                  ps_i = i,
                  ps_generatedLocal = {},
                  ps_generatedLocalPrivate = {},
                  ps_localKnown = uniqueIds (PMax list),
                  ps_vis = {},
                  ps_localCalls = [],
                  ps_tx = None,
                  ps_firstTx = True,
                  ps_store = Map.empty,
                  ps_prog = progr
                  \<rparr>
                  (max_impl list)
                  (finalCheck (invariant progr) i)" \<comment> \<open>TODO finalCheck could be fixed for the initial P (as variant)\<close>
            if c0: "(\<And>tx. s_txOrigin tx \<noteq> Some i)"
              and inv: "invariant progr
                         \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin,
                            txOrigin = s_txOrigin, knownIds = s_knownIds,
                            invocOp = s_invocOp(i \<mapsto> PMax list), invocRes = s_invocRes(i := None)\<rparr>"
            for  s_calls s_happensBefore s_callOrigin s_txOrigin s_knownIds s_invocOp s_invocRes
            apply (auto simp add: )
            apply (repliss_vcg_l asmUnfold: loop_inv_def)
          proof (fuzzy_goal_cases loop_inv_start final loop_body )
            case loop_inv_start
            show ?case
              unfolding loop_inv_def
              by (auto simp add: s_read_def Def_def only_store_changed_def)
          next
            case (loop_body PS li_v li re_v re li_done)
            have [simp]: "fromAny li_v = li"
              using loop_body by (auto simp add: Def_def s_read_def)

            have [simp]: "fromAny re_v = re"
              using loop_body by (auto simp add: Def_def s_read_def)

            have "li \<noteq> []"
              using loop_body Def_def by metis

            show ?case
              unfolding loop_inv_def
              apply (rule exI[where x="tl li"])
              apply (rule exI[where x="max (hd li) re"])
              apply (rule exI[where x="li_done @ [hd li]"])
            proof (auto simp add: Def_def loop_body s_read_def intro!: show_only_store_changed[OF loop_body(7)])
              show "list = li_done @ hd li # tl li"
                using Def_def \<open>li \<noteq> []\<close> `list ::= li_done @ li` by fastforce

              from `if li_done = [] then re = 0 else re = Max (set li_done)`
              show "max (hd li) re = Max (insert (hd li) (set li_done))"
                by (auto split: if_splits)
            qed

          next
            case (final PS li_v li re_v re li_done)
            show ?case
            proof (auto simp add: inv_def inv1_def invContext.defs)

              show "s_read (ps_store PS) (Ref (Suc 0)) = Max (set list)"
                if c0: "invocOp PS i \<triangleq> PMax list"
                  and c1: "list \<noteq> []"
                for  list
                using final that by (auto simp add: inv_def inv1_def invContext.defs Def_def only_store_changed_def split: if_splits)

              show "r = val.Nat (Max (set list))"
                if c0: "ia \<noteq> i"
                  and c1: "invocOp PS ia \<triangleq> PMax list"
                  and c2: "list \<noteq> []"
                  and c3: "invocRes PS ia \<triangleq> r"
                for  ia list r
                using inv that final(7)
                by (auto simp add: inv_def inv1_def final(7) only_store_changed_def, force)
            qed
          qed
        qed (auto simp add: finalCheck_def)
      qed
    qed
  qed
qed

end