chapter\<open>Syntactic Preliminaries for the Second Incompleteness Theorem\<close>

theory II_Prelims
imports Pf_Predicates
begin

declare IndP.simps [simp del]

lemma OrdP_ORD_OF [intro]: "H \<turnstile> OrdP (ORD_OF n)"
proof -
  have "{} \<turnstile> OrdP (ORD_OF n)"
    by (induct n) (auto simp: OrdP_SUCC_I)
  thus ?thesis
    by (rule thin0)
qed

lemma VarP_Var [intro]: "H \<turnstile> VarP \<guillemotleft>Var i\<guillemotright>"
  unfolding VarP_def
  by (auto simp: quot_Var OrdP_ORD_OF intro!: OrdP_SUCC_I cut1[OF Zero_In_SUCC])

lemma VarP_neq_IndP: "{t EQ v, VarP v, IndP t} \<turnstile> Fls"
proof -
  obtain m::name where "atom m \<sharp> (t,v)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: VarP_def IndP.simps [of m])
    apply (rule cut_same [of _ "OrdP (Q_Ind (Var m))"])
    apply (blast intro: Sym Trans OrdP_cong [THEN Iff_MP_same])
    by (metis OrdP_HPairE)
qed

lemma Mem_HFun_Sigma_OrdP: "{HPair t u IN f, HFun_Sigma f} \<turnstile> OrdP t"
proof -
  obtain x::name and y::name and z::name and x'::name and y'::name and z'::name
    where "atom z \<sharp> (f,t,u,z',x,y,x',y')"  "atom z' \<sharp> (f,t,u,x,y,x',y')"
       "atom x \<sharp> (f,t,u,y,x',y')"  "atom y \<sharp> (f,t,u,x',y')"
       "atom x' \<sharp> (f,t,u,y')"  "atom y' \<sharp> (f,t,u)"
    by (metis obtain_fresh)
  thus ?thesis
  apply (simp add: HFun_Sigma.simps [of z f z' x y x' y'])
  apply (rule All2_E [where x="HPair t u", THEN rotate2], auto)
  apply (rule All2_E [where x="HPair t u"], auto intro: OrdP_cong [THEN Iff_MP2_same])
  done
qed

section \<open>NotInDom\<close>

nominal_function NotInDom :: "tm \<Rightarrow> tm \<Rightarrow> fm"
  where "atom z \<sharp> (t, r) \<Longrightarrow> NotInDom t r = All z (Neg (HPair t (Var z) IN r))"
by (auto simp: eqvt_def NotInDom_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma NotInDom_fresh_iff [simp]: "a \<sharp> NotInDom t r \<longleftrightarrow> a \<sharp> (t, r)"
proof -
  obtain j::name where "atom j \<sharp> (t,r)"
    by (rule obtain_fresh)
  thus ?thesis
    by auto
qed

lemma subst_fm_NotInDom [simp]: "(NotInDom t r)(i::=x) = NotInDom (subst i x t) (subst i x r)"
proof -
  obtain j::name where "atom j \<sharp> (i,x,t,r)"
    by (rule obtain_fresh)
  thus ?thesis
    by (auto simp: NotInDom.simps [of j])
qed

lemma NotInDom_cong: "H \<turnstile> t EQ t' \<Longrightarrow> H \<turnstile> r EQ r' \<Longrightarrow> H \<turnstile> NotInDom t r IFF NotInDom t' r'"
  by (rule P2_cong) auto

lemma NotInDom_Zero: "H \<turnstile> NotInDom t Zero"
proof -
  obtain z::name where "atom z \<sharp> t"
    by (metis obtain_fresh)
  hence "{} \<turnstile> NotInDom t Zero"
    by (auto simp: fresh_Pair)
  thus ?thesis
    by (rule thin0)
qed

lemma NotInDom_Fls: "{HPair d d' IN r, NotInDom d r} \<turnstile> A"
proof -
  obtain z::name where "atom z \<sharp> (d,r)"
    by (metis obtain_fresh)
  hence "{HPair d d' IN r, NotInDom d r} \<turnstile> Fls"
    by (auto intro!: Ex_I [where x=d'])
  thus ?thesis
    by (metis ExFalso)
qed

lemma NotInDom_Contra: "H \<turnstile> NotInDom d r \<Longrightarrow> H \<turnstile> HPair x y IN r \<Longrightarrow> insert (x EQ d) H \<turnstile> A"
by (rule NotInDom_Fls [THEN cut2, THEN ExFalso])
   (auto intro: thin1 NotInDom_cong [OF Assume Refl, THEN Iff_MP2_same])

section \<open>Restriction of a Sequence to a Domain\<close>

nominal_function RestrictedP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom x \<sharp> (y,f,k,g); atom y \<sharp> (f,k,g)\<rbrakk> \<Longrightarrow>
    RestrictedP f k g =
      g SUBS f AND
      All x (All y (HPair (Var x) (Var y) IN g IFF
                    (Var x) IN k AND HPair (Var x) (Var y) IN f))"
by (auto simp: eqvt_def RestrictedP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma RestrictedP_fresh_iff [simp]: "a \<sharp> RestrictedP f k g \<longleftrightarrow> a \<sharp> f \<and> a \<sharp> k \<and> a \<sharp> g"
proof -
  obtain x::name and y::name where "atom x \<sharp> (y,f,k,g)" "atom y \<sharp> (f,k,g)"
    by (metis obtain_fresh)
  thus ?thesis
    by auto
qed

lemma subst_fm_RestrictedP [simp]:
  "(RestrictedP f k g)(i::=u) = RestrictedP (subst i u f) (subst i u k) (subst i u g)"
proof -
  obtain x::name and y::name  where "atom x \<sharp> (y,f,k,g,i,u)" "atom y \<sharp> (f,k,g,i,u)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: RestrictedP.simps [of x y])
qed

lemma RestrictedP_cong:
  "\<lbrakk>H \<turnstile> f EQ f'; H \<turnstile> k EQ A'; H \<turnstile> g EQ g'\<rbrakk>
   \<Longrightarrow> H \<turnstile> RestrictedP f k g IFF RestrictedP f' A' g'"
  by (rule P3_cong) auto

lemma RestrictedP_Zero: "H \<turnstile> RestrictedP Zero k Zero"
proof -
  obtain x::name and y::name  where "atom x \<sharp> (y,k)" "atom y \<sharp> (k)"
    by (metis obtain_fresh)
  hence "{} \<turnstile> RestrictedP Zero k Zero"
    by (auto simp: RestrictedP.simps [of x y])
  thus ?thesis
    by (rule thin0)
qed

lemma RestrictedP_Mem: "{ RestrictedP s k s', HPair a b IN s, a IN k } \<turnstile> HPair a b IN s'"
proof -
  obtain x::name and y::name where "atom x \<sharp> (y,s,k,s',a,b)" "atom y \<sharp> (s,k,s',a,b)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: RestrictedP.simps [of x y])
    apply (rule All_E [where x=a, THEN rotate2], auto)
    apply (rule All_E [where x=b], auto intro: Iff_E2)
    done
qed

lemma RestrictedP_imp_Subset: "{RestrictedP s k s'} \<turnstile> s' SUBS s"
proof -
  obtain x::name and y::name where "atom x \<sharp> (y,s,k,s')" "atom y \<sharp> (s,k,s')"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: RestrictedP.simps [of x y])
qed

lemma RestrictedP_Mem2:
  "{ RestrictedP s k s', HPair a b IN s' } \<turnstile> HPair a b IN s AND a IN k"
proof -
  obtain x::name and y::name where "atom x \<sharp> (y,s,k,s',a,b)" "atom y \<sharp> (s,k,s',a,b)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: RestrictedP.simps [of x y] intro: Subset_D)
    apply (rule All_E [where x=a, THEN rotate2], auto)
    apply (rule All_E [where x=b], auto intro: Iff_E1)
    done
qed

lemma RestrictedP_Mem_D: "H \<turnstile> RestrictedP s k t \<Longrightarrow> H \<turnstile> a IN t \<Longrightarrow> insert (a IN s) H \<turnstile> A \<Longrightarrow> H \<turnstile> A"
  by (metis RestrictedP_imp_Subset Subset_E cut1)

lemma RestrictedP_Eats:
  "{ RestrictedP s k s', a IN k } \<turnstile> RestrictedP (Eats s (HPair a b)) k (Eats s' (HPair a b))" (*<*)
proof -
  obtain x::name and y::name
  where "atom x \<sharp> (y,s,k,s',a,b)" "atom y \<sharp> (s,k,s',a,b)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: RestrictedP.simps [of x y])
      apply (metis Assume Subset_Eats_I Subset_trans)
     apply (metis Mem_Eats_I2 Refl)
    apply (rule Swap, auto)
         apply (rule All_E [where x="Var x", THEN rotate2], auto)
         apply (rule All_E [where x="Var y"], simp)
         apply (metis Assume Conj_E Iff_E1)
        apply (blast intro: Subset_D)
       apply (blast intro: Mem_cong [THEN Iff_MP2_same])
      apply (metis Assume AssumeH(2) HPair_cong Mem_Eats_I2)
     apply (rule All_E [where x="Var x", THEN rotate3], auto)
     apply (rule All_E [where x="Var y"], simp)
     apply (metis Assume AssumeH(2) Conj_I Iff_E2 Mem_Eats_I1)
    apply (blast intro: Mem_Eats_I2 HPair_cong)
   done
qed (*>*)

lemma exists_RestrictedP:
  assumes s: "atom s \<sharp> (f,k)"
  shows  "H \<turnstile> Ex s (RestrictedP f k (Var s))" (*<*)
proof -
  obtain j::name and x::name and y::name and z::name
    where atoms: "atom j \<sharp> (k,z,s)"  "atom x \<sharp> (j,k,z,s)"  "atom y \<sharp> (x,j,k,z,s)"  "atom z \<sharp> (s,k)"
    by (metis obtain_fresh)
  have "{} \<turnstile> Ex s (RestrictedP (Var z) k (Var s))"
    apply (rule Ind [of j z]) using atoms s
    apply simp_all
    apply (rule Ex_I [where x=Zero], simp add: RestrictedP_Zero)
    apply (rule All_I)+
    apply (auto del: Ex_EH)
    apply (rule thin1)
    apply (rule Ex_E)
    proof (rule Cases [where A="Ex x (Ex y ((Var x) IN k AND Var j EQ HPair (Var x) (Var y)))"], auto)
      show "{Var x IN k, Var j EQ HPair (Var x) (Var y), RestrictedP (Var z) k (Var s)}
            \<turnstile> Ex s (RestrictedP (Eats (Var z) (Var j)) k (Var s))"
        apply (rule Ex_I [where x="Eats (Var s) (HPair (Var x) (Var y))"])
        using atoms s apply auto
        apply (rule RestrictedP_cong [OF _ Refl Refl, THEN Iff_MP2_same])
        apply (blast intro: Eats_cong [OF Refl])
        apply (rule Var_Eq_subst_Iff [THEN rotate2, THEN Iff_MP_same])
        apply (auto intro: RestrictedP_Eats [THEN cut2])
        done
    next
      obtain u::name and v::name
      where uv: "atom u \<sharp> (x,y,z,s,j,k)" "atom v \<sharp> (u,x,y,z,s,j,k)"
        by (metis obtain_fresh)
      show "{Neg (Ex x (Ex y (Var x IN k AND Var j EQ HPair (Var x) (Var y)))),
             RestrictedP (Var z) k (Var s)} \<turnstile>
             Ex s (RestrictedP (Eats (Var z) (Var j)) k (Var s))"
        apply (rule Ex_I [where x="Var s"])
        using uv atoms
        apply (auto simp: RestrictedP.simps [of u v])
         apply (metis Assume Subset_Eats_I Subset_trans)
        apply (rule Swap, auto)
           apply (rule All_E [THEN rotate4, of _ _ "Var u"], auto)
           apply (rule All_E [where x="Var v"], simp)
           apply (metis Assume Conj_E Iff_E1)
          apply (rule Mem_Eats_I1)
          apply (metis Assume AssumeH(3) Subset_D)
         apply (rule All_E [where x="Var u", THEN rotate5], auto)
         apply (rule All_E [where x="Var v"], simp)
         apply (metis Assume AssumeH(2) Conj_I Iff_E2)
        apply (rule ContraProve [THEN rotate3])
       apply (rule Ex_I [where x="Var u"], simp)
       apply (rule Ex_I [where x="Var v"], auto intro: Sym)
       done
    qed
  hence "{} \<turnstile> (Ex s (RestrictedP (Var z) k (Var s)))(z::=f)"
    by (rule Subst) simp
  thus ?thesis using atoms s
    by simp (rule thin0)
qed (*>*)

lemma cut_RestrictedP:
  assumes s: "atom s \<sharp> (f,k,A)" and "\<forall>C \<in> H. atom s \<sharp> C"
  shows  "insert (RestrictedP f k (Var s)) H \<turnstile> A \<Longrightarrow> H \<turnstile> A"
  apply (rule cut_same [OF exists_RestrictedP [of s]])
  using assms apply auto
  done

lemma RestrictedP_NotInDom: "{ RestrictedP s k s', Neg (j IN k) } \<turnstile> NotInDom j s'"
proof -
  obtain x::name and y::name and z::name
  where "atom x \<sharp> (y,s,j,k,s')" "atom y \<sharp> (s,j,k,s')" "atom z \<sharp> (s,j,k,s')"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: RestrictedP.simps [of x y] NotInDom.simps [of z])
    apply (rule All_E [where x=j, THEN rotate3], auto)
    apply (rule All_E, auto intro: Conj_E1 Iff_E1)
    done
qed

declare RestrictedP.simps [simp del]

section \<open>Applications to LstSeqP\<close>

lemma HFun_Sigma_Eats:
  assumes "H \<turnstile> HFun_Sigma r" "H \<turnstile> NotInDom d r" "H \<turnstile> OrdP d"
    shows "H \<turnstile> HFun_Sigma (Eats r (HPair d d'))" (*<*)
proof -
  obtain x::name and y::name and z::name and x'::name and y'::name and z'::name and z''::name
    where "atom z'' \<sharp> (r,d,d',z,z',x,y,x',y')"
      and "atom z \<sharp> (r,d,d',z',x,y,x',y')" and "atom z' \<sharp> (r,d,d',x,y,x',y')"
      and "atom x \<sharp> (r,d,d',y,x',y')" and "atom y \<sharp> (r,d,d',x',y')"
      and "atom x' \<sharp> (r,d,d',y')" and "atom y' \<sharp> (r,d,d')"
    by (metis obtain_fresh)
  hence "{ HFun_Sigma r, NotInDom d r, OrdP d } \<turnstile> HFun_Sigma (Eats r (HPair d d'))"
    apply (auto simp: HFun_Sigma.simps [of z _ z' x y x' y'])
      \<comment> \<open>case 1\<close>
       apply (rule Ex_I [where x = "Var z"], simp)
       apply (rule Neg_Imp_I, blast)
      apply (rule All_E [where x = "Var z'"], auto)
      \<comment> \<open>case 2\<close>
      apply (rule Ex_I [where x = "Var z"], simp)
      apply (rule Neg_Imp_I, blast)
      apply (rule All_E [where x = "Var z"], simp)
      apply (rule Imp_E, auto del: Disj_EH)
      apply (rule thin1)
      apply (rule thin1)
      apply (rule Ex_I [where x = "Var x"], simp)
      apply (rule Ex_I [where x = "Var y"], simp)
      apply (rule Ex_I [where x = d], simp)
      apply (rule Ex_I [where x = d'], auto)
      apply (blast intro: Disj_I1 OrdNotEqP_I NotInDom_Contra Mem_cong [THEN Iff_MP_same])
    \<comment> \<open>case 3\<close>
    apply (rule Ex_I [where x = "Var z'"])
    apply (subst subst_fm_Ex_with_renaming [where i'=z''] | subst subst_fm.simps)+
    apply (auto simp add: flip_fresh_fresh)
    apply (rule Ex_I [where x = "Var z'", THEN Swap], simp)
    apply (rule Neg_I)
    apply (rule Imp_E, auto del: Disj_EH)
    apply (rule thin1)
    apply (rule thin1)
    apply (rule Ex_I [where x = d], simp)
    apply (rule Ex_I [where x = d'], simp)
    apply (rule Ex_I [where x = "Var x"], simp)
    apply (rule Ex_I [where x = "Var y"], auto)
    apply (blast intro: Disj_I1 Sym_L OrdNotEqP_I NotInDom_Contra Mem_cong [THEN Iff_MP_same])
    \<comment> \<open>case 4\<close>
    apply (rule rotate2 [OF Swap])
    apply (rule Ex_I [where x = d], auto)
    apply (rule Ex_I [where x = d'], auto)
    apply (rule Ex_I [where x = d], auto)
    apply (rule Ex_I [where x = d'], auto intro: Disj_I2)
    done
  thus ?thesis using assms
    by (rule cut3)
qed (*>*)

lemma HFun_Sigma_single [iff]: "H \<turnstile> OrdP d \<Longrightarrow> H \<turnstile> HFun_Sigma (Eats Zero (HPair d d'))"
  by (metis HFun_Sigma_Eats HFun_Sigma_Zero NotInDom_Zero)

lemma LstSeqP_single [iff]: "H \<turnstile> LstSeqP (Eats Zero (HPair Zero x)) Zero x"
  by (auto simp: LstSeqP.simps intro!: OrdP_SUCC_I HDomain_Incl_Eats_I Mem_Eats_I2)

lemma NotInDom_LstSeqP_Eats:
  "{ NotInDom (SUCC k) s, LstSeqP s k y } \<turnstile> LstSeqP (Eats s (HPair (SUCC k) z)) (SUCC k) z"
by (auto simp: LstSeqP.simps intro: HDomain_Incl_Eats_I Mem_Eats_I2 OrdP_SUCC_I HFun_Sigma_Eats)

lemma RestrictedP_HDomain_Incl: "{HDomain_Incl s k, RestrictedP s k s'} \<turnstile> HDomain_Incl s' k"
proof -
  obtain u::name and v::name and x::name and y::name and z::name
    where "atom u \<sharp> (v,s,k,s')" "atom v \<sharp> (s,k,s')"
          "atom x \<sharp> (s,k,s',u,v,y,z)" "atom y \<sharp> (s,k,s',u,v,z)" "atom z \<sharp> (s,k,s',u,v)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: HDomain_Incl.simps [of x _ _ y z])
    apply (rule Ex_I [where x="Var x"], auto)
    apply (rule Ex_I [where x="Var y"], auto)
    apply (rule Ex_I [where x="Var z"], simp)
    apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same, THEN rotate2])
    apply (auto simp: RestrictedP.simps [of u v])
    apply (rule All_E [where x="Var x", THEN rotate2], auto)
    apply (rule All_E [where x="Var y"])
    apply (auto intro: Iff_E ContraProve Mem_cong [THEN Iff_MP_same])
    done
qed

lemma RestrictedP_HFun_Sigma: "{HFun_Sigma s, RestrictedP s k s'} \<turnstile> HFun_Sigma s'"
  by (metis Assume RestrictedP_imp_Subset Subset_HFun_Sigma rcut2)

lemma RestrictedP_LstSeqP:
  "{ RestrictedP s (SUCC k) s', LstSeqP s k y } \<turnstile> LstSeqP s' k y"
  by (auto simp: LstSeqP.simps
           intro: Mem_Neg_refl cut2 [OF RestrictedP_HDomain_Incl]
                               cut2 [OF RestrictedP_HFun_Sigma] cut3 [OF RestrictedP_Mem])

lemma RestrictedP_LstSeqP_Eats:
  "{ RestrictedP s (SUCC k) s', LstSeqP s k y }
   \<turnstile> LstSeqP (Eats s' (HPair (SUCC k) z)) (SUCC k) z"
by (blast intro: Mem_Neg_refl cut2 [OF NotInDom_LstSeqP_Eats]
                              cut2 [OF RestrictedP_NotInDom] cut2 [OF RestrictedP_LstSeqP])

section\<open>Ordinal Addition\<close>

subsection\<open>Predicate form, defined on sequences\<close>

nominal_function SeqHaddP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (sl,s,k,j); atom sl \<sharp> (s,j)\<rbrakk> \<Longrightarrow>
    SeqHaddP s j k y = LstSeqP s k y AND
          HPair Zero j IN s AND
          All2 l k (Ex sl (HPair (Var l) (Var sl) IN s AND
                           HPair (SUCC (Var l)) (SUCC (Var sl)) IN s))"
by (auto simp: eqvt_def SeqHaddP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma SeqHaddP_fresh_iff [simp]: "a \<sharp> SeqHaddP s j k y \<longleftrightarrow> a \<sharp> s \<and> a \<sharp> j \<and> a \<sharp> k \<and> a \<sharp> y"
proof -
  obtain l::name and sl::name where "atom l \<sharp> (sl,s,k,j)" "atom sl \<sharp> (s,j)"
    by (metis obtain_fresh)
  thus ?thesis
    by force
qed

lemma SeqHaddP_subst [simp]:
  "(SeqHaddP s j k y)(i::=t) = SeqHaddP (subst i t s) (subst i t j) (subst i t k) (subst i t y)"
proof -
  obtain l::name and sl::name where "atom l \<sharp> (s,k,j,sl,t,i)" "atom sl \<sharp> (s,k,j,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqHaddP.simps [where l=l and sl=sl])
qed

declare SeqHaddP.simps [simp del]

nominal_function HaddP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (x,y,z)\<rbrakk> \<Longrightarrow>
    HaddP x y z = Ex s (SeqHaddP (Var s) x y z)"
by (auto simp: eqvt_def HaddP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma HaddP_fresh_iff [simp]: "a \<sharp> HaddP x y z \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> y \<and> a \<sharp> z"
proof -
  obtain s::name where "atom s \<sharp> (x,y,z)"
    by (metis obtain_fresh)
  thus ?thesis
    by force
qed

lemma HaddP_subst [simp]: "(HaddP x y z)(i::=t) = HaddP (subst i t x) (subst i t y) (subst i t z)"
proof -
  obtain s::name where "atom s \<sharp> (x,y,z,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: HaddP.simps [of s])
qed

lemma HaddP_cong: "\<lbrakk>H \<turnstile> t EQ t'; H \<turnstile> u EQ u'; H \<turnstile> v EQ v'\<rbrakk> \<Longrightarrow> H \<turnstile> HaddP t u v IFF HaddP t' u' v'"
  by (rule P3_cong) auto

declare HaddP.simps [simp del]

lemma HaddP_Zero2: "H \<turnstile> HaddP x Zero x"
proof -
  obtain s::name and l::name and sl::name where "atom l \<sharp> (sl,s,x)" "atom sl \<sharp> (s,x)" "atom s \<sharp> x"
    by (metis obtain_fresh)
  hence "{} \<turnstile> HaddP x Zero x"
    by (auto simp: HaddP.simps [of s] SeqHaddP.simps [of l sl]
          intro!: Mem_Eats_I2 Ex_I [where x="Eats Zero (HPair Zero x)"])
  thus ?thesis
    by (rule thin0)
qed

lemma HaddP_imp_OrdP: "{HaddP x y z} \<turnstile> OrdP y"
proof -
  obtain s::name and l::name and sl::name
    where "atom l \<sharp> (sl,s,x,y,z)" "atom sl \<sharp> (s,x,y,z)" "atom s \<sharp> (x,y,z)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: HaddP.simps [of s] SeqHaddP.simps [of l sl] LstSeqP.simps)
qed

lemma HaddP_SUCC2: "{HaddP x y z} \<turnstile> HaddP x (SUCC y) (SUCC z)" (*<*)
proof -
  obtain s::name and s'::name and l::name and sl::name
    where "atom s' \<sharp> (l,sl,s,x,y,z)" "atom l \<sharp> (sl,s,x,y,z)" "atom sl \<sharp> (s,x,y,z)" "atom s \<sharp> (x,y,z)"
    by (metis obtain_fresh)
  hence "{HaddP x y z, OrdP y} \<turnstile> HaddP x (SUCC y) (SUCC z)"
    apply (auto simp: HaddP.simps [of s] SeqHaddP.simps [of l sl])
    apply (rule cut_RestrictedP [of s' "Var s" "SUCC y"], auto)
    apply (rule Ex_I [where x="Eats (Var s') (HPair (SUCC y) (SUCC z))"])
       apply (auto intro!: Mem_SUCC_EH)
       apply (metis rotate2 RestrictedP_LstSeqP_Eats rotate3 thin1)
      apply (blast intro: Mem_Eats_I1 cut3 [OF RestrictedP_Mem] cut1 [OF Zero_In_SUCC])
     apply (rule Ex_I [where x="Var l"], auto)
     apply (rule Ex_I [where x="Var sl"], auto)
     apply (blast intro: Mem_Eats_I1 cut3 [OF RestrictedP_Mem] Mem_SUCC_I1)
    apply (blast intro: Mem_Eats_I1 cut3 [OF RestrictedP_Mem] OrdP_IN_SUCC)
   apply (rule ContraProve [THEN rotate2])
   apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same], simp add: LstSeqP.simps)
   apply (rule Ex_I [where x=z])
   apply (force intro: Mem_Eats_I1 Mem_Eats_I2 cut3 [OF RestrictedP_Mem] Mem_SUCC_I2)
   done
 thus ?thesis
   by (metis Assume HaddP_imp_OrdP cut2)
qed (*>*)

subsection\<open>Proving that these relations are functions\<close>

lemma SeqHaddP_Zero_E: "{SeqHaddP s w Zero z} \<turnstile> w EQ z"
proof -
  obtain l::name and sl::name where "atom l \<sharp> (s,w,z,sl)" "atom sl \<sharp> (s,w)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqHaddP.simps [of l sl] LstSeqP.simps intro: HFun_Sigma_E)
qed

lemma SeqHaddP_SUCC_lemma:
  assumes y': "atom y' \<sharp> (s,j,k,y)"
  shows "{SeqHaddP s j (SUCC k) y} \<turnstile> Ex y' (SeqHaddP s j k (Var y') AND y EQ SUCC (Var y'))"
proof -
  obtain l::name and sl::name  where "atom l \<sharp> (s,j,k,y,y',sl)" "atom sl \<sharp> (s,j,k,y,y')"
    by (metis obtain_fresh)
  thus ?thesis using y'
    apply (auto simp: SeqHaddP.simps [where s=s and l=l and sl=sl])
    apply (rule All2_SUCC_E' [where t=k, THEN rotate2], auto)
    apply (auto intro!: Ex_I [where x="Var sl"])
    apply (blast intro: LstSeqP_SUCC) \<comment> \<open>showing @{term"SeqHaddP s j k (Var sl)"}\<close>
    apply (blast intro: LstSeqP_EQ)
    done
qed

lemma SeqHaddP_SUCC:
  assumes "H \<turnstile> SeqHaddP s j (SUCC k) y"  "atom y' \<sharp> (s,j,k,y)"
  shows "H \<turnstile> Ex y' (SeqHaddP s j k (Var y') AND y EQ SUCC (Var y'))"
  by (metis SeqHaddP_SUCC_lemma [THEN cut1] assms)

lemma SeqHaddP_unique: "{OrdP x, SeqHaddP s w x y, SeqHaddP s' w x y'} \<turnstile> y' EQ y" (*<*)
proof -
  obtain i::name and j::name and j'::name and k::name and sl::name and sl'::name
     and l::name and ji::name and ji'::name
   where ij: "atom i \<sharp> (s,s',w,y,y')" "atom j \<sharp> (s,s',w,i,x,y,y')" "atom j' \<sharp> (s,s',w,i,j,x,y,y')"
     and atoms: "atom k \<sharp> (s,s',w,i,j,j')" "atom sl \<sharp> (s,s',w,i,j,j',k)" "atom sl' \<sharp> (s,s',w,i,j,j',k,sl)"
                "atom ji \<sharp> (s,s',w,i,j,j',k,sl,sl')"  "atom ji' \<sharp> (s,s',w,i,j,j',k,sl,sl',ji)"
    by (metis obtain_fresh)
  have "{OrdP (Var i)}
        \<turnstile> All j (All j' (SeqHaddP s w (Var i) (Var j) IMP (SeqHaddP s' w (Var i) (Var j') IMP Var j' EQ Var j)))"
    apply (rule OrdInd2H)
    using ij atoms apply auto
    apply (metis SeqHaddP_Zero_E [THEN cut1] Assume AssumeH(2) Sym Trans)
    \<comment> \<open>SUCC case\<close>
    apply (rule cut_same [OF SeqHaddP_SUCC [where y' = ji and s=s]], auto)
    apply (rule cut_same [OF SeqHaddP_SUCC [where y' = ji' and s=s']], auto)
    apply (rule Ex_I [where x = "Var ji"], auto)
    apply (rule All_E [where x = "Var ji'"], auto)
    apply (blast intro: Trans [OF Hyp] Sym intro!: SUCC_cong)
    done
  hence "{OrdP (Var i)}
         \<turnstile> (All j' (SeqHaddP s w (Var i) (Var j) IMP (SeqHaddP s' w (Var i) (Var j') IMP Var j' EQ Var j)))(j::=y)"
    by (metis All_D)
  hence "{OrdP (Var i)}
         \<turnstile> All j' (SeqHaddP s w (Var i) y IMP (SeqHaddP s' w (Var i) (Var j') IMP Var j' EQ y))"
    using ij by simp
  hence "{OrdP (Var i)}
         \<turnstile> (SeqHaddP s w (Var i) y IMP (SeqHaddP s' w (Var i) (Var j') IMP Var j' EQ y))(j'::=y')"
    by (metis All_D)
  hence "{OrdP (Var i)} \<turnstile> SeqHaddP s w (Var i) y IMP (SeqHaddP s' w (Var i) y' IMP y' EQ y)"
    using ij by simp
  hence "{} \<turnstile> (OrdP (Var i) IMP SeqHaddP s w (Var i) y IMP (SeqHaddP s' w (Var i) y' IMP y' EQ y))(i::=x)"
    by (metis Imp_I Subst emptyE)
  thus ?thesis
    using ij by simp (metis DisjAssoc2 Disj_commute anti_deduction)
qed (*>*)

lemma HaddP_unique: "{HaddP w x y, HaddP w x y'} \<turnstile> y' EQ y"
proof -
  obtain s::name and s'::name  where "atom s \<sharp> (w,x,y,y')" "atom s' \<sharp> (w,x,y,y',s)"
    by (metis obtain_fresh)
  hence "{OrdP x, HaddP w x y, HaddP w x y'} \<turnstile> y' EQ y"
    by (auto simp: HaddP.simps [of s _ _ y]  HaddP.simps [of s' _ _ y']
             intro: SeqHaddP_unique [THEN cut3])
  thus ?thesis
    by (metis HaddP_imp_OrdP cut_same thin1)
qed

lemma HaddP_Zero1: assumes "H \<turnstile> OrdP x" shows "H \<turnstile> HaddP Zero x x"
proof -
  fix k::name
  have "{ OrdP (Var k) } \<turnstile> HaddP Zero (Var k) (Var k)"
    by (rule OrdInd2H [where i=k]) (auto intro: HaddP_Zero2 HaddP_SUCC2 [THEN cut1])
  hence "{} \<turnstile> OrdP (Var k) IMP HaddP Zero (Var k) (Var k)"
    by (metis Imp_I)
  hence "{} \<turnstile> (OrdP (Var k) IMP HaddP Zero (Var k) (Var k))(k::=x)"
    by (rule Subst) auto
  hence "{} \<turnstile> OrdP x IMP HaddP Zero x x"
    by simp
  thus ?thesis using assms
    by (metis MP_same thin0)
qed

lemma HaddP_Zero_D1: "insert (HaddP Zero x y) H \<turnstile> x EQ y"
  by (metis Assume HaddP_imp_OrdP HaddP_Zero1 HaddP_unique [THEN cut2] rcut1)

lemma HaddP_Zero_D2: "insert (HaddP x Zero y) H \<turnstile> x EQ y"
  by (metis Assume HaddP_Zero2 HaddP_unique [THEN cut2])

lemma HaddP_SUCC_Ex2:
  assumes "H \<turnstile> HaddP x (SUCC y) z" "atom z' \<sharp> (x,y,z)"
    shows "H \<turnstile> Ex z' (HaddP x y (Var z') AND z EQ SUCC (Var z'))"
proof -
  obtain s::name and s'::name  where "atom s \<sharp> (x,y,z,z')" "atom s' \<sharp> (x,y,z,z',s)"
    by (metis obtain_fresh)
  hence "{ HaddP x (SUCC y) z } \<turnstile> Ex z' (HaddP x y (Var z') AND z EQ SUCC (Var z'))"
    using assms
    apply (auto simp: HaddP.simps [of s _ _ ]  HaddP.simps [of s' _ _ ])
    apply (rule cut_same [OF SeqHaddP_SUCC_lemma [of z']], auto)
    apply (rule Ex_I, auto)+
    done
  thus ?thesis
    by (metis assms(1) cut1)
qed

lemma HaddP_SUCC1: "{ HaddP x y z } \<turnstile> HaddP (SUCC x) y (SUCC z)" (*<*)
proof -
  obtain i::name and j::name and z'::name
   where atoms: "atom i \<sharp> (x,y,z)"  "atom j \<sharp> (i,x,y,z)"  "atom z' \<sharp> (x,i,j)"
    by (metis obtain_fresh)
  have "{OrdP (Var i)} \<turnstile> All j (HaddP x (Var i) (Var j) IMP HaddP (SUCC x) (Var i) (SUCC (Var j)))"
       (is "_ \<turnstile> ?scheme")
    proof (rule OrdInd2H)
      show "{} \<turnstile> ?scheme(i::=Zero)"
        using atoms apply auto
        apply (rule cut_same [OF HaddP_Zero_D2])
        apply (rule Var_Eq_subst_Iff [THEN Sym_L, THEN Iff_MP_same], auto intro: HaddP_Zero2)
        done
    next
      show "{} \<turnstile> All i (OrdP (Var i) IMP ?scheme IMP ?scheme(i::=SUCC (Var i)))"
        using atoms
        apply auto
        apply (rule cut_same [OF HaddP_SUCC_Ex2 [where z'=z']], auto)
        apply (rule Ex_I [where x="Var z'"], auto)
        apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same, THEN rotate3], simp)
        by (metis Assume HaddP_SUCC2 cut1 thin1)
    qed
  hence "{OrdP (Var i)} \<turnstile> (HaddP x (Var i) (Var j) IMP HaddP (SUCC x) (Var i) (SUCC (Var j)))(j::=z)"
    by (rule All_D)
  hence "{OrdP (Var i)} \<turnstile> HaddP x (Var i) z IMP HaddP (SUCC x) (Var i) (SUCC z)"
    using atoms by auto
  hence "{} \<turnstile> HaddP x (Var i) z IMP HaddP (SUCC x) (Var i) (SUCC z)"
    by (metis HaddP_imp_OrdP Imp_cut)
  hence "{} \<turnstile> (HaddP x (Var i) z IMP HaddP (SUCC x) (Var i) (SUCC z))(i::=y)"
    using atoms by (force intro!: Subst)
  thus ?thesis
    using atoms by simp (metis anti_deduction)
qed (*>*)

lemma HaddP_commute: "{HaddP x y z, OrdP x} \<turnstile> HaddP y x z" (*<*)
proof -
  obtain i::name and j::name and z'::name
   where atoms: "atom i \<sharp> (x,y,z)"  "atom j \<sharp> (i,x,y,z)"  "atom z' \<sharp> (x,i,j)"
    by (metis obtain_fresh)
  have "{OrdP (Var i), OrdP x} \<turnstile> All j (HaddP x (Var i) (Var j) IMP HaddP (Var i) x (Var j))"
       (is "_ \<turnstile> ?scheme")
    proof (rule OrdInd2H)
      show "{OrdP x} \<turnstile> ?scheme(i::=Zero)"
        using atoms apply auto
        apply (rule cut_same [OF HaddP_Zero_D2])
        apply (rule Var_Eq_subst_Iff [THEN Sym_L, THEN Iff_MP_same], auto intro: HaddP_Zero1)
        done
    next
      show "{OrdP x} \<turnstile> All i (OrdP (Var i) IMP ?scheme IMP ?scheme(i::=SUCC (Var i)))"
        using atoms
        apply auto
        apply (rule cut_same [OF HaddP_SUCC_Ex2 [where z'=z']], auto)
        apply (rule Ex_I [where x="Var z'"], auto)
        apply (rule rotate3)
        apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same], simp)
        by (metis Assume HaddP_SUCC1 cut1 thin1)
    qed
  hence "{OrdP (Var i), OrdP x} \<turnstile> (HaddP x (Var i) (Var j) IMP HaddP (Var i) x (Var j))(j::=z)"
    by (rule All_D)
  hence "{OrdP (Var i), OrdP x} \<turnstile> HaddP x (Var i) z IMP HaddP (Var i) x z"
    using atoms by auto
  hence "{OrdP x} \<turnstile> HaddP x (Var i) z IMP HaddP (Var i) x z"
    by (metis HaddP_imp_OrdP Imp_cut)
  hence "{OrdP x} \<turnstile> (HaddP x (Var i) z IMP HaddP (Var i) x z)(i::=y)"
    using atoms by (force intro!: Subst)
  thus ?thesis
    using atoms by simp (metis anti_deduction)
qed (*>*)

lemma HaddP_SUCC_Ex1:
  assumes "atom i \<sharp> (x,y,z)"
    shows "insert (HaddP (SUCC x) y z) (insert (OrdP x) H)
           \<turnstile> Ex i (HaddP x y (Var i) AND z EQ SUCC (Var i))"
proof -
  have "{ HaddP (SUCC x) y z, OrdP x } \<turnstile> Ex i (HaddP x y (Var i) AND z EQ SUCC (Var i))"
    apply (rule cut_same [OF HaddP_commute [THEN cut2]])
    apply (blast intro: OrdP_SUCC_I)+
    apply (rule cut_same [OF HaddP_SUCC_Ex2 [where z'=i]], blast)
    using assms apply auto
    apply (auto intro!: Ex_I [where x="Var i"])
    by (metis AssumeH(2) HaddP_commute [THEN cut2] HaddP_imp_OrdP rotate2 thin1)
  thus ?thesis
    by (metis Assume AssumeH(2) cut2)
qed

lemma HaddP_inv2: "{HaddP x y z, HaddP x y' z, OrdP x} \<turnstile> y' EQ y" (*<*)
proof -
  obtain i::name and j::name and u::name and u'::name
   where atoms: "atom i \<sharp> (x,y,y',z)"  "atom j \<sharp> (i,x,y,y',z)"
                "atom u \<sharp> (x,y,y',i,j)" "atom u' \<sharp> (x,y,y',u,i,j)"
    by (metis obtain_fresh)
  have "{OrdP (Var i)} \<turnstile> All j (HaddP (Var i) y (Var j) IMP HaddP (Var i) y' (Var j) IMP y' EQ y)"
       (is "_ \<turnstile> ?scheme")
    proof (rule OrdInd2H)
      show "{} \<turnstile> ?scheme(i::=Zero)"
        using atoms
        by auto (metis HaddP_Zero_D1 Sym Trans thin1)
    next
      show "{} \<turnstile> All i (OrdP (Var i) IMP ?scheme IMP ?scheme(i::=SUCC (Var i)))"
        using atoms
        apply auto
        apply (rule cut_same [OF HaddP_SUCC_Ex1 [where y=y and i=u, THEN cut2]], auto)
        apply (rule Ex_I [where x="Var u"], auto)
        apply (rule cut_same [OF HaddP_SUCC_Ex1 [where y=y' and i=u', THEN cut2]], auto)
        apply (rule cut_same [where A="SUCC (Var u) EQ SUCC (Var u')"])
        apply (auto intro: Sym Trans)
        apply (rule rotate4 [OF ContraProve])
        apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same], force)
        done
    qed
  hence "{OrdP (Var i)} \<turnstile> (HaddP (Var i) y (Var j) IMP HaddP (Var i) y' (Var j) IMP y' EQ y)(j::=z)"
    by (rule All_D)
  hence "{OrdP (Var i)} \<turnstile> HaddP (Var i) y z IMP HaddP (Var i) y' z IMP y' EQ y"
    using atoms by auto
  hence "{} \<turnstile> OrdP (Var i) IMP HaddP (Var i) y z IMP HaddP (Var i) y' z IMP y' EQ y"
    by (metis Imp_I)
  hence "{} \<turnstile> (OrdP (Var i) IMP HaddP (Var i) y z IMP HaddP (Var i) y' z IMP y' EQ y)(i::=x)"
    using atoms by (force intro!: Subst)
  thus ?thesis
    using atoms by simp (metis DisjAssoc2 Disj_commute anti_deduction)
qed (*>*)

lemma Mem_imp_subtract: (*<*)
  assumes "H \<turnstile> x IN y" "H \<turnstile> OrdP y" and k: "atom (k::name) \<sharp> (x,y)"
    shows  "H \<turnstile> Ex k (HaddP x (Var k) y AND Zero IN (Var k))"
proof -
  obtain i::name
   where atoms: "atom i \<sharp> (x,y,k)"
    by (metis obtain_fresh)
  have "{OrdP (Var i)} \<turnstile> x IN Var i IMP Ex k (HaddP x (Var k) (Var i) AND Zero IN (Var k))"
       (is "_ \<turnstile> ?scheme")
    proof (rule OrdInd2H)
      show "{} \<turnstile> ?scheme(i::=Zero)"
        by auto
    next
      show "{} \<turnstile> All i (OrdP (Var i) IMP ?scheme IMP ?scheme(i::=SUCC (Var i)))"
        using atoms k
        apply (auto intro!: Mem_SUCC_EH)
        apply (rule Ex_I [where x="SUCC (Var k)"], auto)
        apply (metis AssumeH(4) HaddP_SUCC2 cut1 insert_commute)
        apply (blast intro: Mem_SUCC_I1)
        apply (rule Ex_I [where x="SUCC Zero"], auto)
        apply (rule thin1)
        apply (rule Var_Eq_subst_Iff [THEN Sym_L, THEN Iff_MP_same], simp)
        apply (metis HaddP_SUCC2 HaddP_Zero2 cut1)
        apply (rule Ex_I [where x="SUCC (Var k)"], auto intro: Mem_SUCC_I1)
        apply (metis AssumeH(4) HaddP_SUCC2 cut1 insert_commute)
        done
    qed
  hence "{} \<turnstile> OrdP (Var i) IMP x IN Var i IMP Ex k (HaddP x (Var k) (Var i) AND Zero IN (Var k))"
    by (metis Imp_I)
  hence "{} \<turnstile> (OrdP (Var i) IMP x IN Var i IMP Ex k (HaddP x (Var k) (Var i) AND Zero IN (Var k)))(i::=y)"
    by (force intro!: Subst)
  thus ?thesis using assms atoms
    by simp (metis (no_types) anti_deduction cut2)
qed (*>*)

lemma HaddP_OrdP:
  assumes "H \<turnstile> HaddP x y z" "H \<turnstile> OrdP x"  shows "H \<turnstile> OrdP z"  (*<*)
proof -
  obtain i::name and j::name and k::name
   where atoms: "atom i \<sharp> (x,y,z)"  "atom j \<sharp> (i,x,y,z)"  "atom k \<sharp> (i,j,x,y,z)"
    by (metis obtain_fresh)
  have "{OrdP (Var i), OrdP x} \<turnstile> All j (HaddP x (Var i) (Var j) IMP OrdP (Var j))"
       (is "_ \<turnstile> ?scheme")
    proof (rule OrdInd2H)
      show "{OrdP x} \<turnstile> ?scheme(i::=Zero)"
        using atoms
        by (auto intro: HaddP_Zero_D2 OrdP_cong [THEN Iff_MP_same])
    next
      show "{OrdP x} \<turnstile> All i (OrdP (Var i) IMP ?scheme IMP ?scheme(i::=SUCC (Var i)))"
        using atoms
        apply auto
        apply (rule cut_same [OF HaddP_SUCC_Ex2 [where z'=k]], auto)
        apply (rule Ex_I [where x="Var k"], auto)
        apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same, THEN rotate3], auto intro: OrdP_SUCC_I)
        done
    qed
  hence "{OrdP (Var i), OrdP x} \<turnstile> (HaddP x (Var i) (Var j) IMP OrdP (Var j))(j::=z)"
    by (rule All_D)
  hence "{OrdP (Var i), OrdP x} \<turnstile> (HaddP x (Var i) z IMP OrdP z)"
    using atoms by simp
  hence "{OrdP x} \<turnstile> HaddP x (Var i) z IMP OrdP z"
    by (metis HaddP_imp_OrdP Imp_cut)
  hence "{OrdP x} \<turnstile> (HaddP x (Var i) z IMP OrdP z)(i::=y)"
    using atoms by (force intro!: Subst)
  thus ?thesis using assms atoms
    by simp (metis anti_deduction cut2)
qed (*>*)

lemma HaddP_Mem_cancel_left:
  assumes "H \<turnstile> HaddP x y' z'" "H \<turnstile> HaddP x y z" "H \<turnstile> OrdP x"
    shows "H \<turnstile> z' IN z IFF y' IN y" (*<*)
proof -
  obtain i::name and j::name and j'::name and k::name and k'::name
   where atoms: "atom i \<sharp> (x,y,y',z,z')" "atom j \<sharp> (i,x,y,y',z,z')" "atom j' \<sharp> (i,j,x,y,y',z,z')"
                 "atom k \<sharp> (i,j,j',x,y,y',z,z')" "atom k' \<sharp> (i,j,j',k,x,y,y',z,z')"
    by (metis obtain_fresh)
  have "{OrdP (Var i)}
        \<turnstile> All j (All j' (HaddP (Var i) y' (Var j') IMP (HaddP (Var i) y (Var j) IMP
                         ((Var j') IN (Var j) IFF y' IN y))))"
       (is "_ \<turnstile> ?scheme")
    proof (rule OrdInd2H)
      show "{} \<turnstile> ?scheme(i::=Zero)"
        using atoms apply simp
        apply (rule All_I Imp_I Ex_EH)+
        apply (rule cut_same [where A="Var j EQ y"])
        apply (metis HaddP_Zero_D1 Sym)
        apply (rule cut_same [where A="Var j' EQ y'"])
        apply (metis HaddP_Zero_D1 Sym thin1)
        apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same], simp)
        apply (rule thin1)
        apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same], auto)
        done
    next
      show "{} \<turnstile> All i (OrdP (Var i) IMP ?scheme IMP ?scheme(i::=SUCC (Var i)))"
        using atoms apply simp
        apply (rule All_I Imp_I Ex_EH)+
        apply (rule cut_same [OF HaddP_SUCC_Ex1 [of k "Var i" y "Var j", THEN cut2]], simp_all)
        apply (rule AssumeH Conj_EH Ex_EH)+
        apply (rule cut_same [OF HaddP_SUCC_Ex1 [of k' "Var i" y' "Var j'", THEN cut2]], simp_all)
        apply (rule AssumeH Conj_EH Ex_EH)+
        apply (rule rotate7)
        apply (rule All_E [where x = "Var k"], simp)
        apply (rule All_E [where x = "Var k'"], simp_all)
        apply (rule Imp_E AssumeH)+
        apply (rule Iff_trans)
        prefer 2
        apply (rule AssumeH)
        apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same, THEN rotate3], simp)
        apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same, THEN rotate5], simp)
        apply (blast intro!: HaddP_OrdP OrdP_IN_SUCC_Iff)
        done
    qed
  hence "{OrdP (Var i)}
         \<turnstile> (All j' (HaddP (Var i) y' (Var j') IMP (HaddP (Var i) y (Var j) IMP ((Var j') IN (Var j) IFF y' IN y))))(j::=z)"
    by (metis All_D)
  hence "{OrdP (Var i)}
         \<turnstile> (All j' (HaddP (Var i) y' (Var j') IMP (HaddP (Var i) y z IMP ((Var j') IN z IFF y' IN y))))"
    using atoms by simp
  hence "{OrdP (Var i)}
         \<turnstile> (HaddP (Var i) y' (Var j') IMP (HaddP (Var i) y z IMP ((Var j') IN z IFF y' IN y)))(j'::=z')"
    by (metis All_D)
  hence "{OrdP (Var i)} \<turnstile> HaddP (Var i) y' z' IMP (HaddP (Var i) y z IMP (z' IN z IFF y' IN y))"
    using atoms by simp
  hence "{} \<turnstile> (OrdP (Var i) IMP HaddP (Var i) y' z' IMP (HaddP (Var i) y z IMP (z' IN z IFF y' IN y)))(i::=x)"
    by (metis Imp_I Subst emptyE)
  thus ?thesis
    using atoms by simp (metis assms MP_null MP_same)
qed (*>*)

lemma HaddP_Mem_cancel_right_Mem:
  assumes "H \<turnstile> HaddP x' y z'" "H \<turnstile> HaddP x y z" "H \<turnstile> x' IN x" "H \<turnstile> OrdP x"
    shows "H \<turnstile> z' IN z"
proof -
  have "H \<turnstile> OrdP x'"
    by (metis Ord_IN_Ord assms(3) assms(4))
  hence "H \<turnstile> HaddP y x' z'" "H \<turnstile> HaddP y x z"
    by (blast intro: assms HaddP_commute [THEN cut2])+
  thus ?thesis
    by (blast intro: assms HaddP_imp_OrdP [THEN cut1] HaddP_Mem_cancel_left [THEN Iff_MP2_same])
qed

lemma HaddP_Mem_cases:
  assumes "H \<turnstile> HaddP k1 k2 k" "H \<turnstile> OrdP k1"
          "insert (x IN k1) H \<turnstile> A"
          "insert (Var i IN k2) (insert (HaddP k1 (Var i) x) H) \<turnstile> A"
      and i: "atom (i::name) \<sharp> (k1,k2,k,x,A)" and "\<forall>C \<in> H. atom i \<sharp> C"
    shows "insert (x IN k) H \<turnstile> A" (*<*)
proof -
  obtain j::name where j: "atom j \<sharp> (k1,k2,k,x)"
    by (metis obtain_fresh)
  have seq: "{HaddP k1 k2 k, x IN k, OrdP k1} \<turnstile> x IN k1 OR (Ex i (HaddP k1 (Var i) x AND Var i IN k2))"
    apply (rule cut_same [OF HaddP_OrdP])
    apply (rule AssumeH)+
    apply (rule cut_same [OF Ord_IN_Ord])
    apply (rule AssumeH)+
    apply (rule OrdP_linear [of _ x k1], (rule AssumeH)+)
    proof -
      show "{x IN k1, OrdP x, OrdP k, HaddP k1 k2 k, x IN k, OrdP k1} \<turnstile> x IN k1 OR Ex i (HaddP k1 (Var i) x AND Var i IN k2)"
        by (blast intro: Disj_I1)
    next
      show "{x EQ k1, OrdP x, OrdP k, HaddP k1 k2 k, x IN k, OrdP k1} \<turnstile> x IN k1 OR Ex i (HaddP k1 (Var i) x AND Var i IN k2)"
        apply (rule cut_same [OF Zero_In_OrdP [of k2, THEN cut1]])
        apply (metis AssumeH(4) HaddP_imp_OrdP cut1)
        apply auto
        apply (rule cut_same [where A="HaddP x Zero k"])
        apply (blast intro: HaddP_cong [THEN Iff_MP_same] Sym)
        apply (rule cut_same [where A="x EQ k"])
        apply (metis HaddP_Zero_D2)
        apply (blast intro: Mem_non_refl Mem_cong [THEN Iff_MP_same])
        apply (rule Disj_I2)
        apply (rule Ex_I [where x=Zero])
        using i apply auto
        apply (rule HaddP_cong [THEN Iff_MP_same])
        apply (rule AssumeH Refl HaddP_Zero2)+
        done
    next
      show "{k1 IN x, OrdP x, OrdP k, HaddP k1 k2 k, x IN k, OrdP k1} \<turnstile> x IN k1 OR Ex i (HaddP k1 (Var i) x AND Var i IN k2)"
        apply (rule Disj_I2)
        apply (rule cut_same [OF Mem_imp_subtract [of _ k1 x j]])
        apply (rule AssumeH)+
        using i j apply auto
        apply (rule Ex_I [where x="Var j"], auto intro: HaddP_Mem_cancel_left [THEN Iff_MP_same])
        done
    qed
  show ?thesis using assms
    by (force intro: cut_same [OF seq [THEN cut3]] thin1 simp: insert_commute)
qed (*>*)

lemma HaddP_Mem_contra:
  assumes "H \<turnstile> HaddP x y z" "H \<turnstile> z IN x" "H \<turnstile> OrdP x"
    shows "H \<turnstile> A"
proof -
  obtain i::name and j::name and k::name
   where atoms: "atom i \<sharp> (x,y,z)" "atom j \<sharp> (i,x,y,z)" "atom k \<sharp> (i,j,x,y,z)"
    by (metis obtain_fresh)
  have "{OrdP (Var i)}  \<turnstile> All j (HaddP (Var i) y (Var j) IMP Neg ((Var j) IN (Var i)))"
       (is "_ \<turnstile> ?scheme")
    proof (rule OrdInd2H)
      show "{} \<turnstile> ?scheme(i::=Zero)"
        using atoms by auto
    next
      show "{} \<turnstile> All i (OrdP (Var i) IMP ?scheme IMP ?scheme(i::=SUCC (Var i)))"
        using  atoms apply auto
        apply (rule cut_same [OF HaddP_SUCC_Ex1 [of k "Var i" y "Var j", THEN cut2]], auto)
        apply (rule Ex_I [where x="Var k"], auto)
        apply (blast intro: OrdP_IN_SUCC_D Mem_cong [OF _ Refl, THEN Iff_MP_same])
        done
    qed
  hence "{OrdP (Var i)} \<turnstile> (HaddP (Var i) y (Var j) IMP Neg ((Var j) IN (Var i)))(j::=z)"
    by (metis All_D)
  hence "{} \<turnstile> OrdP (Var i) IMP HaddP (Var i) y z IMP Neg (z IN (Var i))"
    using atoms by simp (metis Imp_I)
  hence "{} \<turnstile> (OrdP (Var i) IMP HaddP (Var i) y z IMP Neg (z IN (Var i)))(i::=x)"
    by (metis Subst emptyE)
  thus ?thesis
    using atoms by simp (metis MP_same MP_null Neg_D assms)
qed (*>*)

lemma exists_HaddP:
  assumes "H \<turnstile> OrdP y" "atom j \<sharp> (x,y)"
    shows "H \<turnstile> Ex j (HaddP x y (Var j))"
proof -
  obtain i::name
   where atoms: "atom i \<sharp> (j,x,y)"
    by (metis obtain_fresh)
  have "{OrdP (Var i)} \<turnstile> Ex j (HaddP x (Var i) (Var j))"
       (is "_ \<turnstile> ?scheme")
    proof (rule OrdInd2H)
      show "{} \<turnstile> ?scheme(i::=Zero)"
        using atoms assms
        by (force intro!: Ex_I [where x=x] HaddP_Zero2)
    next
      show "{} \<turnstile> All i (OrdP (Var i) IMP ?scheme IMP ?scheme(i::=SUCC (Var i)))"
        using atoms assms
        apply auto
        apply (auto intro!: Ex_I [where x="SUCC (Var j)"] HaddP_SUCC2)
        apply (metis HaddP_SUCC2 insert_commute thin1)
        done
    qed
  hence "{} \<turnstile> OrdP (Var i) IMP Ex j (HaddP x (Var i) (Var j))"
    by (metis Imp_I)
  hence "{} \<turnstile> (OrdP (Var i) IMP Ex j (HaddP x (Var i) (Var j)))(i::=y)"
    using atoms by (force intro!: Subst)
  thus ?thesis
    using atoms assms by simp (metis MP_null assms(1))
qed

lemma HaddP_Mem_I:
  assumes "H \<turnstile> HaddP x y z" "H \<turnstile> OrdP x" shows "H \<turnstile> x IN SUCC z"
proof -
  have "{HaddP x y z, OrdP x} \<turnstile> x IN SUCC z"
    apply (rule OrdP_linear [of _ x "SUCC z"])
    apply (auto intro: OrdP_SUCC_I HaddP_OrdP)
    apply (rule HaddP_Mem_contra, blast)
    apply (metis Assume Mem_SUCC_I2 OrdP_IN_SUCC_D Sym_L thin1 thin2, blast)
    apply (blast intro: HaddP_Mem_contra Mem_SUCC_Refl OrdP_Trans)
    done
  thus ?thesis
    by (rule cut2) (auto intro: assms)
qed

section \<open>A Shifted Sequence\<close>

nominal_function ShiftP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom x \<sharp> (x',y,z,f,del,k); atom x' \<sharp> (y,z,f,del,k); atom y \<sharp> (z,f,del,k); atom z \<sharp> (f,del,g,k)\<rbrakk> \<Longrightarrow>
    ShiftP f k del g =
      All z (Var z IN g IFF
      (Ex x (Ex x' (Ex y ((Var z) EQ HPair (Var x') (Var y) AND
                          HaddP del (Var x) (Var x') AND
                          HPair (Var x) (Var y) IN f AND Var x IN k)))))"
by (auto simp: eqvt_def ShiftP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma ShiftP_fresh_iff [simp]: "a \<sharp> ShiftP f k del g \<longleftrightarrow> a \<sharp> f \<and> a \<sharp> k \<and> a \<sharp> del \<and> a \<sharp> g"
proof -
  obtain x::name and x'::name and y::name and z::name
    where "atom x \<sharp> (x',y,z,f,del,k)" "atom x' \<sharp> (y,z,f,del,k)"
          "atom y \<sharp> (z,f,del,k)" "atom z \<sharp> (f,del,g,k)"
    by (metis obtain_fresh)
  thus ?thesis
    by auto
qed

lemma subst_fm_ShiftP [simp]:
  "(ShiftP f k del g)(i::=u) = ShiftP (subst i u f) (subst i u k) (subst i u del) (subst i u g)"
proof -
  obtain x::name and x'::name and y::name and z::name
  where "atom x \<sharp> (x',y,z,f,del,k,i,u)" "atom x' \<sharp> (y,z,f,del,k,i,u)"
        "atom y \<sharp> (z,f,del,k,i,u)" "atom z \<sharp> (f,del,g,k,i,u)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: ShiftP.simps [of x x' y z])
qed

lemma ShiftP_Zero: "{} \<turnstile> ShiftP Zero k d Zero"
proof -
  obtain x::name and x'::name and y::name and z::name
  where "atom x \<sharp> (x',y,z,k,d)" "atom x' \<sharp> (y,z,k,d)" "atom y \<sharp> (z,k,d)" "atom z \<sharp> (k,d)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: ShiftP.simps [of x x' y z])
qed

lemma ShiftP_Mem1:
  "{ShiftP f k del g, HPair a b IN f, HaddP del a a', a IN k} \<turnstile> HPair a' b IN g"
proof -
  obtain x::name and x'::name and y::name and z::name
    where "atom x \<sharp> (x',y,z,f,del,k,a,a',b)" "atom x' \<sharp> (y,z,f,del,k,a,a',b)"
          "atom y \<sharp> (z,f,del,k,a,a',b)" "atom z \<sharp> (f,del,g,k,a,a',b)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: ShiftP.simps [of x x' y z])
    apply (rule All_E [where x="HPair a' b"], auto intro!: Iff_E2)
    apply (rule Ex_I [where x=a], simp)
    apply (rule Ex_I [where x="a'"], simp)
    apply (rule Ex_I [where x=b], auto intro: Mem_Eats_I1)
    done
qed

lemma ShiftP_Mem2:
  assumes "atom u \<sharp> (f,k,del,a,b)"
  shows  "{ShiftP f k del g, HPair a b IN g} \<turnstile> Ex u ((Var u) IN k AND HaddP del (Var u) a AND HPair (Var u) b IN f)"
proof -
  obtain x::name and x'::name and y::name and z::name
  where atoms: "atom x \<sharp> (x',y,z,f,del,g,k,a,u,b)" "atom x' \<sharp> (y,z,f,del,g,k,a,u,b)"
               "atom y \<sharp> (z,f,del,g,k,a,u,b)" "atom z \<sharp> (f,del,g,k,a,u,b)"
    by (metis obtain_fresh)
  thus ?thesis using assms
    apply (auto simp: ShiftP.simps [of x x' y z])
    apply (rule All_E [where x="HPair a b"])
    apply (auto intro!: Iff_E1 [OF Assume])
    apply (rule Ex_I [where x="Var x"])
    apply (auto intro: Mem_cong [OF HPair_cong Refl, THEN Iff_MP2_same])
    apply (blast intro: HaddP_cong [OF Refl Refl, THEN Iff_MP2_same])
    done
qed

lemma ShiftP_Mem_D:
  assumes "H \<turnstile> ShiftP f k del g" "H \<turnstile> a IN g"
          "atom x \<sharp> (x',y,a,f,del,k)" "atom x' \<sharp> (y,a,f,del,k)" "atom y \<sharp> (a,f,del,k)"
  shows  "H \<turnstile> (Ex x (Ex x' (Ex y (a EQ HPair (Var x') (Var y) AND
                                  HaddP del (Var x) (Var x') AND
                                  HPair (Var x) (Var y) IN f AND Var x IN k))))"
         (is "_ \<turnstile> ?concl")
proof -
  obtain z::name where "atom z \<sharp> (x,x',y,f,del,g,k,a)"
    by (metis obtain_fresh)
  hence "{ShiftP f k del g, a IN g} \<turnstile> ?concl" using assms
    by (auto simp: ShiftP.simps [of x x' y z]) (rule All_E [where x=a], auto intro: Iff_E1)
  thus ?thesis
    by (rule cut2) (rule assms)+
qed

lemma ShiftP_Eats_Eats:
  "{ShiftP f k del g, HaddP del a a', a IN k}
   \<turnstile> ShiftP (Eats f (HPair a b)) k del (Eats g (HPair a' b))" (*<*)
proof -
  obtain x::name and x'::name and y::name and z::name
    where "atom x \<sharp> (x',y,z,f,del,g,k,a,a',b)" "atom x' \<sharp> (y,z,f,del,g,k,a,a',b)"
          "atom y \<sharp> (z,f,del,g,k,a,a',b)" "atom z \<sharp> (f,del,g,k,a,a',b)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: ShiftP.simps [of x x' y z] intro!: Iff_I [THEN Swap])
    apply (rule All_E [where x="Var z", THEN rotate2], simp)
    apply (rule Iff_E)
    apply auto [1]
    apply (rule Ex_I [where x="Var x"], simp)
    apply (rule Ex_I [where x="Var x'"], simp)
    apply (rule Ex_I [where x="Var y"], simp)
    apply (blast intro: Mem_Eats_I1, blast)
    apply (rule Ex_I [where x=a], simp)
    apply (rule Ex_I [where x="a'"], simp)
    apply (rule Ex_I [where x=b], simp)
    apply (metis Assume AssumeH(3) AssumeH(4) Conj_I Mem_Eats_I2 Refl)
    apply (rule All_E [where x="Var z", THEN rotate5], auto)
    apply (rule Mem_Eats_I1)
    apply (rule Iff_MP2_same [OF Hyp], blast)
    apply (rule Ex_I [where x="Var x"], simp)
    apply (rule Ex_I [where x="Var x'"], simp)
    apply (rule Ex_I [where x="Var y"], auto)
    apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same, THEN rotate5], simp)
    apply (blast intro: Mem_Eats_I2 HaddP_cong [THEN Iff_MP_same] HaddP_unique [THEN cut2] HPair_cong)
    done
qed (*>*)

lemma ShiftP_Eats_Neg:
  assumes "atom u \<sharp> (u',v,f,k,del,g,c)" "atom u' \<sharp> (v,f,k,del,g,c)" "atom v \<sharp> (f,k,del,g,c)"
  shows
  "{ShiftP f k del g,
    Neg (Ex u (Ex u' (Ex v (c EQ HPair (Var u) (Var v) AND Var u IN k AND HaddP del (Var u) (Var u')))))}
   \<turnstile> ShiftP (Eats f c) k del g"  (*<*)
proof -
  obtain x::name and x'::name and y::name and z::name
  where atoms: "atom x \<sharp> (x',y,z,u,u',v,f,k,del,g,c)" "atom x' \<sharp> (y,z,u,u',v,f,k,del,g,c)"
               "atom y \<sharp> (z,u,u',v,f,k,del,g,c)" "atom z \<sharp> (u,u',v,f,k,del,g,c)"
    by (metis obtain_fresh)
  thus ?thesis using assms
    apply (auto simp: ShiftP.simps [of x x' y z] intro!: Iff_I [THEN Swap])
    apply (rule All_E [where x="Var z", THEN rotate3])
    apply (auto intro!: Iff_E1 [OF Assume])
    apply (rule Ex_I [where x="Var x"], simp)
    apply (rule Ex_I [where x="Var x'"], simp)
    apply (rule Ex_I [where x="Var y"], simp)
    apply (blast intro: Mem_Eats_I1)
    apply (rule All_E [where x="Var z", THEN rotate6], simp)
    apply (rule Iff_E2)
    apply (rule Ex_I [where x="Var x"], simp)
    apply (rule Ex_I [where x="Var x'"], simp)
    apply (rule Ex_I [where x="Var y"])
    apply (auto intro: Mem_Eats_I1)
    apply (rule Swap [THEN rotate5])
    apply (rule Ex_I [where x="Var x"], simp)
    apply (rule Ex_I [where x="Var x'"], simp)
    apply (rule Ex_I [where x="Var y"], simp)
    apply (blast intro: Sym Mem_Eats_I1)
    done
qed (*>*)

lemma exists_ShiftP:
  assumes t: "atom t \<sharp> (s,k,del)"
  shows "H \<turnstile> Ex t (ShiftP s k del (Var t))" (*<*)
proof -
  obtain i::name and j::name
    where i: "atom (i::name) \<sharp> (s,t,k,del)" and j: "atom (j::name) \<sharp> (i,s,t,k,del)"
    by (metis obtain_fresh)
  have "{} \<turnstile> Ex t (ShiftP (Var i) k del (Var t))" (is "{} \<turnstile> ?scheme")
  proof (rule Ind [of j])
    show "atom j \<sharp> (i, ?scheme)" using j
      by simp
  next
    show "{} \<turnstile> ?scheme(i::=Zero)" using i t
      by (auto intro!: Ex_I [where x=Zero] simp: ShiftP_Zero)
  next
    obtain x::name and x'::name and y::name
    where atoms: "atom x \<sharp> (x',y,s,k,del,t,i,j)" "atom x' \<sharp> (y,s,k,del,t,i,j)"
                 "atom y \<sharp> (s,k,del,t,i,j)"
      by (metis obtain_fresh)
    let ?caseA = "Ex x (Ex x' (Ex y ((Var j) EQ HPair (Var x) (Var y) AND Var x IN k AND
                                     HaddP del (Var x) (Var x'))))"
    show "{} \<turnstile> All i (All j (?scheme IMP ?scheme(i::=Var j) IMP ?scheme(i::=Eats (Var i) (Var j))))"
      using i j atoms
      apply (auto del: Ex_EH)
      apply (rule Ex_E)
      apply (auto del: Ex_EH)
      apply (rule Ex_E)
      apply (auto del: Ex_EH)
      apply (rule thin1, auto)
      proof (rule Cases [where A="?caseA"])
        show "{?caseA, ShiftP (Var i) k del (Var t)}
              \<turnstile> Ex t (ShiftP (Eats (Var i) (Var j)) k del (Var t))"
          using i j t atoms
          apply (auto simp del: ShiftP.simps)
          apply (rule Ex_I [where x="Eats (Var t) (HPair (Var x') (Var y))"], auto)
          apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same, THEN rotate3])
          apply (auto intro: ShiftP_Eats_Eats [THEN cut3])
          done
      next
        show "{Neg ?caseA, ShiftP (Var i) k del (Var t)}
              \<turnstile> Ex t (ShiftP (Eats (Var i) (Var j)) k del (Var t))"
          using atoms
          by (auto intro!: Ex_I [where x="Var t"] ShiftP_Eats_Neg [of x x' y, THEN cut2]
                   simp: ShiftP_Zero)
      qed
  qed
  hence "{} \<turnstile> (Ex t (ShiftP (Var i) k del (Var t)))(i::=s)"
    by (blast intro: Subst)
  thus ?thesis using i t
    by (auto intro: thin0)
qed (*>*)

section \<open>Union of Two Sets\<close>

nominal_function UnionP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "atom i \<sharp> (x,y,z) \<Longrightarrow> UnionP x y z = All i (Var i IN z IFF (Var i IN x OR Var i IN y))"
by (auto simp: eqvt_def UnionP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma UnionP_fresh_iff [simp]: "a \<sharp> UnionP x y z \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> y \<and> a \<sharp> z"
proof -
  obtain i::name where "atom i \<sharp> (x,y,z)"
    by (metis obtain_fresh)
  thus ?thesis
    by auto
qed

lemma subst_fm_UnionP [simp]:
  "(UnionP x y z)(i::=u) = UnionP (subst i u x) (subst i u y) (subst i u z)"
proof -
  obtain j::name where "atom j \<sharp> (x,y,z,i,u)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: UnionP.simps [of j])
qed

lemma Union_Zero1: "H \<turnstile> UnionP Zero x x"
proof -
  obtain i::name where "atom i \<sharp> x"
    by (metis obtain_fresh)
  hence "{} \<turnstile> UnionP Zero x x"
    by (auto simp: UnionP.simps [of i] intro: Disj_I2)
  thus ?thesis
    by (metis thin0)
qed

lemma Union_Eats: "{UnionP x y z} \<turnstile> UnionP (Eats x a) y (Eats z a)"
proof -
  obtain i::name where "atom i \<sharp> (x,y,z,a)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: UnionP.simps [of i])
    apply (rule Ex_I [where x="Var i"])
    apply (auto intro: Iff_E1 [THEN rotate2] Iff_E2 [THEN rotate2] Mem_Eats_I1 Mem_Eats_I2 Disj_I1 Disj_I2)
    done
qed

lemma exists_Union_lemma:
  assumes z: "atom z \<sharp> (i,y)" and i: "atom i \<sharp> y"
  shows "{} \<turnstile> Ex z (UnionP (Var i) y (Var z))"
proof -
  obtain j::name where j: "atom j \<sharp> (y,z,i)"
    by (metis obtain_fresh)
  show "{} \<turnstile> Ex z (UnionP (Var i) y (Var z))"
    apply (rule Ind [of j i]) using j z i
    apply simp_all
    apply (rule Ex_I [where x=y], simp add: Union_Zero1)
    apply (auto del: Ex_EH)
    apply (rule Ex_E)
    apply (rule NegNeg_E)
    apply (rule Ex_E)
    apply (auto del: Ex_EH)
    apply (rule thin1, force intro: Ex_I [where x="Eats (Var z) (Var j)"] Union_Eats)
    done
qed

lemma exists_UnionP:
  assumes z: "atom z \<sharp> (x,y)"  shows "H \<turnstile> Ex z (UnionP x y (Var z))"
proof -
  obtain i::name  where i: "atom i \<sharp> (y,z)"
    by (metis obtain_fresh)
  hence "{} \<turnstile> Ex z (UnionP (Var i) y (Var z))"
    by (metis exists_Union_lemma fresh_Pair fresh_at_base(2) z)
  hence "{} \<turnstile> (Ex z (UnionP (Var i) y (Var z)))(i::=x)"
    by (metis Subst empty_iff)
  thus ?thesis using i z
    by (simp add: thin0)
qed

lemma UnionP_Mem1: "{ UnionP x y z, a IN x } \<turnstile> a IN z"
proof -
  obtain i::name where "atom i \<sharp> (x,y,z,a)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: UnionP.simps [of i] intro: All_E [where x=a] Disj_I1 Iff_E2)
qed

lemma UnionP_Mem2: "{ UnionP x y z, a IN y } \<turnstile> a IN z"
proof -
  obtain i::name where "atom i \<sharp> (x,y,z,a)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: UnionP.simps [of i] intro: All_E [where x=a] Disj_I2 Iff_E2)
qed

lemma UnionP_Mem: "{ UnionP x y z, a IN z } \<turnstile> a IN x OR a IN y"
proof -
  obtain i::name where "atom i \<sharp> (x,y,z,a)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: UnionP.simps [of i] intro: All_E [where x=a] Iff_E1)
qed

lemma UnionP_Mem_E:
  assumes "H \<turnstile> UnionP x y z"
      and "insert (a IN x) H \<turnstile> A"
      and "insert (a IN y) H \<turnstile> A"
    shows "insert (a IN z) H \<turnstile> A"
  using assms
  by (blast intro: rotate2 cut_same [OF UnionP_Mem [THEN cut2]] thin1)

section \<open>Append on Sequences\<close>

nominal_function SeqAppendP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom g1 \<sharp> (g2,f1,k1,f2,k2,g); atom g2 \<sharp> (f1,k1,f2,k2,g)\<rbrakk> \<Longrightarrow>
    SeqAppendP f1 k1 f2 k2 g =
      (Ex g1 (Ex g2 (RestrictedP f1 k1 (Var g1) AND
                     ShiftP f2 k2 k1 (Var g2) AND
                     UnionP (Var g1) (Var g2) g)))"
by (auto simp: eqvt_def SeqAppendP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma SeqAppendP_fresh_iff [simp]:
  "a \<sharp> SeqAppendP f1 k1 f2 k2 g \<longleftrightarrow> a \<sharp> f1 \<and> a \<sharp> k1 \<and> a \<sharp> f2 \<and> a \<sharp> k2 \<and> a \<sharp> g"
proof -
  obtain g1::name and g2::name
    where "atom g1 \<sharp> (g2,f1,k1,f2,k2,g)" "atom g2 \<sharp> (f1,k1,f2,k2,g)"
    by (metis obtain_fresh)
  thus ?thesis
    by auto
qed

lemma subst_fm_SeqAppendP [simp]:
  "(SeqAppendP f1 k1 f2 k2 g)(i::=u) =
   SeqAppendP (subst i u f1) (subst i u k1) (subst i u f2) (subst i u k2) (subst i u g)"
proof -
  obtain g1::name and g2::name
  where "atom g1 \<sharp> (g2,f1,k1,f2,k2,g,i,u)" "atom g2 \<sharp> (f1,k1,f2,k2,g,i,u)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqAppendP.simps [of g1 g2])
qed

lemma exists_SeqAppendP:
  assumes "atom g \<sharp> (f1,k1,f2,k2)"
  shows "H \<turnstile> Ex g (SeqAppendP f1 k1 f2 k2 (Var g))"
proof -
  obtain g1::name and g2::name
  where atoms: "atom g1 \<sharp> (g2,f1,k1,f2,k2,g)" "atom g2 \<sharp> (f1,k1,f2,k2,g)"
    by (metis obtain_fresh)
  hence "{} \<turnstile> Ex g (SeqAppendP f1 k1 f2 k2 (Var g))"
    using assms
    apply (auto simp: SeqAppendP.simps [of g1 g2])
    apply (rule cut_same [OF exists_RestrictedP [of g1 f1 k1]], auto)
    apply (rule cut_same [OF exists_ShiftP [of g2 f2 k2 k1]], auto)
    apply (rule cut_same [OF exists_UnionP [of g "Var g1" "Var g2"]], auto)
    apply (rule Ex_I [where x="Var g"], simp)
    apply (rule Ex_I [where x="Var g1"], simp)
    apply (rule Ex_I [where x="Var g2"], auto)
    done
  thus ?thesis using assms
    by (metis thin0)
qed

lemma SeqAppendP_Mem1: "{SeqAppendP f1 k1 f2 k2 g, HPair x y IN f1, x IN k1} \<turnstile> HPair x y IN g"
proof -
  obtain g1::name and g2::name
    where "atom g1 \<sharp> (g2,f1,k1,f2,k2,g,x,y)" "atom g2 \<sharp> (f1,k1,f2,k2,g,x,y)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqAppendP.simps [of g1 g2] intro: UnionP_Mem1 [THEN cut2] RestrictedP_Mem [THEN cut3])
qed

lemma SeqAppendP_Mem2: "{SeqAppendP f1 k1 f2 k2 g, HaddP k1 x x', x IN k2, HPair x y IN f2} \<turnstile> HPair x' y IN g"
proof -
  obtain g1::name and g2::name
    where "atom g1 \<sharp> (g2,f1,k1,f2,k2,g,x,x',y)" "atom g2 \<sharp> (f1,k1,f2,k2,g,x,x',y)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqAppendP.simps [of g1 g2] intro: UnionP_Mem2 [THEN cut2] ShiftP_Mem1 [THEN cut4])
qed

lemma SeqAppendP_Mem_E:
  assumes "H \<turnstile> SeqAppendP f1 k1 f2 k2 g"
      and "insert (HPair x y IN f1) (insert (x IN k1) H) \<turnstile> A"
      and "insert (HPair (Var u) y IN f2) (insert (HaddP k1 (Var u) x) (insert (Var u IN k2) H)) \<turnstile> A"
      and u: "atom u \<sharp> (f1,k1,f2,k2,x,y,g,A)" "\<forall>C \<in> H. atom u \<sharp> C"
  shows "insert (HPair x y IN g) H \<turnstile> A" (*<*)
proof -
  obtain g1::name and g2::name
  where atoms: "atom g1 \<sharp> (g2,f1,k1,f2,k2,g,x,y,u)" "atom g2 \<sharp> (f1,k1,f2,k2,g,x,y,u)"
    by (metis obtain_fresh)
  hence "{SeqAppendP f1 k1 f2 k2 g, HPair x y IN g}
         \<turnstile> (HPair x y IN f1 AND x IN k1) OR Ex u ((Var u) IN k2 AND HaddP k1 (Var u) x AND HPair (Var u) y IN f2)"
    using u
    apply (auto simp: SeqAppendP.simps [of g1 g2])
    apply (rule UnionP_Mem_E [THEN rotate4])
    apply (rule AssumeH)+
    apply (blast intro: Disj_I1 cut_same [OF RestrictedP_Mem2 [THEN cut2]])
    apply (rule Disj_I2)
    apply (rule cut_same [OF ShiftP_Mem2 [where u=u, THEN cut2]])
    defer 1
    apply force+
    done
  thus ?thesis
    apply (rule cut_same [OF _ [THEN cut2]])
    using assms
    apply (auto intro: thin1 rotate2 thin3 thin4)
    done
qed (*>*)

section \<open>LstSeqP and SeqAppendP\<close>

lemma HDomain_Incl_SeqAppendP:  \<comment> \<open>The And eliminates the need to prove @{text cut5}\<close>
  "{SeqAppendP f1 k1 f2 k2 g, HDomain_Incl f1 k1 AND HDomain_Incl f2 k2,
    HaddP k1 k2 k, OrdP k1} \<turnstile> HDomain_Incl g k" (*<*)
proof -
  obtain x::name and y::name and z::name and i::name
    where "atom x \<sharp> (f1,k1,f2,k2,g,k,y,z,i)"  "atom y \<sharp> (f1,k1,f2,k2,g,k,z,i)"
          "atom z \<sharp> (f1,k1,f2,k2,g,k,i)"  "atom i \<sharp> (f1,k1,f2,k2,g,k)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: HDomain_Incl.simps [of x _ _ y z])
    apply (rule HaddP_Mem_cases [where i=i, THEN rotate2], auto)
    \<comment> \<open>case 1\<close>
    apply (rule All_E' [where x = "Var x"], blast, auto)
    apply (rule ContraProve [THEN rotate4])
    apply (rule Ex_I [where x = "Var y"], auto)
    apply (rule Ex_I [where x = "Var z"], auto)
    apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same, THEN rotate2], simp)
    apply (rule SeqAppendP_Mem1 [THEN cut3], auto)
    apply (rule Mem_cong [OF Assume Refl, THEN Iff_MP_same], auto)
    \<comment> \<open>case 2\<close>
    apply (rule Ex_I [where x = "Var i"], auto)
    apply (rule ContraProve [THEN rotate5])
    apply (rule Ex_I [where x = "Var y"], simp)
    apply (rule Ex_I [where x = "HPair (Var x) (Var y)"], auto)
    apply (blast intro: SeqAppendP_Mem2 [THEN cut4] Mem_cong [OF _ Refl, THEN Iff_MP_same])
    done
qed (*>*)

declare SeqAppendP.simps [simp del]

lemma HFun_Sigma_SeqAppendP:
  "{SeqAppendP f1 k1 f2 k2 g, HFun_Sigma f1, HFun_Sigma f2, OrdP k1} \<turnstile> HFun_Sigma g" (*<*)
proof -
  obtain x::name and y::name and z::name
     and x'::name and y'::name and z'::name and g1::name and g2::name
     and v::name and v'::name and w::name
    where atoms:
       "atom v \<sharp> (v',w,g1,g2,z,z',x,y,x',y',f1,k1,f2,k2,g)" "atom v' \<sharp> (w,g1,g2,z,z',x,y,x',y',f1,k1,f2,k2,g)"
       "atom w \<sharp> (g1,g2,z,z',x,y,x',y',f1,k1,f2,k2,g)"
       "atom g1 \<sharp> (g2,z,z',x,y,x',y',f1,k1,f2,k2,g)" "atom g2 \<sharp> (z,z',x,y,x',y',f1,k1,f2,k2,g)"
       "atom z \<sharp> (z',x,y,x',y',f1,k1,f2,k2,g)" "atom z' \<sharp> (x,y,x',y',f1,k1,f2,k2,g)"
       "atom x \<sharp> (y,x',y',f1,k1,f2,k2,g)" "atom y \<sharp> (x',y',f1,k1,f2,k2,g)"
       "atom x' \<sharp> (y',f1,k1,f2,k2,g)" "atom y' \<sharp> (f1,k1,f2,k2,g)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (simp add: HFun_Sigma.simps [of z g z' x y x' y'] SeqAppendP.simps [of g1 g2])
    apply (rule Ex_EH Conj_EH All_I Imp_I)+
    apply (rule cut_same [OF UnionP_Mem [where a = "Var z", THEN cut2]])
    apply (rule AssumeH)+
    apply (rule Disj_E)
    apply (rule cut_same [OF UnionP_Mem [where a = "Var z'", THEN cut2]])
    apply (rule AssumeH)+
    apply (rule thin1 [where A="UnionP (Var g1) (Var g2) g", THEN rotate6])
    apply (rule Disj_E)
    \<comment> \<open>case 1/1\<close>
    apply (rule thin1 [where A="ShiftP f2 k2 k1 (Var g2)", THEN rotate5])
    apply (rule RestrictedP_Mem_D [where a = "Var z"])
    apply (rule AssumeH)+
    apply (rule RestrictedP_Mem_D [where a = "Var z'"])
    apply (rule AssumeH)+
    apply (simp add: HFun_Sigma.simps [of z f1 z' x y x' y'])
    apply (rule All2_E [where x = "Var z", THEN rotate8], simp_all, blast)
    apply (rule All2_E [where x = "Var z'"], simp_all, blast)
    apply (rule Ex_EH Conj_EH)+
    apply simp_all
    apply (rule Ex_I [where x="Var x"], simp)
    apply (rule Ex_I [where x="Var y"], simp)
    apply (rule Ex_I [where x="Var x'"], simp)
    apply (rule Ex_I [where x="Var y'"], simp)
    apply (rule Conj_I, blast)+
    apply blast
    \<comment> \<open>case 1/2\<close>
    apply (rule RestrictedP_Mem_D [where a = "Var z"])
    apply (rule AssumeH)+
    apply (rule thin1 [where A="Var z IN g", THEN rotate5])
    apply (rule thin1 [where A="Var z' IN g", THEN rotate4])
    apply (rule cut_same [OF HFun_Sigma_Mem_imp_HPair [of _ f1 "Var z" x y]], simp_all)
    apply (rule AssumeH)+
    apply (rule cut_same [OF ShiftP_Mem_D [where x=v and x'=v' and y=w]])
    apply (rule AssumeH Ex_EH Conj_EH)+
    apply auto [3]
    apply (rule AssumeH Ex_EH Conj_EH)+
    apply simp_all
    apply (rule Ex_I [where x="Var x"], simp)
    apply (rule Ex_I [where x="Var y"], simp)
    apply (rule Ex_I [where x="Var v'"], simp)
    apply (rule Ex_I [where x="Var w"], simp)
    apply auto [1]
    apply (blast intro: Mem_HFun_Sigma_OrdP [THEN cut2] Mem_cong [OF _ Refl, THEN Iff_MP_same])
    apply (blast intro: Hyp HaddP_OrdP)
    apply (rule cut_same [OF RestrictedP_Mem2 [THEN cut2]])
    apply (rule AssumeH)+
    apply (blast intro: Mem_cong [OF _ Refl, THEN Iff_MP_same])
    apply (blast intro: Hyp Mem_cong [OF _ Refl, THEN Iff_MP_same] HaddP_Mem_contra)
    \<comment> \<open>END of case 1/2\<close>
    apply (rule cut_same [OF UnionP_Mem [where a = "Var z'", THEN cut2]])
    apply (rule AssumeH)+
    apply (rule thin1 [where A="UnionP (Var g1) (Var g2) g", THEN rotate6])
    apply (rule Disj_E)
    \<comment> \<open>case 2/1\<close>
    apply (rule RestrictedP_Mem_D [where a = "Var z'"])
    apply (rule AssumeH)+
    apply (rule thin1 [where A="Var z IN g", THEN rotate5])
    apply (rule thin1 [where A="Var z' IN g", THEN rotate4])
    apply (rule cut_same [OF HFun_Sigma_Mem_imp_HPair [of _ f1 "Var z'" x y]], simp_all)
    apply (rule AssumeH)+
    apply (rule cut_same [OF ShiftP_Mem_D [where x=v and x'=v' and y=w]])
    apply (rule AssumeH Ex_EH Conj_EH)+
    apply auto [3]
    apply (rule AssumeH Ex_EH Conj_EH)+
    apply simp_all
    apply (rule Ex_I [where x="Var v'"], simp)
    apply (rule Ex_I [where x="Var w"], simp)
    apply (rule Ex_I [where x="Var x"], simp)
    apply (rule Ex_I [where x="Var y"], simp)
    apply auto [1]
    apply (blast intro: Hyp HaddP_OrdP)
    apply (blast intro: Mem_HFun_Sigma_OrdP [THEN cut2] Mem_cong [OF _ Refl, THEN Iff_MP_same])
    apply (rule cut_same [OF RestrictedP_Mem2 [THEN cut2]])
    apply (rule AssumeH)+
    apply (blast intro: Mem_cong [OF _ Refl, THEN Iff_MP_same])
    apply (blast intro: Mem_cong [OF _ Refl, THEN Iff_MP2_same] HaddP_Mem_contra Hyp)
    \<comment> \<open>case 2/2\<close>
    apply (rule cut_same [OF ShiftP_Mem_D [where x=x and x'=x' and y=y and a = "Var z"]])
    apply (rule AssumeH Ex_EH Conj_EH)+
    apply simp_all
    apply (rule cut_same [OF ShiftP_Mem_D [where x=v and x'=v' and y=w and a = "Var z'"]])
    apply (rule AssumeH Ex_EH Conj_EH)+
    apply simp_all
    apply (rule thin1 [where A="ShiftP f2 k2 k1 (Var g2)", THEN rotate7])
    apply (rule thin1 [where A="RestrictedP f1 k1 (Var g1)", THEN rotate7])
    apply (rule AssumeH Ex_EH Conj_EH)+
    apply simp_all
    apply (rule Ex_I [where x="Var x'"], simp)
    apply (rule Ex_I [where x="Var y"], simp)
    apply (rule Ex_I [where x="Var v'"], simp)
    apply (rule Ex_I [where x="Var w"], auto intro: Hyp HaddP_OrdP)
    apply (rule cut_same [where A="Var x EQ Var v"])
    apply (blast intro: HaddP_inv2 [THEN cut3] HaddP_cong [OF Refl Refl, THEN Iff_MP_same] Hyp)
    apply (rule HFun_Sigma_E [where r=f2])
    apply (auto intro: Hyp Var_Eq_subst_Iff [THEN Iff_MP_same])
    done
qed (*>*)

lemma LstSeqP_SeqAppendP:
  assumes "H \<turnstile> SeqAppendP f1 (SUCC k1) f2 (SUCC k2) g"
          "H \<turnstile> LstSeqP f1 k1 y1" "H \<turnstile> LstSeqP f2 k2 y2" "H \<turnstile> HaddP k1 k2 k"
  shows "H \<turnstile> LstSeqP g (SUCC k) y2"
proof -
  have "{SeqAppendP f1 (SUCC k1) f2 (SUCC k2) g, LstSeqP f1 k1 y1, LstSeqP f2 k2 y2, HaddP k1 k2 k}
   \<turnstile> LstSeqP g (SUCC k) y2"
    apply (auto simp: LstSeqP.simps intro: HaddP_OrdP OrdP_SUCC_I)
    apply (rule HDomain_Incl_SeqAppendP [THEN cut4])
    apply (rule AssumeH Conj_I)+
    apply (blast intro: HaddP_SUCC1 [THEN cut1] HaddP_SUCC2 [THEN cut1])
    apply (blast intro: HaddP_OrdP OrdP_SUCC_I)
    apply (rule HFun_Sigma_SeqAppendP [THEN cut4])
    apply (auto intro: HaddP_OrdP OrdP_SUCC_I)
    apply (blast intro: Mem_SUCC_Refl HaddP_SUCC1 [THEN cut1] HaddP_SUCC2 [THEN cut1]
                        SeqAppendP_Mem2 [THEN cut4])
    done
  thus ?thesis using assms
    by (rule cut4)
qed

lemma SeqAppendP_NotInDom: "{SeqAppendP f1 k1 f2 k2 g, HaddP k1 k2 k, OrdP k1} \<turnstile> NotInDom k g"
proof -
  obtain x::name and z::name
    where "atom x \<sharp> (z,f1,k1,f2,k2,g,k)"  "atom z \<sharp> (f1,k1,f2,k2,g,k)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: NotInDom.simps [of z])
    apply (rule SeqAppendP_Mem_E [where u=x])
    apply (rule AssumeH)+
    apply (blast intro: HaddP_Mem_contra, simp_all)
    apply (rule cut_same [where A="(Var x) EQ k2"])
    apply (blast intro: HaddP_inv2 [THEN cut3])
    apply (blast intro: Mem_non_refl [where x=k2] Mem_cong [OF _ Refl, THEN Iff_MP_same])
    done
qed

lemma LstSeqP_SeqAppendP_Eats:
  assumes "H \<turnstile> SeqAppendP f1 (SUCC k1) f2 (SUCC k2) g"
          "H \<turnstile> LstSeqP f1 k1 y1" "H \<turnstile> LstSeqP f2 k2 y2" "H \<turnstile> HaddP k1 k2 k"
  shows "H \<turnstile> LstSeqP (Eats g (HPair (SUCC (SUCC k)) z)) (SUCC (SUCC k)) z"
proof -
  have "{SeqAppendP f1 (SUCC k1) f2 (SUCC k2) g, LstSeqP f1 k1 y1, LstSeqP f2 k2 y2, HaddP k1 k2 k}
        \<turnstile> LstSeqP (Eats g (HPair (SUCC (SUCC k)) z)) (SUCC (SUCC k)) z"
    apply (rule cut2 [OF NotInDom_LstSeqP_Eats])
    apply (rule SeqAppendP_NotInDom [THEN cut3])
    apply (rule AssumeH)
    apply (metis HaddP_SUCC1 HaddP_SUCC2 cut1 thin1)
    apply (metis Assume LstSeqP_OrdP OrdP_SUCC_I insert_commute)
    apply (blast intro: LstSeqP_SeqAppendP)
    done
  thus ?thesis using assms
    by (rule cut4)
qed

section \<open>Substitution and Abstraction on Terms\<close>

subsection \<open>Atomic cases\<close>

lemma SeqStTermP_Var_same:
  assumes "atom s \<sharp> (k,v,i)" "atom k \<sharp> (v,i)"
    shows "{VarP v} \<turnstile> Ex s (Ex k (SeqStTermP v i v i (Var s) (Var k)))"
proof -
  obtain l::name and sl::name and sl'::name and m::name and sm::name and sm'::name
     and n::name and sn::name and sn'::name
    where "atom l \<sharp> (v,i,s,k,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (v,i,s,k,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (v,i,s,k,m,n,sm,sm',sn,sn')"
          "atom m \<sharp> (v,i,s,k,n,sm,sm',sn,sn')" "atom n \<sharp> (v,i,s,k,sm,sm',sn,sn')"
          "atom sm \<sharp> (v,i,s,k,sm',sn,sn')" "atom sm' \<sharp> (v,i,s,k,sn,sn')"
          "atom sn \<sharp> (v,i,s,k,sn')" "atom sn' \<sharp> (v,i,s,k)"
    by (metis obtain_fresh)
  thus ?thesis using assms
    apply (simp add: SeqStTermP.simps [of l _ _ v i sl sl' m n sm sm' sn sn'])
    apply (rule Ex_I [where x = "Eats Zero (HPair Zero (HPair v i))"], simp)
    apply (rule Ex_I [where x = Zero], auto intro!: Mem_SUCC_EH)
    apply (rule Ex_I [where x = v], simp)
    apply (rule Ex_I [where x = i], auto intro: Disj_I1 Mem_Eats_I2 HPair_cong)
    done
qed

lemma SeqStTermP_Var_diff:
  assumes "atom s \<sharp> (k,v,w,i)" "atom k \<sharp> (v,w,i)"
    shows "{VarP v, VarP w, Neg (v EQ w) } \<turnstile> Ex s (Ex k (SeqStTermP v i w w (Var s) (Var k)))"
proof -
  obtain l::name and sl::name and sl'::name and m::name and sm::name and sm'::name
     and n::name and sn::name and sn'::name
    where "atom l \<sharp> (v,w,i,s,k,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (v,w,i,s,k,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (v,w,i,s,k,m,n,sm,sm',sn,sn')"
          "atom m \<sharp> (v,w,i,s,k,n,sm,sm',sn,sn')" "atom n \<sharp> (v,w,i,s,k,sm,sm',sn,sn')"
          "atom sm \<sharp> (v,w,i,s,k,sm',sn,sn')" "atom sm' \<sharp> (v,w,i,s,k,sn,sn')"
          "atom sn \<sharp> (v,w,i,s,k,sn')" "atom sn' \<sharp> (v,w,i,s,k)"
    by (metis obtain_fresh)
  thus ?thesis using assms
    apply (simp add: SeqStTermP.simps [of l _ _ v i sl sl' m n sm sm' sn sn'])
    apply (rule Ex_I [where x = "Eats Zero (HPair Zero (HPair w w))"], simp)
    apply (rule Ex_I [where x = Zero], auto intro!: Mem_SUCC_EH)
    apply (rule rotate2 [OF Swap])
    apply (rule Ex_I [where x = w], simp)
    apply (rule Ex_I [where x = w], auto simp: VarP_def)
    apply (blast intro: HPair_cong Mem_Eats_I2)
    apply (blast intro: Sym OrdNotEqP_I Disj_I1 Disj_I2)
    done
qed

lemma SeqStTermP_Zero:
  assumes "atom s \<sharp> (k,v,i)" "atom k \<sharp> (v,i)"
    shows "{VarP v} \<turnstile> Ex s (Ex k (SeqStTermP v i Zero Zero (Var s) (Var k)))" (*<*)
proof -
  obtain l::name and sl::name and sl'::name and m::name and sm::name and sm'::name
     and n::name and sn::name and sn'::name
    where "atom l \<sharp> (v,i,s,k,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (v,i,s,k,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (v,i,s,k,m,n,sm,sm',sn,sn')"
          "atom m \<sharp> (v,i,s,k,n,sm,sm',sn,sn')" "atom n \<sharp> (v,i,s,k,sm,sm',sn,sn')"
          "atom sm \<sharp> (v,i,s,k,sm',sn,sn')" "atom sm' \<sharp> (v,i,s,k,sn,sn')"
          "atom sn \<sharp> (v,i,s,k,sn')" "atom sn' \<sharp> (v,i,s,k)"
    by (metis obtain_fresh)
  thus ?thesis using assms
    apply (simp add: SeqStTermP.simps [of l _ _ v i sl sl' m n sm sm' sn sn'])
    apply (rule Ex_I [where x = "Eats Zero (HPair Zero (HPair Zero Zero))"], simp)
    apply (rule Ex_I [where x = Zero], auto intro!: Mem_SUCC_EH)
    apply (rule Ex_I [where x = Zero], simp)
    apply (rule Ex_I [where x = Zero], simp)
    apply (rule Conj_I)
    apply (force intro: Var_Eq_subst_Iff [THEN Iff_MP_same] Mem_Eats_I2)
    apply (force simp: VarP_def OrdNotEqP.simps intro: Disj_I1 Disj_I2)
    done
qed (*>*)

corollary SubstTermP_Zero: "{TermP t} \<turnstile> SubstTermP \<guillemotleft>Var v\<guillemotright> t Zero Zero"
proof -
  obtain s::name and k::name where "atom s \<sharp> (v,t,k)"  "atom k \<sharp> (v,t)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SubstTermP.simps [of s _ _ _ _ k] intro: SeqStTermP_Zero [THEN cut1])
qed

corollary SubstTermP_Var_same: "{VarP v, TermP t} \<turnstile> SubstTermP v t v t"
proof -
  obtain s::name and k::name where "atom s \<sharp> (v,t,k)" "atom k \<sharp> (v,t)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SubstTermP.simps [of s _ _ _ _ k] intro: SeqStTermP_Var_same [THEN cut1])
qed

corollary SubstTermP_Var_diff: "{VarP v, VarP w, Neg (v EQ w), TermP t} \<turnstile> SubstTermP v t w w"
proof -
  obtain s::name and k::name where "atom s \<sharp> (v,w,t,k)" "atom k \<sharp> (v,w,t)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SubstTermP.simps [of s _ _ _ _ k] intro: SeqStTermP_Var_diff [THEN cut3])
qed

lemma SeqStTermP_Ind:
  assumes "atom s \<sharp> (k,v,t,i)" "atom k \<sharp> (v,t,i)"
    shows "{VarP v, IndP t} \<turnstile> Ex s (Ex k (SeqStTermP v i t t (Var s) (Var k)))"
proof -
  obtain l::name and sl::name and sl'::name and m::name and sm::name and sm'::name
     and n::name and sn::name and sn'::name
    where "atom l \<sharp> (v,t,i,s,k,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (v,t,i,s,k,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (v,t,i,s,k,m,n,sm,sm',sn,sn')"
          "atom m \<sharp> (v,t,i,s,k,n,sm,sm',sn,sn')" "atom n \<sharp> (v,t,i,s,k,sm,sm',sn,sn')"
          "atom sm \<sharp> (v,t,i,s,k,sm',sn,sn')" "atom sm' \<sharp> (v,t,i,s,k,sn,sn')"
          "atom sn \<sharp> (v,t,i,s,k,sn')" "atom sn' \<sharp> (v,t,i,s,k)"
    by (metis obtain_fresh)
  thus ?thesis using assms
    apply (simp add: SeqStTermP.simps [of l _ _ v i sl sl' m n sm sm' sn sn'])
    apply (rule Ex_I [where x = "Eats Zero (HPair Zero (HPair t t))"], simp)
    apply (rule Ex_I [where x = Zero], auto intro!: Mem_SUCC_EH)
    apply (rule Ex_I [where x = t], simp)
    apply (rule Ex_I [where x = t], auto intro: HPair_cong Mem_Eats_I2)
    apply (blast intro: Disj_I1 Disj_I2 VarP_neq_IndP)
    done
qed

corollary SubstTermP_Ind: "{VarP v, IndP w, TermP t} \<turnstile> SubstTermP v t w w"
proof -
  obtain s::name and k::name where "atom s \<sharp> (v,w,t,k)" "atom k \<sharp> (v,w,t)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: SubstTermP.simps [of s _ _ _ _ k]
              intro: SeqStTermP_Ind [THEN cut2])
qed

subsection \<open>Non-atomic cases\<close>

lemma SeqStTermP_Eats:
  assumes sk: "atom s \<sharp> (k,s1,s2,k1,k2,t1,t2,u1,u2,v,i)"
              "atom k \<sharp> (t1,t2,u1,u2,v,i)"
    shows "{SeqStTermP v i t1 u1 s1 k1, SeqStTermP v i t2 u2 s2 k2}
           \<turnstile> Ex s (Ex k (SeqStTermP v i (Q_Eats t1 t2) (Q_Eats u1 u2) (Var s) (Var k)))" (*<*)
proof -
  obtain km::name and kn::name and j::name and k'::name and l::name and sl::name and sl'::name
     and m::name and n::name and sm::name and sm'::name and sn::name and sn'::name
    where atoms2: "atom km \<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i,kn,j,k',l,sl,sl',m,n,sm,sm',sn,sn')"
         "atom kn \<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i,j,k',l,sl,sl',m,n,sm,sm',sn,sn')"
         "atom j  \<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i,k',l,sl,sl',m,n,sm,sm',sn,sn')"
      and atoms: "atom k' \<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i,l,sl,sl',m,n,sm,sm',sn,sn')"
         "atom l  \<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i,sl,sl',m,n,sm,sm',sn,sn')"
         "atom sl \<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i,sl',m,n,sm,sm',sn,sn')"
         "atom sl'\<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i,m,n,sm,sm',sn,sn')"
         "atom m  \<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i,n,sm,sm',sn,sn')"
         "atom n  \<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i,sm,sm',sn,sn')"
         "atom sm \<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i,sm',sn,sn')"
         "atom sm'\<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i,sn,sn')"
         "atom sn \<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i,sn')"
         "atom sn'\<sharp> (s1,s2,s,k1,k2,k,t1,t2,u1,u2,v,i)"
    by (metis obtain_fresh)
  let ?hyp = "{HaddP k1 k2 (Var k'), OrdP k1, OrdP k2, SeqAppendP s1 (SUCC k1) s2 (SUCC k2) (Var s), SeqStTermP v i t1 u1 s1 k1, SeqStTermP v i t2 u2 s2 k2}"
  show ?thesis
     using sk atoms
     apply (auto simp: SeqStTermP.simps [of l "Var s" _ _ _ sl sl' m n sm sm' sn sn'])
     apply (rule cut_same [where A="OrdP k1 AND OrdP k2"])
     apply (metis Conj_I SeqStTermP_imp_OrdP thin1 thin2)
     apply (rule cut_same [OF exists_SeqAppendP [of s s1 "SUCC k1" s2 "SUCC k2"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule cut_same [OF exists_HaddP [where j=k' and x=k1 and y=k2]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Eats t1 t2) (Q_Eats u1 u2)))"])
     apply (simp_all (no_asm_simp))
     apply (rule Ex_I [where x="SUCC (SUCC (Var k'))"], simp)
     apply (rule Conj_I [OF _ Conj_I])
     apply (metis SeqStTermP_imp_VarP thin1)
     apply (blast intro: LstSeqP_SeqAppendP_Eats SeqStTermP_imp_LstSeqP [THEN cut1])
     proof (rule All2_SUCC_I, simp_all)
       show "?hyp \<turnstile> Ex sl (Ex sl'
              (HPair (SUCC (SUCC (Var k'))) (HPair (Var sl) (Var sl')) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Eats t1 t2) (Q_Eats u1 u2))) AND
               ((Var sl EQ v AND Var sl' EQ i OR (IndP (Var sl) OR Var sl NEQ v) AND Var sl' EQ Var sl) OR
                Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn'
                 (Var m IN SUCC (SUCC (Var k')) AND
                  Var n IN SUCC (SUCC (Var k')) AND
                  HPair (Var m) (HPair (Var sm) (Var sm')) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Eats t1 t2) (Q_Eats u1 u2))) AND
                  HPair (Var n) (HPair (Var sn) (Var sn')) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Eats t1 t2) (Q_Eats u1 u2))) AND
                  Var sl EQ Q_Eats (Var sm) (Var sn) AND Var sl' EQ Q_Eats (Var sm') (Var sn'))))))))))"
       \<comment> \<open>verifying the final values\<close>
       apply (rule Ex_I [where x="Q_Eats t1 t2"])
       using sk atoms apply simp
       apply (rule Ex_I [where x="Q_Eats u1 u2"], simp)
       apply (rule Conj_I, metis Mem_Eats_I2 Refl)
       apply (rule Disj_I2)
       apply (rule Ex_I [where x=k1], simp)
       apply (rule Ex_I [where x="SUCC (Var k')"], simp)
       apply (rule Ex_I [where x=t1], simp)
       apply (rule Ex_I [where x=u1], simp)
       apply (rule Ex_I [where x=t2], simp)
       apply (rule Ex_I [where x=u2], simp)
       apply (rule Conj_I)
       apply (blast intro: HaddP_Mem_I LstSeqP_OrdP Mem_SUCC_I1)
       apply (rule Conj_I [OF Mem_SUCC_Refl Conj_I])
       apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem1 [THEN cut3] Mem_SUCC_Refl SeqStTermP_imp_LstSeqP [THEN cut1]
                           LstSeqP_imp_Mem)
       apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] Mem_SUCC_Refl SeqStTermP_imp_LstSeqP [THEN cut1]
                           HaddP_SUCC1 [THEN cut1] LstSeqP_imp_Mem)
       done
     next
       show "?hyp \<turnstile> All2 l (SUCC (SUCC (Var k')))
                (Ex sl (Ex sl'
                  (HPair (Var l) (HPair (Var sl) (Var sl')) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Eats t1 t2) (Q_Eats u1 u2))) AND
                   ((Var sl EQ v AND Var sl' EQ i OR (IndP (Var sl) OR Var sl NEQ v) AND Var sl' EQ Var sl) OR
                    Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn'
                       (Var m IN Var l AND
                        Var n IN Var l AND
                        HPair (Var m) (HPair (Var sm) (Var sm')) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Eats t1 t2) (Q_Eats u1 u2))) AND
                        HPair (Var n) (HPair (Var sn) (Var sn')) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Eats t1 t2) (Q_Eats u1 u2))) AND
                        Var sl EQ Q_Eats (Var sm) (Var sn) AND Var sl' EQ Q_Eats (Var sm') (Var sn')))))))))))"
     \<comment> \<open>verifying the sequence buildup\<close>
     apply (rule cut_same [where A="HaddP (SUCC k1) (SUCC k2) (SUCC (SUCC (Var k')))"])
     apply (blast intro: HaddP_SUCC1 [THEN cut1] HaddP_SUCC2 [THEN cut1])
     apply (rule All_I Imp_I)+
     apply (rule HaddP_Mem_cases [where i=j])
     using sk atoms atoms2 apply simp_all
     apply (rule AssumeH)
     apply (blast intro: OrdP_SUCC_I LstSeqP_OrdP)
     \<comment> \<open>... the sequence buildup via s1\<close>
     apply (simp add: SeqStTermP.simps [of l s1 _ _ _ sl sl' m n sm sm' sn sn'])
     apply (rule AssumeH Ex_EH Conj_EH)+
     apply (rule All2_E [THEN rotate2])
     apply (simp | rule AssumeH Ex_EH Conj_EH)+
     apply (rule Ex_I [where x="Var sl"], simp)
     apply (rule Ex_I [where x="Var sl'"], simp)
     apply (rule Conj_I)
     apply (metis Mem_Eats_I1 SeqAppendP_Mem1 rotate3 thin2 thin4)
     apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
     apply (rule Ex_I [where x="Var m"], simp)
     apply (rule Ex_I [where x="Var n"], simp)
     apply (rule Ex_I [where x="Var sm"], simp)
     apply (rule Ex_I [where x="Var sm'"], simp)
     apply (rule Ex_I [where x="Var sn"], simp)
     apply (rule Ex_I [where x="Var sn'"], simp_all)
     apply (rule Conj_I, rule AssumeH)+
     apply (blast del: Disj_EH intro: OrdP_Trans [OF OrdP_SUCC_I] Mem_Eats_I1 [OF SeqAppendP_Mem1 [THEN cut3]] Hyp)
     \<comment> \<open>... the sequence buildup via s2\<close>
     apply (simp add: SeqStTermP.simps [of l s2 _ _ _ sl sl' m n sm sm' sn sn'])
     apply (rule AssumeH Ex_EH Conj_EH)+
     apply (rule All2_E [THEN rotate2])
     apply (simp | rule AssumeH Ex_EH Conj_EH)+
     apply (rule Ex_I [where x="Var sl"], simp)
     apply (rule Ex_I [where x="Var sl'"], simp)
     apply (rule cut_same [where A="OrdP (Var j)"])
     apply (metis HaddP_imp_OrdP rotate2 thin2)
     apply (rule Conj_I)
     apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] del: Disj_EH)
     apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
     apply simp_all
     apply (rule cut_same [OF exists_HaddP [where j=km and x="SUCC k1" and y="Var m"]])
     apply (blast intro!: Ord_IN_Ord, simp)
     apply (rule cut_same [OF exists_HaddP [where j=kn and x="SUCC k1" and y="Var n"]])
     apply (blast intro!: Ord_IN_Ord, simp)
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule Ex_I [where x="Var km"], simp)
     apply (rule Ex_I [where x="Var kn"], simp)
     apply (rule Ex_I [where x="Var sm"], simp)
     apply (rule Ex_I [where x="Var sm'"], simp)
     apply (rule Ex_I [where x="Var sn"], simp)
     apply (rule Ex_I [where x="Var sn'"], simp_all)
     apply (rule Conj_I [OF _ Conj_I])
     apply (blast intro!: HaddP_Mem_cancel_left [THEN Iff_MP2_same] OrdP_SUCC_I intro: LstSeqP_OrdP Hyp)+
     apply (blast intro: OrdP_Trans Hyp Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] HaddP_imp_OrdP [THEN cut1])
     done
   qed
qed (*>*)

theorem SubstTermP_Eats:
   "{SubstTermP v i t1 u1, SubstTermP v i t2 u2} \<turnstile> SubstTermP v i (Q_Eats t1 t2) (Q_Eats u1 u2)"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (v,i,t1,u1,t2,u2)" "atom k1 \<sharp> (v,i,t1,u1,t2,u2,s1)"
          "atom s2 \<sharp> (v,i,t1,u1,t2,u2,k1,s1)" "atom k2 \<sharp> (v,i,t1,u1,t2,u2,s2,k1,s1)"
          "atom s  \<sharp> (v,i,t1,u1,t2,u2,k2,s2,k1,s1)"
          "atom k  \<sharp> (v,i,t1,u1,t2,u2,s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
   thus ?thesis
     by (auto intro!: SeqStTermP_Eats [THEN cut2]
              simp: SubstTermP.simps [of s _ _ _ "(Q_Eats u1 u2)" k]
                    SubstTermP.simps [of s1 v i t1 u1 k1]
                    SubstTermP.simps [of s2 v i t2 u2 k2])
qed

subsection \<open>Substitution over a constant\<close>

lemma SeqConstP_lemma:
  assumes "atom m \<sharp> (s,k,c,n,sm,sn)"  "atom n \<sharp> (s,k,c,sm,sn)"
          "atom sm \<sharp> (s,k,c,sn)"      "atom sn \<sharp> (s,k,c)"
    shows "{ SeqConstP s k c }
           \<turnstile> c EQ Zero OR
             Ex m (Ex n (Ex sm (Ex sn (Var m IN k AND Var n IN k AND
                   SeqConstP s (Var m) (Var sm) AND
                   SeqConstP s (Var n) (Var sn) AND
                   c EQ Q_Eats (Var sm) (Var sn)))))"  (*<*)
proof -
  obtain l::name and sl::name where "atom l \<sharp> (s,k,c,sl,m,n,sm,sn)" "atom sl \<sharp> (s,k,c,m,n,sm,sn)"
    by (metis obtain_fresh)
  thus ?thesis using assms
    apply (simp add: SeqCTermP.simps [of l s k sl m n sm sn])
    apply (rule Conj_EH)+
    apply (rule All2_SUCC_E [THEN rotate2], auto del: Disj_EH)
    apply (rule cut_same [where A = "c EQ (Var sl)"])
    apply (metis Assume AssumeH(4) LstSeqP_EQ)
    apply (rule Disj_EH)
    apply (blast intro: Disj_I1 Sym Trans)
    \<comment> \<open>now the quantified case\<close>
    apply (auto intro!: Disj_I2)
    apply (rule Ex_I [where x = "Var m"], simp)
    apply (rule Ex_I [where x = "Var n"], simp)
    apply (rule Ex_I [where x = "Var sm"], simp)
    apply (rule Ex_I [where x = "Var sn"], simp)
    apply (simp_all add: SeqCTermP.simps [of l s _ sl m n sm sn])
    apply ((rule Conj_I)+, blast intro: LstSeqP_Mem)+
    \<comment> \<open>first SeqCTermP subgoal\<close>
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    \<comment> \<open>next SeqCTermP subgoal\<close>
    apply ((rule Conj_I)+, blast intro: LstSeqP_Mem)+
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    \<comment> \<open>finally, the equality pair\<close>
    apply (blast intro: Trans)
    done
qed (*>*)

lemma SeqConstP_imp_SubstTermP: "{SeqConstP s kk c, TermP t} \<turnstile> SubstTermP \<guillemotleft>Var w\<guillemotright> t c c" (*<*)
proof -
  obtain j::name and k::name and l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms: "atom j \<sharp> (s,kk,c,t,k,l,sl,m,n,sm,sn)"  "atom k \<sharp> (s,kk,c,t,l,sl,m,n,sm,sn)"
                 "atom l \<sharp> (s,kk,c,t,sl,m,n,sm,sn)"   "atom sl \<sharp> (s,kk,c,t,m,n,sm,sn)"
                 "atom m \<sharp> (s,kk,c,t,n,sm,sn)"  "atom n \<sharp> (s,kk,c,t,sm,sn)"
                 "atom sm \<sharp> (s,kk,c,t,sn)"      "atom sn \<sharp> (s,kk,c,t)"
    by (metis obtain_fresh)
  have "{ OrdP (Var k), TermP t } \<turnstile> All j (SeqConstP s (Var k) (Var j) IMP SubstTermP \<guillemotleft>Var w\<guillemotright> t (Var j) (Var j))"
        (is "_ \<turnstile> ?scheme")
    proof (rule OrdIndH [where j=l])
      show "atom l \<sharp> (k, ?scheme)" using atoms
        by simp
    next
      show "{TermP t} \<turnstile> All k (OrdP (Var k) IMP (All2 l (Var k) (?scheme(k::= Var l)) IMP ?scheme))"
        using atoms apply auto
        apply (rule Swap)
        apply (rule cut_same)
        apply (rule cut1 [OF SeqConstP_lemma [of m s "Var k" "Var j" n sm sn]], auto)
        \<comment> \<open>case 1, @{term Zero}\<close>
        apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same])
        apply (auto intro: SubstTermP_Zero [THEN cut1])
        \<comment> \<open>case 2, @{term Q_Eats}\<close>
        apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same, THEN rotate2], simp)
        apply (rule SubstTermP_Eats [THEN cut2])
        \<comment> \<open>First argument\<close>
        apply (rule All2_E' [OF Hyp, where x="Var m"], blast+, simp_all)
        apply (force intro: All_E [where x="Var sm"])
        \<comment> \<open>Second argument\<close>
        apply (rule All2_E' [OF Hyp, where x="Var n"], blast+, simp_all)
        apply (rule All_E [where x="Var sn"], auto)
        done
    qed
  hence "{OrdP (Var k), TermP t} \<turnstile> (SeqConstP s (Var k) (Var j) IMP SubstTermP \<guillemotleft>Var w\<guillemotright> t (Var j) (Var j))(j::=c)"
    by (metis All_D)
  hence "{TermP t} \<turnstile> (SeqConstP s (Var k) c IMP SubstTermP \<guillemotleft>Var w\<guillemotright> t c c)"
    using atoms by simp (metis Imp_cut SeqCTermP_imp_OrdP)
  hence "{TermP t} \<turnstile> (SeqConstP s (Var k) c IMP SubstTermP \<guillemotleft>Var w\<guillemotright> t c c)(k::=kk)"
    using atoms by (force intro!: Subst)
  thus ?thesis
    using atoms by (simp add: anti_deduction)
qed (*>*)

theorem SubstTermP_Const: "{ConstP c, TermP t} \<turnstile> SubstTermP \<guillemotleft>Var w\<guillemotright> t c c"
proof -
  obtain s::name and k::name where "atom s \<sharp> (c,t,w,k)" "atom k \<sharp> (c,t,w)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: CTermP.simps [of k s c] SeqConstP_imp_SubstTermP)
qed

section \<open>Substitution on Formulas\<close>

subsection \<open>Membership\<close>

lemma SubstAtomicP_Mem:
  "{SubstTermP v i x x', SubstTermP v i y y'} \<turnstile> SubstAtomicP v i (Q_Mem x y) (Q_Mem x' y')"
proof -
  obtain t::name and u::name and t'::name and u'::name
    where "atom t \<sharp> (v,i,x,x',y,y',t',u,u')" "atom t' \<sharp> (v,i,x,x',y,y',u,u')"
      "atom u \<sharp> (v,i,x,x',y,y',u')" "atom u' \<sharp> (v,i,x,x',y,y')"
    by (metis obtain_fresh)
  thus ?thesis
    apply (simp add: SubstAtomicP.simps [of t _ _ _ _ t' u u'])
    apply (rule Ex_I [where x = x], simp)
    apply (rule Ex_I [where x = y], simp)
    apply (rule Ex_I [where x = x'], simp)
    apply (rule Ex_I [where x = y'], auto intro: Disj_I2)
    done
qed

lemma SeqSubstFormP_Mem:
  assumes "atom s \<sharp> (k,x,y,x',y',v,i)" "atom k \<sharp> (x,y,x',y',v,i)"
  shows "{SubstTermP v i x x', SubstTermP v i y y'}
           \<turnstile> Ex s (Ex k (SeqSubstFormP v i (Q_Mem x y) (Q_Mem x' y') (Var s) (Var k)))"
proof -
  let ?vs = "(s,k,x,y,x',y',v,i)"
  obtain l::name and sl::name and sl'::name and m::name and n::name and sm::name and sm'::name and sn::name and sn'::name
    where "atom l \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn')"
      "atom sl \<sharp> (?vs,sl',m,n,sm,sm',sn,sn')" "atom sl' \<sharp> (?vs,m,n,sm,sm',sn,sn')"
      "atom m \<sharp> (?vs,n,sm,sm',sn,sn')" "atom n \<sharp> (?vs,sm,sm',sn,sn')"
      "atom sm \<sharp> (?vs,sm',sn,sn')" "atom sm' \<sharp> (?vs,sn,sn')"
      "atom sn \<sharp> (?vs,sn')" "atom sn' \<sharp> ?vs"
    by (metis obtain_fresh)
  thus ?thesis
    using assms
    apply (auto simp: SeqSubstFormP.simps [of l "Var s" _ _ _ sl sl' m n sm sm' sn sn'])
    apply (rule Ex_I [where x = "Eats Zero (HPair Zero (HPair (Q_Mem x y) (Q_Mem x' y')))"], simp)
    apply (rule Ex_I [where x = Zero], auto intro!: Mem_SUCC_EH)
    apply (rule Ex_I [where x = "Q_Mem x y"], simp)
    apply (rule Ex_I [where x = "Q_Mem x' y'"], auto intro: Mem_Eats_I2 HPair_cong)
    apply (blast intro: SubstAtomicP_Mem [THEN cut2] Disj_I1)
    done
qed

lemma SubstFormP_Mem:
  "{SubstTermP v i x x', SubstTermP v i y y'} \<turnstile> SubstFormP v i (Q_Mem x y) (Q_Mem x' y')"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (v,i,x,y,x',y')" "atom k1 \<sharp> (v,i,x,y,x',y',s1)"
      "atom s2 \<sharp> (v,i,x,y,x',y',k1,s1)" "atom k2 \<sharp> (v,i,x,y,x',y',s2,k1,s1)"
      "atom s  \<sharp> (v,i,x,y,x',y',k2,s2,k1,s1)" "atom k  \<sharp> (v,i,x,y,x',y',s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SubstFormP.simps [of s v i "(Q_Mem x y)" _ k]
        SubstFormP.simps [of s1 v i x x' k1]
        SubstFormP.simps [of s2 v i y y' k2]
        intro: SubstTermP_imp_TermP SubstTermP_imp_VarP SeqSubstFormP_Mem thin1)
qed

subsection \<open>Equality\<close>

lemma SubstAtomicP_Eq:
  "{SubstTermP v i x x', SubstTermP v i y y'} \<turnstile> SubstAtomicP v i (Q_Eq x y) (Q_Eq x' y')"
proof -
  obtain t::name and u::name and t'::name  and u'::name
    where "atom t \<sharp> (v,i,x,x',y,y',t',u,u')" "atom t' \<sharp> (v,i,x,x',y,y',u,u')"
      "atom u \<sharp> (v,i,x,x',y,y',u')" "atom u' \<sharp> (v,i,x,x',y,y')"
    by (metis obtain_fresh)
  thus ?thesis
    apply (simp add: SubstAtomicP.simps [of t _ _ _ _ t' u u'])
    apply (rule Ex_I [where x = x], simp)
    apply (rule Ex_I [where x = y], simp)
    apply (rule Ex_I [where x = x'], simp)
    apply (rule Ex_I [where x = y'], auto intro: Disj_I1)
    done
qed

lemma SeqSubstFormP_Eq:
  assumes sk: "atom s \<sharp> (k,x,y,x',y',v,i)" "atom k \<sharp> (x,y,x',y',v,i)"
  shows "{SubstTermP v i x x', SubstTermP v i y y'}
           \<turnstile> Ex s (Ex k (SeqSubstFormP v i (Q_Eq x y) (Q_Eq x' y') (Var s) (Var k)))"
proof -
  let ?vs = "(s,k,x,y,x',y',v,i)"
  obtain l::name and sl::name and sl'::name and m::name and n::name and sm::name and sm'::name and sn::name and sn'::name
    where "atom l \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn')"
      "atom sl \<sharp> (?vs,sl',m,n,sm,sm',sn,sn')" "atom sl' \<sharp> (?vs,m,n,sm,sm',sn,sn')"
      "atom m \<sharp> (?vs,n,sm,sm',sn,sn')" "atom n \<sharp> (?vs,sm,sm',sn,sn')"
      "atom sm \<sharp> (?vs,sm',sn,sn')" "atom sm' \<sharp> (?vs,sn,sn')"
      "atom sn \<sharp> (?vs,sn')" "atom sn' \<sharp> ?vs"
    by (metis obtain_fresh)
  thus ?thesis
    using sk
    apply (auto simp: SeqSubstFormP.simps [of l "Var s" _ _ _ sl sl' m n sm sm' sn sn'])
    apply (rule Ex_I [where x = "Eats Zero (HPair Zero (HPair (Q_Eq x y) (Q_Eq x' y')))"], simp)
    apply (rule Ex_I [where x = Zero], auto intro!: Mem_SUCC_EH)
    apply (rule Ex_I [where x = "Q_Eq x y"], simp)
    apply (rule Ex_I [where x = "Q_Eq x' y'"], auto)
     apply (metis Mem_Eats_I2 Assume HPair_cong Refl)
    apply (blast intro: SubstAtomicP_Eq [THEN cut2] Disj_I1)
    done
qed

lemma SubstFormP_Eq:
  "{SubstTermP v i x x', SubstTermP v i y y'} \<turnstile> SubstFormP v i (Q_Eq x y) (Q_Eq x' y')"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (v,i,x,y,x',y')" "atom k1 \<sharp> (v,i,x,y,x',y',s1)"
      "atom s2 \<sharp> (v,i,x,y,x',y',k1,s1)" "atom k2 \<sharp> (v,i,x,y,x',y',s2,k1,s1)"
      "atom s  \<sharp> (v,i,x,y,x',y',k2,s2,k1,s1)" "atom k  \<sharp> (v,i,x,y,x',y',s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SubstFormP.simps [of s v i "(Q_Eq x y)" _ k]
        SubstFormP.simps [of s1 v i x x' k1]
        SubstFormP.simps [of s2 v i y y' k2]
        intro: SeqSubstFormP_Eq SubstTermP_imp_TermP SubstTermP_imp_VarP thin1)
qed

subsection \<open>Negation\<close>

lemma SeqSubstFormP_Neg:
  assumes "atom s \<sharp> (k,s1,k1,x,x',v,i)" "atom k \<sharp> (s1,k1,x,x',v,i)"
  shows "{SeqSubstFormP v i x x' s1 k1, TermP i, VarP v}
           \<turnstile> Ex s (Ex k (SeqSubstFormP v i (Q_Neg x) (Q_Neg x') (Var s) (Var k)))" (*<*)
proof -
  let ?vs = "(s1,k1,s,k,x,x',v,i)"
  obtain l::name and sl::name and sl'::name and m::name and n::name and
    sm::name and sm'::name and sn::name and sn'::name
    where atoms:
      "atom l \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn')"
      "atom sl \<sharp> (?vs,sl',m,n,sm,sm',sn,sn')" "atom sl' \<sharp> (?vs,m,n,sm,sm',sn,sn')"
      "atom m \<sharp> (?vs,n,sm,sm',sn,sn')" "atom n \<sharp> (?vs,sm,sm',sn,sn')"
      "atom sm \<sharp> (?vs,sm',sn,sn')" "atom sm' \<sharp> (?vs,sn,sn')"
      "atom sn \<sharp> (?vs,sn')" "atom sn' \<sharp> ?vs"
    by (metis obtain_fresh)
  let ?hyp = "{RestrictedP s1 (SUCC k1) (Var s), OrdP k1, SeqSubstFormP v i x x' s1 k1, TermP i, VarP v}"
  show ?thesis
    using assms atoms
    apply (auto simp: SeqSubstFormP.simps [of l "Var s" _ _ _ sl sl' m n sm sm' sn sn'])
    apply (rule cut_same [where A="OrdP k1"])
     apply (metis SeqSubstFormP_imp_OrdP thin2)
    apply (rule cut_same [OF exists_RestrictedP [of s s1 "SUCC k1"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
      apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC k1) (HPair (Q_Neg x) (Q_Neg x')))"])
      apply (simp_all (no_asm_simp))
    apply (rule Ex_I [where x="(SUCC k1)"])
    apply (simp add: flip_fresh_fresh)
    apply (rule Conj_I)
     apply (blast intro: RestrictedP_LstSeqP_Eats [THEN cut2] SeqSubstFormP_imp_LstSeqP [THEN cut1])
  proof (rule All2_SUCC_I, simp_all)
    show "?hyp \<turnstile> Ex sl (Ex sl'
              (HPair (SUCC k1) (HPair (Var sl) (Var sl')) IN Eats (Var s) (HPair (SUCC k1) (HPair (Q_Neg x) (Q_Neg x'))) AND
               (SubstAtomicP v i (Var sl) (Var sl') OR
                Ex m (Ex n
                   (Ex sm (Ex sm'
                       (Ex sn (Ex sn'
                       (Var m IN SUCC k1 AND
                        Var n IN SUCC k1 AND
                        HPair (Var m) (HPair (Var sm) (Var sm')) IN Eats (Var s) (HPair (SUCC k1) (HPair (Q_Neg x) (Q_Neg x'))) AND
                        HPair (Var n) (HPair (Var sn) (Var sn')) IN Eats (Var s) (HPair (SUCC k1) (HPair (Q_Neg x) (Q_Neg x'))) AND
                        (Var sl EQ Q_Disj (Var sm) (Var sn) AND Var sl' EQ Q_Disj (Var sm') (Var sn') OR
                          Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm') OR Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm')))))))))))"
      \<comment> \<open>verifying the final values\<close>
      apply (rule Ex_I [where x="Q_Neg x"])
      using assms atoms apply simp
      apply (rule Ex_I [where x="Q_Neg x'"], simp)
      apply (rule Conj_I, metis Mem_Eats_I2 Refl)
      apply (rule Disj_I2)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule_tac x=x' in Ex_I, simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule_tac x=x' in Ex_I, simp)
      apply (rule Conj_I [OF Mem_SUCC_Refl])+
      apply (blast intro: Disj_I1 Disj_I2 Mem_Eats_I1 RestrictedP_Mem [THEN cut3] Mem_SUCC_Refl
          SeqSubstFormP_imp_LstSeqP [THEN cut1] LstSeqP_imp_Mem)
      done
  next
    show "?hyp \<turnstile> All2 l (SUCC k1)
                (Ex sl (Ex sl'
                    (HPair (Var l) (HPair (Var sl) (Var sl')) IN Eats (Var s) (HPair (SUCC k1) (HPair (Q_Neg x) (Q_Neg x'))) AND
                     (SubstAtomicP v i (Var sl) (Var sl') OR
                      Ex m (Ex n
                         (Ex sm (Ex sm'
                             (Ex sn (Ex sn'
                                 (Var m IN Var l AND
                                  Var n IN Var l AND
                                  HPair (Var m) (HPair (Var sm) (Var sm')) IN Eats (Var s) (HPair (SUCC k1) (HPair (Q_Neg x) (Q_Neg x'))) AND
                                  HPair (Var n) (HPair (Var sn) (Var sn')) IN Eats (Var s) (HPair (SUCC k1) (HPair (Q_Neg x) (Q_Neg x'))) AND
                                  (Var sl EQ Q_Disj (Var sm) (Var sn) AND Var sl' EQ Q_Disj (Var sm') (Var sn') OR
                            Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm') OR Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm'))))))))))))"
      \<comment> \<open>verifying the sequence buildup\<close>
      apply (rule All_I Imp_I)+
      using assms atoms apply simp_all
        \<comment> \<open>... the sequence buildup via s1\<close>
      apply (simp add: SeqSubstFormP.simps [of l s1 _ _ _ sl sl' m n sm sm' sn sn'])
      apply (rule AssumeH Ex_EH Conj_EH)+
      apply (rule All2_E [THEN rotate2], auto del: Disj_EH)
      apply (rule Ex_I [where x="Var sl"], simp)
      apply (rule Ex_I [where x="Var sl'"], simp)
      apply (rule Conj_I)
       apply (blast intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] del: Disj_EH)
      apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
                  apply (rule Ex_I [where x="Var m"], simp)
                  apply (rule Ex_I [where x="Var n"], simp)
                  apply (rule Ex_I [where x="Var sm"], simp)
                  apply (rule Ex_I [where x="Var sm'"], simp)
                  apply (rule Ex_I [where x="Var sn"], simp)
                  apply (rule Ex_I [where x="Var sn'"], auto del: Disj_EH)
       apply (blast intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] OrdP_Trans [OF OrdP_SUCC_I])+
      done
  qed
qed (*>*)

theorem SubstFormP_Neg: "{SubstFormP v i x x'} \<turnstile> SubstFormP v i (Q_Neg x) (Q_Neg x')"
proof -
  obtain k1::name and s1::name and k::name and s::name
    where "atom s1 \<sharp> (v,i,x,x')"        "atom k1 \<sharp> (v,i,x,x',s1)"
      "atom s  \<sharp> (v,i,x,x',k1,s1)"  "atom k  \<sharp> (v,i,x,x',s,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: SubstFormP.simps [of s v i "Q_Neg x" _ k] SubstFormP.simps [of s1 v i x x' k1]
        intro: SeqSubstFormP_Neg [THEN cut3])
qed

subsection \<open>Disjunction\<close>

lemma SeqSubstFormP_Disj:
  assumes "atom s \<sharp> (k,s1,s2,k1,k2,x,y,x',y',v,i)" "atom k \<sharp> (s1,s2,k1,k2,x,y,x',y',v,i)"
  shows "{SeqSubstFormP v i x x' s1 k1,
            SeqSubstFormP v i y y' s2 k2, TermP i, VarP v}
           \<turnstile> Ex s (Ex k (SeqSubstFormP v i (Q_Disj x y) (Q_Disj x' y') (Var s) (Var k)))" (*<*)
proof -
  let ?vs = "(s1,s2,s,k1,k2,k,x,y,x',y',v,i)"
  obtain km::name and kn::name and j::name and k'::name
    and l::name and sl::name and sl'::name and m::name and n::name
    and sm::name and sm'::name and sn::name and sn'::name
    where atoms2: "atom km \<sharp> (kn,j,k',l,s1,s2,s,k1,k2,k,x,y,x',y',v,i,sl,sl',m,n,sm,sm',sn,sn')"
      "atom kn \<sharp> (j,k',l,s1,s2,s,k1,k2,k,x,y,x',y',v,i,sl,sl',m,n,sm,sm',sn,sn')"
      "atom j \<sharp> (k',l,s1,s2,s,k1,k2,k,x,y,x',y',v,i,sl,sl',m,n,sm,sm',sn,sn')"
      and atoms: "atom k' \<sharp> (l,s1,s2,s,k1,k2,k,x,y,x',y',v,i,sl,sl',m,n,sm,sm',sn,sn')"
      "atom l \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,sl,sl',m,n,sm,sm',sn,sn')"
      "atom sl \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,sl',m,n,sm,sm',sn,sn')"
      "atom sl' \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,m,n,sm,sm',sn,sn')"
      "atom m \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,n,sm,sm',sn,sn')"
      "atom n \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,sm,sm',sn,sn')"
      "atom sm \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,sm',sn,sn')"
      "atom sm' \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,sn,sn')"
      "atom sn \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,sn')"
      "atom sn' \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i)"
    by (metis obtain_fresh)
  let ?hyp = "{HaddP k1 k2 (Var k'), OrdP k1, OrdP k2, SeqAppendP s1 (SUCC k1) s2 (SUCC k2) (Var s),
               SeqSubstFormP v i x x' s1 k1, SeqSubstFormP v i y y' s2 k2, TermP i, VarP v}"
  show ?thesis
    using assms atoms
    apply (auto simp: SeqSubstFormP.simps [of l "Var s" _ _ _ sl sl' m n sm sm' sn sn'])
    apply (rule cut_same [where A="OrdP k1 AND OrdP k2"])
     apply (metis Conj_I SeqSubstFormP_imp_OrdP thin1 thin2)
    apply (rule cut_same [OF exists_SeqAppendP [of s s1 "SUCC k1" s2 "SUCC k2"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
      apply (rule cut_same [OF exists_HaddP [where j=k' and x=k1 and y=k2]])
        apply (rule AssumeH Ex_EH Conj_EH | simp)+
        apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC(SUCC(Var k'))) (HPair(Q_Disj x y)(Q_Disj x' y')))"])
        apply (simp_all (no_asm_simp))
    apply (rule Ex_I [where x="SUCC (SUCC (Var k'))"], simp)
    apply (rule Conj_I)
     apply (blast intro: LstSeqP_SeqAppendP_Eats SeqSubstFormP_imp_LstSeqP [THEN cut1])
  proof (rule All2_SUCC_I, simp_all)
    show "?hyp \<turnstile> Ex sl (Ex sl'
                 (HPair (SUCC (SUCC (Var k'))) (HPair (Var sl) (Var sl')) IN
                  Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Disj x y) (Q_Disj x' y'))) AND
                  (SubstAtomicP v i (Var sl) (Var sl') OR
                   Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn'
                      (Var m IN SUCC (SUCC (Var k')) AND
                       Var n IN SUCC (SUCC (Var k')) AND
                       HPair (Var m) (HPair (Var sm) (Var sm')) IN
                       Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Disj x y) (Q_Disj x' y'))) AND
                       HPair (Var n) (HPair (Var sn) (Var sn')) IN
                       Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Disj x y) (Q_Disj x' y'))) AND
                       (Var sl EQ Q_Disj (Var sm) (Var sn) AND Var sl' EQ Q_Disj (Var sm') (Var sn') OR
                          Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm') OR Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm')))))))))))"
      \<comment> \<open>verifying the final values\<close>
      apply (rule Ex_I [where x="Q_Disj x y"])
      using assms atoms apply simp
      apply (rule Ex_I [where x="Q_Disj x' y'"], simp)
      apply (rule Conj_I, metis Mem_Eats_I2 Refl)
      apply (rule Disj_I2)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x="SUCC (Var k')"], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule_tac x=x' in Ex_I, simp)
      apply (rule Ex_I [where x=y], simp)
      apply (rule_tac x=y' in Ex_I, simp)
      apply (rule Conj_I)
       apply (blast intro: HaddP_Mem_I LstSeqP_OrdP Mem_SUCC_I1)
      apply (rule Conj_I [OF Mem_SUCC_Refl])
      apply (blast intro: Disj_I1 Mem_Eats_I1 Mem_SUCC_Refl SeqSubstFormP_imp_LstSeqP [THEN cut1]
          LstSeqP_imp_Mem SeqAppendP_Mem1 [THEN cut3] SeqAppendP_Mem2 [THEN cut4] HaddP_SUCC1 [THEN cut1])
      done
  next
    show "?hyp \<turnstile>  All2 l (SUCC (SUCC (Var k')))
     (Ex sl
       (Ex sl'
         (HPair (Var l) (HPair (Var sl) (Var sl')) IN
          Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Disj x y) (Q_Disj x' y'))) AND
          (SubstAtomicP v i (Var sl) (Var sl') OR
           Ex m (Ex n
              (Ex sm (Ex sm'
                  (Ex sn (Ex sn'
                      (Var m IN Var l AND
                       Var n IN Var l AND
                       HPair (Var m) (HPair (Var sm) (Var sm')) IN
                       Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Disj x y) (Q_Disj x' y'))) AND
                       HPair (Var n) (HPair (Var sn) (Var sn')) IN
                       Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (Q_Disj x y) (Q_Disj x' y'))) AND
                       (Var sl EQ Q_Disj (Var sm) (Var sn) AND Var sl' EQ Q_Disj (Var sm') (Var sn') OR
                            Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm') OR Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm'))))))))))))"
      \<comment> \<open>verifying the sequence buildup\<close>
      apply (rule cut_same [where A="HaddP (SUCC k1) (SUCC k2) (SUCC (SUCC (Var k')))"])
       apply (blast intro: HaddP_SUCC1 [THEN cut1] HaddP_SUCC2 [THEN cut1])
      apply (rule All_I Imp_I)+
       apply (rule HaddP_Mem_cases [where i=j])
      using assms atoms atoms2 apply simp_all
          apply (rule AssumeH)
         apply (blast intro: OrdP_SUCC_I LstSeqP_OrdP)
        \<comment> \<open>... the sequence buildup via s1\<close>
        apply (simp add: SeqSubstFormP.simps [of l s1 _ _ _ sl sl' m n sm sm' sn sn'])
        apply (rule AssumeH Ex_EH Conj_EH)+
        apply (rule All2_E [THEN rotate2])
          apply (simp | rule AssumeH Ex_EH Conj_EH)+
            apply (rule Ex_I [where x="Var sl"], simp)
            apply (rule Ex_I [where x="Var sl'"], simp)
            apply (rule Conj_I [OF Mem_Eats_I1])
             apply (metis SeqAppendP_Mem1 rotate3 thin2 thin4)
            apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
                        apply (rule Ex_I [where x="Var m"], simp)
                        apply (rule Ex_I [where x="Var n"], simp)
                        apply (rule Ex_I [where x="Var sm"], simp)
                        apply (rule Ex_I [where x="Var sm'"], simp)
                        apply (rule Ex_I [where x="Var sn"], simp)
                        apply (rule Ex_I [where x="Var sn'"], simp_all (no_asm_simp))
       apply (rule Conj_I, rule AssumeH)+
       apply (rule Conj_I)
        apply (blast intro: OrdP_Trans [OF OrdP_SUCC_I] Mem_Eats_I1 [OF SeqAppendP_Mem1 [THEN cut3]] Hyp)
       apply (blast intro: Disj_I1 Disj_I2 OrdP_Trans [OF OrdP_SUCC_I] Mem_Eats_I1 [OF SeqAppendP_Mem1 [THEN cut3]] Hyp)
        \<comment> \<open>... the sequence buildup via s2\<close>
      apply (simp add: SeqSubstFormP.simps [of l s2 _ _ _ sl sl' m n sm sm' sn sn'])
      apply (rule AssumeH Ex_EH Conj_EH)+
      apply (rule All2_E [THEN rotate2])
        apply (simp | rule AssumeH Ex_EH Conj_EH)+
          apply (rule Ex_I [where x="Var sl"], simp)
          apply (rule Ex_I [where x="Var sl'"], simp)
          apply (rule cut_same [where A="OrdP (Var j)"])
           apply (metis HaddP_imp_OrdP rotate2 thin2)
          apply (rule Conj_I)
           apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] del: Disj_EH)
          apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
                      apply (rule cut_same [OF exists_HaddP [where j=km and x="SUCC k1" and y="Var m"]])
                        apply (blast intro: Ord_IN_Ord, simp)
                      apply (rule cut_same [OF exists_HaddP [where j=kn and x="SUCC k1" and y="Var n"]])
                        apply (metis AssumeH(6) Ord_IN_Ord0 rotate8, simp)
                      apply (rule AssumeH Ex_EH Conj_EH | simp)+
                          apply (rule Ex_I [where x="Var km"], simp)
                          apply (rule Ex_I [where x="Var kn"], simp)
                          apply (rule Ex_I [where x="Var sm"], simp)
                          apply (rule Ex_I [where x="Var sm'"], simp)
                          apply (rule Ex_I [where x="Var sn"], simp)
                          apply (rule Ex_I [where x="Var sn'"], simp_all (no_asm_simp))
      apply (rule Conj_I [OF _ Conj_I])
        apply (blast intro!: HaddP_Mem_cancel_left [THEN Iff_MP2_same] OrdP_SUCC_I intro: LstSeqP_OrdP Hyp)+
      apply (blast del: Disj_EH  intro: OrdP_Trans Hyp
          intro!: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] HaddP_imp_OrdP [THEN cut1])
      done
  qed
qed (*>*)

theorem SubstFormP_Disj:
  "{SubstFormP v i x x', SubstFormP v i y y'} \<turnstile> SubstFormP v i (Q_Disj x y) (Q_Disj x' y')"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (v,i,x,y,x',y')"        "atom k1 \<sharp> (v,i,x,y,x',y',s1)"
      "atom s2 \<sharp> (v,i,x,y,x',y',k1,s1)"  "atom k2 \<sharp> (v,i,x,y,x',y',s2,k1,s1)"
      "atom s  \<sharp> (v,i,x,y,x',y',k2,s2,k1,s1)" "atom k  \<sharp> (v,i,x,y,x',y',s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: SubstFormP.simps [of s v i "Q_Disj x y" _ k]
        SubstFormP.simps [of s1 v i x x' k1]
        SubstFormP.simps [of s2 v i y y' k2]
        intro: SeqSubstFormP_Disj [THEN cut4])
qed

subsection \<open>Existential\<close>

lemma SeqSubstFormP_Ex:
  assumes "atom s \<sharp> (k,s1,k1,x,x',v,i)" "atom k \<sharp> (s1,k1,x,x',v,i)"
  shows "{SeqSubstFormP v i x x' s1 k1, TermP i, VarP v}
           \<turnstile> Ex s (Ex k (SeqSubstFormP v i (Q_Ex x) (Q_Ex x') (Var s) (Var k)))" (*<*)
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name
    and sm::name and sm'::name and sn::name and sn'::name
    where atoms:
      "atom l \<sharp> (s1,k1,s,k,x,x',v,i,sl,sl',m,n,sm,sm',sn,sn')"
      "atom sl \<sharp> (s1,k1,s,k,x,x',v,i,sl',m,n,sm,sm',sn,sn')"
      "atom sl' \<sharp> (s1,k1,s,k,x,x',v,i,m,n,sm,sm',sn,sn')"
      "atom m \<sharp> (s1,k1,s,k,x,x',v,i,n,sm,sm',sn,sn')"
      "atom n \<sharp> (s1,k1,s,k,x,x',v,i,sm,sm',sn,sn')"
      "atom sm \<sharp> (s1,k1,s,k,x,x',v,i,sm',sn,sn')"
      "atom sm' \<sharp> (s1,k1,s,k,x,x',v,i,sn,sn')"
      "atom sn \<sharp> (s1,k1,s,k,x,x',v,i,sn')"
      "atom sn' \<sharp> (s1,k1,s,k,x,x',v,i)"
    by (metis obtain_fresh)
  let ?hyp = "{RestrictedP s1 (SUCC k1) (Var s), OrdP k1, SeqSubstFormP v i x x' s1 k1, TermP i, VarP v}"
  show ?thesis
    using assms atoms
    apply (auto simp: SeqSubstFormP.simps [of l "Var s" _ _ _ sl sl' m n sm sm' sn sn'])
    apply (rule cut_same [where A="OrdP k1"])
     apply (metis SeqSubstFormP_imp_OrdP thin2)
    apply (rule cut_same [OF exists_RestrictedP [of s s1 "SUCC k1"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
      apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC k1) (HPair (Q_Ex x) (Q_Ex x')))"], simp)
      apply (rule Ex_I [where x="(SUCC k1)"], simp)
      apply (rule Conj_I)
       apply (blast intro: RestrictedP_LstSeqP_Eats [THEN cut2] SeqSubstFormP_imp_LstSeqP [THEN cut1])
  proof (rule All2_SUCC_I, simp_all)
    show "?hyp \<turnstile> Ex sl (Ex sl'
          (HPair (SUCC k1) (HPair (Var sl) (Var sl')) IN Eats (Var s) (HPair (SUCC k1) (HPair (Q_Ex x) (Q_Ex x'))) AND
           (SubstAtomicP v i (Var sl) (Var sl') OR
            Ex m (Ex n
               (Ex sm (Ex sm'
                   (Ex sn (Ex sn'
                       (Var m IN SUCC k1 AND
                        Var n IN SUCC k1 AND
                        HPair (Var m) (HPair (Var sm) (Var sm')) IN Eats (Var s) (HPair (SUCC k1) (HPair (Q_Ex x) (Q_Ex x'))) AND
                        HPair (Var n) (HPair (Var sn) (Var sn')) IN Eats (Var s) (HPair (SUCC k1) (HPair (Q_Ex x) (Q_Ex x'))) AND
                        (Var sl EQ Q_Disj (Var sm) (Var sn) AND Var sl' EQ Q_Disj (Var sm') (Var sn') OR
                          Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm') OR Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm')))))))))))"
      \<comment> \<open>verifying the final values\<close>
      apply (rule Ex_I [where x="Q_Ex x"])
      using assms atoms apply simp
      apply (rule Ex_I [where x="Q_Ex x'"], simp)
      apply (rule Conj_I, metis Mem_Eats_I2 Refl)
      apply (rule Disj_I2)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule_tac x=x' in Ex_I, simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule_tac x=x' in Ex_I, simp)
      apply (rule Conj_I [OF Mem_SUCC_Refl])+
      apply (blast intro: Disj_I2 Mem_Eats_I1 RestrictedP_Mem [THEN cut3] Mem_SUCC_Refl
          SeqSubstFormP_imp_LstSeqP [THEN cut1] LstSeqP_imp_Mem)
      done
  next
    show "?hyp
             \<turnstile> All2 l (SUCC k1)
                (Ex sl (Ex sl'
                    (HPair (Var l) (HPair (Var sl) (Var sl')) IN Eats (Var s) (HPair (SUCC k1) (HPair (Q_Ex x) (Q_Ex x'))) AND
                     (SubstAtomicP v i (Var sl) (Var sl') OR
                      Ex m (Ex n
                         (Ex sm (Ex sm'
                             (Ex sn (Ex sn'
                                 (Var m IN Var l AND
                                  Var n IN Var l AND
                                  HPair (Var m) (HPair (Var sm) (Var sm')) IN Eats (Var s) (HPair (SUCC k1) (HPair (Q_Ex x) (Q_Ex x'))) AND
                                  HPair (Var n) (HPair (Var sn) (Var sn')) IN Eats (Var s) (HPair (SUCC k1) (HPair (Q_Ex x) (Q_Ex x'))) AND
                                  (Var sl EQ Q_Disj (Var sm) (Var sn) AND Var sl' EQ Q_Disj (Var sm') (Var sn') OR
                            Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm') OR Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm'))))))))))))"
      \<comment> \<open>verifying the sequence buildup\<close>
      using assms atoms
        \<comment> \<open>... the sequence buildup via s1\<close>
      apply (auto simp add: SeqSubstFormP.simps [of l s1 _ _ _ sl sl' m n sm sm' sn sn'])
      apply (rule Swap)
      apply (rule All2_E, auto del: Disj_EH)
      apply (rule Ex_I [where x="Var sl"], simp)
      apply (rule Ex_I [where x="Var sl'"], simp)
      apply (rule Conj_I)
       apply (blast intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] del: Disj_EH)
      apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
                  apply (rule Ex_I [where x="Var m"], simp)
                  apply (rule Ex_I [where x="Var n"], simp)
                  apply (rule Ex_I [where x="Var sm"], simp)
                  apply (rule Ex_I [where x="Var sm'"], simp)
                  apply (rule Ex_I [where x="Var sn"], simp)
                  apply (rule Ex_I [where x="Var sn'"])
                  apply (auto intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] OrdP_Trans [OF OrdP_SUCC_I] del: Disj_EH)
      done
  qed
qed (*>*)

theorem SubstFormP_Ex: "{SubstFormP v i x x'} \<turnstile> SubstFormP v i (Q_Ex x) (Q_Ex x')"
proof -
  obtain k1::name and s1::name and k::name and s::name
    where "atom s1 \<sharp> (v,i,x,x')"        "atom k1 \<sharp> (v,i,x,x',s1)"
      "atom s  \<sharp> (v,i,x,x',k1,s1)"  "atom k  \<sharp> (v,i,x,x',s,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: SubstFormP.simps [of s v i "Q_Ex x" _ k] SubstFormP.simps [of s1 v i x x' k1]
        intro: SeqSubstFormP_Ex [THEN cut3])
qed

section \<open>Constant Terms\<close>

lemma ConstP_Zero: "{} \<turnstile> ConstP Zero"
proof -
  obtain s::name and k::name and l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms:
      "atom s \<sharp> (k,l,sl,m,n,sm,sn)"
      "atom k \<sharp> (l,sl,m,n,sm,sn)"
      "atom l \<sharp> (sl,m,n,sm,sn)"
      "atom sl \<sharp> (m,n,sm,sn)"
      "atom m \<sharp> (n,sm,sn)"
      "atom n \<sharp> (sm,sn)"
      "atom sm \<sharp> sn"
    by (metis obtain_fresh)
  then show ?thesis
    apply (subst CTermP.simps[of k s]; auto?)
    apply (rule Ex_I[of _ _ _ "Eats Zero (HPair Zero Zero)"]; auto?)
    apply (rule Ex_I[of _ _ _ "Zero"]; auto?)
    apply (subst SeqCTermP.simps[of l _ _ sl m n sm sn]; auto?)
    apply (rule Ex_I[of _ _ _ "Zero"]; auto?)
     apply (rule Mem_SUCC_E[OF Mem_Zero_E])
     apply (rule Mem_Eats_I2)
     apply (rule HPair_cong[OF Assume Refl])
    apply (rule Disj_I1[OF Refl])
    done
qed

lemma SeqConstP_Eats:
  assumes "atom s \<sharp> (k,s1,s2,k1,k2,t1,t2)" "atom k \<sharp> (s1,s2,k1,k2,t1,t2)"
    shows "{SeqConstP s1 k1 t1, SeqConstP s2 k2 t2}
           \<turnstile> Ex s (Ex k (SeqConstP (Var s) (Var k) (Q_Eats t1 t2)))" (*<*)
proof -
  obtain km::name and kn::name and j::name and k'::name
     and l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms:
         "atom km \<sharp> (kn,j,k',l,s1,s2,s,k1,k2,k,t1,t2,sl,m,n,sm,sn)"
         "atom kn \<sharp> (j,k',l,s1,s2,s,k1,k2,k,t1,t2,sl,m,n,sm,sn)"
         "atom j \<sharp> (k',l,s1,s2,s,k1,k2,k,t1,t2,sl,m,n,sm,sn)"
         "atom k' \<sharp> (l,s1,s2,s,k1,k2,k,t1,t2,sl,m,n,sm,sn)"
         "atom l \<sharp> (s1,s2,s,k1,k2,k,t1,t2,sl,m,n,sm,sn)"
         "atom sl \<sharp> (s1,s2,s,k1,k2,k,t1,t2,m,n,sm,sn)"
         "atom m \<sharp> (s1,s2,s,k1,k2,k,t1,t2,n,sm,sn)"
         "atom n \<sharp> (s1,s2,s,k1,k2,k,t1,t2,sm,sn)"
         "atom sm \<sharp> (s1,s2,s,k1,k2,k,t1,t2,sn)"
         "atom sn \<sharp> (s1,s2,s,k1,k2,k,t1,t2)"
    by (metis obtain_fresh)
  let ?hyp = "{HaddP k1 k2 (Var k'), OrdP k1, OrdP k2, SeqAppendP s1 (SUCC k1) s2 (SUCC k2) (Var s),
              SeqConstP s1 k1 t1, SeqConstP s2 k2 t2}"
  show ?thesis
     using assms atoms
     apply (auto simp: SeqCTermP.simps [of l "Var s" _ sl m n sm sn])
     apply (rule cut_same [where A="OrdP k1 AND OrdP k2"])
     apply (metis Conj_I SeqCTermP_imp_OrdP thin1 thin2)
     apply (rule cut_same [OF exists_SeqAppendP [of s s1 "SUCC k1" s2 "SUCC k2"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule cut_same [OF exists_HaddP [where j=k' and x=k1 and y=k2]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2))"], simp)
     apply (rule Ex_I [where x="SUCC (SUCC (Var k'))"], simp)
     apply (rule Conj_I)
     apply (blast intro: LstSeqP_SeqAppendP_Eats SeqCTermP_imp_LstSeqP [THEN cut1])
     proof (rule All2_SUCC_I, simp_all)
       show "?hyp \<turnstile> Ex sl (HPair (SUCC (SUCC (Var k'))) (Var sl) IN Eats (Var s)
                          (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2))   AND
                (Var sl EQ Zero OR Fls OR
                 Ex m (Ex n(Ex sm (Ex sn
                      (Var m IN SUCC (SUCC (Var k')) AND
                       Var n IN SUCC (SUCC (Var k')) AND
                       HPair (Var m) (Var sm) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2)) AND
                       HPair (Var n) (Var sn) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2)) AND
                       Var sl EQ Q_Eats (Var sm) (Var sn)))))))"
       \<comment> \<open>verifying the final values\<close>
       apply (rule Ex_I [where x="Q_Eats t1 t2"])
       using assms atoms apply simp
       apply (rule Conj_I, metis Mem_Eats_I2 Refl)
       apply (rule Disj_I2)+
       apply (rule Ex_I [where x=k1], simp)
       apply (rule Ex_I [where x="SUCC (Var k')"], simp)
       apply (rule Ex_I [where x=t1], simp)
       apply (rule Ex_I [where x=t2], simp)
       apply (rule Conj_I)
       apply (blast intro: HaddP_Mem_I LstSeqP_OrdP Mem_SUCC_I1)
       apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem1 [THEN cut3] SeqAppendP_Mem2 [THEN cut4]
                 Mem_SUCC_Refl SeqCTermP_imp_LstSeqP [THEN cut1] LstSeqP_imp_Mem HaddP_SUCC1 [THEN cut1])
       done
     next
       show "?hyp \<turnstile> All2 l (SUCC (SUCC (Var k')))
                 (Ex sl
                   (HPair (Var l) (Var sl) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2)) AND
                    (Var sl EQ Zero OR Fls OR
                     Ex m (Ex n (Ex sm (Ex sn
                          (Var m IN Var l AND
                           Var n IN Var l AND
                           HPair (Var m) (Var sm) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2)) AND
                           HPair (Var n) (Var sn) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2)) AND
                           Var sl EQ Q_Eats (Var sm) (Var sn))))))))"
     \<comment> \<open>verifying the sequence buildup\<close>
     apply (rule cut_same [where A="HaddP (SUCC k1) (SUCC k2) (SUCC (SUCC (Var k')))"])
     apply (blast intro: HaddP_SUCC1 [THEN cut1] HaddP_SUCC2 [THEN cut1])
     apply (rule All_I Imp_I)+
     apply (rule HaddP_Mem_cases [where i=j])
     using assms atoms apply simp_all
     apply (rule AssumeH)
     apply (blast intro: OrdP_SUCC_I LstSeqP_OrdP)
     \<comment> \<open>... the sequence buildup via s1\<close>
     apply (simp add: SeqCTermP.simps [of l s1 _ sl m n sm sn])
     apply (rule AssumeH Ex_EH Conj_EH)+
     apply (rule All2_E [THEN rotate2], auto del: Disj_EH)
     apply (rule Ex_I [where x="Var sl"], simp)
     apply (rule Conj_I)
     apply (rule Mem_Eats_I1)
     apply (metis SeqAppendP_Mem1 rotate3 thin2 thin4)
     apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
     apply simp_all
     apply (rule Ex_I [where x="Var m"], simp)
     apply (rule Ex_I [where x="Var n"], simp)
     apply (rule Ex_I [where x="Var sm"], simp)
     apply (rule Ex_I [where x="Var sn"], simp)
     apply (rule Conj_I, rule AssumeH)+
     apply (blast del: Disj_EH intro: OrdP_Trans [OF OrdP_SUCC_I] Mem_Eats_I1 [OF SeqAppendP_Mem1 [THEN cut3]] Hyp)
     \<comment> \<open>... the sequence buildup via s2\<close>
     apply (simp add: SeqCTermP.simps [of l s2 _ sl m n sm sn])
     apply (rule AssumeH Ex_EH Conj_EH)+
     apply (rule All2_E [THEN rotate2], auto del: Disj_EH)
     apply (rule Ex_I [where x="Var sl"], simp)
     apply (rule cut_same [where A="OrdP (Var j)"])
     apply (metis HaddP_imp_OrdP rotate2 thin2)
     apply (rule Conj_I)
     apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] del: Disj_EH)
     apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
     apply (rule cut_same [OF exists_HaddP [where j=km and x="SUCC k1" and y="Var m"]])
     apply (blast intro: Ord_IN_Ord, simp)
     apply (rule cut_same [OF exists_HaddP [where j=kn and x="SUCC k1" and y="Var n"]])
     apply (metis AssumeH(6) Ord_IN_Ord0 rotate8, simp)
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule Ex_I [where x="Var km"], simp)
     apply (rule Ex_I [where x="Var kn"], simp)
     apply (rule Ex_I [where x="Var sm"], simp)
     apply (rule Ex_I [where x="Var sn"], simp_all)
     apply (rule Conj_I [OF _ Conj_I])
     apply (blast intro!: HaddP_Mem_cancel_left [THEN Iff_MP2_same] OrdP_SUCC_I intro: LstSeqP_OrdP Hyp)+
     apply (blast del: Disj_EH  intro: OrdP_Trans Hyp
                  intro!: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] HaddP_imp_OrdP [THEN cut1])
     done
   qed
 qed (*>*)

theorem ConstP_Eats: "{ConstP t1, ConstP t2} \<turnstile> ConstP (Q_Eats t1 t2)"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (t1,t2)" "atom k1 \<sharp> (t1,t2,s1)"
      "atom s2 \<sharp> (t1,t2,k1,s1)" "atom k2 \<sharp> (t1,t2,s2,k1,s1)"
      "atom s  \<sharp> (t1,t2,k2,s2,k1,s1)" "atom k  \<sharp> (t1,t2,s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: CTermP.simps [of k s "(Q_Eats t1 t2)"]
        CTermP.simps [of k1 s1 t1]  CTermP.simps [of k2 s2 t2]
        intro!:  SeqConstP_Eats [THEN cut2])
qed

lemma TermP_Zero: "{} \<turnstile> TermP Zero"
proof -
  obtain s::name and k::name and l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms:
      "atom s \<sharp> (k,l,sl,m,n,sm,sn)"
      "atom k \<sharp> (l,sl,m,n,sm,sn)"
      "atom l \<sharp> (sl,m,n,sm,sn)"
      "atom sl \<sharp> (m,n,sm,sn)"
      "atom m \<sharp> (n,sm,sn)"
      "atom n \<sharp> (sm,sn)"
      "atom sm \<sharp> sn"
    by (metis obtain_fresh)
  then show ?thesis
    apply (subst CTermP.simps[of k s]; auto?)
    apply (rule Ex_I[of _ _ _ "Eats Zero (HPair Zero Zero)"]; auto?)
    apply (rule Ex_I[of _ _ _ "Zero"]; auto?)
    apply (subst SeqCTermP.simps[of l _ _ sl m n sm sn]; auto?)
    apply (rule Ex_I[of _ _ _ "Zero"]; auto?)
     apply (rule Mem_SUCC_E[OF Mem_Zero_E])
     apply (rule Mem_Eats_I2)
     apply (rule HPair_cong[OF Assume Refl])
    apply (rule Disj_I1[OF Refl])
    done
qed

lemma TermP_Var: "{} \<turnstile> TermP \<guillemotleft>Var x\<guillemotright>"
proof -
  obtain s::name and k::name and l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms:
      "atom s \<sharp> (k,l,sl,m,n,sm,sn,x)"
      "atom k \<sharp> (l,sl,m,n,sm,sn,x)"
      "atom l \<sharp> (sl,m,n,sm,sn,x)"
      "atom sl \<sharp> (m,n,sm,sn,x)"
      "atom m \<sharp> (n,sm,sn,x)"
      "atom n \<sharp> (sm,sn,x)"
      "atom sm \<sharp> (sn,x)"
      "atom sn \<sharp> x"
    by (metis obtain_fresh)
  then show ?thesis
    apply (subst CTermP.simps[of k s]; auto?)
    apply (rule Ex_I[of _ _ _ "Eats Zero (HPair Zero \<guillemotleft>Var x\<guillemotright>)"]; auto?)
    apply (rule Ex_I[of _ _ _ "Zero"]; auto?)
    apply (subst SeqCTermP.simps[of l _ _ sl m n sm sn]; auto?)
    apply (rule Ex_I[of _ _ _ "\<guillemotleft>Var x\<guillemotright>"]; auto?)
     apply (rule Mem_SUCC_E[OF Mem_Zero_E])
     apply (rule Mem_Eats_I2)
     apply (rule HPair_cong[OF Assume Refl])
    apply (rule Disj_I2[OF Disj_I1])
    apply (auto simp: VarP_Var)
    done
qed

lemma SeqTermP_Eats:
  assumes "atom s \<sharp> (k,s1,s2,k1,k2,t1,t2)" "atom k \<sharp> (s1,s2,k1,k2,t1,t2)"
    shows "{SeqTermP s1 k1 t1, SeqTermP s2 k2 t2}
           \<turnstile> Ex s (Ex k (SeqTermP (Var s) (Var k) (Q_Eats t1 t2)))" (*<*)
proof -
  obtain km::name and kn::name and j::name and k'::name
     and l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms:
         "atom km \<sharp> (kn,j,k',l,s1,s2,s,k1,k2,k,t1,t2,sl,m,n,sm,sn)"
         "atom kn \<sharp> (j,k',l,s1,s2,s,k1,k2,k,t1,t2,sl,m,n,sm,sn)"
         "atom j \<sharp> (k',l,s1,s2,s,k1,k2,k,t1,t2,sl,m,n,sm,sn)"
         "atom k' \<sharp> (l,s1,s2,s,k1,k2,k,t1,t2,sl,m,n,sm,sn)"
         "atom l \<sharp> (s1,s2,s,k1,k2,k,t1,t2,sl,m,n,sm,sn)"
         "atom sl \<sharp> (s1,s2,s,k1,k2,k,t1,t2,m,n,sm,sn)"
         "atom m \<sharp> (s1,s2,s,k1,k2,k,t1,t2,n,sm,sn)"
         "atom n \<sharp> (s1,s2,s,k1,k2,k,t1,t2,sm,sn)"
         "atom sm \<sharp> (s1,s2,s,k1,k2,k,t1,t2,sn)"
         "atom sn \<sharp> (s1,s2,s,k1,k2,k,t1,t2)"
    by (metis obtain_fresh)
  let ?hyp = "{HaddP k1 k2 (Var k'), OrdP k1, OrdP k2, SeqAppendP s1 (SUCC k1) s2 (SUCC k2) (Var s),
              SeqTermP s1 k1 t1, SeqTermP s2 k2 t2}"
  show ?thesis
     using assms atoms
     apply (auto simp: SeqCTermP.simps [of l "Var s" _ sl m n sm sn])
     apply (rule cut_same [where A="OrdP k1 AND OrdP k2"])
     apply (metis Conj_I SeqCTermP_imp_OrdP thin1 thin2)
     apply (rule cut_same [OF exists_SeqAppendP [of s s1 "SUCC k1" s2 "SUCC k2"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule cut_same [OF exists_HaddP [where j=k' and x=k1 and y=k2]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2))"], simp)
     apply (rule Ex_I [where x="SUCC (SUCC (Var k'))"], simp)
     apply (rule Conj_I)
     apply (blast intro: LstSeqP_SeqAppendP_Eats SeqCTermP_imp_LstSeqP [THEN cut1])
     proof (rule All2_SUCC_I, simp_all)
       show "?hyp \<turnstile> Ex sl (HPair (SUCC (SUCC (Var k'))) (Var sl) IN Eats (Var s)
                          (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2))   AND
                (Var sl EQ Zero OR VarP (Var sl) OR
                 Ex m (Ex n(Ex sm (Ex sn
                      (Var m IN SUCC (SUCC (Var k')) AND
                       Var n IN SUCC (SUCC (Var k')) AND
                       HPair (Var m) (Var sm) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2)) AND
                       HPair (Var n) (Var sn) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2)) AND
                       Var sl EQ Q_Eats (Var sm) (Var sn)))))))"
       \<comment> \<open>verifying the final values\<close>
       apply (rule Ex_I [where x="Q_Eats t1 t2"])
       using assms atoms apply simp
       apply (rule Conj_I, metis Mem_Eats_I2 Refl)
       apply (rule Disj_I2)+
       apply (rule Ex_I [where x=k1], simp)
       apply (rule Ex_I [where x="SUCC (Var k')"], simp)
       apply (rule Ex_I [where x=t1], simp)
       apply (rule Ex_I [where x=t2], simp)
       apply (rule Conj_I)
       apply (blast intro: HaddP_Mem_I LstSeqP_OrdP Mem_SUCC_I1)
       apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem1 [THEN cut3] SeqAppendP_Mem2 [THEN cut4]
                 Mem_SUCC_Refl SeqCTermP_imp_LstSeqP [THEN cut1] LstSeqP_imp_Mem HaddP_SUCC1 [THEN cut1])
       done
     next
       show "?hyp \<turnstile> All2 l (SUCC (SUCC (Var k')))
                 (Ex sl
                   (HPair (Var l) (Var sl) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2)) AND
                    (Var sl EQ Zero OR VarP (Var sl) OR
                     Ex m (Ex n (Ex sm (Ex sn
                          (Var m IN Var l AND
                           Var n IN Var l AND
                           HPair (Var m) (Var sm) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2)) AND
                           HPair (Var n) (Var sn) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Eats t1 t2)) AND
                           Var sl EQ Q_Eats (Var sm) (Var sn))))))))"
     \<comment> \<open>verifying the sequence buildup\<close>
     apply (rule cut_same [where A="HaddP (SUCC k1) (SUCC k2) (SUCC (SUCC (Var k')))"])
     apply (blast intro: HaddP_SUCC1 [THEN cut1] HaddP_SUCC2 [THEN cut1])
     apply (rule All_I Imp_I)+
     apply (rule HaddP_Mem_cases [where i=j])
     using assms atoms apply simp_all
     apply (rule AssumeH)
     apply (blast intro: OrdP_SUCC_I LstSeqP_OrdP)
     \<comment> \<open>... the sequence buildup via s1\<close>
     apply (simp add: SeqCTermP.simps [of l s1 _ sl m n sm sn])
     apply (rule AssumeH Ex_EH Conj_EH)+
     apply (rule All2_E [THEN rotate2], auto del: Disj_EH)
     apply (rule Ex_I [where x="Var sl"], simp)
     apply (rule Conj_I)
     apply (rule Mem_Eats_I1)
     apply (metis SeqAppendP_Mem1 rotate3 thin2 thin4)
     apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
     apply simp_all
     apply (rule Ex_I [where x="Var m"], simp)
     apply (rule Ex_I [where x="Var n"], simp)
     apply (rule Ex_I [where x="Var sm"], simp)
     apply (rule Ex_I [where x="Var sn"], simp)
     apply (rule Conj_I, rule AssumeH)+
     apply (blast del: Disj_EH intro: OrdP_Trans [OF OrdP_SUCC_I] Mem_Eats_I1 [OF SeqAppendP_Mem1 [THEN cut3]] Hyp)
     \<comment> \<open>... the sequence buildup via s2\<close>
     apply (simp add: SeqCTermP.simps [of l s2 _ sl m n sm sn])
     apply (rule AssumeH Ex_EH Conj_EH)+
     apply (rule All2_E [THEN rotate2], auto del: Disj_EH)
     apply (rule Ex_I [where x="Var sl"], simp)
     apply (rule cut_same [where A="OrdP (Var j)"])
     apply (metis HaddP_imp_OrdP rotate2 thin2)
     apply (rule Conj_I)
     apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] del: Disj_EH)
     apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
     apply (rule cut_same [OF exists_HaddP [where j=km and x="SUCC k1" and y="Var m"]])
     apply (blast intro: Ord_IN_Ord, simp)
     apply (rule cut_same [OF exists_HaddP [where j=kn and x="SUCC k1" and y="Var n"]])
     apply (metis AssumeH(6) Ord_IN_Ord0 rotate8, simp)
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule Ex_I [where x="Var km"], simp)
     apply (rule Ex_I [where x="Var kn"], simp)
     apply (rule Ex_I [where x="Var sm"], simp)
     apply (rule Ex_I [where x="Var sn"], simp_all)
     apply (rule Conj_I [OF _ Conj_I])
     apply (blast intro!: HaddP_Mem_cancel_left [THEN Iff_MP2_same] OrdP_SUCC_I intro: LstSeqP_OrdP Hyp)+
     apply (blast del: Disj_EH  intro: OrdP_Trans Hyp
                  intro!: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] HaddP_imp_OrdP [THEN cut1])
     done
   qed
qed (*>*)

theorem TermP_Eats: "{TermP t1, TermP t2} \<turnstile> TermP (Q_Eats t1 t2)"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (t1,t2)" "atom k1 \<sharp> (t1,t2,s1)"
      "atom s2 \<sharp> (t1,t2,k1,s1)" "atom k2 \<sharp> (t1,t2,s2,k1,s1)"
      "atom s  \<sharp> (t1,t2,k2,s2,k1,s1)" "atom k  \<sharp> (t1,t2,s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: CTermP.simps [of k s "(Q_Eats t1 t2)"]
        CTermP.simps [of k1 s1 t1]  CTermP.simps [of k2 s2 t2]
        intro!:  SeqTermP_Eats [THEN cut2])
qed

section \<open>Proofs\<close>

lemma PrfP_inference:
  assumes "atom s \<sharp> (k,s1,s2,k1,k2,\<alpha>1,\<alpha>2,\<beta>)" "atom k \<sharp> (s1,s2,k1,k2,\<alpha>1,\<alpha>2,\<beta>)"
    shows "{PrfP s1 k1 \<alpha>1, PrfP s2 k2 \<alpha>2, ModPonP \<alpha>1 \<alpha>2 \<beta> OR ExistsP \<alpha>1 \<beta> OR SubstP \<alpha>1 \<beta>}
           \<turnstile> Ex k (Ex s (PrfP (Var s) (Var k) \<beta>))" (*<*)
proof -
  obtain km::name and kn::name and j::name and k'::name
     and l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms:
         "atom km \<sharp> (kn,j,k',l,s1,s2,s,k1,k2,k,\<alpha>1,\<alpha>2,\<beta>,sl,m,n,sm,sn)"
         "atom kn \<sharp> (j,k',l,s1,s2,s,k1,k2,k,\<alpha>1,\<alpha>2,\<beta>,sl,m,n,sm,sn)"
         "atom j \<sharp> (k',l,s1,s2,s,k1,k2,k,\<alpha>1,\<alpha>2,\<beta>,sl,m,n,sm,sn)"
         "atom k' \<sharp> (l,s1,s2,s,k1,k2,k,\<alpha>1,\<alpha>2,\<beta>,sl,m,n,sm,sn)"
         "atom l \<sharp> (s1,s2,s,k1,k2,k,\<alpha>1,\<alpha>2,\<beta>,sl,m,n,sm,sn)"
         "atom sl \<sharp> (s1,s2,s,k1,k2,k,\<alpha>1,\<alpha>2,\<beta>,m,n,sm,sn)"
         "atom m \<sharp> (s1,s2,s,k1,k2,k,\<alpha>1,\<alpha>2,\<beta>,n,sm,sn)"
         "atom n \<sharp> (s1,s2,s,k1,k2,k,\<alpha>1,\<alpha>2,\<beta>,sm,sn)"
         "atom sm \<sharp> (s1,s2,s,k1,k2,k,\<alpha>1,\<alpha>2,\<beta>,sn)"
         "atom sn \<sharp> (s1,s2,s,k1,k2,k,\<alpha>1,\<alpha>2,\<beta>)"
    by (metis obtain_fresh)
  let ?hyp = "{HaddP k1 k2 (Var k'), OrdP k1, OrdP k2, SeqAppendP s1 (SUCC k1) s2 (SUCC k2) (Var s),
              PrfP s1 k1 \<alpha>1, PrfP s2 k2 \<alpha>2, ModPonP \<alpha>1 \<alpha>2 \<beta> OR ExistsP \<alpha>1 \<beta> OR SubstP \<alpha>1 \<beta>}"
  show ?thesis
     using assms atoms
     apply (simp add: PrfP.simps [of l "Var s" sl m n sm sn])
     apply (rule cut_same [where A="OrdP k1 AND OrdP k2"])
     apply (metis Conj_I PrfP_imp_OrdP thin1 thin2)
     apply (rule cut_same [OF exists_SeqAppendP [of s s1 "SUCC k1" s2 "SUCC k2"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule cut_same [OF exists_HaddP [where j=k' and x=k1 and y=k2]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule Ex_I [where x="SUCC (SUCC (Var k'))"], simp)
     apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC (SUCC (Var k'))) \<beta>)"], simp)
     apply (rule Conj_I)
     apply (blast intro: LstSeqP_SeqAppendP_Eats PrfP_imp_LstSeqP [THEN cut1])
     proof (rule All2_SUCC_I, simp_all)
       show "?hyp \<turnstile> Ex sn
                 (HPair (SUCC (SUCC (Var k'))) (Var sn) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) \<beta>) AND
                  (AxiomP (Var sn) OR
                   Ex m (Ex l (Ex sm (Ex sl
                      (Var m IN SUCC (SUCC (Var k')) AND
                       Var l IN SUCC (SUCC (Var k')) AND
                       HPair (Var m) (Var sm) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) \<beta>) AND
                       HPair (Var l) (Var sl) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) \<beta>) AND
                       (ModPonP (Var sm) (Var sl) (Var sn) OR ExistsP (Var sm) (Var sn) OR SubstP (Var sm) (Var sn))))))))"
       \<comment> \<open>verifying the final values\<close>
       apply (rule Ex_I [where x="\<beta>"])
       using assms atoms apply simp
       apply (rule Conj_I, metis Mem_Eats_I2 Refl)
       apply (rule Disj_I2)
       apply (rule Ex_I [where x=k1], simp)
       apply (rule Ex_I [where x="SUCC (Var k')"], simp)
       apply (rule_tac x=\<alpha>1 in Ex_I, simp)
       apply (rule_tac x=\<alpha>2 in Ex_I, simp)
       apply (rule Conj_I)
       apply (blast intro: HaddP_Mem_I LstSeqP_OrdP Mem_SUCC_I1)
       apply (rule Conj_I [OF Mem_SUCC_Refl Conj_I])
       apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem1 [THEN cut3] Mem_SUCC_Refl PrfP_imp_LstSeqP [THEN cut1] LstSeqP_imp_Mem)
       apply (blast del: Disj_EH  intro: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] Mem_SUCC_Refl
                     PrfP_imp_LstSeqP [THEN cut1] HaddP_SUCC1 [THEN cut1] LstSeqP_imp_Mem)
       done
     next
       show "?hyp \<turnstile> All2 n (SUCC (SUCC (Var k')))
               (Ex sn
                 (HPair (Var n) (Var sn) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) \<beta>) AND
                  (AxiomP (Var sn) OR
                   Ex m (Ex l (Ex sm (Ex sl
                      (Var m IN Var n AND
                       Var l IN Var n AND
                       HPair (Var m) (Var sm) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) \<beta>) AND
                       HPair (Var l) (Var sl) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) \<beta>) AND
                       (ModPonP (Var sm) (Var sl) (Var sn) OR ExistsP (Var sm) (Var sn) OR SubstP (Var sm) (Var sn)))))))))"
     \<comment> \<open>verifying the sequence buildup\<close>
     apply (rule cut_same [where A="HaddP (SUCC k1) (SUCC k2) (SUCC (SUCC (Var k')))"])
     apply (blast intro: HaddP_SUCC1 [THEN cut1] HaddP_SUCC2 [THEN cut1])
     apply (rule All_I Imp_I)+
     apply (rule HaddP_Mem_cases [where i=j])
     using assms atoms apply simp_all
     apply (rule AssumeH)
     apply (blast intro: OrdP_SUCC_I LstSeqP_OrdP)
     \<comment> \<open>... the sequence buildup via s1\<close>
     apply (simp add: PrfP.simps [of l s1 sl m n sm sn])
     apply (rule AssumeH Ex_EH Conj_EH)+
     apply (rule All2_E [THEN rotate2])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule Ex_I [where x="Var sn"], simp)
     apply (rule Conj_I)
     apply (rule Mem_Eats_I1)
     apply (metis SeqAppendP_Mem1 rotate3 thin2 thin4)
     apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
     apply (rule Ex_I [where x="Var m"], simp)
     apply (rule Ex_I [where x="Var l"], simp)
     apply (rule Ex_I [where x="Var sm"], simp)
     apply (rule Ex_I [where x="Var sl"], simp_all)
     apply (rule Conj_I, rule AssumeH)+
     apply (blast del: Disj_EH intro: OrdP_Trans [OF OrdP_SUCC_I] Mem_Eats_I1 [OF SeqAppendP_Mem1 [THEN cut3]] Hyp)
     \<comment> \<open>... the sequence buildup via s2\<close>
     apply (simp add: PrfP.simps [of l s2 sl m n sm sn])
     apply (rule AssumeH Ex_EH Conj_EH)+
     apply (rule All2_E [THEN rotate2])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule Ex_I [where x="Var sn"], simp)
     apply (rule cut_same [where A="OrdP (Var j)"])
     apply (metis HaddP_imp_OrdP rotate2 thin2)
     apply (rule Conj_I)
     apply (blast intro!: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] del: Disj_EH)
     apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
     apply (rule cut_same [OF exists_HaddP [where j=km and x="SUCC k1" and y="Var m"]])
     apply (blast intro: Ord_IN_Ord, simp)
     apply (rule cut_same [OF exists_HaddP [where j=kn and x="SUCC k1" and y="Var l"]])
     apply (blast intro!: Ord_IN_Ord)
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
     apply (rule Ex_I [where x="Var km"], simp)
     apply (rule Ex_I [where x="Var kn"], simp)
     apply (rule Ex_I [where x="Var sm"], simp)
     apply (rule Ex_I [where x="Var sl"], simp_all)
     apply (rule Conj_I [OF _ Conj_I])
     apply (blast intro!: HaddP_Mem_cancel_left [THEN Iff_MP2_same] OrdP_SUCC_I intro: LstSeqP_OrdP Hyp)+
     apply (blast del: Disj_EH  intro: OrdP_Trans Hyp
                  intro!: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] HaddP_imp_OrdP [THEN cut1])
     done
   qed
qed (*>*)

corollary PfP_inference: "{PfP \<alpha>1, PfP \<alpha>2, ModPonP \<alpha>1 \<alpha>2 \<beta> OR ExistsP \<alpha>1 \<beta> OR SubstP \<alpha>1 \<beta>} \<turnstile> PfP \<beta>"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (\<alpha>1,\<alpha>2,\<beta>)" "atom k1 \<sharp> (\<alpha>1,\<alpha>2,\<beta>,s1)"
          "atom s2 \<sharp> (\<alpha>1,\<alpha>2,\<beta>,k1,s1)""atom k2 \<sharp> (\<alpha>1,\<alpha>2,\<beta>,s2,k1,s1)"
          "atom s  \<sharp> (\<alpha>1,\<alpha>2,\<beta>,k2,s2,k1,s1)"
          "atom k  \<sharp> (\<alpha>1,\<alpha>2,\<beta>,s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
   thus ?thesis
     apply (simp add: PfP.simps [of k s \<beta>] PfP.simps [of k1 s1 \<alpha>1]  PfP.simps [of k2 s2 \<alpha>2])
     apply (auto intro!: PrfP_inference [of s k "Var s1" "Var s2", THEN cut3] del: Disj_EH)
     done
qed

theorem PfP_implies_SubstForm_PfP:
   assumes "H \<turnstile> PfP y" "H \<turnstile> SubstFormP x t y z"
     shows "H \<turnstile> PfP z"
proof -
  obtain u::name and v::name
    where atoms: "atom u \<sharp> (t,x,y,z,v)"   "atom v \<sharp> (t,x,y,z)"
    by (metis obtain_fresh)
  show ?thesis
    apply (rule PfP_inference [of y, THEN cut3])
    apply (rule assms)+
    using atoms
    apply (auto simp: SubstP.simps [of u _ _ v] intro!: Disj_I2)
    apply (rule Ex_I [where x=x], simp)
    apply (rule Ex_I [where x=t], simp add: assms)
    done
qed

theorem PfP_implies_ModPon_PfP: "\<lbrakk>H \<turnstile> PfP (Q_Imp x y); H \<turnstile> PfP x\<rbrakk> \<Longrightarrow> H \<turnstile> PfP y"
  by (force intro: PfP_inference [of x, THEN cut3] Disj_I1  simp add: ModPonP_def)

corollary PfP_implies_ModPon_PfP_quot: "\<lbrakk>H \<turnstile> PfP \<guillemotleft>\<alpha> IMP \<beta>\<guillemotright>; H \<turnstile> PfP \<guillemotleft>\<alpha>\<guillemotright>\<rbrakk> \<Longrightarrow> H \<turnstile> PfP \<guillemotleft>\<beta>\<guillemotright>"
  by (auto simp: quot_fm_def intro: PfP_implies_ModPon_PfP)

lemma TermP_quot:
  fixes \<alpha> :: tm
  shows "{} \<turnstile> TermP \<guillemotleft>\<alpha>\<guillemotright>"
  by (induct \<alpha> rule: tm.induct)
    (auto simp: quot_Eats intro: TermP_Zero TermP_Var TermP_Eats[THEN cut2])

lemma TermP_quot_dbtm:
  fixes \<alpha> :: tm
  assumes "wf_dbtm u"
  shows "{} \<turnstile> TermP (quot_dbtm u)"
  using assms
  by (induct u rule: dbtm.induct)
    (auto simp: quot_Eats intro: TermP_Zero
    TermP_Var[unfolded quot_tm_def, simplified] TermP_Eats[THEN cut2])

section \<open>Formulas\<close>

section \<open>Abstraction on Formulas\<close>

subsection \<open>Membership\<close>

lemma AbstAtomicP_Mem:
  "{AbstTermP v i x x', AbstTermP v i y y'} \<turnstile> AbstAtomicP v i (Q_Mem x y) (Q_Mem x' y')"
proof -
  obtain t::name and u::name and t'::name and u'::name
    where "atom t \<sharp> (v,i,x,x',y,y',t',u,u')" "atom t' \<sharp> (v,i,x,x',y,y',u,u')"
      "atom u \<sharp> (v,i,x,x',y,y',u')" "atom u' \<sharp> (v,i,x,x',y,y')"
    by (metis obtain_fresh)
  thus ?thesis
    apply (simp add: AbstAtomicP.simps [of t _ _ _ _ t' u u'])
    apply (rule Ex_I [where x = x], simp)
    apply (rule Ex_I [where x = y], simp)
    apply (rule Ex_I [where x = x'], simp)
    apply (rule Ex_I [where x = y'], auto intro: Disj_I2)
    done
qed

lemma SeqAbstFormP_Mem:
  assumes "atom s \<sharp> (k,x,y,x',y',v,i)" "atom k \<sharp> (x,y,x',y',v,i)"
  shows "{AbstTermP v i x x', AbstTermP v i y y'}
           \<turnstile> Ex s (Ex k (SeqAbstFormP v i (Q_Mem x y) (Q_Mem x' y') (Var s) (Var k)))"
proof -
  let ?vs = "(s,k,x,y,x',y',v,i)"
  obtain l::name and sl::name and sl'::name and m::name and n::name and sm::name and sm'::name and sn::name and sn'::name
    and sli smi sni :: name
    where
      "atom sni \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l,sli,smi)"
      "atom smi \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l,sli)"
      "atom sli \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l)"
      "atom l \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn')"
      "atom sl \<sharp> (?vs,sl',m,n,sm,sm',sn,sn')" "atom sl' \<sharp> (?vs,m,n,sm,sm',sn,sn')"
      "atom m \<sharp> (?vs,n,sm,sm',sn,sn')" "atom n \<sharp> (?vs,sm,sm',sn,sn')"
      "atom sm \<sharp> (?vs,sm',sn,sn')" "atom sm' \<sharp> (?vs,sn,sn')"
      "atom sn \<sharp> (?vs,sn')" "atom sn' \<sharp> ?vs"
    by (metis obtain_fresh)
  thus ?thesis
    using assms
    apply (auto simp: SeqAbstFormP.simps [of l "Var s" _ _ sli sl sl' m n smi sm sm' sni sn sn'])
    apply (rule Ex_I [where x = "Eats Zero (HPair Zero (HPair i (HPair (Q_Mem x y) (Q_Mem x' y'))))"], simp)
    apply (rule Ex_I [where x = Zero], auto intro!: Mem_SUCC_EH)
    apply (rule Ex_I [where x = "i"], simp)
    apply (rule Ex_I [where x = "Q_Mem x y"], simp)
    apply (rule Ex_I [where x = "Q_Mem x' y'"], auto intro: Mem_Eats_I2 HPair_cong)
    apply (blast intro: AbstAtomicP_Mem [THEN cut2] Disj_I1)
    done
qed

lemma AbstFormP_Mem:
  "{AbstTermP v i x x', AbstTermP v i y y'} \<turnstile> AbstFormP v i (Q_Mem x y) (Q_Mem x' y')"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (v,i,x,y,x',y')" "atom k1 \<sharp> (v,i,x,y,x',y',s1)"
      "atom s2 \<sharp> (v,i,x,y,x',y',k1,s1)" "atom k2 \<sharp> (v,i,x,y,x',y',s2,k1,s1)"
      "atom s  \<sharp> (v,i,x,y,x',y',k2,s2,k1,s1)" "atom k  \<sharp> (v,i,x,y,x',y',s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: AbstFormP.simps [of s v i "(Q_Mem x y)" _ k]
        AbstFormP.simps [of s1 v i x x' k1]
        AbstFormP.simps [of s2 v i y y' k2]
        intro: AbstTermP_imp_VarP AbstTermP_imp_OrdP SeqAbstFormP_Mem thin1)
qed

subsection \<open>Equality\<close>

lemma AbstAtomicP_Eq:
  "{AbstTermP v i x x', AbstTermP v i y y'} \<turnstile> AbstAtomicP v i (Q_Eq x y) (Q_Eq x' y')"
proof -
  obtain t::name and u::name and t'::name  and u'::name
    where "atom t \<sharp> (v,i,x,x',y,y',t',u,u')" "atom t' \<sharp> (v,i,x,x',y,y',u,u')"
      "atom u \<sharp> (v,i,x,x',y,y',u')" "atom u' \<sharp> (v,i,x,x',y,y')"
    by (metis obtain_fresh)
  thus ?thesis
    apply (simp add: AbstAtomicP.simps [of t _ _ _ _ t' u u'])
    apply (rule Ex_I [where x = x], simp)
    apply (rule Ex_I [where x = y], simp)
    apply (rule Ex_I [where x = x'], simp)
    apply (rule Ex_I [where x = y'], auto intro: Disj_I1)
    done
qed

lemma SeqAbstFormP_Eq:
  assumes sk: "atom s \<sharp> (k,x,y,x',y',v,i)" "atom k \<sharp> (x,y,x',y',v,i)"
  shows "{AbstTermP v i x x', AbstTermP v i y y'}
           \<turnstile> Ex s (Ex k (SeqAbstFormP v i (Q_Eq x y) (Q_Eq x' y') (Var s) (Var k)))"
proof -
  let ?vs = "(s,k,x,y,x',y',v,i)"
  obtain l::name and sl::name and sl'::name and m::name and n::name and sm::name and sm'::name and sn::name and sn'::name
    and sli smi sni :: name
    where
      "atom sni \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l,sli,smi)"
      "atom smi \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l,sli)"
      "atom sli \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l)"
      "atom l \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn')"
      "atom sl \<sharp> (?vs,sl',m,n,sm,sm',sn,sn')" "atom sl' \<sharp> (?vs,m,n,sm,sm',sn,sn')"
      "atom m \<sharp> (?vs,n,sm,sm',sn,sn')" "atom n \<sharp> (?vs,sm,sm',sn,sn')"
      "atom sm \<sharp> (?vs,sm',sn,sn')" "atom sm' \<sharp> (?vs,sn,sn')"
      "atom sn \<sharp> (?vs,sn')" "atom sn' \<sharp> ?vs"
    by (metis obtain_fresh)
  thus ?thesis
    using sk
    apply (auto simp: SeqAbstFormP.simps [of l "Var s" _ _ sli sl sl' m n smi sm sm' sni sn sn'])
    apply (rule Ex_I [where x = "Eats Zero (HPair Zero (HPair i (HPair (Q_Eq x y) (Q_Eq x' y'))))"], simp)
    apply (rule Ex_I [where x = Zero], auto intro!: Mem_SUCC_EH)
    apply (rule Ex_I [where x = "i"], simp)
    apply (rule Ex_I [where x = "Q_Eq x y"], simp)
    apply (rule Ex_I [where x = "Q_Eq x' y'"], auto)
     apply (metis Mem_Eats_I2 Assume HPair_cong Refl)
    apply (blast intro: AbstAtomicP_Eq [THEN cut2] Disj_I1)
    done
qed

lemma AbstFormP_Eq:
  "{AbstTermP v i x x', AbstTermP v i y y'} \<turnstile> AbstFormP v i (Q_Eq x y) (Q_Eq x' y')"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (v,i,x,y,x',y')" "atom k1 \<sharp> (v,i,x,y,x',y',s1)"
      "atom s2 \<sharp> (v,i,x,y,x',y',k1,s1)" "atom k2 \<sharp> (v,i,x,y,x',y',s2,k1,s1)"
      "atom s  \<sharp> (v,i,x,y,x',y',k2,s2,k1,s1)" "atom k  \<sharp> (v,i,x,y,x',y',s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: AbstFormP.simps [of s v i "(Q_Eq x y)" _ k]
        AbstFormP.simps [of s1 v i x x' k1]
        AbstFormP.simps [of s2 v i y y' k2]
        intro: SeqAbstFormP_Eq AbstTermP_imp_OrdP AbstTermP_imp_VarP thin1)
qed

subsection \<open>Negation\<close>

lemma SeqAbstFormP_Neg:
  assumes "atom s \<sharp> (k,s1,k1,x,x',v,i)" "atom k \<sharp> (s1,k1,x,x',v,i)"
  shows "{SeqAbstFormP v i x x' s1 k1, OrdP i, VarP v}
           \<turnstile> Ex s (Ex k (SeqAbstFormP v i (Q_Neg x) (Q_Neg x') (Var s) (Var k)))" (*<*)
proof -
  let ?vs = "(s1,k1,s,k,x,x',v,i)"
  obtain l::name and sl::name and sl'::name and m::name and n::name and
    sm::name and sm'::name and sn::name and sn'::name
    and sli smi sni :: name
    where atoms:
      "atom sni \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l,sli,smi)"
      "atom smi \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l,sli)"
      "atom sli \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l)"
      "atom l \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn')"
      "atom sl \<sharp> (?vs,sl',m,n,sm,sm',sn,sn')" "atom sl' \<sharp> (?vs,m,n,sm,sm',sn,sn')"
      "atom m \<sharp> (?vs,n,sm,sm',sn,sn')" "atom n \<sharp> (?vs,sm,sm',sn,sn')"
      "atom sm \<sharp> (?vs,sm',sn,sn')" "atom sm' \<sharp> (?vs,sn,sn')"
      "atom sn \<sharp> (?vs,sn')" "atom sn' \<sharp> ?vs"
    by (metis obtain_fresh)
  let ?hyp = "{RestrictedP s1 (SUCC k1) (Var s), OrdP k1, SeqAbstFormP v i x x' s1 k1, OrdP i, VarP v}"
  show ?thesis
    using assms atoms
    apply (auto simp: SeqAbstFormP.simps [of l "Var s" _ _ sli sl sl' m n smi sm sm' sni sn sn'])
    apply (rule cut_same [where A="OrdP k1"])
     apply (metis SeqAbstFormP_imp_OrdP thin2)
    apply (rule cut_same [OF exists_RestrictedP [of s s1 "SUCC k1"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
      apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Neg x) (Q_Neg x'))))"])
      apply (simp_all (no_asm_simp))
    apply (rule Ex_I [where x="(SUCC k1)"])
    apply (simp add: flip_fresh_fresh)
    apply (rule Conj_I)
     apply (blast intro: RestrictedP_LstSeqP_Eats [THEN cut2] SeqAbstFormP_imp_LstSeqP [THEN cut1])
  proof (rule All2_SUCC_I, simp_all)
    show "?hyp \<turnstile> SyntaxN.Ex sli (SyntaxN.Ex sl (SyntaxN.Ex sl'
            (HPair (SUCC k1) (HPair (Var sli) (HPair (Var sl) (Var sl'))) IN
              Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Neg x) (Q_Neg x')))) AND
            (AbstAtomicP v (Var sli) (Var sl) (Var sl') OR
              OrdP (Var sli) AND
              SyntaxN.Ex m (SyntaxN.Ex n
              (SyntaxN.Ex smi (SyntaxN.Ex sm (SyntaxN.Ex sm'
              (SyntaxN.Ex sni (SyntaxN.Ex sn (SyntaxN.Ex sn'
              (Var m IN SUCC k1 AND Var n IN SUCC k1 AND
              HPair (Var m) (HPair (Var smi) (HPair (Var sm) (Var sm'))) IN
                Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Neg x) (Q_Neg x')))) AND
              HPair (Var n) (HPair (Var sni) (HPair (Var sn) (Var sn'))) IN
                Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Neg x) (Q_Neg x')))) AND
              (Var sli EQ Var smi AND Var sli EQ Var sni AND
              Var sl EQ Q_Disj (Var sm) (Var sn) AND  Var sl' EQ Q_Disj (Var sm') (Var sn') OR
              Var sli EQ Var smi AND Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm') OR
              SUCC (Var sli) EQ Var smi AND Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm'))))))))))))))"
      \<comment> \<open>verifying the final values\<close>
      apply (rule Ex_I [where x="i"])
      using assms atoms apply simp
      apply (rule Ex_I [where x="Q_Neg x"], simp)
      apply (rule Ex_I [where x="Q_Neg x'"], simp)
      apply (rule Conj_I, metis Mem_Eats_I2 Refl)
      apply (rule Disj_I2)
      apply (rule Conj_I, blast)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x=i], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule_tac x=x' in Ex_I, simp)
      apply (rule Ex_I [where x=i], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule_tac x=x' in Ex_I, simp)
      apply (rule Conj_I [OF Mem_SUCC_Refl])+
      apply (blast intro: Disj_I1 Disj_I2 Mem_Eats_I1 RestrictedP_Mem [THEN cut3] Mem_SUCC_Refl
          SeqAbstFormP_imp_LstSeqP [THEN cut1] LstSeqP_imp_Mem)
      done
  next
    show "?hyp \<turnstile> All2 l (SUCC k1) (SyntaxN.Ex sli (SyntaxN.Ex sl (SyntaxN.Ex sl'
      (HPair (Var l) (HPair (Var sli) (HPair (Var sl) (Var sl'))) IN
        Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Neg x) (Q_Neg x')))) AND
      (AbstAtomicP v (Var sli) (Var sl) (Var sl') OR
        OrdP (Var sli) AND
        SyntaxN.Ex m (SyntaxN.Ex n
        (SyntaxN.Ex smi (SyntaxN.Ex sm (SyntaxN.Ex sm'
        (SyntaxN.Ex sni (SyntaxN.Ex sn (SyntaxN.Ex sn'
        (Var m IN Var l AND Var n IN Var l AND
        HPair (Var m) (HPair (Var smi) (HPair (Var sm) (Var sm'))) IN
          Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Neg x) (Q_Neg x')))) AND
        HPair (Var n) (HPair (Var sni) (HPair (Var sn) (Var sn'))) IN
          Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Neg x) (Q_Neg x')))) AND
        (Var sli EQ Var smi AND Var sli EQ Var sni AND
        Var sl EQ Q_Disj (Var sm) (Var sn) AND Var sl' EQ Q_Disj (Var sm') (Var sn') OR
        Var sli EQ Var smi AND Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm') OR
        SUCC (Var sli) EQ Var smi AND Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm')))))))))))))))"
      \<comment> \<open>verifying the sequence buildup\<close>
      apply (rule All_I Imp_I)+
      using assms atoms apply simp_all
        \<comment> \<open>... the sequence buildup via s1\<close>
       apply (simp add: SeqAbstFormP.simps [of l s1 _ _ sli sl sl' m n smi sm sm' sni sn sn'])
      apply (rule AssumeH Ex_EH Conj_EH)+
      apply (rule All2_E [THEN rotate2], auto del: Disj_EH)
      apply (rule Ex_I [where x="Var sli"], simp)
      apply (rule Ex_I [where x="Var sl"], simp)
      apply (rule Ex_I [where x="Var sl'"], simp)
      apply (rule Conj_I)
       apply (blast intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] del: Disj_EH)
      apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH Conj_I)+
                  apply (rule Ex_I [where x="Var m"], simp)
                  apply (rule Ex_I [where x="Var n"], simp)
                  apply (rule Ex_I [where x="Var smi"], simp)
                  apply (rule Ex_I [where x="Var sm"], simp)
                  apply (rule Ex_I [where x="Var sm'"], simp)
                  apply (rule Ex_I [where x="Var sni"], simp)
                  apply (rule Ex_I [where x="Var sn"], simp)
                  apply (rule Ex_I [where x="Var sn'"], auto del: Disj_EH)
       apply (rule Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] AssumeH OrdP_Trans [OF OrdP_SUCC_I])+
      done
  qed
qed (*>*)

theorem AbstFormP_Neg: "{AbstFormP v i x x'} \<turnstile> AbstFormP v i (Q_Neg x) (Q_Neg x')"
proof -
  obtain k1::name and s1::name and k::name and s::name
    where "atom s1 \<sharp> (v,i,x,x')"        "atom k1 \<sharp> (v,i,x,x',s1)"
      "atom s  \<sharp> (v,i,x,x',k1,s1)"  "atom k  \<sharp> (v,i,x,x',s,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: AbstFormP.simps [of s v i "Q_Neg x" _ k] AbstFormP.simps [of s1 v i x x' k1]
        intro: SeqAbstFormP_Neg [THEN cut3])
qed

subsection \<open>Disjunction\<close>

lemma SeqAbstFormP_Disj:
  assumes "atom s \<sharp> (k,s1,s2,k1,k2,x,y,x',y',v,i)" "atom k \<sharp> (s1,s2,k1,k2,x,y,x',y',v,i)"
  shows "{SeqAbstFormP v i x x' s1 k1,
            SeqAbstFormP v i y y' s2 k2, OrdP i, VarP v}
           \<turnstile> Ex s (Ex k (SeqAbstFormP v i (Q_Disj x y) (Q_Disj x' y') (Var s) (Var k)))" (*<*)
proof -
  let ?vs = "(s1,s2,s,k1,k2,k,x,y,x',y',v,i)"
  obtain km::name and kn::name and j::name and k'::name
    and l::name and sl::name and sl'::name and m::name and n::name
    and sm::name and sm'::name and sn::name and sn'::name and sli sni smi :: name
    where atoms2: "atom km \<sharp> (kn,j,k',sni,smi,sli,l,s1,s2,s,k1,k2,k,x,y,x',y',v,i,sl,sl',m,n,sm,sm',sn,sn')"
      "atom kn \<sharp> (j,k',sni,smi,sli,l,s1,s2,s,k1,k2,k,x,y,x',y',v,i,sl,sl',m,n,sm,sm',sn,sn')"
      "atom j \<sharp> (k',sni,smi,sli,l,s1,s2,s,k1,k2,k,x,y,x',y',v,i,sl,sl',m,n,sm,sm',sn,sn')"
      and atoms: "atom k' \<sharp> (sni,smi,sli,l,s1,s2,s,k1,k2,k,x,y,x',y',v,i,sl,sl',m,n,sm,sm',sn,sn')"
      "atom sni \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l,sli,smi)"
      "atom smi \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l,sli)"
      "atom sli \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l)"
      "atom l \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,sl,sl',m,n,sm,sm',sn,sn')"
      "atom sl \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,sl',m,n,sm,sm',sn,sn')"
      "atom sl' \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,m,n,sm,sm',sn,sn')"
      "atom m \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,n,sm,sm',sn,sn')"
      "atom n \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,sm,sm',sn,sn')"
      "atom sm \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,sm',sn,sn')"
      "atom sm' \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,sn,sn')"
      "atom sn \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i,sn')"
      "atom sn' \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',v,i)"
    by (metis obtain_fresh)
  let ?hyp = "{HaddP k1 k2 (Var k'), OrdP k1, OrdP k2, SeqAppendP s1 (SUCC k1) s2 (SUCC k2) (Var s),
               SeqAbstFormP v i x x' s1 k1, SeqAbstFormP v i y y' s2 k2, OrdP i, VarP v}"
  show ?thesis
    using assms atoms
    apply (auto simp: SeqAbstFormP.simps [of l "Var s" _ _ sli sl sl' m n smi sm sm' sni sn sn'])
    apply (rule cut_same [where A="OrdP k1 AND OrdP k2"])
     apply (metis Conj_I SeqAbstFormP_imp_OrdP thin1 thin2)
    apply (rule cut_same [OF exists_SeqAppendP [of s s1 "SUCC k1" s2 "SUCC k2"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
      apply (rule cut_same [OF exists_HaddP [where j=k' and x=k1 and y=k2]])
        apply (rule AssumeH Ex_EH Conj_EH | simp)+
        apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC(SUCC(Var k'))) (HPair i (HPair(Q_Disj x y)(Q_Disj x' y'))))"])
        apply (simp_all (no_asm_simp))
    apply (rule Ex_I [where x="SUCC (SUCC (Var k'))"], simp)
    apply (rule Conj_I)
     apply (blast intro: LstSeqP_SeqAppendP_Eats SeqAbstFormP_imp_LstSeqP [THEN cut1])
  proof (rule All2_SUCC_I, simp_all)
    show "?hyp \<turnstile> SyntaxN.Ex sli (SyntaxN.Ex sl (SyntaxN.Ex sl'
         (HPair (SUCC (SUCC (Var k'))) (HPair (Var sli) (HPair (Var sl) (Var sl'))) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair i (HPair (Q_Disj x y) (Q_Disj x' y')))) AND
          (AbstAtomicP v (Var sli) (Var sl) (Var sl') OR
           OrdP (Var sli) AND
           SyntaxN.Ex m
            (SyntaxN.Ex n
              (SyntaxN.Ex smi
                (SyntaxN.Ex sm
                  (SyntaxN.Ex sm'
                    (SyntaxN.Ex sni
                      (SyntaxN.Ex sn
                        (SyntaxN.Ex sn'
                          (Var m IN SUCC (SUCC (Var k')) AND
                           Var n IN SUCC (SUCC (Var k')) AND
                           HPair (Var m) (HPair (Var smi) (HPair (Var sm) (Var sm'))) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair i (HPair (Q_Disj x y) (Q_Disj x' y')))) AND
                           HPair (Var n) (HPair (Var sni) (HPair (Var sn) (Var sn'))) IN Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair i (HPair (Q_Disj x y) (Q_Disj x' y')))) AND
                           (Var sli EQ Var smi AND Var sli EQ Var sni AND Var sl EQ Q_Disj (Var sm) (Var sn) AND Var sl' EQ Q_Disj (Var sm') (Var sn') OR
                            Var sli EQ Var smi AND Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm') OR
                            SUCC (Var sli) EQ Var smi AND Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm'))))))))))))))"
      \<comment> \<open>verifying the final values\<close>
      apply (rule Ex_I [where x="i"])
      using assms atoms apply simp
      apply (rule Ex_I [where x="Q_Disj x y"], simp)
      apply (rule Ex_I [where x="Q_Disj x' y'"], simp)
      apply (rule Conj_I, metis Mem_Eats_I2 Refl)
      apply (rule Disj_I2)
      apply (rule Conj_I, blast)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x="SUCC (Var k')"], simp)
      apply (rule Ex_I [where x=i], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule_tac x=x' in Ex_I, simp)
      apply (rule Ex_I [where x=i], simp)
      apply (rule Ex_I [where x=y], simp)
      apply (rule_tac x=y' in Ex_I, simp)
      apply (rule Conj_I)
       apply (blast intro: HaddP_Mem_I LstSeqP_OrdP Mem_SUCC_I1)
      apply (rule Conj_I [OF Mem_SUCC_Refl])
      apply (blast intro: Disj_I1 Mem_Eats_I1 Mem_SUCC_Refl SeqAbstFormP_imp_LstSeqP [THEN cut1]
          LstSeqP_imp_Mem SeqAppendP_Mem1 [THEN cut3] SeqAppendP_Mem2 [THEN cut4] HaddP_SUCC1 [THEN cut1])
      done
  next
    show "?hyp \<turnstile> All2 l (SUCC (SUCC (Var k')))
     (SyntaxN.Ex sli
       (SyntaxN.Ex sl
         (SyntaxN.Ex sl'
           (HPair (Var l) (HPair (Var sli) (HPair (Var sl) (Var sl'))) IN
            Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair i (HPair (Q_Disj x y) (Q_Disj x' y')))) AND
            (AbstAtomicP v (Var sli) (Var sl) (Var sl') OR
             OrdP (Var sli) AND
             SyntaxN.Ex m
              (SyntaxN.Ex n
                (SyntaxN.Ex smi
                  (SyntaxN.Ex sm
                    (SyntaxN.Ex sm'
                      (SyntaxN.Ex sni
                        (SyntaxN.Ex sn
                          (SyntaxN.Ex sn'
                            (Var m IN Var l AND
                             Var n IN Var l AND
                             HPair (Var m) (HPair (Var smi) (HPair (Var sm) (Var sm'))) IN
                             Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair i (HPair (Q_Disj x y) (Q_Disj x' y')))) AND
                             HPair (Var n) (HPair (Var sni) (HPair (Var sn) (Var sn'))) IN
                             Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair i (HPair (Q_Disj x y) (Q_Disj x' y')))) AND
                             (Var sli EQ Var smi AND Var sli EQ Var sni AND Var sl EQ Q_Disj (Var sm) (Var sn) AND Var sl' EQ Q_Disj (Var sm') (Var sn') OR
                              Var sli EQ Var smi AND Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm') OR
                              SUCC (Var sli) EQ Var smi AND Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm')))))))))))))))"
      \<comment> \<open>verifying the sequence buildup\<close>
      apply (rule cut_same [where A="HaddP (SUCC k1) (SUCC k2) (SUCC (SUCC (Var k')))"])
       apply (blast intro: HaddP_SUCC1 [THEN cut1] HaddP_SUCC2 [THEN cut1])
      apply (rule All_I Imp_I)+
       apply (rule HaddP_Mem_cases [where i=j])
      using assms atoms atoms2 apply simp_all
          apply (rule AssumeH)
         apply (blast intro: OrdP_SUCC_I LstSeqP_OrdP)
        \<comment> \<open>... the sequence buildup via s1\<close>
       apply (simp add: SeqAbstFormP.simps [of l s1 _ _ sli sl sl' m n smi sm sm' sni sn sn'])
        apply (rule AssumeH Ex_EH Conj_EH)+
        apply (rule All2_E [THEN rotate2])
          apply (simp | rule AssumeH Ex_EH Conj_EH)+
            apply (rule Ex_I [where x="Var sli"], simp)
            apply (rule Ex_I [where x="Var sl"], simp)
            apply (rule Ex_I [where x="Var sl'"], simp)
            apply (rule Conj_I [OF Mem_Eats_I1])
             apply (metis SeqAppendP_Mem1 rotate3 thin2 thin4)
            apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
                          apply (rule Conj_I)
                          apply (blast intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] del: Disj_EH)
                        apply (rule Ex_I [where x="Var m"], simp)
                        apply (rule Ex_I [where x="Var n"], simp)
                        apply (rule Ex_I [where x="Var smi"], simp)
                        apply (rule Ex_I [where x="Var sm"], simp)
                        apply (rule Ex_I [where x="Var sm'"], simp)
                        apply (rule Ex_I [where x="Var sni"], simp)
                        apply (rule Ex_I [where x="Var sn"], simp)
                        apply (rule Ex_I [where x="Var sn'"], simp_all (no_asm_simp))
       apply (rule Conj_I, rule AssumeH)+
       apply (rule Conj_I)
        apply (blast intro: OrdP_Trans [OF OrdP_SUCC_I] Mem_Eats_I1 [OF SeqAppendP_Mem1 [THEN cut3]] Hyp)
       apply (blast intro: Disj_I1 Disj_I2 OrdP_Trans [OF OrdP_SUCC_I] Mem_Eats_I1 [OF SeqAppendP_Mem1 [THEN cut3]] Hyp)
        \<comment> \<open>... the sequence buildup via s2\<close>
       apply (simp add: SeqAbstFormP.simps [of l s2 _ _ sli sl sl' m n smi sm sm' sni sn sn'])
      apply (rule AssumeH Ex_EH Conj_EH)+
      apply (rule All2_E [THEN rotate2])
        apply (simp | rule AssumeH Ex_EH Conj_EH)+
          apply (rule Ex_I [where x="Var sli"], simp)
          apply (rule Ex_I [where x="Var sl"], simp)
          apply (rule Ex_I [where x="Var sl'"], simp)
          apply (rule cut_same [where A="OrdP (Var j)"])
           apply (metis HaddP_imp_OrdP rotate2 thin2)
          apply (rule Conj_I)
           apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] del: Disj_EH)
          apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
                      apply (rule cut_same [OF exists_HaddP [where j=km and x="SUCC k1" and y="Var m"]])
                        apply (blast intro: Ord_IN_Ord, simp)
                      apply (rule cut_same [OF exists_HaddP [where j=kn and x="SUCC k1" and y="Var n"]])
                        apply (metis AssumeH(6) Ord_IN_Ord0 rotate8, simp)
                      apply (rule AssumeH Ex_EH Conj_EH | simp)+
                          apply (rule Conj_I)
                          apply (blast intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] del: Disj_EH)
                          apply (rule Ex_I [where x="Var km"], simp)
                          apply (rule Ex_I [where x="Var kn"], simp)
                          apply (rule Ex_I [where x="Var smi"], simp)
                          apply (rule Ex_I [where x="Var sm"], simp)
                          apply (rule Ex_I [where x="Var sm'"], simp)
                          apply (rule Ex_I [where x="Var sni"], simp)
                          apply (rule Ex_I [where x="Var sn"], simp)
                          apply (rule Ex_I [where x="Var sn'"], simp_all (no_asm_simp))
      apply (rule Conj_I [OF _ Conj_I])
        apply (blast intro!: HaddP_Mem_cancel_left [THEN Iff_MP2_same] OrdP_SUCC_I intro: LstSeqP_OrdP Hyp)+
      apply (blast del: Disj_EH  intro: OrdP_Trans Hyp
          intro!: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] HaddP_imp_OrdP [THEN cut1])
      done
  qed
qed (*>*)

theorem AbstFormP_Disj:
  "{AbstFormP v i x x', AbstFormP v i y y'} \<turnstile> AbstFormP v i (Q_Disj x y) (Q_Disj x' y')"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (v,i,x,y,x',y')"        "atom k1 \<sharp> (v,i,x,y,x',y',s1)"
      "atom s2 \<sharp> (v,i,x,y,x',y',k1,s1)"  "atom k2 \<sharp> (v,i,x,y,x',y',s2,k1,s1)"
      "atom s  \<sharp> (v,i,x,y,x',y',k2,s2,k1,s1)" "atom k  \<sharp> (v,i,x,y,x',y',s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: AbstFormP.simps [of s v i "Q_Disj x y" _ k]
        AbstFormP.simps [of s1 v i x x' k1]
        AbstFormP.simps [of s2 v i y y' k2]
        intro: SeqAbstFormP_Disj [THEN cut4])
qed

subsection \<open>Existential\<close>

lemma SeqAbstFormP_Ex:
  assumes "atom s \<sharp> (k,s1,k1,x,x',v,i)" "atom k \<sharp> (s1,k1,x,x',v,i)"
  shows "{SeqAbstFormP v (SUCC i) x x' s1 k1, OrdP i, VarP v}
           \<turnstile> Ex s (Ex k (SeqAbstFormP v i (Q_Ex x) (Q_Ex x') (Var s) (Var k)))" (*<*)
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name
    and sm::name and sm'::name and sn::name and sn'::name
    and sli smi sni :: name
    where atoms:
      "atom sni \<sharp> (s1,k1,s,k,x,x',v,i,sl,sl',m,n,sm,sm',sn,sn',l,sli,smi)"
      "atom smi \<sharp> (s1,k1,s,k,x,x',v,i,sl,sl',m,n,sm,sm',sn,sn',l,sli)"
      "atom sli \<sharp> (s1,k1,s,k,x,x',v,i,sl,sl',m,n,sm,sm',sn,sn',l)"
      "atom l \<sharp> (s1,k1,s,k,x,x',v,i,sl,sl',m,n,sm,sm',sn,sn')"
      "atom sl \<sharp> (s1,k1,s,k,x,x',v,i,sl',m,n,sm,sm',sn,sn')"
      "atom sl' \<sharp> (s1,k1,s,k,x,x',v,i,m,n,sm,sm',sn,sn')"
      "atom m \<sharp> (s1,k1,s,k,x,x',v,i,n,sm,sm',sn,sn')"
      "atom n \<sharp> (s1,k1,s,k,x,x',v,i,sm,sm',sn,sn')"
      "atom sm \<sharp> (s1,k1,s,k,x,x',v,i,sm',sn,sn')"
      "atom sm' \<sharp> (s1,k1,s,k,x,x',v,i,sn,sn')"
      "atom sn \<sharp> (s1,k1,s,k,x,x',v,i,sn')"
      "atom sn' \<sharp> (s1,k1,s,k,x,x',v,i)"
    by (metis obtain_fresh)
  let ?hyp = "{RestrictedP s1 (SUCC k1) (Var s), OrdP k1, SeqAbstFormP v (SUCC i) x x' s1 k1, OrdP i, VarP v}"
  show ?thesis
    using assms atoms
    apply (auto simp: SeqAbstFormP.simps [of l "Var s" _ _ sli sl sl' m n smi sm sm' sni sn sn'])
    apply (rule cut_same [where A="OrdP k1"])
     apply (metis SeqAbstFormP_imp_OrdP thin2)
    apply (rule cut_same [OF exists_RestrictedP [of s s1 "SUCC k1"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
      apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Ex x) (Q_Ex x'))))"], simp)
      apply (rule Ex_I [where x="(SUCC k1)"], simp)
      apply (rule Conj_I)
       apply (blast intro: RestrictedP_LstSeqP_Eats [THEN cut2] SeqAbstFormP_imp_LstSeqP [THEN cut1])
  proof (rule All2_SUCC_I, simp_all)
    show "?hyp \<turnstile> SyntaxN.Ex sli
     (SyntaxN.Ex sl
       (SyntaxN.Ex sl'
         (HPair (SUCC k1) (HPair (Var sli) (HPair (Var sl) (Var sl'))) IN Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Ex x) (Q_Ex x')))) AND
          (AbstAtomicP v (Var sli) (Var sl) (Var sl') OR
           OrdP (Var sli) AND
           SyntaxN.Ex m
            (SyntaxN.Ex n
              (SyntaxN.Ex smi
                (SyntaxN.Ex sm
                  (SyntaxN.Ex sm'
                    (SyntaxN.Ex sni
                      (SyntaxN.Ex sn
                        (SyntaxN.Ex sn'
                          (Var m IN SUCC k1 AND
                           Var n IN SUCC k1 AND
                           HPair (Var m) (HPair (Var smi) (HPair (Var sm) (Var sm'))) IN
                           Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Ex x) (Q_Ex x')))) AND
                           HPair (Var n) (HPair (Var sni) (HPair (Var sn) (Var sn'))) IN
                           Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Ex x) (Q_Ex x')))) AND
                           (Var sli EQ Var smi AND
                            Var sli EQ Var sni AND Var sl EQ Q_Disj (Var sm) (Var sn) AND Var sl' EQ Q_Disj (Var sm') (Var sn') OR
                            Var sli EQ Var smi AND Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm') OR
                            SUCC (Var sli) EQ Var smi AND Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm'))))))))))))))"
      \<comment> \<open>verifying the final values\<close>
      apply (rule Ex_I [where x="i"])
      using assms atoms apply simp
      apply (rule Ex_I [where x="Q_Ex x"], simp)
      apply (rule Ex_I [where x="Q_Ex x'"], simp)
      apply (rule Conj_I, metis Mem_Eats_I2 Refl)
      apply (rule Disj_I2)
      apply (rule Conj_I, blast)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x="SUCC i"], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule_tac x=x' in Ex_I, simp)
      apply (rule Ex_I [where x="SUCC i"], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule_tac x=x' in Ex_I, simp)
      apply (rule Conj_I [OF Mem_SUCC_Refl])+
      apply (blast intro: Disj_I2 Mem_Eats_I1 RestrictedP_Mem [THEN cut3] Mem_SUCC_Refl
          SeqAbstFormP_imp_LstSeqP [THEN cut1] LstSeqP_imp_Mem)
      done
  next
    show "?hyp
             \<turnstile> All2 l (SUCC k1)
     (SyntaxN.Ex sli
       (SyntaxN.Ex sl
         (SyntaxN.Ex sl'
           (HPair (Var l) (HPair (Var sli) (HPair (Var sl) (Var sl'))) IN Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Ex x) (Q_Ex x')))) AND
            (AbstAtomicP v (Var sli) (Var sl) (Var sl') OR
             OrdP (Var sli) AND
             SyntaxN.Ex m
              (SyntaxN.Ex n
                (SyntaxN.Ex smi
                  (SyntaxN.Ex sm
                    (SyntaxN.Ex sm'
                      (SyntaxN.Ex sni
                        (SyntaxN.Ex sn
                          (SyntaxN.Ex sn'
                            (Var m IN Var l AND
                             Var n IN Var l AND
                             HPair (Var m) (HPair (Var smi) (HPair (Var sm) (Var sm'))) IN
                             Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Ex x) (Q_Ex x')))) AND
                             HPair (Var n) (HPair (Var sni) (HPair (Var sn) (Var sn'))) IN
                             Eats (Var s) (HPair (SUCC k1) (HPair i (HPair (Q_Ex x) (Q_Ex x')))) AND
                             (Var sli EQ Var smi AND Var sli EQ Var sni AND Var sl EQ Q_Disj (Var sm) (Var sn) AND Var sl' EQ Q_Disj (Var sm') (Var sn') OR
                              Var sli EQ Var smi AND Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm') OR
                              SUCC (Var sli) EQ Var smi AND Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm')))))))))))))))"
      \<comment> \<open>verifying the sequence buildup\<close>
      using assms atoms
        \<comment> \<open>... the sequence buildup via s1\<close>
      apply (auto simp add: SeqAbstFormP.simps [of l s1 _ _ sli sl sl' m n smi sm sm' sni sn sn'])
      apply (rule Swap)
      apply (rule All2_E, auto del: Disj_EH)
      apply (rule Ex_I [where x="Var sli"], simp)
      apply (rule Ex_I [where x="Var sl"], simp)
      apply (rule Ex_I [where x="Var sl'"], simp)
      apply (rule Conj_I)
       apply (blast intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] del: Disj_EH)
      apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
          apply (rule Conj_I)
           apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] del: Disj_EH)
                  apply (rule Ex_I [where x="Var m"], simp)
                  apply (rule Ex_I [where x="Var n"], simp)
                  apply (rule Ex_I [where x="Var smi"], simp)
                  apply (rule Ex_I [where x="Var sm"], simp)
                  apply (rule Ex_I [where x="Var sm'"], simp)
                  apply (rule Ex_I [where x="Var sni"], simp)
                  apply (rule Ex_I [where x="Var sn"], simp)
                  apply (rule Ex_I [where x="Var sn'"])
                  apply (auto intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] OrdP_Trans [OF OrdP_SUCC_I] del: Disj_EH)
      done
  qed
qed (*>*)

theorem AbstFormP_Ex: "{AbstFormP v (SUCC i) x x'} \<turnstile> AbstFormP v i (Q_Ex x) (Q_Ex x')"
proof -
  obtain k1::name and s1::name and k::name and s::name
    where "atom s1 \<sharp> (v,i,x,x')"        "atom k1 \<sharp> (v,i,x,x',s1)"
      "atom s  \<sharp> (v,i,x,x',k1,s1)"  "atom k  \<sharp> (v,i,x,x',s,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: AbstFormP.simps [of s v i "Q_Ex x" _ k] AbstFormP.simps [of s1 v "SUCC i" x x' k1]
        intro!: SeqAbstFormP_Ex [THEN cut3] Ord_IN_Ord[OF Mem_SUCC_I2[OF Refl], of _ i])
qed

corollary AbstTermP_Zero: "{OrdP t} \<turnstile> AbstTermP \<guillemotleft>Var v\<guillemotright> t Zero Zero"
proof -
  obtain s::name and k::name where "atom s \<sharp> (v,t,k)"  "atom k \<sharp> (v,t)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: AbstTermP.simps [of s _ _ _ _ k] intro: SeqStTermP_Zero [THEN cut1])
qed

corollary AbstTermP_Var_same: "{VarP v, OrdP t} \<turnstile> AbstTermP v t v (Q_Ind t)"
proof -
  obtain s::name and k::name where "atom s \<sharp> (v,t,k)" "atom k \<sharp> (v,t)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: AbstTermP.simps [of s _ _ _ _ k] intro: SeqStTermP_Var_same [THEN cut1])
qed

corollary AbstTermP_Var_diff: "{VarP v, VarP w, Neg (v EQ w), OrdP t} \<turnstile> AbstTermP v t w w"
proof -
  obtain s::name and k::name where "atom s \<sharp> (v,w,t,k)" "atom k \<sharp> (v,w,t)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: AbstTermP.simps [of s _ _ _ _ k] intro: SeqStTermP_Var_diff [THEN cut3])
qed

theorem AbstTermP_Eats:
   "{AbstTermP v i t1 u1, AbstTermP v i t2 u2} \<turnstile> AbstTermP v i (Q_Eats t1 t2) (Q_Eats u1 u2)"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (v,i,t1,u1,t2,u2)" "atom k1 \<sharp> (v,i,t1,u1,t2,u2,s1)"
          "atom s2 \<sharp> (v,i,t1,u1,t2,u2,k1,s1)" "atom k2 \<sharp> (v,i,t1,u1,t2,u2,s2,k1,s1)"
          "atom s  \<sharp> (v,i,t1,u1,t2,u2,k2,s2,k1,s1)"
          "atom k  \<sharp> (v,i,t1,u1,t2,u2,s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
   thus ?thesis
     by (auto intro!: SeqStTermP_Eats [THEN cut2]
              simp: AbstTermP.simps [of s _ _ _ "(Q_Eats u1 u2)" k]
                    AbstTermP.simps [of s1 v i t1 u1 k1]
                    AbstTermP.simps [of s2 v i t2 u2 k2])
 qed

corollary AbstTermP_Ind: "{VarP v, IndP w, OrdP t} \<turnstile> AbstTermP v t w w"
proof -
  obtain s::name and k::name where "atom s \<sharp> (v,w,t,k)" "atom k \<sharp> (v,w,t)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: AbstTermP.simps [of s _ _ _ _ k]
              intro: SeqStTermP_Ind [THEN cut2])
qed

lemma ORD_OF_EQ_diff: "x \<noteq> y \<Longrightarrow> {ORD_OF x EQ ORD_OF y} \<turnstile> Fls"
proof (induct x arbitrary: y)
  case (Suc x)
  then show ?case using SUCC_inject_E
    by (cases y) (auto simp: gr0_conv_Suc Eats_EQ_Zero_E SUCC_def)
qed (auto simp: gr0_conv_Suc SUCC_def)

lemma quot_Var_EQ_diff: "i \<noteq> x \<Longrightarrow> {\<guillemotleft>Var i\<guillemotright> EQ \<guillemotleft>Var x\<guillemotright>} \<turnstile> Fls"
  by (auto simp: quot_Var ORD_OF_EQ_diff)

lemma AbstTermP_dbtm: "{} \<turnstile> AbstTermP \<guillemotleft>Var i\<guillemotright> (ORD_OF n) (quot_dbtm u) (quot_dbtm (abst_dbtm i n u))"
proof (induct u rule: dbtm.induct)
  case (DBVar x)
  then show ?case
    by (auto simp: quot_Var[symmetric] quot_Var_EQ_diff
      intro!: AbstTermP_Var_same[THEN cut2] AbstTermP_Var_diff[THEN cut4] TermP_Zero)
qed (auto intro!: AbstTermP_Zero[THEN cut1] AbstTermP_Eats[THEN cut2] AbstTermP_Ind[THEN cut3] IndP_Q_Ind)

lemma AbstFormP_dbfm: "{} \<turnstile> AbstFormP \<guillemotleft>Var i\<guillemotright> (ORD_OF n) (quot_dbfm db) (quot_dbfm (abst_dbfm i n db))"
  by (induction db arbitrary: n rule: dbfm.induct)
    (auto intro!: AbstTermP_dbtm AbstFormP_Mem[THEN cut2] AbstFormP_Eq[THEN cut2]
        AbstFormP_Disj[THEN cut2] AbstFormP_Neg[THEN cut1] AbstFormP_Ex[THEN cut1]
        dest: meta_spec[of _ "Suc _"])

lemmas AbstFormP = AbstFormP_dbfm[where db="trans_fm [] A" and n = 0 for A,
    simplified, folded quot_fm_def, unfolded abst_trans_fm]

lemma SubstTermP_trivial_dbtm:
  "atom i \<sharp> u \<Longrightarrow> {} \<turnstile> SubstTermP \<guillemotleft>Var i\<guillemotright> Zero (quot_dbtm u) (quot_dbtm u)"
proof (induct u rule: dbtm.induct)
  case (DBVar x)
  then show ?case
    by (auto simp: quot_Var[symmetric] quot_Var_EQ_diff
      intro!: SubstTermP_Var_same[THEN cut2] SubstTermP_Var_diff[THEN cut4] TermP_Zero)
qed (auto intro!: SubstTermP_Zero[THEN cut1] SubstTermP_Eats[THEN cut2] SubstTermP_Ind[THEN cut3]
  TermP_Zero IndP_Q_Ind)

lemma SubstTermP_dbtm: "wf_dbtm t \<Longrightarrow>
   {} \<turnstile> SubstTermP \<guillemotleft>Var i\<guillemotright> (quot_dbtm t) (quot_dbtm u) (quot_dbtm (subst_dbtm t i u))"
proof (induct u rule: dbtm.induct)
  case (DBVar x)
  then show ?case
    apply (auto simp: quot_Var[symmetric]
      intro!: SubstTermP_Var_same[THEN cut2] SubstTermP_Var_diff[THEN cut4] TermP_quot_dbtm)
    apply (auto simp: quot_Var ORD_OF_EQ_diff)
    done
qed (auto intro!: SubstTermP_Zero[THEN cut1] SubstTermP_Ind[THEN cut3] SubstTermP_Eats[THEN cut2]
   TermP_quot_dbtm IndP_Q_Ind)

lemma SubstFormP_trivial_dbfm:
  fixes X :: fm
  assumes "atom i \<sharp> db"
  shows "{} \<turnstile> SubstFormP \<guillemotleft>Var i\<guillemotright> Zero (quot_dbfm db) (quot_dbfm db)"
  using assms
  by (induct db rule: dbfm.induct)
    (auto intro!: SubstFormP_Ex[THEN cut1] SubstFormP_Neg[THEN cut1] SubstFormP_Disj[THEN cut2]
          SubstFormP_Eq[THEN cut2] SubstFormP_Mem[THEN cut2] SubstTermP_trivial_dbtm)+

lemma SubstFormP_dbfm:
  assumes "wf_dbtm t"
  shows "{} \<turnstile> SubstFormP \<guillemotleft>Var i\<guillemotright> (quot_dbtm t) (quot_dbfm db) (quot_dbfm (subst_dbfm t i db))"
  by (induct db rule: dbfm.induct)
    (auto intro!: SubstTermP_dbtm assms SubstFormP_Ex[THEN cut1] SubstFormP_Neg[THEN cut1]
           SubstFormP_Disj[THEN cut2] SubstFormP_Eq[THEN cut2] SubstFormP_Mem[THEN cut2])+

lemmas SubstFormP_trivial = SubstFormP_trivial_dbfm[where db="trans_fm [] A" for A,
    simplified, folded quot_tm_def quot_fm_def quot_subst_eq]
lemmas SubstFormP = SubstFormP_dbfm[OF wf_dbtm_trans_tm, where db="trans_fm [] A" for A,
    simplified, folded quot_tm_def quot_fm_def quot_subst_eq]
lemmas SubstFormP_Zero = SubstFormP_dbfm[OF wf_dbtm.Zero, where db="trans_fm [] A" for A,
    simplified, folded  trans_tm.simps[of "[]"], folded quot_tm_def quot_fm_def quot_subst_eq]

lemma AtomicP_Mem:
  "{TermP x, TermP y} \<turnstile> AtomicP (Q_Mem x y)"
proof -
  obtain t::name and u::name
    where "atom t \<sharp> (x, y)" "atom u \<sharp> (t, x, y)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (simp add: AtomicP.simps [of t u])
    apply (rule Ex_I [where x = x], simp)
    apply (rule Ex_I [where x = y], simp)
    apply (auto intro: Disj_I2)
    done
qed

lemma AtomicP_Eq:
  "{TermP x, TermP y} \<turnstile> AtomicP (Q_Eq x y)"
proof -
  obtain t::name and u::name
    where "atom t \<sharp> (x, y)" "atom u \<sharp> (t, x, y)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (simp add: AtomicP.simps [of t u])
    apply (rule Ex_I [where x = x], simp)
    apply (rule Ex_I [where x = y], simp)
    apply (auto intro: Disj_I1)
    done
qed

lemma SeqFormP_Mem:
  assumes "atom s \<sharp> (k,x,y)" "atom k \<sharp> (x,y)"
  shows "{TermP x, TermP y} \<turnstile> Ex k (Ex s (SeqFormP (Var s) (Var k) (Q_Mem x y)))"
proof -
  let ?vs = "(x,y,s,k)"
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where
      "atom l \<sharp> (?vs,sl,m,n,sm,sn)"
      "atom sl \<sharp> (?vs,m,n,sm,sn)"
      "atom m \<sharp> (?vs,n,sm,sn)" "atom n \<sharp> (?vs,sm,sn)"
      "atom sm \<sharp> (?vs,sn)"
      "atom sn \<sharp> (?vs)"
    by (metis obtain_fresh)
  with assms show ?thesis
    apply (auto simp: SeqFormP.simps[of l "Var s" _ _ sl m n sm sn])
    apply (rule Ex_I [where x = Zero], simp)
    apply (rule Ex_I [where x = "Eats Zero (HPair Zero (Q_Mem x y))"], auto intro!: Mem_SUCC_EH)
    apply (rule Ex_I [where x = "Q_Mem x y"], auto intro!: Mem_Eats_I2 HPair_cong Disj_I1 AtomicP_Mem[THEN cut2])
    done
qed

lemma SeqFormP_Eq:
  assumes "atom s \<sharp> (k,x,y)" "atom k \<sharp> (x,y)"
  shows "{TermP x, TermP y} \<turnstile> Ex k (Ex s (SeqFormP (Var s) (Var k) (Q_Eq x y)))"
proof -
  let ?vs = "(x,y,s,k)"
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where
      "atom l \<sharp> (?vs,sl,m,n,sm,sn)"
      "atom sl \<sharp> (?vs,m,n,sm,sn)"
      "atom m \<sharp> (?vs,n,sm,sn)" "atom n \<sharp> (?vs,sm,sn)"
      "atom sm \<sharp> (?vs,sn)"
      "atom sn \<sharp> (?vs)"
    by (metis obtain_fresh)
  with assms show ?thesis
    apply (auto simp: SeqFormP.simps[of l "Var s" _ _ sl m n sm sn])
    apply (rule Ex_I [where x = Zero], simp)
    apply (rule Ex_I [where x = "Eats Zero (HPair Zero (Q_Eq x y))"], auto intro!: Mem_SUCC_EH)
    apply (rule Ex_I [where x = "Q_Eq x y"], auto intro!: Mem_Eats_I2 HPair_cong Disj_I1 AtomicP_Eq[THEN cut2])
    done
qed

lemma FormP_Mem:
  "{TermP x, TermP y} \<turnstile> FormP (Q_Mem x y)"
proof -
  obtain s::name and k::name
    where "atom s \<sharp> (x, y)" "atom k \<sharp> (s, x, y)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp add: FormP.simps [of k s] intro!: SeqFormP_Mem)
qed

lemma FormP_Eq:
  "{TermP x, TermP y} \<turnstile> FormP (Q_Eq x y)"
proof -
  obtain s::name and k::name
    where "atom s \<sharp> (x, y)" "atom k \<sharp> (s, x, y)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp add: FormP.simps [of k s] intro!: SeqFormP_Eq)
qed

subsection \<open>MakeForm\<close>

lemma MakeFormP_Neg: "{} \<turnstile> MakeFormP (Q_Neg x) x y"
proof -
  obtain a::name and b::name
    where "atom a \<sharp> (x, y)" "atom b \<sharp> (a, x, y)" by (metis obtain_fresh)
  then show ?thesis
    by (auto simp: MakeFormP.simps[of a _ _ _ b] intro: Disj_I2[OF Disj_I1])
qed

lemma MakeFormP_Disj: "{} \<turnstile> MakeFormP (Q_Disj x y) x y"
proof -
  obtain a::name and b::name
    where "atom a \<sharp> (x, y)" "atom b \<sharp> (a, x, y)" by (metis obtain_fresh)
  then show ?thesis
    by (auto simp: MakeFormP.simps[of a _ _ _ b] intro: Disj_I1)
qed

lemma MakeFormP_Ex: "{AbstFormP v Zero t x} \<turnstile> MakeFormP (Q_Ex x) t y"
proof -
  obtain a::name and b::name
    where "atom a \<sharp> (v, x, t, y)" "atom b \<sharp> (a, v, x, t, y)" by (metis obtain_fresh)
  then show ?thesis
    by (subst MakeFormP.simps[of a _ _ _ b])
      (force intro!: Disj_I2[OF Disj_I2] intro: Ex_I[of _ _ _ v] Ex_I[of _ _ _ x])+
qed

subsection \<open>Negation\<close>

lemma SeqFormP_Neg:
  assumes "atom s \<sharp> (k,s1,k1,x)" "atom k \<sharp> (s1,k1,x)"
  shows "{SeqFormP s1 k1 x} \<turnstile> Ex k (Ex s (SeqFormP (Var s) (Var k) (Q_Neg x)))" (*<*)
proof -
  let ?vs = "(s1,k1,s,k,x)"
  obtain l::name and sl::name and m::name and n::name and
    sm::name and sn::name
    where atoms:
      "atom l \<sharp> (?vs,sl,m,n,sm,sn)"
      "atom sl \<sharp> (?vs,m,n,sm,sn)"
      "atom m \<sharp> (?vs,n,sm,sn)" "atom n \<sharp> (?vs,sm,sn)"
      "atom sm \<sharp> (?vs,sn)"
      "atom sn \<sharp> (?vs)"
    by (metis obtain_fresh)
  let ?hyp = "{RestrictedP s1 (SUCC k1) (Var s), OrdP k1, SeqFormP s1 k1 x}"
  show ?thesis
    using assms atoms
    apply (auto simp: SeqFormP.simps [of l "Var s" _ _ sl m n sm sn])
    apply (rule cut_same [where A="OrdP k1"])
    apply (rule SeqFormP_imp_OrdP)
    apply (rule cut_same [OF exists_RestrictedP [of s s1 "SUCC k1"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
    apply (rule Ex_I [where x="(SUCC k1)"])
      apply (simp_all (no_asm_simp))
      apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC k1)  (Q_Neg x))"])
      apply (simp_all (no_asm_simp))
    apply (rule Conj_I)
     apply (blast intro: RestrictedP_LstSeqP_Eats [THEN cut2] SeqFormP_imp_LstSeqP [THEN cut1])
  proof (rule All2_SUCC_I, simp_all)
    show "?hyp \<turnstile> SyntaxN.Ex sn
     (HPair (SUCC k1) (Var sn) IN
      Eats (Var s) (HPair (SUCC k1) (Q_Neg x)) AND
      (AtomicP (Var sn) OR
       SyntaxN.Ex m
        (SyntaxN.Ex l
          (SyntaxN.Ex sm
            (SyntaxN.Ex sl
              (Var m IN SUCC k1 AND
               Var l IN SUCC k1 AND
               HPair (Var m) (Var sm) IN
               Eats (Var s) (HPair (SUCC k1) (Q_Neg x)) AND
               HPair (Var l) (Var sl) IN
               Eats (Var s) (HPair (SUCC k1) (Q_Neg x)) AND
               MakeFormP (Var sn) (Var sm) (Var sl)))))))"
      \<comment> \<open>verifying the final values\<close>
      apply (rule Ex_I [where x="Q_Neg x"])
      using assms atoms apply simp
      apply (rule Conj_I, metis Mem_Eats_I2 Refl)
      apply (rule Disj_I2)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule Conj_I [OF Mem_SUCC_Refl])+
      apply (blast intro: Disj_I1 Disj_I2 Mem_Eats_I1 RestrictedP_Mem [THEN cut3] Mem_SUCC_Refl
          SeqFormP_imp_LstSeqP [THEN cut1] LstSeqP_imp_Mem MakeFormP_Neg[THEN thin0])
      done
  next
    show "?hyp \<turnstile> All2 n (SUCC k1)
     (SyntaxN.Ex sn
       (HPair (Var n) (Var sn) IN
        Eats (Var s) (HPair (SUCC k1) (Q_Neg x)) AND
        (AtomicP (Var sn) OR
         SyntaxN.Ex m
          (SyntaxN.Ex l
            (SyntaxN.Ex sm
              (SyntaxN.Ex sl
                (Var m IN Var n AND
                 Var l IN Var n AND
                 HPair (Var m) (Var sm) IN
                 Eats (Var s) (HPair (SUCC k1) (Q_Neg x)) AND
                 HPair (Var l) (Var sl) IN
                 Eats (Var s) (HPair (SUCC k1) (Q_Neg x)) AND
                 MakeFormP (Var sn) (Var sm) (Var sl))))))))"
      \<comment> \<open>verifying the sequence buildup\<close>
      apply (rule All_I Imp_I)+
      using assms atoms apply simp_all
        \<comment> \<open>... the sequence buildup via s1\<close>
    apply (simp add: SeqFormP.simps [of l s1 _ _ sl m n sm sn])
      apply (rule AssumeH Ex_EH Conj_EH)+
      apply (rule All2_E [THEN rotate2], auto del: Disj_EH)
      apply (rule Ex_I [where x="Var sn"], simp)
      apply (rule Conj_I)
       apply (blast intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] del: Disj_EH)
      apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH Conj_I)+
              apply (rule Ex_I [where x="Var m"], simp)
              apply (rule Ex_I [where x="Var l"], simp)
              apply (rule Ex_I [where x="Var sm"], simp)
              apply (rule Ex_I [where x="Var sl"], simp)
              apply auto
       apply (rule Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] AssumeH OrdP_Trans [OF OrdP_SUCC_I])+
      done
  qed
qed (*>*)

theorem FormP_Neg: "{FormP x} \<turnstile> FormP (Q_Neg x)"
proof -
  obtain k1::name and s1::name and k::name and s::name
    where "atom s1 \<sharp> x"        "atom k1 \<sharp> (x,s1)"
      "atom s \<sharp> (x,k1,s1)"  "atom k  \<sharp> (x,s,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: FormP.simps [of k s "Q_Neg x"] FormP.simps [of k1 s1 x]
        intro: SeqFormP_Neg [THEN cut1])
qed

subsection \<open>Disjunction\<close>

lemma SeqFormP_Disj:
  assumes "atom s \<sharp> (k,s1,s2,k1,k2,x,y)" "atom k \<sharp> (s1,s2,k1,k2,x,y)"
  shows "{SeqFormP s1 k1 x, SeqFormP s2 k2 y}
           \<turnstile> Ex k (Ex s (SeqFormP (Var s) (Var k) (Q_Disj x y)))" (*<*)
proof -
  let ?vs = "(s1,s2,s,k1,k2,k,x,y)"
  obtain km::name and kn::name and j::name and k'::name
    and l::name and sl::name and m::name and n::name
    and sm::name and sn::name
    where atoms2: "atom km \<sharp> (kn,j,k',l,s1,s2,s,k1,k2,k,x,y,sl,m,n,sm,sn)"
      "atom kn \<sharp> (j,k',l,s1,s2,s,k1,k2,k,x,y,sl,m,n,sm,sn)"
      "atom j \<sharp> (k',l,s1,s2,s,k1,k2,k,x,y,sl,m,n,sm,sn)"
      and atoms: "atom k' \<sharp> (l,s1,s2,s,k1,k2,k,x,y,sl,m,n,sm,sn)"
      "atom l \<sharp> (s1,s2,s,k1,k2,k,x,y,sl,m,n,sm,sn)"
      "atom sl \<sharp> (s1,s2,s,k1,k2,k,x,y,m,n,sm,sn)"
      "atom m \<sharp> (s1,s2,s,k1,k2,k,x,y,n,sm,sn)"
      "atom n \<sharp> (s1,s2,s,k1,k2,k,x,y,sm,sn)"
      "atom sm \<sharp> (s1,s2,s,k1,k2,k,x,y,sn)"
      "atom sn \<sharp> (s1,s2,s,k1,k2,k,x,y)"
    by (metis obtain_fresh)
  let ?hyp = "{HaddP k1 k2 (Var k'), OrdP k1, OrdP k2, SeqAppendP s1 (SUCC k1) s2 (SUCC k2) (Var s),
               SeqFormP s1 k1 x, SeqFormP s2 k2 y}"
  show ?thesis
    using assms atoms
    apply (auto simp: SeqFormP.simps [of l "Var s" _ _ sl m n sm sn])
    apply (rule cut_same [where A="OrdP k1 AND OrdP k2"])
     apply (metis Conj_I SeqFormP_imp_OrdP thin1 thin2)
    apply (rule cut_same [OF exists_SeqAppendP [of s s1 "SUCC k1" s2 "SUCC k2"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
      apply (rule cut_same [OF exists_HaddP [where j=k' and x=k1 and y=k2]])
        apply (rule AssumeH Ex_EH Conj_EH | simp)+
        apply (rule Ex_I [where x="SUCC (SUCC (Var k'))"])
        apply (simp_all (no_asm_simp) add: )
    apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC(SUCC(Var k'))) (Q_Disj x y))"], simp)
    apply (rule Conj_I)
     apply (blast intro: LstSeqP_SeqAppendP_Eats SeqFormP_imp_LstSeqP [THEN cut1])
  proof (rule All2_SUCC_I, simp_all)
    show "?hyp \<turnstile> SyntaxN.Ex sn
     (HPair (SUCC (SUCC (Var k'))) (Var sn) IN
      Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Disj x y)) AND
      (AtomicP (Var sn) OR
       SyntaxN.Ex m
        (SyntaxN.Ex l
          (SyntaxN.Ex sm
            (SyntaxN.Ex sl
              (Var m IN SUCC (SUCC (Var k')) AND
               Var l IN SUCC (SUCC (Var k')) AND
               HPair (Var m) (Var sm) IN
               Eats (Var s)
                (HPair (SUCC (SUCC (Var k'))) (Q_Disj x y)) AND
               HPair (Var l) (Var sl) IN
               Eats (Var s)
                (HPair (SUCC (SUCC (Var k'))) (Q_Disj x y)) AND
               MakeFormP (Var sn) (Var sm) (Var sl)))))))"
      \<comment> \<open>verifying the final values\<close>
      apply (rule Ex_I [where x="Q_Disj x y"])
      using assms atoms apply simp
      apply (rule Conj_I, metis Mem_Eats_I2 Refl)
      apply (rule Disj_I2)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x="SUCC (Var k')"], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule Ex_I [where x=y], simp)
      apply (rule Conj_I)
       apply (blast intro: HaddP_Mem_I LstSeqP_OrdP Mem_SUCC_I1)
      apply (rule Conj_I [OF Mem_SUCC_Refl])
      apply (blast intro: Disj_I1 Mem_Eats_I1 Mem_SUCC_Refl SeqFormP_imp_LstSeqP [THEN cut1]
          LstSeqP_imp_Mem SeqAppendP_Mem1 [THEN cut3] SeqAppendP_Mem2 [THEN cut4] HaddP_SUCC1 [THEN cut1]
          MakeFormP_Disj[THEN thin0])
      done
  next
    show "?hyp \<turnstile> All2 n (SUCC (SUCC (Var k')))
     (SyntaxN.Ex sn
       (HPair (Var n) (Var sn) IN
        Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (Q_Disj x y)) AND
        (AtomicP (Var sn) OR
         SyntaxN.Ex m
          (SyntaxN.Ex l
            (SyntaxN.Ex sm
              (SyntaxN.Ex sl
                (Var m IN Var n AND
                 Var l IN Var n AND
                 HPair (Var m) (Var sm) IN
                 Eats (Var s)
                  (HPair (SUCC (SUCC (Var k'))) (Q_Disj x y)) AND
                 HPair (Var l) (Var sl) IN
                 Eats (Var s)
                  (HPair (SUCC (SUCC (Var k'))) (Q_Disj x y)) AND
                 MakeFormP (Var sn) (Var sm) (Var sl))))))))"
      \<comment> \<open>verifying the sequence buildup\<close>
      apply (rule cut_same [where A="HaddP (SUCC k1) (SUCC k2) (SUCC (SUCC (Var k')))"])
       apply (blast intro: HaddP_SUCC1 [THEN cut1] HaddP_SUCC2 [THEN cut1])
      apply (rule All_I Imp_I)+
       apply (rule HaddP_Mem_cases [where i=j])
      using assms atoms atoms2 apply simp_all
          apply (rule AssumeH)
         apply (blast intro: OrdP_SUCC_I LstSeqP_OrdP)
        \<comment> \<open>... the sequence buildup via s1\<close>
        apply (simp add: SeqFormP.simps [of l s1 _ _ sl m n sm sn])
        apply (rule AssumeH Ex_EH Conj_EH)+
        apply (rule All2_E [THEN rotate2])
          apply (simp | rule AssumeH Ex_EH Conj_EH)+
            apply (rule Ex_I [where x="Var sn"], simp)
            apply (rule Conj_I [OF Mem_Eats_I1])
             apply (metis SeqAppendP_Mem1 rotate3 thin2 thin4)
            apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
                        apply (rule Ex_I [where x="Var m"], simp)
                        apply (rule Ex_I [where x="Var l"], simp)
                        apply (rule Ex_I [where x="Var sm"], simp)
                        apply (rule Ex_I [where x="Var sl"], simp_all (no_asm_simp))
       apply (rule Conj_I, rule AssumeH)+
       apply (rule Conj_I)
        apply (blast intro: OrdP_Trans [OF OrdP_SUCC_I] Mem_Eats_I1 [OF SeqAppendP_Mem1 [THEN cut3]] Hyp)
       apply (blast intro: Disj_I1 Disj_I2 OrdP_Trans [OF OrdP_SUCC_I] Mem_Eats_I1 [OF SeqAppendP_Mem1 [THEN cut3]] Hyp)
        \<comment> \<open>... the sequence buildup via s2\<close>
      apply (simp add: SeqFormP.simps [of l s2 _ _ sl m n sm sn])
      apply (rule AssumeH Ex_EH Conj_EH)+
      apply (rule All2_E [THEN rotate2])
        apply (simp | rule AssumeH Ex_EH Conj_EH)+
          apply (rule Ex_I [where x="Var sn"], simp)
          apply (rule cut_same [where A="OrdP (Var j)"])
           apply (metis HaddP_imp_OrdP rotate2 thin2)
          apply (rule Conj_I)
           apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] del: Disj_EH)
          apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
                      apply (rule cut_same [OF exists_HaddP [where j=km and x="SUCC k1" and y="Var m"]])
                        apply (blast intro: Ord_IN_Ord, simp)
                apply (rule cut_same [OF exists_HaddP [where j=kn and x="SUCC k1" and y="Var l"]])
                        apply (metis AssumeH(6) Ord_IN_Ord0 rotate8, simp)
                      apply (rule AssumeH Ex_EH Conj_EH | simp)+
                          apply (rule Ex_I [where x="Var km"], simp)
                          apply (rule Ex_I [where x="Var kn"], simp)
                          apply (rule Ex_I [where x="Var sm"], simp)
                          apply (rule Ex_I [where x="Var sl"], simp_all (no_asm_simp))
      apply (rule Conj_I [OF _ Conj_I])
        apply (blast intro!: HaddP_Mem_cancel_left [THEN Iff_MP2_same] OrdP_SUCC_I intro: LstSeqP_OrdP Hyp)+
      apply (blast del: Disj_EH  intro: OrdP_Trans Hyp
          intro!: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] HaddP_imp_OrdP [THEN cut1])
      done
  qed
qed (*>*)

theorem FormP_Disj:
  "{FormP x, FormP y} \<turnstile> FormP (Q_Disj x y)"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (x,y)"        "atom k1 \<sharp> (x,y,s1)"
      "atom s2 \<sharp> (x,y,k1,s1)"  "atom k2 \<sharp> (x,y,s2,k1,s1)"
      "atom s  \<sharp> (x,y,k2,s2,k1,s1)" "atom k  \<sharp> (x,y,s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: FormP.simps [of k s "Q_Disj x y"]
        FormP.simps [of k1 s1 x]
        FormP.simps [of k2 s2 y]
        intro: SeqFormP_Disj [THEN cut2])
qed

subsection \<open>Existential\<close>

lemma SeqFormP_Ex:
  assumes "atom s \<sharp> (k,s1,k1,x,y,v)" "atom k \<sharp> (s1,k1,x,y,v)"
  shows "{SeqFormP s1 k1 x,AbstFormP v Zero x y, VarP v} \<turnstile> Ex k (Ex s (SeqFormP (Var s) (Var k) (Q_Ex y)))"
proof -
  let ?vs = "(s1,s,k1,k,x,y,v)"
  obtain km::name and kn::name and j::name and k'::name
    and l::name and sl::name and m::name and n::name
    and sm::name and sn::name
    where atoms2: "atom km \<sharp> (kn,j,k',l,s1,s,k1,k,x,y,v,sl,m,n,sm,sn)"
      "atom kn \<sharp> (j,k',l,s1,s,k1,k,x,y,v,sl,m,n,sm,sn)"
      "atom j \<sharp> (k',l,s1,s,k1,k,x,y,v,sl,m,n,sm,sn)"
      and atoms: "atom k' \<sharp> (l,s1,s,k1,k,x,y,v,sl,m,n,sm,sn)"
      "atom l \<sharp> (s1,s,k1,k,x,y,v,sl,m,n,sm,sn)"
      "atom sl \<sharp> (s1,s,k1,k,x,y,v,m,n,sm,sn)"
      "atom m \<sharp> (s1,s,k1,k,x,y,v,n,sm,sn)"
      "atom n \<sharp> (s1,s,k1,k,x,y,v,sm,sn)"
      "atom sm \<sharp> (s1,s,k1,k,x,y,v,sn)"
      "atom sn \<sharp> (s1,s,k1,k,x,y,v)"
    by (metis obtain_fresh)
  let ?hyp = "{RestrictedP s1 (SUCC k1) (Var s), OrdP k1, SeqFormP s1 k1 x,AbstFormP v Zero x y, VarP v}"
  show ?thesis
    using assms atoms
    apply (auto simp: SeqFormP.simps [of l "Var s" _ _ sl m n sm sn])
    apply (rule cut_same [where A="OrdP k1"])
     apply (metis SeqFormP_imp_OrdP thin2)
    apply (rule cut_same [OF exists_RestrictedP [of s s1 "SUCC k1"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
      apply (rule Ex_I [where x="(SUCC k1)"], simp)
      apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC k1) (Q_Ex y))"], simp)
      apply (rule Conj_I)
       apply (blast intro: RestrictedP_LstSeqP_Eats [THEN cut2] SeqFormP_imp_LstSeqP [THEN cut1])
  proof (rule All2_SUCC_I, simp_all)
    show "?hyp \<turnstile>  SyntaxN.Ex sn
     (HPair (SUCC k1) (Var sn) IN
      Eats (Var s) (HPair (SUCC k1) (Q_Ex y)) AND
      (AtomicP (Var sn) OR
       SyntaxN.Ex m
        (SyntaxN.Ex l
          (SyntaxN.Ex sm
            (SyntaxN.Ex sl
              (Var m IN SUCC k1 AND
               Var l IN SUCC k1 AND
               HPair (Var m) (Var sm) IN
               Eats (Var s) (HPair (SUCC k1) (Q_Ex y)) AND
               HPair (Var l) (Var sl) IN
               Eats (Var s) (HPair (SUCC k1) (Q_Ex y)) AND
               MakeFormP (Var sn) (Var sm) (Var sl)))))))"
      \<comment> \<open>verifying the final values\<close>
      apply (rule Ex_I [where x="Q_Ex y"])
      using assms atoms apply simp
      apply (rule Conj_I, metis Mem_Eats_I2 Refl)
      apply (rule Disj_I2)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule Conj_I [OF Mem_SUCC_Refl])+
      apply safe
      apply (blast intro: Disj_I2 Mem_Eats_I1 RestrictedP_Mem [THEN cut3] Mem_SUCC_Refl
          SeqFormP_imp_LstSeqP [THEN cut1] LstSeqP_imp_Mem)
      apply (blast intro: Disj_I2 Mem_Eats_I1 RestrictedP_Mem [THEN cut3] Mem_SUCC_Refl
          SeqFormP_imp_LstSeqP [THEN cut1] LstSeqP_imp_Mem)
      apply (rule MakeFormP_Ex[THEN cut1, of _ v])
      apply blast
      done
  next
    show "?hyp \<turnstile> All2 n (SUCC k1)
     (SyntaxN.Ex sn
       (HPair (Var n) (Var sn) IN
        Eats (Var s) (HPair (SUCC k1) (Q_Ex y)) AND
        (AtomicP (Var sn) OR
         SyntaxN.Ex m
          (SyntaxN.Ex l
            (SyntaxN.Ex sm
              (SyntaxN.Ex sl
                (Var m IN Var n AND
                 Var l IN Var n AND
                 HPair (Var m) (Var sm) IN
                 Eats (Var s) (HPair (SUCC k1) (Q_Ex y)) AND
                 HPair (Var l) (Var sl) IN
                 Eats (Var s) (HPair (SUCC k1) (Q_Ex y)) AND
                 MakeFormP (Var sn) (Var sm) (Var sl))))))))"
      apply (rule All_I Imp_I)+
      using assms atoms apply simp_all
        \<comment> \<open>... the sequence buildup via s1\<close>
      apply (simp add: SeqFormP.simps [of l s1 _ _ sl m n sm sn])
      apply (rule AssumeH Ex_EH Conj_EH)+
      apply (rule All2_E [THEN rotate2], auto del: Disj_EH)
      apply (rule Ex_I [where x="Var sn"], simp)
      apply (rule Conj_I)
       apply (blast intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] del: Disj_EH)
      apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH Conj_I)+
              apply (rule Ex_I [where x="Var m"], simp)
              apply (rule Ex_I [where x="Var l"], simp)
              apply (rule Ex_I [where x="Var sm"], simp)
              apply (rule Ex_I [where x="Var sl"], simp)
              apply auto
       apply (rule Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] AssumeH OrdP_Trans [OF OrdP_SUCC_I])+
      done
  qed
qed (*>*)

theorem FormP_Ex: "{FormP t, AbstFormP \<guillemotleft>Var i\<guillemotright> Zero t x} \<turnstile> FormP (Q_Ex x)"
proof -
  obtain k1::name and s1::name and k::name and s::name
    where "atom s1 \<sharp> (i,t,x)" "atom k1 \<sharp> (i,t,x,s1)" "atom s  \<sharp> (i,t,x,k1,s1)"  "atom k \<sharp> (i,t,x,s,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: FormP.simps [of k s "Q_Ex x"] FormP.simps [of k1 s1 t]
      intro!: SeqFormP_Ex [THEN cut3])
qed

lemma FormP_quot_dbfm:
  fixes A :: dbfm
  shows "wf_dbfm A \<Longrightarrow> {} \<turnstile> FormP (quot_dbfm A)"
  by (induct A rule: wf_dbfm.induct)
    (auto simp: intro!: FormP_Mem[THEN cut2] FormP_Eq[THEN cut2] Ex_I
      FormP_Neg[THEN cut1] FormP_Disj[THEN cut2] FormP_Ex[THEN cut2]
      TermP_quot_dbtm AbstFormP_dbfm[where n=0, simplified])

lemma FormP_quot:
  fixes A :: fm
  shows "{} \<turnstile> FormP \<guillemotleft>A\<guillemotright>"
  unfolding quot_fm_def
  by (rule FormP_quot_dbfm, rule wf_dbfm_trans_fm)

lemma PfP_I:
  assumes "{} \<turnstile> PrfP S K A"
  shows "{} \<turnstile> PfP A"
proof -
  obtain s::name and k::name where "atom s \<sharp> (k,A,S,K)" "atom k \<sharp> (A,S,K)" by (metis obtain_fresh)
  with assms show ?thesis
    apply (subst PfP.simps[of s k]; simp)
    apply (rule Ex_I[of _ _ _ K], auto, rule Ex_I[of _ _ _ S], auto)
    done
qed

lemmas PfP_Single_I = PfP_I[of "Eats Zero (HPair Zero \<guillemotleft>A\<guillemotright>)" Zero for A]

lemma PfP_extra: "{} \<turnstile> PfP \<guillemotleft>extra_axiom\<guillemotright>"
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms:
      "atom l \<sharp> (sl,m,n,sm,sn)"
      "atom sl \<sharp> (m,n,sm,sn)"
      "atom m \<sharp> (n,sm,sn)"
      "atom n \<sharp> (sm,sn)"
      "atom sm \<sharp> sn"
    by (metis obtain_fresh)
  with Extra show ?thesis
    apply (intro PfP_Single_I[of extra_axiom])
    apply (subst PrfP.simps[of l _ sl m n sm sn]; auto?)
    apply (rule Ex_I[of _ _ _ "\<guillemotleft>extra_axiom\<guillemotright>"]; auto?)
     apply (rule Mem_SUCC_E[OF Mem_Zero_E])
     apply (rule Mem_Eats_I2)
     apply (rule HPair_cong[OF Assume Refl])
    apply (auto simp: AxiomP_def intro!: Disj_I1)
    done
qed

lemma SentP_I:
  assumes "A \<in> boolean_axioms"
  shows "{} \<turnstile> SentP \<guillemotleft>A\<guillemotright>"
proof -
  obtain x y z :: name where "atom z \<sharp> (x,y)" "atom y \<sharp> x" by (metis obtain_fresh)
  with assms show ?thesis
    apply (subst SentP.simps[of x y z]; simp)
    subgoal
    proof (erule boolean_axioms.cases, goal_cases Ident DisjI1 DisjCont DisjAssoc DisjConj)
      case (Ident A)
      then show ?thesis
        by (intro Ex_I[of _ _ _ "\<guillemotleft>A\<guillemotright>"]; simp)+
          (auto simp: FormP_quot[THEN thin0] quot_simps intro!: Disj_I1)
    next
      case (DisjI1 A B)
      then show ?thesis
        by (intro Ex_I[of _ _ _ "\<guillemotleft>A\<guillemotright>"]; simp, (intro Ex_I[of _ _ _ "\<guillemotleft>B\<guillemotright>"]; simp)?)+
          (auto simp: FormP_quot[THEN thin0] quot_simps intro!: Disj_I2[OF Disj_I1])
    next
      case (DisjCont A)
      then show ?thesis
        by (intro Ex_I[of _ _ _ "\<guillemotleft>A\<guillemotright>"]; simp)+
          (auto simp: FormP_quot[THEN thin0] quot_simps intro!: Disj_I2[OF Disj_I2[OF Disj_I1]])
    next
      case (DisjAssoc A B C)
      then show ?thesis
        by (intro Ex_I[of _ _ _ "\<guillemotleft>A\<guillemotright>"]; simp, intro Ex_I[of _ _ _ "\<guillemotleft>B\<guillemotright>"]; simp, intro Ex_I[of _ _ _ "\<guillemotleft>C\<guillemotright>"]; simp)+
          (auto simp: FormP_quot[THEN thin0] quot_simps intro!: Disj_I2[OF Disj_I2[OF Disj_I2[OF Disj_I1]]])
    next
      case (DisjConj A B C)
      then show ?thesis
        by (intro Ex_I[of _ _ _ "\<guillemotleft>A\<guillemotright>"]; simp, intro Ex_I[of _ _ _ "\<guillemotleft>B\<guillemotright>"]; simp, intro Ex_I[of _ _ _ "\<guillemotleft>C\<guillemotright>"]; simp)+
          (auto simp: FormP_quot[THEN thin0] quot_simps intro!: Disj_I2[OF Disj_I2[OF Disj_I2[OF Disj_I2]]])
    qed
    done
qed

lemma SentP_subst [simp]: "(SentP A)(j::=w) = SentP (subst j w A)"
proof -
  obtain x y z ::name where "atom x \<sharp> (y,z,j,w,A)" "atom y \<sharp> (z,j,w,A)"  "atom z \<sharp> (j,w,A)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SentP.simps [of x y z])
qed

theorem proved_imp_proved_PfP:
  assumes "{} \<turnstile> \<alpha>"
  shows "{} \<turnstile> PfP \<guillemotleft>\<alpha>\<guillemotright>"
  using assms
proof (induct "{} :: fm set" \<alpha> rule: hfthm.induct)
  case (Hyp A)
  then show ?case
    by auto
next
  case Extra
  then show ?case by (simp add: PfP_extra)
next
  case (Bool A)
  obtain l::name and sl::name and m::name and n::name and
         sm::name and sn::name and x::name and y::name and z::name
         where atoms:
          "atom l \<sharp> (x,y,z,sl,m,n,sm,sn)"
         "atom sl \<sharp> (x,y,z,m,n,sm,sn)"
          "atom m \<sharp> (x,y,z,n,sm,sn)"
          "atom n \<sharp> (x,y,z,sm,sn)"
         "atom sm \<sharp> (x,y,z,sn)"
         "atom sn \<sharp> (x,y,z)"
          "atom z \<sharp> (x,y)"
          "atom y \<sharp> x"
    by (metis obtain_fresh)
  with Bool show ?case
    apply (intro PfP_Single_I[of A])
    apply (subst PrfP.simps[of l _ sl m n sm sn]; auto?)
    apply (rule Ex_I[of _ _ _ "\<guillemotleft>A\<guillemotright>"]; auto?)
     apply (rule Mem_SUCC_E[OF Mem_Zero_E])
     apply (rule Mem_Eats_I2)
     apply (rule HPair_cong[OF Assume Refl])
    apply (rule Disj_I1)
    apply (unfold AxiomP_def; simp)
    apply (rule Disj_I2[OF Disj_I1])
    apply (auto elim!: SentP_I[THEN thin0])
    done
next
  case (Eq A)
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name and x::name and y::name and z::name
         where atoms:
          "atom l \<sharp> (x,y,z,sl,m,n,sm,sn)"
         "atom sl \<sharp> (x,y,z,m,n,sm,sn)"
          "atom m \<sharp> (x,y,z,n,sm,sn)"
          "atom n \<sharp> (x,y,z,sm,sn)"
         "atom sm \<sharp> (x,y,z,sn)"
         "atom sn \<sharp> (x,y,z)"
          "atom z \<sharp> (x,y)"
          "atom y \<sharp> x"
    by (metis obtain_fresh)
  with Eq show ?case
    apply (intro PfP_Single_I[of A])
    apply (subst PrfP.simps[of l _ sl m n sm sn]; auto?)
    apply (rule Ex_I[of _ _ _ "\<guillemotleft>A\<guillemotright>"]; auto?)
     apply (rule Mem_SUCC_E[OF Mem_Zero_E])
     apply (rule Mem_Eats_I2)
     apply (rule HPair_cong[OF Assume Refl])
    apply (rule Disj_I1)
    apply (unfold AxiomP_def; simp)
    apply (rule Disj_I2[OF Disj_I2[OF Disj_I1]])
    apply (auto simp: equality_axioms_def
      intro: Disj_I1 Disj_I2[OF Disj_I1] Disj_I2[OF Disj_I2[OF Disj_I1]] Disj_I2[OF Disj_I2[OF Disj_I2]])
    done
next
  case (Spec A)
  obtain l::name and sl::name and m::name and n::name and
         sm::name and sn::name and x::name and y::name and z::name
         where atoms:
          "atom l \<sharp> (x,y,z,sl,m,n,sm,sn)"
         "atom sl \<sharp> (x,y,z,m,n,sm,sn)"
          "atom m \<sharp> (x,y,z,n,sm,sn)"
          "atom n \<sharp> (x,y,z,sm,sn)"
         "atom sm \<sharp> (x,y,z,sn)"
         "atom sn \<sharp> (x,y,z)"
          "atom z \<sharp> (x,y)"
          "atom y \<sharp> x"
    by (metis obtain_fresh)
  let ?vs = "(x,y,z,l,sl,m,n,sm,sn)"
  from Spec atoms show ?case
    apply (intro PfP_Single_I[of A])
    apply (subst PrfP.simps[of l _ sl m n sm sn]; auto?)
    apply (rule Ex_I[of _ _ _ "\<guillemotleft>A\<guillemotright>"]; auto?)
     apply (rule Mem_SUCC_E[OF Mem_Zero_E])
     apply (rule Mem_Eats_I2)
     apply (rule HPair_cong[OF Assume Refl])
    apply (rule Disj_I1)
    apply (unfold AxiomP_def; simp)
    apply (rule Disj_I2[OF Disj_I2[OF Disj_I2[OF Disj_I2[OF Disj_I1]]]])
    subgoal premises prems
    using prems proof (cases A rule: special_axioms.cases)
    case (I X i t)
    let ?vs' = "(?vs, X, i, t)"
      obtain AA XX ii tt res :: name
        where atoms:
          "atom AA \<sharp> (?vs', res, tt, ii, XX)"
          "atom XX \<sharp> (?vs', res, tt, ii)"
          "atom ii \<sharp> (?vs', res, tt)"
          "atom tt \<sharp> (?vs', res)"
          "atom res \<sharp> ?vs'"
        by (metis obtain_fresh)
      with I show ?thesis
        apply (subst Special_axP.simps[of ii _ res tt AA XX]; simp?)
        apply (rule Ex_I[of _ _ _ "\<guillemotleft>Var i\<guillemotright>"]; auto?)
        apply (rule Ex_I[of _ _ _ "\<guillemotleft>X\<guillemotright>"]; auto?)
        apply (rule Ex_I[of _ _ _ "quot_dbfm (trans_fm [i] X)"]; auto?)
        apply (rule Ex_I[of _ _ _ "\<guillemotleft>t\<guillemotright>"]; auto?)
        apply (rule Ex_I[of _ _ _ "\<guillemotleft>X(i::=t)\<guillemotright>"]; auto?)
            apply (auto simp: TermP_quot[THEN thin0] FormP_quot[THEN thin0]
               SubstFormP[THEN thin0] AbstFormP[THEN thin0]
               quot_Ex quot_Disj quot_Neg vquot_fm_def)
        done
    qed
    done
next
  case (HF A)
  obtain l::name and sl::name and m::name and n::name and
         sm::name and sn::name and x::name and y::name and z::name
         where atoms:
          "atom l \<sharp> (x,y,z,sl,m,n,sm,sn)"
         "atom sl \<sharp> (x,y,z,m,n,sm,sn)"
          "atom m \<sharp> (x,y,z,n,sm,sn)"
          "atom n \<sharp> (x,y,z,sm,sn)"
         "atom sm \<sharp> (x,y,z,sn)"
         "atom sn \<sharp> (x,y,z)"
          "atom z \<sharp> (x,y)"
          "atom y \<sharp> x"
    by (metis obtain_fresh)
  with HF show ?case
    apply (intro PfP_Single_I[of A])
    apply (subst PrfP.simps[of l _ sl m n sm sn]; auto?)
    apply (rule Ex_I[of _ _ _ "\<guillemotleft>A\<guillemotright>"]; auto?)
     apply (rule Mem_SUCC_E[OF Mem_Zero_E])
     apply (rule Mem_Eats_I2)
     apply (rule HPair_cong[OF Assume Refl])
    apply (rule Disj_I1)
    apply (unfold AxiomP_def; simp)
    apply (rule Disj_I2[OF Disj_I2[OF Disj_I2[OF Disj_I1]]])
    apply (auto simp: HF_axioms_def intro: Disj_I1 Disj_I2)
    done
next
  case (Ind A)
  obtain l::name and sl::name and m::name and n::name and
         sm::name and sn::name and x::name and y::name and z::name
         where atoms:
          "atom l \<sharp> (x,y,z,sl,m,n,sm,sn)"
         "atom sl \<sharp> (x,y,z,m,n,sm,sn)"
          "atom m \<sharp> (x,y,z,n,sm,sn)"
          "atom n \<sharp> (x,y,z,sm,sn)"
         "atom sm \<sharp> (x,y,z,sn)"
         "atom sn \<sharp> (x,y,z)"
          "atom z \<sharp> (x,y)"
          "atom y \<sharp> x"
    by (metis obtain_fresh)
  let ?vs = "(x,y,z,l,sl,m,n,sm,sn)"
  from Ind atoms show ?case
    apply (intro PfP_Single_I[of A])
    apply (subst PrfP.simps[of l _ sl m n sm sn]; auto?)
    apply (rule Ex_I[of _ _ _ "\<guillemotleft>A\<guillemotright>"]; auto?)
     apply (rule Mem_SUCC_E[OF Mem_Zero_E])
     apply (rule Mem_Eats_I2)
     apply (rule HPair_cong[OF Assume Refl])
    apply (rule Disj_I1)
    apply (unfold AxiomP_def; simp)
    apply (rule Disj_I2[OF Disj_I2[OF Disj_I2[OF  Disj_I2[OF Disj_I2]]]])
    subgoal premises prems
    using prems proof (cases A rule: induction_axioms.cases)
      case (ind j i X)
      let ?vs' = "(?vs, X, i, j)"
      obtain ax allvw allw xevw xw x0 xa w v :: name
        where atoms:
          "atom ax \<sharp> (?vs', v, w, xa, x0, xw, xevw, allw, allvw)"
          "atom allvw \<sharp> (?vs', v, w, xa, x0, xw, xevw, allw)"
          "atom allw \<sharp> (?vs', v, w, xa, x0, xw, xevw)"
          "atom xevw \<sharp> (?vs', v, w, xa, x0, xw)"
          "atom xw \<sharp> (?vs', v, w, xa, x0)"
          "atom x0 \<sharp> (?vs', v, w, xa)"
          "atom xa \<sharp> (?vs', v, w)"
          "atom w \<sharp> (?vs', v)"
          "atom v \<sharp> (?vs')"
        by (metis obtain_fresh)
      with ind(2) show ?thesis
        unfolding ind(1)
        apply (subst Induction_axP.simps[of ax _ allvw allw xevw xw x0 xa w v])
                 apply simp_all
        apply (rule Ex_I[of _ _ _ "\<guillemotleft>Var i\<guillemotright>"]; auto?)
        apply (rule Ex_I[of _ _ _ "\<guillemotleft>Var j\<guillemotright>"]; auto?)
        apply (rule Ex_I[of _ _ _ "\<guillemotleft>X\<guillemotright>"]; auto?)
        apply (rule Ex_I[of _ _ _ "\<guillemotleft>X(i::=Zero)\<guillemotright>"]; auto?)
        apply (rule Ex_I[of _ _ _ "\<guillemotleft>X(i::=Var j)\<guillemotright>"]; auto?)
        apply (rule Ex_I[of _ _ _ "\<guillemotleft>X(i::=Eats (Var i) (Var j))\<guillemotright>"]; auto?)
        apply (rule Ex_I[of _ _ _ "quot_dbfm (trans_fm [j] (X IMP (X(i::= Var j) IMP X(i::= Eats(Var i)(Var j)))))"]; auto?)
        apply (rule Ex_I[of _ _ _ "Q_All (quot_dbfm (trans_fm [j,i] (X IMP (X(i::= Var j) IMP X(i::= Eats(Var i)(Var j))))))"]; auto?)
        apply (rule Ex_I[of _ _ _ "quot_dbfm (trans_fm [i] X)"]; auto?)
        subgoal
          apply (rule thin0)
          apply (rule OrdNotEqP_I)
            apply (auto simp: quot_Var ORD_OF_EQ_diff intro!: OrdP_SUCC_I0[THEN cut1])
          done
        subgoal
          by (auto simp: VarNonOccFormP.simps FormP_quot[THEN thin0] SubstFormP_trivial[THEN thin0])
        subgoal
          by (rule SubstFormP_Zero[THEN thin0])
        subgoal
          by (rule SubstFormP[THEN thin0])
        subgoal
          unfolding quot_Eats[symmetric] One_nat_def[symmetric]
          by (rule SubstFormP[THEN thin0])
        subgoal
          unfolding quot_simps[symmetric] quot_dbfm.simps[symmetric] trans_fm.simps[symmetric]
          by (rule AbstFormP[THEN thin0])
        subgoal
          by (auto simp only: quot_simps[symmetric] quot_dbfm.simps[symmetric] trans_fm.simps[symmetric]
            fresh_Cons fresh_Nil fresh_Pair trans_fm.simps(5)[symmetric, of j "[]"]
            quot_fm_def[symmetric] intro!: AbstFormP[THEN thin0])
        subgoal
          unfolding quot_simps[symmetric] quot_dbfm.simps[symmetric] trans_fm.simps[symmetric]
          by (rule AbstFormP[THEN thin0])
        subgoal
          by (auto simp: quot_simps trans_fm.simps(5)[of j "[i]"]
            fresh_Cons fresh_Pair)
        done
    qed
    done
next
  case (MP H A B H')
  then show ?case
    by (auto elim!: PfP_implies_ModPon_PfP_quot)
next
  case (Exists A B i)
  obtain a x y z::name
    where atoms:
      "atom a \<sharp> (i,x,y,z)"
      "atom z \<sharp> (i,x,y)"
      "atom y \<sharp> (i,x)"
      "atom x \<sharp> i"
    by (metis obtain_fresh)
  with Exists show ?case
    apply (auto elim!: PfP_inference [THEN cut3] intro!: PfP_extra Disj_I2[OF Disj_I1])
    apply (subst ExistsP.simps[of x _ _ a y z]; (auto simp: VarNonOccFormP.simps)?)
    apply (rule Ex_I[of _ _ _ "\<guillemotleft>A\<guillemotright>"]; auto?)
    apply (rule Ex_I[of _ _ _ "quot_dbfm (trans_fm [i] A)"]; auto?)
    apply (rule Ex_I[of _ _ _ "\<guillemotleft>B\<guillemotright>"]; auto?)
    apply (rule Ex_I[of _ _ _ "\<guillemotleft>Var i\<guillemotright>"]; auto?)
         apply (auto simp: FormP_quot quot_Disj quot_Neg quot_Ex SubstFormP_trivial AbstFormP)
    done
qed

end