section \<open>The Instantiation\<close>

(*<*)
theory Instance
  imports Goedel_Incompleteness.Abstract_Second_Goedel
    Incompleteness.Quote Incompleteness.Goedel_I
begin
(*>*)

definition "Fvars t = {a :: name. \<not> atom a \<sharp> t}"

lemma Fvars_tm_simps[simp]:
  "Fvars Zero = {}"
  "Fvars (Var a) = {a}"
  "Fvars (Eats x y) = Fvars x \<union> Fvars y"
  by (auto simp: Fvars_def fresh_at_base(2))

lemma finite_Fvars_tm[simp]:
  fixes t :: tm
  shows "finite (Fvars t)"
  by (induct t rule: tm.induct) auto

lemma Fvars_fm_simps[simp]:
  "Fvars (x IN y) = Fvars x \<union> Fvars y"
  "Fvars (x EQ y) = Fvars x \<union> Fvars y"
  "Fvars (A OR B) = Fvars A \<union> Fvars B"
  "Fvars (A AND B) = Fvars A \<union> Fvars B"
  "Fvars (A IMP B) = Fvars A \<union> Fvars B"
  "Fvars Fls = {}"
  "Fvars (Neg A) = Fvars A"
  "Fvars (Ex a A) = Fvars A - {a}"
  "Fvars (All a A) = Fvars A - {a}"
  by (auto simp: Fvars_def fresh_at_base(2))

lemma finite_Fvars_fm[simp]:
  fixes A :: fm
  shows "finite (Fvars A)"
  by (induct A rule: fm.induct) auto

lemma subst_tm_subst_tm[simp]:
  "x \<noteq> y \<Longrightarrow> atom x \<sharp> u \<Longrightarrow> subst y u (subst x t v) = subst x (subst y u t) (subst y u v)"
  by (induct v rule: tm.induct) auto

lemma subst_fm_subst_fm[simp]:
  "x \<noteq> y \<Longrightarrow> atom x \<sharp> u \<Longrightarrow> (A(x::=t))(y::=u) = (A(y::=u))(x::=subst y u t)"
  by (nominal_induct A avoiding: x t y u rule: fm.strong_induct) auto

lemma Fvars_ground_aux: "Fvars t \<subseteq> B \<Longrightarrow> ground_aux t (atom ` B)"
  by (induct t rule: tm.induct) auto

lemma ground_Fvars: "ground t \<longleftrightarrow> Fvars t = {}"
  apply (rule iffI)
   apply (auto simp only: Fvars_def ground_fresh) []
  apply (auto intro: Fvars_ground_aux[of t "{}", simplified])
  done

lemma Fvars_ground_fm_aux: "Fvars A \<subseteq> B \<Longrightarrow> ground_fm_aux A (atom ` B)"
  apply (induct A arbitrary: B rule: fm.induct)
      apply (auto simp: Diff_subset_conv Fvars_ground_aux)
  apply (drule meta_spec, drule meta_mp, assumption)
  apply auto
  done

lemma ground_fm_Fvars: "ground_fm A \<longleftrightarrow> Fvars A = {}"
  apply (rule iffI)
   apply (auto simp only: Fvars_def ground_fresh) []
  apply (auto intro: Fvars_ground_fm_aux[of A "{}", simplified])
  done

interpretation Generic_Syntax where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  apply unfold_locales
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal for t by (induct t rule: tm.induct) auto
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal unfolding Fvars_def fresh_subst_fm_if by auto
  subgoal unfolding Fvars_def by auto
  subgoal unfolding Fvars_def by simp
  subgoal by simp
  subgoal unfolding Fvars_def by simp
  done

lemma coding_tm_Fvars_empty[simp]: "coding_tm t \<Longrightarrow> Fvars t = {}"
  by (induct t rule: coding_tm.induct) (auto simp: Fvars_def)

lemma Fvars_empty_ground[simp]: "Fvars t = {} \<Longrightarrow> ground t"
  by (induct t rule: tm.induct) auto

interpretation Syntax_with_Numerals where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  apply unfold_locales
  subgoal by (auto intro!: exI[of _ Zero])
  subgoal by simp
  subgoal by (simp add: ground_Fvars)
  done

declare FvarsT_num[simp del]

interpretation Deduct2_with_False where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  and eql = "(EQ)"
  and cnj = "(AND)"
  and imp = "(IMP)"
  and all = "All"
  and exi = "Ex"
  and fls = "Fls"
  and prv = "(\<turnstile>) {}"
  and bprv = "(\<turnstile>) {}"
  apply unfold_locales
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal unfolding Fvars_def by simp
  subgoal unfolding Fvars_def by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal using MP_null by blast
  subgoal by blast
  subgoal for A B C
    apply (rule Imp_I)+
    apply (rule MP_same[of _ B])
     apply (rule MP_same[of _ C])
      apply (auto intro: Neg_D)
    done
  subgoal by blast
  subgoal by blast
  subgoal by blast
  subgoal unfolding Fvars_def by (auto intro: MP_null)
  subgoal unfolding Fvars_def by (auto intro: MP_null)
  subgoal by (auto intro: All_D)
  subgoal by (auto intro: Ex_I)
  subgoal by simp
  subgoal by (metis Conj_E2 Iff_def Imp_I Var_Eq_subst_Iff)
  subgoal by blast
  subgoal by simp
  done

interpretation HBL1 where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  and eql = "(EQ)"
  and cnj = "(AND)"
  and imp = "(IMP)"
  and all = "All"
  and exi = "Ex"
  and prv = "(\<turnstile>) {}"
  and bprv = "(\<turnstile>) {}"
  and enc = "quot"
  and P = "PfP (Var xx)"
  apply unfold_locales
  subgoal by (simp add: quot_fm_coding)
  subgoal by simp
  subgoal unfolding Fvars_def by (auto simp: fresh_at_base(2))
  subgoal by (auto simp: proved_imp_proved_PfP)
  done

interpretation Goedel_Form where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  and eql = "(EQ)"
  and cnj = "(AND)"
  and imp = "(IMP)"
  and all = "All"
  and exi = "Ex"
  and fls = "Fls"
  and prv = "(\<turnstile>) {}"
  and bprv = "(\<turnstile>) {}"
  and enc = "quot"
  and S = "KRP (quot (Var xx)) (Var xx) (Var yy)"
  and P = "PfP (Var xx)"
  apply unfold_locales
  subgoal by simp
  subgoal unfolding Fvars_def by (auto simp: fresh_at_base(2))
  subgoal
    unfolding Let_def
    by (subst psubst_eq_rawpsubst2)
      (auto simp: quot_fm_coding prove_KRP Fvars_def)
  subgoal
    unfolding Let_def
    by (subst (1 2) psubst_eq_rawpsubst2)
      (auto simp: quot_fm_coding KRP_unique[THEN Sym] Fvars_def)
  done

interpretation g2: Goedel_Second_Assumptions where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  and eql = "(EQ)"
  and cnj = "(AND)"
  and imp = "(IMP)"
  and all = "All"
  and exi = "Ex"
  and fls = "Fls"
  and prv = "(\<turnstile>) {}"
  and bprv = "(\<turnstile>) {}"
  and enc = "quot"
  and S = "KRP (quot (Var xx)) (Var xx) (Var yy)"
  and P = "PfP (Var xx)"
  apply unfold_locales
  subgoal by (auto simp: PP_def intro: PfP_implies_ModPon_PfP_quot)
  subgoal by (auto simp: PP_def quot_fm_coding Provability)
  done

theorem Goedel_II: "\<not> {} \<turnstile> Fls \<Longrightarrow> \<not> {} \<turnstile> neg (PfP \<guillemotleft>Fls\<guillemotright>)"
  by (rule g2.goedel_second[unfolded consistent_def PP_def PfP_subst subst.simps simp_thms if_True])

lemma ground_fm_PrfP[simp]:
  "ground_fm (PrfP s k t) \<longleftrightarrow> ground s \<and> ground k \<and> ground t"
  by (auto simp add: ground_aux_def ground_fm_aux_def supp_conv_fresh)

lemma Fvars_HPair[simp]: "Fvars (HPair t u) = Fvars t \<union> Fvars u"
  unfolding Fvars_def
  by auto

lemma ground_HPair[simp]: "ground (HPair t u) \<longleftrightarrow> ground t \<and> ground u"
  unfolding ground_Fvars
  by auto

interpretation dwfd: Deduct2_with_False_Disj where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  and eql = "(EQ)"
  and cnj = "(AND)"
  and dsj = "(OR)"
  and imp = "(IMP)"
  and all = "All"
  and exi = "Ex"
  and fls = "Fls"
  and prv = "(\<turnstile>) {}"
  and bprv = "(\<turnstile>) {}"
  apply unfold_locales
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by (auto intro: Disj_I1)
  subgoal by (auto intro: Disj_I2)
  subgoal by (auto intro: ContraAssume)
  subgoal by simp
  done

interpretation Minimal_Truth_Soundness where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  and eql = "(EQ)"
  and cnj = "(AND)"
  and dsj = "(OR)"
  and imp = "(IMP)"
  and all = "All"
  and exi = "Ex"
  and fls = "Fls"
  and prv = "(\<turnstile>) {}"
  and isTrue = "eval_fm e0"
  apply unfold_locales
  subgoal by (auto simp: Fls_def)
  subgoal by simp
  subgoal by (auto simp only: ex_eval_fm_iff_exists_tm eval_fm.simps(4) subst_fm.simps)
  subgoal by (auto simp only: ex_eval_fm_iff_exists_tm)
  subgoal by (simp add: neg_def)
  subgoal by (auto dest: hfthm_sound)
  done

lemma neg_Neg:
  "{} \<turnstile> neg \<phi> IFF Neg \<phi>"
  unfolding neg_def
  by (auto simp: Fls_def intro: ContraAssume)

lemma ground_aux_mono: "A \<subseteq> B \<Longrightarrow> ground_aux t A \<Longrightarrow> ground_aux t B"
  unfolding ground_aux_def by auto

interpretation g1: Goedel_Form_Minimal_Truth_Soundness_HBL1iff_prv_Compl_Pf_Classical where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  and eql = "(EQ)"
  and cnj = "(AND)"
  and dsj = "(OR)"
  and imp = "(IMP)"
  and all = "All"
  and exi = "Ex"
  and fls = "Fls"
  and prv = "(\<turnstile>) {}"
  and bprv = "(\<turnstile>) {}"
  and enc = "quot"
  and S = "KRP (quot (Var xx)) (Var xx) (Var yy)"
  and P = "PfP (Var xx)"
  and isTrue = "eval_fm e0"
  and Pf = "Ex xx' (Ex yy' (Var yy EQ HPair (Var xx') (Var yy') AND PrfP (Var xx') (Var yy') (Var xx)))"
  apply unfold_locales
  subgoal by simp
  subgoal unfolding Fvars_def by (auto simp: fresh_at_base(2))
  subgoal for \<phi>
    unfolding Let_def
    supply PfP.simps[simp del]
    apply (subst psubst_eq_rawpsubst2) apply (simp_all add: PfP.simps[of yy' xx' "quot \<phi>", simplified])
    apply (auto simp: eqv_def)
     apply (rule Ex_I[of _ _ _ "HPair (Var xx') (Var yy')"])
     apply (subst subst_fm_Ex_with_renaming[of xx _ xx' yy]; (auto simp: Conj_eqvt))
     apply (subst subst_fm_Ex_with_renaming[of zz _ yy' yy]; (auto simp: Conj_eqvt HPair_eqvt PrfP.eqvt))
     apply (rule Ex_I[of _ _ _ "(Var xx')"]; auto)
     apply (rule Ex_I[of _ _ _ "(Var yy')"]; auto)
     apply (rule Ex_I[of _ _ _ "(Var yy')"]; auto)
    apply (rule Ex_I[of _ _ _ "(Var xx')"]; auto)
    done
  subgoal
    by (auto simp: PP_def proved_iff_proved_PfP[symmetric])
  subgoal for n \<phi>
    unfolding Let_def
    apply (subst (1 2) psubst_eq_rawpsubst2)
           apply (simp_all add: ground_Fvars)
    apply (rule impI)
    apply (rule Sigma_fm_imp_thm)
      apply (auto simp: ground_Fvars[symmetric] elim: ground_aux_mono[OF empty_subsetI])
     apply (auto simp: ground_aux_def ground_fm_aux_def supp_conv_fresh fresh_at_base Fvars_def)
    done
  subgoal for \<phi>
    apply (rule NegNeg_D)
    apply (auto simp: PP_def dest!: Iff_MP_same[OF neg_Neg] Iff_MP_same[OF Neg_cong[OF neg_Neg]])
    done
  done

theorem Goedel_I: "\<exists>\<phi>. \<not> {} \<turnstile> \<phi> \<and> \<not> {} \<turnstile> Neg \<phi> \<and> eval_fm e0 \<phi>"
  by (meson Iff_MP2_same g1.recover_proofs.goedel_first_classic_strong[OF consistent] neg_Neg)

text \<open>
The following interpretation is redundant, because
@{locale Goedel_Form_Minimal_Truth_Soundness_HBL1iff_prv_Compl_Pf_Classical} (interpreted above)
is a sublocale of @{locale Goedel_Form_Classical_HBL1_rev_prv_Minimal_Truth_Soundness_TIP}.
However, the latter requires less infrastructure (no Pf formula).

The definition of isTrue prevents Isabelle from noticing that the locale has already been
interpreted via the above g1 interpretation of
@{locale Goedel_Form_Minimal_Truth_Soundness_HBL1iff_prv_Compl_Pf_Classical}.
\<close>

definition isTrue where
  "isTrue = eval_fm e0"

interpretation g1': Goedel_Form_Classical_HBL1_rev_prv_Minimal_Truth_Soundness_TIP where
      var = "UNIV :: name set"
  and trm = "UNIV :: tm set"
  and fmla = "UNIV :: fm set"
  and num = "{t. ground t}"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fm A x u"
  and eql = "(EQ)"
  and cnj = "(AND)"
  and dsj = "(OR)"
  and imp = "(IMP)"
  and all = "All"
  and exi = "Ex"
  and fls = "Fls"
  and prv = "(\<turnstile>) {}"
  and bprv = "(\<turnstile>) {}"
  and enc = "quot"
  and S = "KRP (quot (Var xx)) (Var xx) (Var yy)"
  and P = "PfP (Var xx)"
  and isTrue = "isTrue"
  apply unfold_locales
  unfolding isTrue_def
  subgoal by (auto simp: Fls_def)
  subgoal by simp
  subgoal by (auto simp only: ex_eval_fm_iff_exists_tm eval_fm.simps(4) subst_fm.simps)
  subgoal by (auto simp only: ex_eval_fm_iff_exists_tm)
  subgoal by (simp add: neg_def)
  subgoal by (auto dest: hfthm_sound)
  subgoal by (auto simp: proved_iff_proved_PfP[symmetric] PP_def quot_fm_coding
        simp del: eval_fm_PfP
        dest!: Iff_MP_same[OF neg_Neg] Iff_MP_same[OF Neg_cong[OF neg_Neg]] NegNeg_D
        Sigma_fm_imp_thm[rotated 2])
  done

theorem Goedel_I': "\<exists>\<phi>. \<not> {} \<turnstile> \<phi> \<and> \<not> {} \<turnstile> Neg \<phi> \<and> isTrue \<phi>"
  by (meson Iff_MP2_same g1'.goedel_first_classic_strong[OF consistent] neg_Neg)

(*<*)
end
(*>*)


(*  Title:       Pnet.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Lemmas for partial networks"

theory Pnet
imports AWN_SOS Invariants
begin

text \<open>
  These lemmas mostly concern the preservation of node structure by @{term pnet_sos} transitions.
\<close>

lemma pnet_maintains_dom:
  assumes "(s, a, s') \<in> trans (pnet np p)"
    shows "net_ips s = net_ips s'"
  using assms proof (induction p arbitrary: s a s')
    fix i R \<sigma> s a s'
    assume "(s, a, s') \<in> trans (pnet np \<langle>i; R\<rangle>)"
    hence "(s, a, s') \<in> node_sos (trans (np i))" ..
    thus "net_ips s = net_ips s'"
      by (rule node_sos.cases) simp_all
  next
    fix p1 p2 s a s'
    assume "\<And>s a s'. (s, a, s') \<in> trans (pnet np p1) \<Longrightarrow> net_ips s = net_ips s'"
       and "\<And>s a s'. (s, a, s') \<in> trans (pnet np p2) \<Longrightarrow> net_ips s = net_ips s'"
       and "(s, a, s') \<in> trans (pnet np (p1 \<parallel> p2))"
    thus "net_ips s = net_ips s'"
      by simp (erule pnet_sos.cases, simp_all)
  qed

lemma pnet_net_ips_net_tree_ips [elim]:
  assumes "s \<in> reachable (pnet np p) I"
    shows "net_ips s = net_tree_ips p"
  using assms proof induction
    fix s
    assume "s \<in> init (pnet np p)"
    thus "net_ips s = net_tree_ips p"
    proof (induction p arbitrary: s)
      fix i R s
      assume "s \<in> init (pnet np \<langle>i; R\<rangle>)"
      then obtain ns where "s = NodeS i ns R" ..
      thus "net_ips s = net_tree_ips \<langle>i; R\<rangle>"
        by simp
    next
      fix p1 p2 s
      assume IH1: "\<And>s. s \<in> init (pnet np p1) \<Longrightarrow> net_ips s = net_tree_ips p1"
         and IH2: "\<And>s. s \<in> init (pnet np p2) \<Longrightarrow> net_ips s = net_tree_ips p2"
         and "s \<in> init (pnet np (p1 \<parallel> p2))"
      from this(3) obtain s1 s2 where "s1 \<in> init (pnet np p1)"
                                  and "s2 \<in> init (pnet np p2)"
                                  and "s = SubnetS s1 s2" by auto
      from this(1-2) have "net_ips s1 = net_tree_ips p1"
                      and "net_ips s2 = net_tree_ips p2"
        using IH1 IH2 by auto
      with \<open>s = SubnetS s1 s2\<close> show "net_ips s = net_tree_ips (p1 \<parallel> p2)" by auto
    qed
  next
    fix s a s'
    assume "(s, a, s') \<in> trans (pnet np p)"
       and "net_ips s = net_tree_ips p"
    from this(1) have "net_ips s = net_ips s'"
      by (rule pnet_maintains_dom)
    with \<open>net_ips s = net_tree_ips p\<close> show "net_ips s' = net_tree_ips p"
      by simp
  qed

lemma pnet_init_net_ips_net_tree_ips:
  assumes "s \<in> init (pnet np p)"
    shows "net_ips s = net_tree_ips p"
  using assms(1) by (rule reachable_init [THEN pnet_net_ips_net_tree_ips])

lemma pnet_init_in_net_ips_in_net_tree_ips [elim]:
  assumes "s \<in> init (pnet np p)"
      and "i \<in> net_ips s"
    shows "i \<in> net_tree_ips p"
  using assms by (clarsimp dest!: pnet_init_net_ips_net_tree_ips)

lemma pnet_init_not_in_net_tree_ips_not_in_net_ips [elim]:
  assumes "s \<in> init (pnet np p)"
      and "i \<notin> net_tree_ips p"
    shows "i \<notin> net_ips s"
  proof
    assume "i \<in> net_ips s"
    with assms(1) have "i \<in> net_tree_ips p" ..
    with assms(2) show False ..
  qed

lemma net_node_reachable_is_node:
  assumes "st \<in> reachable (pnet np \<langle>ii; R\<^sub>i\<rangle>) I"
    shows "\<exists>ns R. st = NodeS ii ns R"
  using assms proof induct
    fix s
    assume "s \<in> init (pnet np \<langle>ii; R\<^sub>i\<rangle>)"
    thus "\<exists>ns R. s = NodeS ii ns R"
      by (rule pnet_node_init') simp
  next
    fix s a s'
    assume "s \<in> reachable (pnet np \<langle>ii; R\<^sub>i\<rangle>) I"
       and "\<exists>ns R. s = NodeS ii ns R"
       and "(s, a, s') \<in> trans (pnet np \<langle>ii; R\<^sub>i\<rangle>)"
       and "I a"
    thus "\<exists>ns R. s' = NodeS ii ns R"
      by (auto simp add: trans_node_comp dest!: node_sos_dest)
  qed

lemma partial_net_preserves_subnets:
  assumes "(SubnetS s t, a, st') \<in> pnet_sos (trans (pnet np p1)) (trans (pnet np p2))"
    shows "\<exists>s' t'. st' = SubnetS s' t'"
  using assms by cases simp_all

lemma net_par_reachable_is_subnet:
  assumes "st \<in> reachable (pnet np (p1 \<parallel> p2)) I"
    shows "\<exists>s t. st = SubnetS s t"
  using assms by induct (auto dest!: partial_net_preserves_subnets)

lemma reachable_par_subnet_induct [consumes, case_names init step]:
  assumes "SubnetS s t \<in> reachable (pnet np (p1 \<parallel> p2)) I"
      and init: "\<And>s t. SubnetS s t \<in> init (pnet np (p1 \<parallel> p2)) \<Longrightarrow> P s t"
      and step: "\<And>s t s' t' a. \<lbrakk>
                    SubnetS s t \<in> reachable (pnet np (p1 \<parallel> p2)) I;
                    P s t; (SubnetS s t, a, SubnetS s' t') \<in> (trans (pnet np (p1 \<parallel> p2))); I a \<rbrakk>
                    \<Longrightarrow> P s' t'"
    shows "P s t"
  using assms(1) proof (induction "SubnetS s t" arbitrary: s t)
    fix s t
    assume "SubnetS s t \<in> init (pnet np (p1 \<parallel> p2))"
    with init show "P s t" .
  next
    fix st a s' t'
    assume "st \<in> reachable (pnet np (p1 \<parallel> p2)) I"
       and tr: "(st, a, SubnetS s' t') \<in> trans (pnet np (p1 \<parallel> p2))"
       and "I a"
       and IH: "\<And>s t. st = SubnetS s t \<Longrightarrow> P s t"
    from this(1) obtain s t where "st = SubnetS s t"
                              and str: "SubnetS s t \<in> reachable (pnet np (p1 \<parallel> p2)) I"
      by (metis net_par_reachable_is_subnet)
    note this(2)
    moreover from IH and \<open>st = SubnetS s t\<close> have "P s t" .
    moreover from \<open>st = SubnetS s t\<close> and tr
      have "(SubnetS s t, a, SubnetS s' t') \<in> trans (pnet np (p1 \<parallel> p2))" by simp
    ultimately show "P s' t'"
      using \<open>I a\<close> by (rule step)
  qed

lemma subnet_reachable:
  assumes "SubnetS s1 s2 \<in> reachable (pnet np (p1 \<parallel> p2)) TT"
    shows "s1 \<in> reachable (pnet np p1) TT"
          "s2 \<in> reachable (pnet np p2) TT"
  proof -
    from assms have "s1 \<in> reachable (pnet np p1) TT
                  \<and> s2 \<in> reachable (pnet np p2) TT"
    proof (induction rule: reachable_par_subnet_induct)
      fix s1 s2
      assume "SubnetS s1 s2 \<in> init (pnet np (p1 \<parallel> p2))"
      thus "s1 \<in> reachable (pnet np p1) TT
          \<and> s2 \<in> reachable (pnet np p2) TT"
        by (auto dest: reachable_init)
    next
      case (step s1 s2 s1' s2' a)
      hence "SubnetS s1 s2 \<in> reachable (pnet np (p1 \<parallel> p2)) TT"
        and sr1: "s1 \<in> reachable (pnet np p1) TT"
        and sr2: "s2 \<in> reachable (pnet np p2) TT"
        and "(SubnetS s1 s2, a, SubnetS s1' s2') \<in> trans (pnet np (p1 \<parallel> p2))" by auto
      from this(4)
        have "(SubnetS s1 s2, a, SubnetS s1' s2') \<in> pnet_sos (trans (pnet np p1)) (trans (pnet np p2))"
          by simp
      thus "s1' \<in> reachable (pnet np p1) TT
         \<and> s2' \<in> reachable (pnet np p2) TT"
        by cases (insert sr1 sr2, auto elim: reachable_step)
    qed
    thus "s1 \<in> reachable (pnet np p1) TT"
         "s2 \<in> reachable (pnet np p2) TT" by auto
  qed

lemma delivered_to_node [elim]:
  assumes "s \<in> reachable (pnet np \<langle>ii; R\<^sub>i\<rangle>) TT"
      and "(s, i:deliver(d), s') \<in> trans (pnet np \<langle>ii; R\<^sub>i\<rangle>)"
    shows "i = ii"
  proof -
    from assms(1) obtain P R where "s = NodeS ii P R"
      by (metis net_node_reachable_is_node)
    with assms(2) show "i = ii"
       by (clarsimp simp add: trans_node_comp elim!: node_deliverTE')
  qed

lemma delivered_to_net_ips:
  assumes "s \<in> reachable (pnet np p) TT"
      and "(s, i:deliver(d), s') \<in> trans (pnet np p)"
    shows "i \<in> net_ips s"
  using assms proof (induction p arbitrary: s s')
    fix ii R\<^sub>i s s'
    assume sr: "s \<in> reachable (pnet np \<langle>ii; R\<^sub>i\<rangle>) TT"
       and "(s, i:deliver(d), s') \<in> trans (pnet np \<langle>ii; R\<^sub>i\<rangle>)"
    from this(2) have tr: "(s, i:deliver(d), s') \<in> node_sos (trans (np ii))" by simp
    from sr obtain P R where [simp]: "s = NodeS ii P R"
      by (metis net_node_reachable_is_node)
    moreover from tr obtain P' R' where [simp]: "s' = NodeS ii P' R'"
      by simp (metis node_sos_dest)
    ultimately have "i = ii" using tr by auto
    thus "i \<in> net_ips s" by simp
  next
    fix p1 p2 s s'
    assume IH1: "\<And>s s'. \<lbrakk> s \<in> reachable (pnet np p1) TT;
                          (s, i:deliver(d), s') \<in> trans (pnet np p1) \<rbrakk> \<Longrightarrow> i \<in> net_ips s"
       and IH2: "\<And>s s'. \<lbrakk> s \<in> reachable (pnet np p2) TT;
                          (s, i:deliver(d), s') \<in> trans (pnet np p2) \<rbrakk> \<Longrightarrow> i \<in> net_ips s"
       and sr: "s \<in> reachable (pnet np (p1 \<parallel> p2)) TT"
       and tr: "(s, i:deliver(d), s') \<in> trans (pnet np (p1 \<parallel> p2))"
    from tr have "(s, i:deliver(d), s') \<in> pnet_sos (trans (pnet np p1)) (trans (pnet np p2))"
      by simp
    thus "i \<in> net_ips s"
    proof (rule partial_deliverTE)
      fix s1 s1' s2
      assume "s = SubnetS s1 s2"
         and "s' = SubnetS s1' s2"
         and tr: "(s1, i:deliver(d), s1') \<in> trans (pnet np p1)"
      from sr have "s1 \<in> reachable (pnet np p1) TT"
        by (auto simp only: \<open>s = SubnetS s1 s2\<close> elim: subnet_reachable)
      hence "i \<in> net_ips s1" using tr by (rule IH1)
      thus "i \<in> net_ips s" by (simp add: \<open>s = SubnetS s1 s2\<close>)
    next
      fix s2 s2' s1
      assume "s = SubnetS s1 s2"
         and "s' = SubnetS s1 s2'"
         and tr: "(s2, i:deliver(d), s2') \<in> trans (pnet np p2)"
      from sr have "s2 \<in> reachable (pnet np p2) TT"
        by (auto simp only: \<open>s = SubnetS s1 s2\<close> elim: subnet_reachable)
      hence "i \<in> net_ips s2" using tr by (rule IH2)
      thus "i \<in> net_ips s" by (simp add: \<open>s = SubnetS s1 s2\<close>)
    qed
  qed

lemma wf_net_tree_net_ips_disjoint [elim]:
  assumes "wf_net_tree (p1 \<parallel> p2)"
      and "s1 \<in> reachable (pnet np p1) S"
      and "s2 \<in> reachable (pnet np p2) S"
    shows "net_ips s1 \<inter> net_ips s2 = {}"
  proof -
    from \<open>wf_net_tree (p1 \<parallel> p2)\<close> have "net_tree_ips p1 \<inter> net_tree_ips p2 = {}" by auto
    moreover from assms(2) have "net_ips s1 = net_tree_ips p1" ..
    moreover from assms(3) have "net_ips s2 = net_tree_ips p2" ..
    ultimately show ?thesis by simp
  qed

lemma init_mapstate_Some_aodv_init [elim]:
  assumes "s \<in> init (pnet np p)"
      and "netmap s i = Some v"
    shows "v \<in> init (np i)"
  using assms proof (induction p arbitrary: s)
    fix ii R s
    assume "s \<in> init (pnet np \<langle>ii; R\<rangle>)"
       and "netmap s i = Some v"
    from this(1) obtain ns where s: "s = NodeS ii ns R"
      and ns: "ns \<in> init (np ii)" ..
    from s and \<open>netmap s i = Some v\<close> have "i = ii"
      by simp (metis domI domIff)
    with s ns show "v \<in> init (np i)"
      using \<open>netmap s i = Some v\<close> by simp
  next
    fix p1 p2 s
    assume IH1: "\<And>s. s \<in> init (pnet np p1) \<Longrightarrow> netmap s i = Some v \<Longrightarrow> v \<in> init (np i)"
       and IH2: "\<And>s. s \<in> init (pnet np p2) \<Longrightarrow> netmap s i = Some v \<Longrightarrow> v \<in> init (np i)"
       and "s \<in> init (pnet np (p1 \<parallel> p2))"
       and "netmap s i = Some v"
    from this(3) obtain s1 s2 where "s = SubnetS s1 s2"
                                and "s1 \<in> init (pnet np p1)"
                                and "s2 \<in> init (pnet np p2)" by auto
    from this(1) and \<open>netmap s i = Some v\<close>
      have "netmap s1 i = Some v \<or> netmap s2 i = Some v" by auto
    thus "v \<in> init (np i)"
    proof
      assume "netmap s1 i = Some v"
      with \<open>s1 \<in> init (pnet np p1)\<close> show ?thesis by (rule IH1)
    next
      assume "netmap s2 i = Some v"
      with \<open>s2 \<in> init (pnet np p2)\<close> show ?thesis by (rule IH2)
    qed
  qed

lemma reachable_connect_netmap [elim]:
  assumes "s \<in> reachable (pnet np n) TT"
      and "(s, connect(i, i'), s') \<in> trans (pnet np n)"
    shows "netmap s' = netmap s"
  using assms proof (induction n arbitrary: s s')
    fix ii R\<^sub>i s s'
    assume sr: "s \<in> reachable (pnet np \<langle>ii; R\<^sub>i\<rangle>) TT"
       and "(s, connect(i, i'), s') \<in> trans (pnet np \<langle>ii; R\<^sub>i\<rangle>)"
    from this(2) have tr: "(s, connect(i, i'), s') \<in> node_sos (trans (np ii))" ..
    from sr obtain p R where "s = NodeS ii p R"
      by (metis net_node_reachable_is_node)
    with tr show "netmap s' = netmap s"
      by (auto elim!: node_sos.cases)
  next
    fix p1 p2 s s'
    assume IH1: "\<And>s s'. \<lbrakk> s \<in> reachable (pnet np p1) TT;
                          (s, connect(i, i'), s') \<in> trans (pnet np p1) \<rbrakk> \<Longrightarrow> netmap s' = netmap s"
       and IH2: "\<And>s s'. \<lbrakk> s \<in> reachable (pnet np p2) TT;
                          (s, connect(i, i'), s') \<in> trans (pnet np p2) \<rbrakk> \<Longrightarrow> netmap s' = netmap s"
       and sr: "s \<in> reachable (pnet np (p1 \<parallel> p2)) TT"
       and tr: "(s, connect(i, i'), s') \<in> trans (pnet np (p1 \<parallel> p2))"
    from tr have "(s, connect(i, i'), s') \<in> pnet_sos (trans (pnet np p1)) (trans (pnet np p2))"
      by simp
    thus "netmap s' = netmap s"
    proof cases
      fix s1 s1' s2 s2'
      assume "s = SubnetS s1 s2"
         and "s' = SubnetS s1' s2'"
         and tr1: "(s1, connect(i, i'), s1') \<in> trans (pnet np p1)"
         and tr2: "(s2, connect(i, i'), s2') \<in> trans (pnet np p2)"
    from this(1) and sr
      have "SubnetS s1 s2 \<in> reachable (pnet np (p1 \<parallel> p2)) TT" by simp
    hence sr1: "s1 \<in> reachable (pnet np p1) TT"
      and sr2: "s2 \<in> reachable (pnet np p2) TT"
      by (auto intro: subnet_reachable)
    from sr1 tr1 have "netmap s1' = netmap s1" by (rule IH1)
    moreover from sr2 tr2 have "netmap s2' = netmap s2" by (rule IH2)
    ultimately show "netmap s' = netmap s"
      using \<open>s = SubnetS s1 s2\<close> and \<open>s' = SubnetS s1' s2'\<close> by simp
    qed simp_all
  qed

lemma reachable_disconnect_netmap [elim]:
  assumes "s \<in> reachable (pnet np n) TT"
      and "(s, disconnect(i, i'), s') \<in> trans (pnet np n)"
    shows "netmap s' = netmap s"
  using assms proof (induction n arbitrary: s s')
    fix ii R\<^sub>i s s'
    assume sr: "s \<in> reachable (pnet np \<langle>ii; R\<^sub>i\<rangle>) TT"
       and "(s, disconnect(i, i'), s') \<in> trans (pnet np \<langle>ii; R\<^sub>i\<rangle>)"
    from this(2) have tr: "(s, disconnect(i, i'), s') \<in> node_sos (trans (np ii))" ..
    from sr obtain p R where "s = NodeS ii p R"
      by (metis net_node_reachable_is_node)
    with tr show "netmap s' = netmap s"
      by (auto elim!: node_sos.cases)
  next
    fix p1 p2 s s'
    assume IH1: "\<And>s s'. \<lbrakk> s \<in> reachable (pnet np p1) TT;
                          (s, disconnect(i, i'), s') \<in> trans (pnet np p1) \<rbrakk> \<Longrightarrow> netmap s' = netmap s"
       and IH2: "\<And>s s'. \<lbrakk> s \<in> reachable (pnet np p2) TT;
                          (s, disconnect(i, i'), s') \<in> trans (pnet np p2) \<rbrakk> \<Longrightarrow> netmap s' = netmap s"
       and sr: "s \<in> reachable (pnet np (p1 \<parallel> p2)) TT"
       and tr: "(s, disconnect(i, i'), s') \<in> trans (pnet np (p1 \<parallel> p2))"
    from tr have "(s, disconnect(i, i'), s') \<in> pnet_sos (trans (pnet np p1)) (trans (pnet np p2))"
      by simp
    thus "netmap s' = netmap s"
    proof cases
      fix s1 s1' s2 s2'
      assume "s = SubnetS s1 s2"
         and "s' = SubnetS s1' s2'"
         and tr1: "(s1, disconnect(i, i'), s1') \<in> trans (pnet np p1)"
         and tr2: "(s2, disconnect(i, i'), s2') \<in> trans (pnet np p2)"
    from this(1) and sr
      have "SubnetS s1 s2 \<in> reachable (pnet np (p1 \<parallel> p2)) TT" by simp
    hence sr1: "s1 \<in> reachable (pnet np p1) TT"
      and sr2: "s2 \<in> reachable (pnet np p2) TT"
      by (auto intro: subnet_reachable)
    from sr1 tr1 have "netmap s1' = netmap s1" by (rule IH1)
    moreover from sr2 tr2 have "netmap s2' = netmap s2" by (rule IH2)
    ultimately show "netmap s' = netmap s"
      using \<open>s = SubnetS s1 s2\<close> and \<open>s' = SubnetS s1' s2'\<close> by simp
    qed simp_all
  qed

fun net_ip_action :: "(ip \<Rightarrow> ('s, 'm seq_action) automaton)
                       \<Rightarrow> 'm node_action \<Rightarrow> ip \<Rightarrow> net_tree \<Rightarrow> 's net_state \<Rightarrow> 's net_state \<Rightarrow> bool"
where
    "net_ip_action np a i (p1 \<parallel> p2) (SubnetS s1 s2) (SubnetS s1' s2') =
         ((i \<in> net_ips s1 \<longrightarrow> ((s1, a, s1') \<in> trans (pnet np p1)
                                \<and> s2' = s2 \<and> net_ip_action np a i p1 s1 s1'))
          \<and> (i \<in> net_ips s2 \<longrightarrow> ((s2, a, s2') \<in> trans (pnet np p2))
                                   \<and> s1' = s1 \<and> net_ip_action np a i p2 s2 s2'))"
  | "net_ip_action np a i p s s' = True"

lemma pnet_tau_single_node [elim]:
  assumes "wf_net_tree p"
      and "s \<in> reachable (pnet np p) TT"
      and "(s, \<tau>, s') \<in> trans (pnet np p)"
  shows "\<exists>i\<in>net_ips s. ((\<forall>j. j\<noteq>i \<longrightarrow> netmap s' j = netmap s j)
                         \<and> net_ip_action np \<tau> i p s s')"
  using assms proof (induction p arbitrary: s s')
    fix ii R\<^sub>i s s'
    assume "s \<in> reachable (pnet np \<langle>ii; R\<^sub>i\<rangle>) TT"
       and "(s, \<tau>, s') \<in> trans (pnet np \<langle>ii; R\<^sub>i\<rangle>)"
    from this obtain p R p' R' where "s = NodeS ii p R" and "s' = NodeS ii p' R'"
      by (metis (hide_lams, no_types) TT_True net_node_reachable_is_node
                                      reachable_step)
    hence "net_ips s = {ii}"
      and "net_ips s' = {ii}" by simp_all
    hence "\<exists>i\<in>dom (netmap s). \<forall>j. j \<noteq> i \<longrightarrow> netmap s' j = netmap s j"
      by (simp add: net_ips_is_dom_netmap)
    thus "\<exists>i\<in>net_ips s. (\<forall>j. j \<noteq> i \<longrightarrow> netmap s' j = netmap s j)
                         \<and> net_ip_action np \<tau> i (\<langle>ii; R\<^sub>i\<rangle>) s s'"
      by (simp add: net_ips_is_dom_netmap)
  next
    fix p1 p2 s s'
    assume IH1: "\<And>s s'. \<lbrakk> wf_net_tree p1;
                          s \<in> reachable (pnet np p1) TT;
                          (s, \<tau>, s') \<in> trans (pnet np p1) \<rbrakk>
                         \<Longrightarrow> \<exists>i\<in>net_ips s. (\<forall>j. j \<noteq> i \<longrightarrow> netmap s' j = netmap s j)
                                            \<and> net_ip_action np \<tau> i p1 s s'"
       and IH2: "\<And>s s'. \<lbrakk> wf_net_tree p2;
                          s \<in> reachable (pnet np p2) TT;
                          (s, \<tau>, s') \<in> trans (pnet np p2) \<rbrakk>
                         \<Longrightarrow> \<exists>i\<in>net_ips s. (\<forall>j. j \<noteq> i \<longrightarrow> netmap s' j = netmap s j)
                                            \<and> net_ip_action np \<tau> i p2 s s'"
       and sr: "s \<in> reachable (pnet np (p1 \<parallel> p2)) TT"
       and "wf_net_tree (p1 \<parallel> p2)"
       and tr: "(s, \<tau>, s') \<in> trans (pnet np (p1 \<parallel> p2))"
    from \<open>wf_net_tree (p1 \<parallel> p2)\<close> have "net_tree_ips p1 \<inter> net_tree_ips p2 = {}"
                                  and "wf_net_tree p1"
                                  and "wf_net_tree p2" by auto
    from tr have "(s, \<tau>, s') \<in> pnet_sos (trans (pnet np p1)) (trans (pnet np p2))" by simp
    thus "\<exists>i\<in>net_ips s. (\<forall>j. j \<noteq> i \<longrightarrow> netmap s' j = netmap s j)
                        \<and> net_ip_action np \<tau> i (p1 \<parallel> p2) s s'"
    proof cases
      fix s1 s1' s2
      assume subs:  "s = SubnetS s1 s2"
         and subs': "s' = SubnetS s1' s2"
         and tr1: "(s1, \<tau>, s1') \<in> trans (pnet np p1)"
      from sr have sr1: "s1 \<in> reachable (pnet np p1) TT"
               and "s2 \<in> reachable (pnet np p2) TT"
        by (simp_all only: subs) (erule subnet_reachable)+
      with \<open>net_tree_ips p1 \<inter> net_tree_ips p2 = {}\<close> have "dom(netmap s1) \<inter> dom(netmap s2) = {}"
        by (metis net_ips_is_dom_netmap pnet_net_ips_net_tree_ips)
      from \<open>wf_net_tree p1\<close> sr1 tr1 obtain i where "i\<in>dom(netmap s1)"
                                               and *: "\<forall>j. j \<noteq> i \<longrightarrow> netmap s1' j = netmap s1 j"
                                               and "net_ip_action np \<tau> i p1 s1 s1'"
          by (auto simp add: net_ips_is_dom_netmap dest!: IH1)
      from this(1) and \<open>dom(netmap s1) \<inter> dom(netmap s2) = {}\<close> have "i\<notin>dom(netmap s2)"
        by auto
      with subs subs' tr1 \<open>net_ip_action np \<tau> i p1 s1 s1'\<close> have "net_ip_action np \<tau> i (p1 \<parallel> p2) s s'"
        by (simp add: net_ips_is_dom_netmap)
      moreover have "\<forall>j. j \<noteq> i \<longrightarrow> (netmap s1' ++ netmap s2) j = (netmap s1 ++ netmap s2) j"
      proof (intro allI impI)
        fix j
        assume "j \<noteq> i"
        with * have "netmap s1' j = netmap s1 j" by simp
        thus "(netmap s1' ++ netmap s2) j = (netmap s1 ++ netmap s2) j"
          by (metis (hide_lams, mono_tags) map_add_dom_app_simps(1) map_add_dom_app_simps(3))
      qed
      ultimately show ?thesis using \<open>i\<in>dom(netmap s1)\<close> subs subs'
        by (auto simp add: net_ips_is_dom_netmap)
    next
      fix s2 s2' s1
      assume subs: "s = SubnetS s1 s2"
         and subs': "s' = SubnetS s1 s2'"
         and tr2: "(s2, \<tau>, s2') \<in> trans (pnet np p2)"
      from sr have "s1 \<in> reachable (pnet np p1) TT"
               and sr2: "s2 \<in> reachable (pnet np p2) TT"
        by (simp_all only: subs) (erule subnet_reachable)+
      with \<open>net_tree_ips p1 \<inter> net_tree_ips p2 = {}\<close> have "dom(netmap s1) \<inter> dom(netmap s2) = {}"
        by (metis net_ips_is_dom_netmap pnet_net_ips_net_tree_ips)
      from \<open>wf_net_tree p2\<close> sr2 tr2 obtain i where "i\<in>dom(netmap s2)"
                                               and *: "\<forall>j. j \<noteq> i \<longrightarrow> netmap s2' j = netmap s2 j"
                                               and "net_ip_action np \<tau> i p2 s2 s2'"
          by (auto simp add: net_ips_is_dom_netmap dest!: IH2)
      from this(1) and \<open>dom(netmap s1) \<inter> dom(netmap s2) = {}\<close> have "i\<notin>dom(netmap s1)"
        by auto
      with subs subs' tr2 \<open>net_ip_action np \<tau> i p2 s2 s2'\<close> have "net_ip_action np \<tau> i (p1 \<parallel> p2) s s'"
        by (simp add: net_ips_is_dom_netmap)
      moreover have "\<forall>j. j \<noteq> i \<longrightarrow> (netmap s1 ++ netmap s2') j = (netmap s1 ++ netmap s2) j"
      proof (intro allI impI)
        fix j
        assume "j \<noteq> i"
        with * have "netmap s2' j = netmap s2 j" by simp
        thus "(netmap s1 ++ netmap s2') j = (netmap s1 ++ netmap s2) j"
          by (metis (hide_lams, mono_tags) domD map_add_Some_iff map_add_dom_app_simps(3))
      qed
      ultimately show ?thesis using \<open>i\<in>dom(netmap s2)\<close> subs subs'
        by (clarsimp simp add: net_ips_is_dom_netmap)
           (metis domI dom_map_add map_add_find_right)
    qed simp_all
  qed

lemma pnet_deliver_single_node [elim]:
  assumes "wf_net_tree p"
      and "s \<in> reachable (pnet np p) TT"
      and "(s, i:deliver(d), s') \<in> trans (pnet np p)"
  shows "(\<forall>j. j\<noteq>i \<longrightarrow> netmap s' j = netmap s j) \<and> net_ip_action np (i:deliver(d)) i p s s'"
    (is "?P p s s'")
  using assms proof (induction p arbitrary: s s')
    fix ii R\<^sub>i s s'
    assume sr: "s \<in> reachable (pnet np \<langle>ii; R\<^sub>i\<rangle>) TT"
       and tr: "(s, i:deliver(d), s') \<in> trans (pnet np \<langle>ii; R\<^sub>i\<rangle>)"
    from this obtain p R p' R' where "s = NodeS ii p R" and "s' = NodeS ii p' R'"
      by (metis (hide_lams, no_types) TT_True net_node_reachable_is_node
                                      reachable_step)
    hence "net_ips s = {ii}"
      and "net_ips s' = {ii}" by simp_all
    hence "\<forall>j. j \<noteq> ii \<longrightarrow> netmap s' j = netmap s j"
      by simp
    moreover from sr tr have "i = ii" by (rule delivered_to_node)
    ultimately show "(\<forall>j. j \<noteq> i \<longrightarrow> netmap s' j = netmap s j)
                     \<and> net_ip_action np (i:deliver(d)) i (\<langle>ii; R\<^sub>i\<rangle>) s s'"
      by simp
  next
    fix p1 p2 s s'
    assume IH1: "\<And>s s'. \<lbrakk> wf_net_tree p1;
                          s \<in> reachable (pnet np p1) TT;
                          (s, i:deliver(d), s') \<in> trans (pnet np p1) \<rbrakk>
                         \<Longrightarrow> (\<forall>j. j \<noteq> i \<longrightarrow> netmap s' j = netmap s j)
                             \<and> net_ip_action np (i:deliver(d)) i p1 s s'"
       and IH2: "\<And>s s'. \<lbrakk> wf_net_tree p2;
                          s \<in> reachable (pnet np p2) TT;
                          (s, i:deliver(d), s') \<in> trans (pnet np p2) \<rbrakk>
                         \<Longrightarrow> (\<forall>j. j \<noteq> i \<longrightarrow> netmap s' j = netmap s j)
                             \<and> net_ip_action np (i:deliver(d)) i p2 s s'"
       and sr: "s \<in> reachable (pnet np (p1 \<parallel> p2)) TT"
       and "wf_net_tree (p1 \<parallel> p2)"
       and tr: "(s, i:deliver(d), s') \<in> trans (pnet np (p1 \<parallel> p2))"
    from \<open>wf_net_tree (p1 \<parallel> p2)\<close> have "net_tree_ips p1 \<inter> net_tree_ips p2 = {}"
                                  and "wf_net_tree p1"
                                  and "wf_net_tree p2" by auto
    from tr have "(s, i:deliver(d), s') \<in> pnet_sos (trans (pnet np p1)) (trans (pnet np p2))" by simp
    thus "(\<forall>j. j \<noteq> i \<longrightarrow> netmap s' j = netmap s j)
          \<and> net_ip_action np (i:deliver(d)) i (p1 \<parallel> p2) s s'"
    proof cases
      fix s1 s1' s2
      assume subs:  "s = SubnetS s1 s2"
         and subs': "s' = SubnetS s1' s2"
         and tr1: "(s1, i:deliver(d), s1') \<in> trans (pnet np p1)"
      from sr have sr1: "s1 \<in> reachable (pnet np p1) TT"
               and "s2 \<in> reachable (pnet np p2) TT"
        by (simp_all only: subs) (erule subnet_reachable)+
      with \<open>net_tree_ips p1 \<inter> net_tree_ips p2 = {}\<close> have "dom(netmap s1) \<inter> dom(netmap s2) = {}"
        by (metis net_ips_is_dom_netmap pnet_net_ips_net_tree_ips)
      moreover from sr1 tr1 have "i \<in> net_ips s1" by (rule delivered_to_net_ips)
      ultimately have "i\<notin>dom(netmap s2)" by (auto simp add: net_ips_is_dom_netmap)

      from \<open>wf_net_tree p1\<close> sr1 tr1 have *: "\<forall>j. j \<noteq> i \<longrightarrow> netmap s1' j = netmap s1 j"
                                     and "net_ip_action np (i:deliver(d)) i p1 s1 s1'"
          by (auto dest!: IH1)
      from subs subs' tr1 this(2) \<open>i\<notin>dom(netmap s2)\<close>
        have "net_ip_action np (i:deliver(d)) i (p1 \<parallel> p2) s s'"
          by (simp add: net_ips_is_dom_netmap)
      moreover have "\<forall>j. j \<noteq> i \<longrightarrow> (netmap s1' ++ netmap s2) j = (netmap s1 ++ netmap s2) j"
      proof (intro allI impI)
        fix j
        assume "j \<noteq> i"
        with * have "netmap s1' j = netmap s1 j" by simp
        thus "(netmap s1' ++ netmap s2) j = (netmap s1 ++ netmap s2) j"
          by (metis (hide_lams, mono_tags) map_add_dom_app_simps(1) map_add_dom_app_simps(3))
      qed
      ultimately show ?thesis using \<open>i\<in>net_ips s1\<close> subs subs' by auto
    next
      fix s2 s2' s1
      assume subs: "s = SubnetS s1 s2"
         and subs': "s' = SubnetS s1 s2'"
         and tr2: "(s2, i:deliver(d), s2') \<in> trans (pnet np p2)"
      from sr have "s1 \<in> reachable (pnet np p1) TT"
               and sr2: "s2 \<in> reachable (pnet np p2) TT"
        by (simp_all only: subs) (erule subnet_reachable)+
      with \<open>net_tree_ips p1 \<inter> net_tree_ips p2 = {}\<close> have "dom(netmap s1) \<inter> dom(netmap s2) = {}"
        by (metis net_ips_is_dom_netmap pnet_net_ips_net_tree_ips)
      moreover from sr2 tr2 have "i \<in> net_ips s2" by (rule delivered_to_net_ips)
      ultimately have "i\<notin>dom(netmap s1)" by (auto simp add: net_ips_is_dom_netmap)

      from \<open>wf_net_tree p2\<close> sr2 tr2 have *: "\<forall>j. j \<noteq> i \<longrightarrow> netmap s2' j = netmap s2 j"
                                     and "net_ip_action np (i:deliver(d)) i p2 s2 s2'"
          by (auto dest!: IH2)
      from subs subs' tr2 this(2) \<open>i\<notin>dom(netmap s1)\<close>
        have "net_ip_action np (i:deliver(d)) i (p1 \<parallel> p2) s s'"
          by (simp add: net_ips_is_dom_netmap)
      moreover have "\<forall>j. j \<noteq> i \<longrightarrow> (netmap s1 ++ netmap s2') j = (netmap s1 ++ netmap s2) j"
      proof (intro allI impI)
        fix j
        assume "j \<noteq> i"
        with * have "netmap s2' j = netmap s2 j" by simp
        thus "(netmap s1 ++ netmap s2') j = (netmap s1 ++ netmap s2) j"
          by (metis (hide_lams, mono_tags) domD map_add_Some_iff map_add_dom_app_simps(3))
      qed
      ultimately show ?thesis using \<open>i\<in>net_ips s2\<close> subs subs' by auto
    qed simp_all
  qed

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Early_Bisim_Subst
  imports Weak_Early_Bisim Strong_Early_Bisim_Subst
begin

consts weakBisimSubst :: "(pi \<times> pi) set"
abbreviation weakEarlyBisimSubstJudge (infixr "\<approx>\<^sup>s" 65) where "P \<approx>\<^sup>s Q \<equiv> (P, Q) \<in> (substClosed weakBisim)"

lemma congBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx>\<^sup>s Q"

  shows "P \<approx> Q"
using assms substClosedSubset
by blast

lemma strongBisimWeakBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sup>s Q"

  shows "P \<approx>\<^sup>s Q"
using assms
by(auto simp add: substClosed_def intro: strongBisimWeakBisim)

lemma eqvt:
  shows "eqvt (substClosed weakBisim)"
by(rule eqvtSubstClosed[OF Weak_Early_Bisim.eqvt])

lemma eqvtI[eqvt]:
  fixes P :: pi
  and   Q :: pi
  and   perm :: "name prm"

  assumes "P \<approx>\<^sup>s Q"

  shows "(perm \<bullet> P) \<approx>\<^sup>s (perm \<bullet> Q)"
using assms
by(rule eqvtRelI[OF eqvt])

lemma reflexive:
  fixes P :: pi

  shows "P \<approx>\<^sup>s P"
by(force simp add: substClosed_def intro: Weak_Early_Bisim.reflexive)

lemma symetric:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx>\<^sup>s Q"

  shows "Q \<approx>\<^sup>s P"
using assms
by(force simp add: substClosed_def intro: Weak_Early_Bisim.symetric)

lemma partUnfold:
  fixes P :: pi
  and   Q :: pi
  and   s :: "(name \<times> name) list"

  assumes "P \<approx>\<^sup>s Q"

  shows "P[<s>] \<approx>\<^sup>s Q[<s>]"
using assms
proof(auto simp add: substClosed_def)
  fix s'
  assume "\<forall>s. P[<s>] \<approx> Q[<s>]"
  hence "P[<(s@s')>] \<approx> Q[<(s@s')>]" by blast
  moreover have "P[<(s@s')>] = (P[<s>])[<s'>]"
    by(induct s', auto)
  moreover have "Q[<(s@s')>] = (Q[<s>])[<s'>]"
    by(induct s', auto)

  ultimately show "(P[<s>])[<s'>] \<approx> (Q[<s>])[<s'>]"
    by simp
qed

end


theory "TLA-Utils"
  imports "HOL-TLA.TLA"
begin

syntax
  "_liftSubset" :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<subseteq> _)" [50, 51] 50)
  "_liftInter"  :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<inter> _)" [50, 51] 50)
  "_liftUn"     :: "[lift, lift] \<Rightarrow> lift"                ("(_/ \<union> _)" [50, 51] 50)

translations
  "_liftSubset"   == "_lift2 (\<subseteq>)"
  "_liftInter"    == "_lift2 (\<inter>)"
  "_liftUn"       == "_lift2 (\<union>)"

lemma imp_imp_leadsto:
  assumes "\<turnstile> F \<longrightarrow> G"
  shows "\<turnstile> S \<longrightarrow> (F \<leadsto> G)"
  apply (auto simp add: Valid_def)
  using ImplLeadsto_simple assms by blast

lemma imp_leadsto_transitive[trans]:
  assumes "\<turnstile> S \<longrightarrow> (F \<leadsto> G)"
  assumes "\<turnstile> S \<longrightarrow> (G \<leadsto> H)"
  shows "\<turnstile> S \<longrightarrow> (F \<leadsto> H)"
  using assms
  apply (auto simp add: Valid_def)
  using LatticeTransitivity by fastforce

lemma imp_eventually_tautology:
  assumes "\<turnstile> F"
  shows "\<turnstile> S \<longrightarrow> \<diamond>F"
  using assms by (smt DmdImplE Valid_def int_simps(1) temp_simps(2) unl_lift2)

lemma temp_impI:
  assumes "sigma \<Turnstile> P \<Longrightarrow> sigma \<Turnstile> Q"
  shows "sigma \<Turnstile> P \<longrightarrow> Q"
  using assms by auto

lemma temp_conjI:
  assumes "sigma \<Turnstile> P" "sigma \<Turnstile> Q"
  shows "sigma \<Turnstile> P \<and> Q"
  using assms by auto

lemma temp_conjE:
  assumes "sigma \<Turnstile> F \<and> G"
  assumes  "\<lbrakk> sigma \<Turnstile> F; sigma \<Turnstile> G \<rbrakk> \<Longrightarrow> P"
  shows "P"
  using assms by auto

lemma temp_disjE:
  assumes "sigma \<Turnstile> F \<or> G"
  assumes "sigma \<Turnstile> F \<Longrightarrow> P"
  assumes "sigma \<Turnstile> G \<Longrightarrow> P"
  shows "P"
  using assms by auto

lemma temp_exI:
  assumes "sigma \<Turnstile> F x"
  shows "sigma \<Turnstile> (\<exists>x. F x)"
  using assms by auto

lemma temp_exE:
  assumes "sigma \<Turnstile> \<exists>x. F x"
  assumes "\<And>x. sigma \<Turnstile> F x \<Longrightarrow> P"
  shows "P"
  using assms by auto

lemma temp_ex_impI:
  assumes "\<And>x. \<turnstile> F x \<longrightarrow> G"
  shows "\<turnstile> (\<exists>x. F x) \<longrightarrow> G"
  using assms by (auto simp add: Valid_def)

lemma action_beforeI: assumes "s \<Turnstile> P" shows "(s,t) \<Turnstile> $P" using assms by simp
lemma action_afterI:  assumes "t \<Turnstile> P" shows "(s,t) \<Turnstile> P$" using assms by simp

lemma temp_imp_conjI:
  assumes "\<turnstile> S \<longrightarrow> P" "\<turnstile> S \<longrightarrow> Q"
  shows "\<turnstile> S \<longrightarrow> P \<and> Q"
  using assms unfolding Valid_def
  by auto

lemma temp_imp_box_conjI:
  assumes "\<turnstile> S \<longrightarrow> \<box>P" "\<turnstile> S \<longrightarrow> \<box>Q"
  shows "\<turnstile> S \<longrightarrow> \<box>(P \<and> Q)"
  using assms by (simp add: split_box_conj Valid_def)

lemma temp_box_conjE:
  assumes "sigma \<Turnstile> \<box>(F \<and> G)"
  assumes  "\<lbrakk> sigma \<Turnstile> \<box>F; sigma \<Turnstile> \<box>G \<rbrakk> \<Longrightarrow> P"
  shows "P"
  using assms STL5 unfolding Valid_def
  by (simp add: split_box_conj)

lemma temp_imp_trans [trans]:
  assumes "\<turnstile> F \<longrightarrow> G"
  assumes "\<turnstile> G \<longrightarrow> H"
  shows "\<turnstile> F \<longrightarrow> H"
  using assms unfolding Valid_def by auto

lemma imp_leadsto_invariant:
  fixes S :: temporal
  fixes P I :: stpred
  assumes "\<turnstile> S \<longrightarrow> \<box>I"
  shows "\<turnstile> S \<longrightarrow> (P \<leadsto> I)"
proof (intro tempI temp_impI)
  fix sigma
  assume S: "sigma \<Turnstile> S"
  with assms have "sigma \<Turnstile> \<box>I" by auto
  thus "sigma \<Turnstile> P \<leadsto> I"
    unfolding leadsto_def
    by (metis InitDmd STL4E boxInit_stp dmdInit_stp intI temp_impI)
qed

lemma imp_forall_leadsto:
  fixes S :: temporal
  fixes P :: "'a \<Rightarrow> bool"
  fixes Q :: "'a \<Rightarrow> stpred"
  fixes R :: stpred
  assumes "\<And>x. P x \<Longrightarrow> \<turnstile> S \<longrightarrow> (Q x \<leadsto> R)"
  shows "\<turnstile> S \<longrightarrow> (\<forall> x. (#(P x) \<and> Q x) \<leadsto> R)"
  using assms
  unfolding Valid_def leadsto_def
  apply auto
  by (metis (full_types) ImplLeadsto_simple TrueW int_simps(11) int_simps(17) int_simps(19) inteq_reflection leadsto_def tempD)

lemma temp_dmd_box_imp:
  assumes "sigma \<Turnstile> \<diamond>\<box> P"
  assumes "\<turnstile> P \<longrightarrow> Q"
  shows "sigma \<Turnstile> \<diamond>\<box> Q"
  using assms DmdImplE STL4 by blast

lemma temp_box_dmd_imp:
  assumes "sigma \<Turnstile> \<box>\<diamond> P"
  assumes "\<turnstile> P \<longrightarrow> Q"
  shows "sigma \<Turnstile> \<box>\<diamond> Q"
  using assms DmdImpl STL4E by blast

lemma not_stuck_forever:
  fixes Stuck :: stpred
  fixes Progress :: action
  assumes "\<turnstile> Progress \<longrightarrow> $Stuck \<longrightarrow> \<not> Stuck$"
  shows "\<turnstile> \<box>\<diamond>Progress \<longrightarrow> \<not> \<diamond>\<box>Stuck"
  using assms
  by (unfold dmd_def, simp, intro STL4, simp, intro TLA2, auto)

lemma stable_dmd_stuck:
  assumes "\<turnstile> S \<longrightarrow> stable P"
  assumes "\<turnstile> S \<longrightarrow> \<diamond>P"
  shows "\<turnstile> S \<longrightarrow> \<diamond>\<box>P"
  using assms DmdStable by (meson temp_imp_conjI temp_imp_trans)

lemma enabled_before_conj[simp]:
  "PRED Enabled ($P \<and> Q) = (PRED (P \<and> Enabled Q))"
  unfolding enabled_def by (intro ext, auto)

lemma imp_leadsto_reflexive: "\<turnstile> S \<longrightarrow> (F \<leadsto> F)" using LatticeReflexivity [where F = F] by auto

lemma imp_leadsto_diamond:
  assumes "\<turnstile> S \<longrightarrow> (A \<leadsto> (B \<or> C))"
  assumes "\<turnstile> S \<longrightarrow> (B \<leadsto> D)"
  assumes "\<turnstile> S \<longrightarrow> (C \<leadsto> D)"
  shows   "\<turnstile> S \<longrightarrow> (A \<leadsto> D)"
proof (intro tempI temp_impI)
  fix sigma
  assume S: "sigma \<Turnstile> S"
  with assms have
    ABC: "sigma \<Turnstile> A \<leadsto> (B \<or> C)" and
    BD:  "sigma \<Turnstile> B \<leadsto> D" and
    CD:  "sigma \<Turnstile> C \<leadsto> D"
    by (auto simp add: Valid_def)
  with LatticeDiamond [where A = A and B = B and C = C and D = D]
  show "sigma \<Turnstile> A \<leadsto> D"
    by (auto simp add: Valid_def)
qed

lemma imp_disj_leadstoI:
  assumes "\<turnstile> S \<longrightarrow> (A \<leadsto> C)"
  assumes "\<turnstile> S \<longrightarrow> (B \<leadsto> C)"
  shows "\<turnstile> S \<longrightarrow> (A \<or> B \<leadsto> C)"
  by (intro imp_leadsto_diamond [OF imp_leadsto_reflexive] assms)

lemma imp_disj_excl_leadstoI:
  assumes "\<turnstile> S \<longrightarrow> (A \<leadsto> C)"
  assumes "\<turnstile> S \<longrightarrow> ((\<not>A \<and> B) \<leadsto> C)"
  shows "\<turnstile> S \<longrightarrow> (A \<or> B \<leadsto> C)"
proof -
  have "\<turnstile> S \<longrightarrow> (A \<or> B \<leadsto> (A \<or> (\<not>A \<and> B)))"
    by (intro imp_imp_leadsto, auto)
  also have "\<turnstile> S \<longrightarrow> ((A \<or> (\<not>A \<and> B)) \<leadsto> C)"
    using assms by (intro imp_disj_leadstoI)
  finally show ?thesis .
qed

lemma temp_conj_eq_imp:
  assumes "\<turnstile> P \<longrightarrow> (Q = R)"
  shows "\<turnstile> (P \<and> Q) = (P \<and> R)"
  using assms by (auto simp add: Valid_def)

text \<open>The following lemma is particularly useful for a system that makes
some progress which either reaches the desired state directly or which leaves it in
a state that is definitely not the desired state but from which it can reach the desired state via
some further progress.\<close>

lemma imp_leadsto_triangle_excl:
  assumes AB: "\<turnstile> S \<longrightarrow> (A \<leadsto> B)"
  assumes BC: "\<turnstile> S \<longrightarrow> ((B \<and> \<not>C) \<leadsto> C)"
  shows "\<turnstile> S \<longrightarrow> (A \<leadsto> C)"
proof -
  have "\<turnstile> ((B \<and> \<not>C) \<or> (B \<and> C)) = B" by auto
  from inteq_reflection [OF this] AB have ABCBC: "\<turnstile> S \<longrightarrow> (A \<leadsto> ((B \<and> \<not>C) \<or> (B \<and> C)))" by simp

  show ?thesis
  proof (intro imp_leadsto_diamond [OF ABCBC] BC)
    from ImplLeadsto_simple [where F = "LIFT (B \<and> C)"]
    show "\<turnstile> S \<longrightarrow> (B \<and> C \<leadsto> C)"
      by (auto simp add: Valid_def)
  qed
qed

lemma imp_leadsto_triangle_extra_assm:
  assumes AB: "\<turnstile> S \<longrightarrow> (A \<and> \<not>B \<leadsto> A \<and> B)"
  shows "\<turnstile> S \<longrightarrow> (A \<leadsto> A \<and> B)"
proof (rule imp_leadsto_triangle_excl [OF imp_leadsto_reflexive])
  have "\<turnstile> S \<longrightarrow> (A \<and> \<not> (A \<and> B) \<leadsto> A \<and> \<not>B)"
    by (intro imp_imp_leadsto, auto)
  with AB show "\<turnstile> S \<longrightarrow> (A \<and> \<not> (A \<and> B) \<leadsto> A \<and> B)" by (metis imp_leadsto_transitive)
qed

lemma imp_forall:
  assumes "\<And>x. \<turnstile> S \<longrightarrow> P x"
  shows "\<turnstile> S \<longrightarrow> (\<forall>x. P x)"
  using assms by (auto simp add: Valid_def)

lemma imp_exists_leadstoI:
  assumes "\<And>x. \<turnstile> S \<longrightarrow> (P x \<leadsto> Q)"
  shows "\<turnstile> S \<longrightarrow> ((\<exists> x. P x) \<leadsto> Q)"
  unfolding inteq_reflection [OF leadsto_exists]
  by (intro imp_forall assms)

lemma imp_INV_leadsto:
  "\<turnstile> S \<longrightarrow> \<box>I \<Longrightarrow> \<turnstile> S \<longrightarrow> (P \<and> I \<leadsto> Q) \<Longrightarrow> \<turnstile> S \<longrightarrow> (P \<leadsto> Q)"
  using INV_leadsto by (auto simp add: Valid_def, blast)

lemma wf_imp_leadsto:
  assumes 1: "wf r"
  and 2: "\<And>x. \<turnstile> S \<longrightarrow> (F x \<leadsto> (G \<or> (\<exists>y. #((y,x)\<in>r) \<and> F y)))"
  shows "\<turnstile> S \<longrightarrow> (F x \<leadsto> G)"
proof (intro tempI temp_impI)
  fix sigma assume sigma: "sigma \<Turnstile> S"
  with 2 have "\<And>x. sigma \<Turnstile> F x \<leadsto> (G \<or> (\<exists>y. #((y,x)\<in>r) \<and> F y))"
    by (auto simp add: Valid_def)
  from 1 this show "sigma \<Turnstile> F x \<leadsto> G" by (rule wf_leadsto)
qed

lemma wf_imp_ex_leadsto:
  assumes 1: "wf r" and 2: "\<And>x. \<turnstile> S \<longrightarrow> (F x \<leadsto> (G \<or> (\<exists>y. #((y,x)\<in>r) \<and> F y)))"
  shows "\<turnstile> S \<longrightarrow> ((\<exists>x. F x) \<leadsto> G)"
  using 1 2
  by (intro imp_exists_leadstoI wf_imp_leadsto [where G = G], auto)

lemma unstable_implies_infinitely_often:
  fixes P :: stpred
  assumes "\<turnstile> S \<longrightarrow> (\<not>P \<leadsto> P)"
  shows "\<turnstile> S \<longrightarrow> \<box>\<diamond>P"
proof -
  define T :: stpred where "T \<equiv> PRED #True"
  have "\<turnstile> S \<longrightarrow> (T \<leadsto> P)"
  proof (rule imp_leadsto_triangle_excl)
    show "\<turnstile> S \<longrightarrow> (T \<leadsto> T)" by (intro imp_imp_leadsto, simp)
    from assms show "\<turnstile> S \<longrightarrow> (T \<and> \<not> P \<leadsto> P)" by (simp add: T_def)
  qed
  thus ?thesis by (simp add: leadsto_def T_def)
qed

lemma imp_infinitely_often_implies_eventually:
  assumes "\<turnstile> S \<longrightarrow> \<box>\<diamond>P"
  shows "\<turnstile> S \<longrightarrow> \<diamond>P"
  using assms reflT temp_imp_trans by blast

lemma imp_eventually_forever_implies_infinitely_often:
  fixes P :: stpred
  assumes "\<turnstile> S \<longrightarrow> \<diamond>\<box>P"
  shows "\<turnstile> S \<longrightarrow> \<box>\<diamond>P"
  using assms DBImplBD temp_imp_trans by blast

lemma imp_leadsto_add_precondition:
  assumes "\<turnstile> S \<longrightarrow> \<box>R"
  assumes "\<turnstile> S \<longrightarrow> ((P \<and> R) \<leadsto> Q)"
  shows "\<turnstile> S \<longrightarrow> (P \<leadsto> Q)"
  using assms
  by (meson INV_leadsto temp_imp_conjI temp_imp_trans)

lemma box_conj_simp[simp]: "(TEMP \<box>(F \<and> G)) = (TEMP \<box>F \<and> \<box>G)"
  using STL5 by fastforce

lemma box_box_conj:
  shows "\<turnstile> (\<box>(F \<and> \<box>P)) = (\<box>F \<and> \<box>P)"
  by (metis STL3 STL5 inteq_reflection)

lemmas box_box_conj_simp[simp] = inteq_reflection [OF box_box_conj]

lemma box_before_conj:
  shows "\<turnstile> (\<box>A \<and> \<box>P) \<longrightarrow> (\<box>(A \<and> $P))"
  by (metis STL5 TLA.Init_simps(2) TrueW boxInit_act boxInit_stp int_simps(13) inteq_reflection)

lemma box_conj_box_dmd:
  shows "\<turnstile> (\<box>P \<and> \<box>\<diamond>Q) \<longrightarrow> \<box>\<diamond>(P \<and> Q)"
  by (metis (mono_tags, lifting) BoxDmd_simple STL3 STL4 STL5 inteq_reflection)

lemma imp_box_imp_leadsto:
  assumes "\<turnstile> S \<longrightarrow> \<box>(P \<longrightarrow> Q)"
  shows "\<turnstile> S \<longrightarrow> (P \<leadsto> Q)"
  using assms
  unfolding Valid_def
  apply auto
  by (metis ImplLeadsto Init.Init_simps(1) Init_simps2(3) STL4E boxInitD dmdInitD leadsto_def more_temp_simps3(2))

lemma temp_conj_assoc[simp]: "TEMP ((P \<and> Q) \<and> R) = TEMP (P \<and> Q \<and> R)" by auto

lemma enabled_exI:
  assumes "s \<Turnstile> Enabled P x"
  shows "s \<Turnstile> Enabled (\<exists> x. P x)"
  using assms
  unfolding enabled_def by auto

lemma enabled_guard_conjI:
  assumes "\<And>t. (s,t) \<Turnstile> P"
  assumes "s \<Turnstile> Enabled Q"
  shows "s \<Turnstile> Enabled (P \<and> Q)"
  using assms unfolding enabled_def by auto

lemma angle_ex_simp[simp]: "(ACT <\<exists>x. P x>_vs) = (ACT \<exists>x. <P x>_vs)"
  by (auto simp add: angle_def)

lemma leadsto_dmd_classical: "\<turnstile> ((\<diamond>F) \<and> ((\<box>\<not>G) \<leadsto> G)) \<longrightarrow> (F \<leadsto> G)"
  unfolding leadsto_def dmd_def
  by (force simp: Init_simps elim: STL4E)

lemma "\<turnstile> WF(A)_vars \<longrightarrow> \<box>[\<not> A]_vars \<longrightarrow> \<box>\<diamond>\<not>Enabled (<A>_vars)"
proof -
  have 1: "\<turnstile> [\<not> A]_vars = (\<not><A>_vars)" by (auto simp add: angle_def square_def)
  have 2: "\<turnstile> (\<box>\<diamond>\<not>Enabled (<A>_vars)) = (\<not>\<diamond>\<box>Enabled (<A>_vars))"
    by (auto simp add: more_temp_simps)
  show ?thesis
    unfolding WF_def inteq_reflection[OF 1] inteq_reflection[OF 2]
    apply auto
    using more_temp_simps3(7) reflT by fastforce
qed

lemma imp_SFI:
  assumes "\<turnstile> S \<longrightarrow> (Enabled (<A>_v) \<leadsto> <A>_v)"
  shows "\<turnstile> S \<longrightarrow> SF(A)_v"
  unfolding SF_def using assms leadsto_infinite apply auto by fastforce

lemma imp_pred_leadsto_act_reflexive: "\<turnstile> S \<longrightarrow> (A \<leadsto> $A)"
  by (metis Init_stp_act_rev imp_leadsto_reflexive leadsto_def)

lemma imp_unstable_leadsto_change:
  assumes "\<turnstile> S \<longrightarrow> (P \<leadsto> \<not>P)"
  shows "\<turnstile> S \<longrightarrow> (P \<leadsto> ($P \<and> \<not>P$))"
proof -
  note assms
  also have "\<turnstile> (P \<leadsto> \<not>P) \<longrightarrow> (P \<leadsto> ($P \<and> \<not>P$))"
    unfolding leadsto_def
  proof (intro STL4 tempI temp_impI)
    fix sigma
    assume Init_P: "sigma \<Turnstile> Init P"
    assume "sigma \<Turnstile> Init P \<longrightarrow> \<diamond>\<not> P"
    with Init_P have not_always_P: "sigma \<Turnstile> \<not>\<box>P"
      by (auto simp add: more_temp_simps)

    show "sigma \<Turnstile> \<diamond>($P \<and> \<not> P$)"
    proof (rule ccontr, simp add: more_temp_simps)
      assume no_transition: "sigma \<Turnstile> \<box>\<not> ($P \<and> \<not> P$)"
      have "sigma \<Turnstile> \<box>P"
      proof (invariant, intro Init_P, intro Stable)
        from no_transition show "sigma \<Turnstile> \<box>\<not> ($P \<and> \<not> P$)".
        show "\<turnstile> $P \<and> \<not> ($P \<and> \<not> P$) \<longrightarrow> P$" by auto
      qed
      with not_always_P show False by simp
    qed
  qed
  finally show ?thesis by simp
qed

lemma
  fixes A B C :: temporal
  assumes "\<turnstile> A \<longrightarrow> B \<longrightarrow> C" "sigma \<Turnstile> \<box>A" "sigma \<Turnstile> \<box>B"
  shows ABC_imp_box: "sigma \<Turnstile> \<box>C"
  using assms by (metis (full_types) STL4E normalT tempD unl_lift2)

lemma shows imp_after_leadsto: "\<turnstile> S \<longrightarrow> (P$ \<leadsto> P)"
  unfolding Valid_def leadsto_def apply auto
  by (metis DmdPrime InitDmd dmdInitD necT tempD temp_imp_trans)

lemma imp_eventually_leadsto_eventually[trans]:
  assumes 1: "\<turnstile> S \<longrightarrow> \<diamond>P"
  assumes 2: "\<turnstile> S \<longrightarrow> (P \<leadsto> Q)"
  shows "\<turnstile> S \<longrightarrow> \<diamond>Q"
proof (intro tempI temp_impI)
  fix sigma assume sigma: "sigma \<Turnstile> S"
  with 1 2 have 1: "sigma \<Turnstile> \<diamond>P" and 2: "sigma \<Turnstile> P \<leadsto> Q" by auto

  from 1 2 show "sigma \<Turnstile> \<diamond>Q"
    apply (simp add: leadsto_def)
    by (metis DmdImpl2 dmdInit dup_dmdD)
qed

lemma imp_eventually_init:
  assumes "\<turnstile> S \<longrightarrow> Init P"
  shows "\<turnstile> S \<longrightarrow> \<diamond> P"
  using assms InitDmd_gen temp_imp_trans by blast

lemma imp_box_before_afterI:
  assumes "\<turnstile> S \<longrightarrow> \<box>P"
  shows "\<turnstile> S \<longrightarrow> \<box>($P \<and> P$)"
  using assms using BoxPrime temp_imp_trans by blast

lemma imp_box_afterI:
  assumes "\<turnstile> S \<longrightarrow> \<box>P"
  shows "\<turnstile> S \<longrightarrow> \<box>(P$)"
proof -
  from assms have "\<turnstile> S \<longrightarrow> \<box>($P \<and> P$)" by (intro imp_box_before_afterI)
  also have "\<turnstile> \<box>($P \<and> P$) \<longrightarrow> \<box>(P$)" by auto
  finally show ?thesis .
qed

lemma imp_dmd_conj_invariant:
  assumes "\<turnstile> S \<longrightarrow> \<box>P"
  assumes "\<turnstile> S \<longrightarrow> \<diamond>Q"
  shows "\<turnstile> S \<longrightarrow> \<diamond>(P \<and> Q)"
  using assms BoxDmd_simple by fastforce

lemma invariantI:
  fixes A :: action
  assumes "\<turnstile> S \<longrightarrow> Init P"
  assumes "\<turnstile> S \<longrightarrow> \<box>A"
  assumes "\<And>s t. \<lbrakk> s \<Turnstile> P; (s,t) \<Turnstile> A \<rbrakk>  \<Longrightarrow> t \<Turnstile> P"
  shows "\<turnstile> S \<longrightarrow> \<box>P"
proof invariant
  fix sigma assume sigma: "sigma \<Turnstile> S"
  with assms show "sigma \<Turnstile> Init P" by auto
  show "sigma \<Turnstile> stable P"
  proof (intro Stable actionI temp_impI)
    from sigma assms show "sigma \<Turnstile> \<box>A" by auto
    fix s t assume "(s,t) \<Turnstile> $P \<and> A" with assms show "(s,t) \<Turnstile> P$" by auto
  qed
qed

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |               December 2005               |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_law_DIV
imports CSP_F_law_basic CSP_T_law_DIV
begin

(*****************************************************************

         1. DIV |[X]| DIV
         2. DIV |[X]| P
         3. P |[X]| DIV
         4. DIV -- X
         5. DIV [[r]]
         6. DIV ;; P
         7. P ;; DIV
         8. DIV |. n

 *****************************************************************)

(*********************************************************
                       DIV |[X]| DIV
 *********************************************************)

lemma cspF_DIV_Parallel:
   "DIV |[X]| DIV =F[M1,M2] DIV"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_DIV_Parallel)
apply (rule order_antisym)
apply (rule, simp add: in_failures)+
done

(*********************************************************
                       DIV |[X]| P
 *********************************************************)

lemma cspF_DIV_Parallel_step_l:
   "DIV |[X]| (? :Y -> Qf) =F[M,M] (? x:(Y-X) -> (DIV |[X]| Qf x)) [+] DIV"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_DIV_Parallel_step_l)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_failures)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
 apply (elim conjE exE disjE)
 apply (simp_all add: in_traces)
done

lemma cspF_DIV_Parallel_step_r:
   "(? :Y -> Qf) |[X]| DIV =F[M,M] (? x:(Y-X) -> (Qf x |[X]| DIV)) [+] DIV"
apply (rule cspF_rw_left)
apply (rule cspF_commut)
apply (rule cspF_rw_right)
apply (rule cspF_decompo)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_commut)
apply (rule cspF_reflex)
apply (rule cspF_DIV_Parallel_step_l)
done

lemmas cspF_DIV_Parallel_step =
       cspF_DIV_Parallel_step_l cspF_DIV_Parallel_step_r

(*********************************************************
                      DIV and Parallel
 *********************************************************)

lemma cspF_DIV_Parallel_Ext_choice_DIV_l:
  "(P [+] DIV) |[X]| DIV =F[M,M] (P |[X]| DIV)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_DIV_Parallel_Ext_choice_DIV_l)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_failures)

(* <= *)
 apply (rule, simp add: in_failures)
done

lemma cspF_DIV_Parallel_Ext_choice_DIV_r:
  "DIV |[X]| (P [+] DIV) =F[M,M] (DIV |[X]| P)"
apply (rule cspF_rw_left)
apply (rule cspF_commut)
apply (rule cspF_rw_left)
apply (rule cspF_DIV_Parallel_Ext_choice_DIV_l)
apply (rule cspF_commut)
done

lemmas cspF_DIV_Parallel_Ext_choice_DIV =
       cspF_DIV_Parallel_Ext_choice_DIV_l
       cspF_DIV_Parallel_Ext_choice_DIV_r

(*********************************************************
                      DIV -- X
 *********************************************************)

lemma cspF_DIV_Hiding_Id:
   "DIV -- X =F[M1,M2] DIV"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_DIV_Hiding_Id)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_failures)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
done

(*** div-hide-step ***)

lemma cspF_DIV_Hiding_step:
  "((? :Y -> Pf) [+] DIV) -- X =F[M,M]
   (((? x:(Y-X) -> (Pf x -- X)) [+] DIV) |~| (! x:(Y Int X) .. (Pf x -- X)))"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_DIV_Hiding_step)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_failures)
 apply (elim conjE exE disjE)
 apply (simp_all)
 apply (simp_all add: in_traces)

  apply (case_tac "a : X")
  apply (simp)
  apply (blast)
  apply (force)

(* <= *)
 apply (rule)
  apply (simp add: in_failures)
  apply (elim conjE exE bexE disjE)
  apply (simp_all)

   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (simp)

   apply (simp add: in_traces)

   apply (rule_tac x="<>" in exI)
   apply (simp add: Evset_def)
   apply (fast)

   apply (rule_tac x="<Ev a> ^^^ sa" in exI)
   apply (simp)
done

(*********************************************************
                      DIV [[r]]
 *********************************************************)

lemma cspF_DIV_Renaming_Id:
   "DIV [[r]] =F[M1,M2] DIV"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_DIV_Renaming_Id)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_failures)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
done

(*********************************************************
                       DIV ;; P
 *********************************************************)

lemma cspF_DIV_Seq_compo: "DIV ;; P =F[M1,M2] DIV"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_DIV_Seq_compo)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_failures)
 apply (elim conjE exE)
 apply (simp add: in_traces)

(* <= *)
 apply (rule, simp add: in_failures)
done

(*********************************************************
               DIV and Sequential composition
 *********************************************************)

lemma cspF_DIV_Seq_compo_step:
  "((? :X -> Pf) [> DIV) ;; Q =F[M,M] (? x:X -> (Pf x ;; Q)) [> DIV"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_DIV_Seq_compo_step)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_failures in_traces)
 apply (elim conjE exE disjE)
 apply (simp_all)

 apply (insert trace_nil_or_Tick_or_Ev)
 apply (drule_tac x="sa" in spec)

 apply (elim disjE conjE exE)
  apply (simp_all)
  apply (simp add: appt_assoc)
  apply (rule disjI2)
  apply (rule_tac x="sc" in exI)
  apply (rule_tac x="t" in exI)
  apply (simp)

(* <= *)
 apply (rule, simp add: in_failures in_traces)
 apply (elim conjE exE disjE)
 apply (simp_all)

  apply (rule disjI2)
  apply (rule_tac x="<Ev a> ^^^ sb" in exI)
  apply (rule_tac x="t" in exI)
  apply (simp add: appt_assoc)
done

(*********************************************************
                      DIV |. n
 *********************************************************)

lemma cspF_DIV_Depth_rest:
   "DIV |. n =F[M1,M2] DIV"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_DIV_Depth_rest)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_failures)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
done

(*********************************************************
                      cspF_DIV
 *********************************************************)

lemmas cspF_DIV =
       cspF_DIV_Parallel
       cspF_DIV_Parallel_step
       cspF_DIV_Parallel_Ext_choice_DIV
       cspF_DIV_Hiding_Id
       cspF_DIV_Hiding_step
       cspF_DIV_Renaming_Id
       cspF_DIV_Seq_compo
       cspF_DIV_Seq_compo_step
       cspF_DIV_Depth_rest

(*********************************************************
                       P [+] DIV
 *********************************************************)

lemma cspF_Ext_choice_DIV_resolve: "P [+] DIV =F[M,M] P [> DIV"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Ext_choice_DIV_resolve)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_failures)
 apply (simp add: in_traces)
 apply (force)

(* <= *)
 apply (rule, simp add: in_traces in_failures)
 apply (force)
done

end


(*
  File:    Linear_Recurrences_Misc.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Miscellaneous material required for linear recurrences\<close>
theory Linear_Recurrences_Misc
imports
  Complex_Main
  "HOL-Computational_Algebra.Computational_Algebra"
  "HOL-Computational_Algebra.Polynomial_Factorial"
begin

fun zip_with where
  "zip_with f (x#xs) (y#ys) = f x y # zip_with f xs ys"
| "zip_with f _ _ = []"

lemma length_zip_with [simp]: "length (zip_with f xs ys) = min (length xs) (length ys)"
  by (induction f xs ys rule: zip_with.induct) simp_all

lemma zip_with_altdef: "zip_with f xs ys = map (\<lambda>(x,y). f x y) (zip xs ys)"
  by (induction f xs ys rule: zip_with.induct) simp_all

lemma zip_with_nth [simp]:
  "n < length xs \<Longrightarrow> n < length ys \<Longrightarrow> zip_with f xs ys ! n = f (xs!n) (ys!n)"
  by (simp add: zip_with_altdef)

lemma take_zip_with: "take n (zip_with f xs ys) = zip_with f (take n xs) (take n ys)"
proof (induction f xs ys arbitrary: n rule: zip_with.induct)
  case (1 f x xs y ys n)
  thus ?case by (cases n) simp_all
qed simp_all

lemma drop_zip_with: "drop n (zip_with f xs ys) = zip_with f (drop n xs) (drop n ys)"
proof (induction f xs ys arbitrary: n rule: zip_with.induct)
  case (1 f x xs y ys n)
  thus ?case by (cases n) simp_all
qed simp_all

lemma map_zip_with: "map f (zip_with g xs ys) = zip_with (\<lambda>x y. f (g x y)) xs ys"
  by (induction g xs ys rule: zip_with.induct) simp_all

lemma zip_with_map: "zip_with f (map g xs) (map h ys) = zip_with (\<lambda>x y. f (g x) (h y)) xs ys"
  by (induction "\<lambda>x y. f (g x) (h y)" xs ys rule: zip_with.induct) simp_all

lemma zip_with_map_left: "zip_with f (map g xs) ys = zip_with (\<lambda>x y. f (g x) y) xs ys"
  using zip_with_map[of f g xs "\<lambda>x. x" ys] by simp

lemma zip_with_map_right: "zip_with f xs (map g ys) = zip_with (\<lambda>x y. f x (g y)) xs ys"
  using zip_with_map[of f "\<lambda>x. x" xs g ys] by simp

lemma zip_with_swap: "zip_with (\<lambda>x y. f y x) xs ys = zip_with f ys xs"
  by (induction f ys xs rule: zip_with.induct) simp_all

lemma set_zip_with: "set (zip_with f xs ys) = (\<lambda>(x,y). f x y) ` set (zip xs ys)"
  by (induction f xs ys rule: zip_with.induct) simp_all

lemma zip_with_Pair: "zip_with Pair (xs :: 'a list) (ys :: 'b list) = zip xs ys"
  by (induction "Pair :: 'a \<Rightarrow> 'b \<Rightarrow> _" xs ys rule: zip_with.induct) simp_all

lemma zip_with_altdef':
    "zip_with f xs ys = [f (xs!i) (ys!i). i \<leftarrow> [0..<min (length xs) (length ys)]]"
  by (induction f xs ys rule: zip_with.induct) (simp_all add: map_upt_Suc del: upt_Suc)

lemma zip_altdef: "zip xs ys = [(xs!i, ys!i). i \<leftarrow> [0..<min (length xs) (length ys)]]"
  by (simp add: zip_with_Pair [symmetric] zip_with_altdef')

lemma card_poly_roots_bound:
  fixes p :: "'a::{comm_ring_1,ring_no_zero_divisors} poly"
  assumes "p \<noteq> 0"
  shows   "card {x. poly p x = 0} \<le> degree p"
using assms
proof (induction "degree p" arbitrary: p rule: less_induct)
  case (less p)
  show ?case
  proof (cases "\<exists>x. poly p x = 0")
    case False
    hence "{x. poly p x = 0} = {}" by blast
    thus ?thesis by simp
  next
    case True
    then obtain x where x: "poly p x = 0" by blast
    hence "[:-x, 1:] dvd p" by (subst (asm) poly_eq_0_iff_dvd)
    then obtain q where q: "p = [:-x, 1:] * q" by (auto simp: dvd_def)
    with \<open>p \<noteq> 0\<close> have [simp]: "q \<noteq> 0" by auto
    have deg: "degree p = Suc (degree q)"
      by (subst q, subst degree_mult_eq) auto
    have "card {x. poly p x = 0} \<le> card (insert x {x. poly q x = 0})"
      by (intro card_mono) (auto intro: poly_roots_finite simp: q)
    also have "\<dots> \<le> Suc (card {x. poly q x = 0})"
      by (rule card_insert_le_m1) auto
    also from deg have  "card {x. poly q x = 0} \<le> degree q"
      using \<open>p \<noteq> 0\<close> and q by (intro less) auto
    also have "Suc \<dots> = degree p" by (simp add: deg)
    finally show ?thesis by - simp_all
  qed
qed

lemma poly_eqI_degree:
  fixes p q :: "'a :: {comm_ring_1, ring_no_zero_divisors} poly"
  assumes "\<And>x. x \<in> A \<Longrightarrow> poly p x = poly q x"
  assumes "card A > degree p" "card A > degree q"
  shows   "p = q"
proof (rule ccontr)
  assume neq: "p \<noteq> q"
  have "degree (p - q) \<le> max (degree p) (degree q)"
    by (rule degree_diff_le_max)
  also from assms have "\<dots> < card A" by linarith
  also have "\<dots> \<le> card {x. poly (p - q) x = 0}"
    using neq and assms by (intro card_mono poly_roots_finite) auto
  finally have "degree (p - q) < card {x. poly (p - q) x = 0}" .
  moreover have "degree (p - q) \<ge> card {x. poly (p - q) x = 0}"
    using neq by (intro card_poly_roots_bound) auto
  ultimately show False by linarith
qed

lemma poly_root_order_induct [case_names 0 no_roots root]:
  fixes p :: "'a :: idom poly"
  assumes "P 0" "\<And>p. (\<And>x. poly p x \<noteq> 0) \<Longrightarrow> P p"
          "\<And>p x n. n > 0 \<Longrightarrow> poly p x \<noteq> 0 \<Longrightarrow> P p \<Longrightarrow> P ([:-x, 1:] ^ n * p)"
  shows   "P p"
proof (induction "degree p" arbitrary: p rule: less_induct)
  case (less p)
  consider "p = 0" | "p \<noteq> 0" "\<exists>x. poly p x = 0" | "\<And>x. poly p x \<noteq> 0" by blast
  thus ?case
  proof cases
    case 3
    with assms(2)[of p] show ?thesis by simp
  next
    case 2
    then obtain x where x: "poly p x = 0" by auto
    have "[:-x, 1:] ^ order x p dvd p" by (intro order_1)
    then obtain q where q: "p = [:-x, 1:] ^ order x p * q" by (auto simp: dvd_def)
    with 2 have [simp]: "q \<noteq> 0" by auto
    have order_pos: "order x p > 0"
      using \<open>p \<noteq> 0\<close> and x by (auto simp: order_root)
    have "order x p = order x p + order x q"
      by (subst q, subst order_mult) (auto simp: order_power_n_n)
    hence [simp]: "order x q = 0" by simp
    have deg: "degree p = order x p + degree q"
      by (subst q, subst degree_mult_eq) (auto simp: degree_power_eq)
    with order_pos have "degree q < degree p" by simp
    hence "P q" by (rule less)
    with order_pos have "P ([:-x, 1:] ^ order x p * q)"
      by (intro assms(3)) (auto simp: order_root)
    with q show ?thesis by simp
  qed (simp_all add: assms(1))
qed

lemma complex_poly_decompose:
  "smult (lead_coeff p) (\<Prod>z|poly p z = 0. [:-z, 1:] ^ order z p) = (p :: complex poly)"
proof (induction p rule: poly_root_order_induct)
  case (no_roots p)
  show ?case
  proof (cases "degree p = 0")
    case False
    hence "\<not>constant (poly p)" by (subst constant_degree)
    with fundamental_theorem_of_algebra and no_roots show ?thesis by blast
  qed (auto elim!: degree_eq_zeroE)
next
  case (root p x n)
  from root have *: "{z. poly ([:- x, 1:] ^ n * p) z = 0} = insert x {z. poly p z = 0}"
    by auto
  have "smult (lead_coeff ([:-x, 1:] ^ n * p))
           (\<Prod>z|poly ([:-x,1:] ^ n * p) z = 0. [:-z, 1:] ^ order z ([:- x, 1:] ^ n * p)) =
        [:- x, 1:] ^ order x ([:- x, 1:] ^ n * p) *
          smult (lead_coeff p) (\<Prod>z\<in>{z. poly p z = 0}. [:- z, 1:] ^ order z ([:- x, 1:] ^ n * p))"
    by (subst *, subst prod.insert)
       (insert root, auto intro: poly_roots_finite simp: mult_ac lead_coeff_mult lead_coeff_power)
  also have "order x ([:- x, 1:] ^ n * p) = n"
    using root by (subst order_mult) (auto simp: order_power_n_n order_0I)
  also have "(\<Prod>z\<in>{z. poly p z = 0}. [:- z, 1:] ^ order z ([:- x, 1:] ^ n * p)) =
               (\<Prod>z\<in>{z. poly p z = 0}. [:- z, 1:] ^ order z p)"
  proof (intro prod.cong refl, goal_cases)
    case (1 y)
    with root have "order y ([:-x,1:] ^ n) = 0" by (intro order_0I) auto
    thus ?case using root by (subst order_mult) auto
  qed
  also note root.IH
  finally show ?case .
qed simp_all

lemma normalize_field:
  "normalize (x :: 'a :: {normalization_semidom,field}) = (if x = 0 then 0 else 1)"
  by (auto simp: normalize_1_iff dvd_field_iff)

lemma unit_factor_field [simp]:
  "unit_factor (x :: 'a :: {normalization_semidom,field}) = x"
  using unit_factor_mult_normalize[of x] normalize_field[of x]
  by (simp split: if_splits)

lemma coprime_linear_poly:
  fixes c :: "'a :: field_gcd"
  assumes "c \<noteq> c'"
  shows   "coprime [:c,1:] [:c',1:]"
proof -
  have "gcd [:c,1:] [:c',1:] = gcd ([:c,1:] - [:c',1:]) [:c',1:]"
    by (rule gcd_diff1 [symmetric])
  also have "[:c,1:] - [:c',1:] = [:c-c':]" by simp
  also from assms have "gcd \<dots> [:c',1:] = normalize [:c-c':]"
    by (intro gcd_proj1_if_dvd) (auto simp: const_poly_dvd_iff dvd_field_iff)
  also from assms have "\<dots> = 1" by (simp add: normalize_poly_def)
  finally show "coprime [:c,1:] [:c',1:]"
    by (simp add: gcd_eq_1_imp_coprime)
qed

lemma coprime_linear_poly':
  fixes c :: "'a :: field_gcd"
  assumes "c \<noteq> c'" "c \<noteq> 0" "c' \<noteq> 0"
  shows   "coprime [:1,c:] [:1,c':]"
proof -
  have "gcd [:1,c:] [:1,c':] = gcd ([:1,c:] mod [:1,c':]) [:1,c':]"
    by simp
  also have "eucl_rel_poly [:1, c:] [:1, c':] ([:c/c':], [:1-c/c':])"
    using assms by (auto simp add: eucl_rel_poly_iff one_pCons)
  hence "[:1,c:] mod [:1,c':] = [:1 - c / c':]"
    by (rule mod_poly_eq)
  also from assms have "gcd \<dots> [:1,c':] = normalize ([:1 - c / c':])"
    by (intro gcd_proj1_if_dvd) (auto simp: const_poly_dvd_iff dvd_field_iff)
  also from assms have "\<dots> = 1" by (auto simp: normalize_poly_def)
  finally show ?thesis
    by (rule gcd_eq_1_imp_coprime)
qed

end