(*<*)
theory TAO_5_MetaSolver
imports
  TAO_4_BasicDefinitions
  "HOL-Eisbach.Eisbach"
begin
(*>*)

section\<open>MetaSolver\<close>
text\<open>\label{TAO_MetaSolver}\<close>

text\<open>
\begin{remark}
  \<open>meta_solver\<close> is a resolution prover that translates
  expressions in the embedded logic to expressions in the meta-logic,
  resp. semantic expressions.
  The rules for connectives, quantifiers, exemplification
  and encoding are straightforward.
  Furthermore, rules for the defined identities are derived.
  The defined identities in the embedded logic coincide with the
  meta-logical equality.
\end{remark}
\<close>

locale MetaSolver
begin
  interpretation Semantics .

  named_theorems meta_intro
  named_theorems meta_elim
  named_theorems meta_subst
  named_theorems meta_cong

  method meta_solver = (assumption | rule meta_intro
      | erule meta_elim | drule meta_elim |  subst meta_subst
      | subst (asm) meta_subst | (erule notE; (meta_solver; fail))
      )+

subsection\<open>Rules for Implication\<close>
text\<open>\label{TAO_MetaSolver_Implication}\<close>

subsection\<open>Rules for Negation\<close>
text\<open>\label{TAO_MetaSolver_Negation}\<close>

  lemma NotI[meta_intro]: "\<not>[\<phi> in v] \<Longrightarrow> [\<^bold>\<not>\<phi> in v]"
    by (simp add: Semantics.T4)
  lemma NotE[meta_elim]: "[\<^bold>\<not>\<phi> in v] \<Longrightarrow> \<not>[\<phi> in v]"
    by (simp add: Semantics.T4)
  lemma NotS[meta_subst]: "[\<^bold>\<not>\<phi> in v] = (\<not>[\<phi> in v])"
    by (simp add: Semantics.T4)

subsection\<open>Rules for Conjunction\<close>
text\<open>\label{TAO_MetaSolver_Conjunction}\<close>

subsection\<open>Rules for Equivalence\<close>
text\<open>\label{TAO_MetaSolver_Equivalence}\<close>

  lemma EquivI[meta_intro]: "([\<phi> in v] \<longleftrightarrow> [\<psi> in v]) \<Longrightarrow> [\<phi> \<^bold>\<equiv> \<psi> in v]"
    by (simp add: equiv_def NotS ImplS ConjS)
  lemma EquivE[meta_elim]: "[\<phi> \<^bold>\<equiv> \<psi> in v] \<Longrightarrow> ([\<phi> in v] \<longleftrightarrow> [\<psi> in v])"
    by (auto simp: equiv_def NotS ImplS ConjS)
  lemma EquivS[meta_subst]: "[\<phi> \<^bold>\<equiv> \<psi> in v] = ([\<phi> in v] \<longleftrightarrow> [\<psi> in v])"
    by (auto simp: equiv_def NotS ImplS ConjS)

subsection\<open>Rules for Disjunction\<close>
text\<open>\label{TAO_MetaSolver_Disjunction}\<close>

  lemma DisjI[meta_intro]: "([\<phi> in v] \<or> [\<psi> in v]) \<Longrightarrow> [\<phi> \<^bold>\<or> \<psi> in v]"
    by (auto simp: disj_def NotS ImplS)
  lemma DisjE[meta_elim]: "[\<phi> \<^bold>\<or> \<psi> in v] \<Longrightarrow> ([\<phi> in v] \<or> [\<psi> in v])"
    by (auto simp: disj_def NotS ImplS)
  lemma DisjS[meta_subst]: "[\<phi> \<^bold>\<or> \<psi> in v] = ([\<phi> in v] \<or> [\<psi> in v])"
    by (auto simp: disj_def NotS ImplS)

subsection\<open>Rules for Necessity\<close>
text\<open>\label{TAO_MetaSolver_Necessity}\<close>

  lemma BoxI[meta_intro]: "(\<And>v.[\<phi> in v]) \<Longrightarrow> [\<^bold>\<box>\<phi> in v]"
    by (simp add: Semantics.T6)
  lemma BoxE[meta_elim]: "[\<^bold>\<box>\<phi> in v] \<Longrightarrow> (\<And>v.[\<phi> in v])"
    by (simp add: Semantics.T6)
  lemma BoxS[meta_subst]: "[\<^bold>\<box>\<phi> in v] = (\<forall> v.[\<phi> in v])"
    by (simp add: Semantics.T6)

subsection\<open>Rules for Possibility\<close>
text\<open>\label{TAO_MetaSolver_Possibility}\<close>

  lemma DiaI[meta_intro]: "(\<exists>v.[\<phi> in v]) \<Longrightarrow> [\<^bold>\<diamond>\<phi> in v]"
    by (metis BoxS NotS diamond_def)
  lemma DiaE[meta_elim]: "[\<^bold>\<diamond>\<phi> in v] \<Longrightarrow> (\<exists>v.[\<phi> in v])"
    by (metis BoxS NotS diamond_def)
  lemma DiaS[meta_subst]: "[\<^bold>\<diamond>\<phi> in v] = (\<exists> v.[\<phi> in v])"
    by (metis BoxS NotS diamond_def)

subsection\<open>Rules for Quantification\<close>
text\<open>\label{TAO_MetaSolver_Quantification}\<close>

  lemma AllI[meta_intro]: "(\<And>x. [\<phi> x in v]) \<Longrightarrow> [\<^bold>\<forall> x. \<phi> x in v]"
    by (auto simp: T8)
  lemma AllE[meta_elim]: "[\<^bold>\<forall>x. \<phi> x in v] \<Longrightarrow> (\<And>x.[\<phi> x in v])"
    by (auto simp: T8)
  lemma AllS[meta_subst]: "[\<^bold>\<forall>x. \<phi> x in v] = (\<forall>x.[\<phi> x in v])"
    by (auto simp: T8)

subsubsection\<open>Rules for Existence\<close>
  lemma ExIRule: "([\<phi> y in v]) \<Longrightarrow> [\<^bold>\<exists>x. \<phi> x in v]"
    by (auto simp: exists_def Semantics.T8 Semantics.T4)
  lemma ExI[meta_intro]: "(\<exists> y . [\<phi> y in v]) \<Longrightarrow> [\<^bold>\<exists>x. \<phi> x in v]"
    by (auto simp: exists_def Semantics.T8 Semantics.T4)
  lemma ExE[meta_elim]: "[\<^bold>\<exists>x. \<phi> x in v] \<Longrightarrow> (\<exists> y . [\<phi> y in v])"
    by (auto simp: exists_def Semantics.T8 Semantics.T4)
  lemma ExS[meta_subst]: "[\<^bold>\<exists>x. \<phi> x in v] = (\<exists> y . [\<phi> y in v])"
    by (auto simp: exists_def Semantics.T8 Semantics.T4)
  lemma ExERule: assumes "[\<^bold>\<exists>x. \<phi> x in v]" obtains x where "[\<phi> x in v]"
    using ExE assms by auto

subsection\<open>Rules for Actuality\<close>
text\<open>\label{TAO_MetaSolver_Actuality}\<close>

  lemma ActualI[meta_intro]: "[\<phi> in dw] \<Longrightarrow> [\<^bold>\<A>\<phi> in v]"
    by (auto simp: Semantics.T7)
  lemma ActualE[meta_elim]: "[\<^bold>\<A>\<phi> in v] \<Longrightarrow> [\<phi> in dw]"
    by (auto simp: Semantics.T7)
  lemma ActualS[meta_subst]: "[\<^bold>\<A>\<phi> in v] = [\<phi> in dw]"
    by (auto simp: Semantics.T7)

subsection \<open>Rules for Encoding\<close>
text\<open>\label{TAO_MetaSolver_Encoding}\<close>

  lemma EncI[meta_intro]:
    assumes "\<exists> r o\<^sub>1 . Some r = d\<^sub>1 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 \<in> en r"
    shows "[\<lbrace>x,F\<rbrace> in v]"
    using assms by (auto simp: Semantics.T2)
  lemma EncE[meta_elim]:
    assumes "[\<lbrace>x,F\<rbrace> in v]"
    shows "\<exists> r o\<^sub>1 . Some r = d\<^sub>1 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 \<in> en r"
    using assms by (auto simp: Semantics.T2)
  lemma EncS[meta_subst]:
    "[\<lbrace>x,F\<rbrace> in v] = (\<exists> r o\<^sub>1 . Some r = d\<^sub>1 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 \<in> en r)"
    by (auto simp: Semantics.T2)

subsection\<open>Rules for Exemplification\<close>
text\<open>\label{TAO_MetaSolver_Exemplification}\<close>

subsubsection\<open>Zero-place Relations\<close>

  lemma Exe0I[meta_intro]:
    assumes "\<exists> r . Some r = d\<^sub>0 p \<and> ex0 r v"
    shows "[\<lparr>p\<rparr> in v]"
    using assms by (auto simp: Semantics.T3)
  lemma Exe0E[meta_elim]:
    assumes "[\<lparr>p\<rparr> in v]"
    shows "\<exists> r . Some r = d\<^sub>0 p \<and> ex0 r v"
    using assms by (auto simp: Semantics.T3)
  lemma Exe0S[meta_subst]:
    "[\<lparr>p\<rparr> in v] = (\<exists> r . Some r = d\<^sub>0 p \<and> ex0 r v)"
    by (auto simp: Semantics.T3)

subsubsection\<open>One-Place Relations\<close>

  lemma Exe1I[meta_intro]:
    assumes "\<exists> r o\<^sub>1 . Some r = d\<^sub>1 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 \<in> ex1 r v"
    shows "[\<lparr>F,x\<rparr> in v]"
    using assms by (auto simp: Semantics.T1_1)
  lemma Exe1E[meta_elim]:
    assumes "[\<lparr>F,x\<rparr> in v]"
    shows "\<exists> r o\<^sub>1 . Some r = d\<^sub>1 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 \<in> ex1 r v"
    using assms by (auto simp: Semantics.T1_1)
  lemma Exe1S[meta_subst]:
    "[\<lparr>F,x\<rparr> in v] = (\<exists> r o\<^sub>1 . Some r = d\<^sub>1 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 \<in> ex1 r v)"
    by (auto simp: Semantics.T1_1)

subsubsection\<open>Two-Place Relations\<close>

  lemma Exe2I[meta_intro]:
    assumes "\<exists> r o\<^sub>1 o\<^sub>2 . Some r = d\<^sub>2 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x
                      \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y \<and> (o\<^sub>1, o\<^sub>2) \<in> ex2 r v"
    shows "[\<lparr>F,x,y\<rparr> in v]"
    using assms by (auto simp: Semantics.T1_2)
  lemma Exe2E[meta_elim]:
    assumes "[\<lparr>F,x,y\<rparr> in v]"
    shows "\<exists> r o\<^sub>1 o\<^sub>2 . Some r = d\<^sub>2 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x
                    \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y \<and> (o\<^sub>1, o\<^sub>2) \<in> ex2 r v"
    using assms by (auto simp: Semantics.T1_2)
  lemma Exe2S[meta_subst]:
    "[\<lparr>F,x,y\<rparr> in v] = (\<exists> r o\<^sub>1 o\<^sub>2 . Some r = d\<^sub>2 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x
                      \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y \<and> (o\<^sub>1, o\<^sub>2) \<in> ex2 r v)"
    by (auto simp: Semantics.T1_2)

subsubsection\<open>Three-Place Relations\<close>

  lemma Exe3I[meta_intro]:
    assumes "\<exists> r o\<^sub>1 o\<^sub>2 o\<^sub>3 . Some r = d\<^sub>3 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x
                         \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y \<and> Some o\<^sub>3 = d\<^sub>\<kappa> z
                         \<and> (o\<^sub>1, o\<^sub>2, o\<^sub>3) \<in> ex3 r v"
    shows "[\<lparr>F,x,y,z\<rparr> in v]"
    using assms by (auto simp: Semantics.T1_3)
  lemma Exe3E[meta_elim]:
    assumes "[\<lparr>F,x,y,z\<rparr> in v]"
    shows "\<exists> r o\<^sub>1 o\<^sub>2 o\<^sub>3 . Some r = d\<^sub>3 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x
                       \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y \<and> Some o\<^sub>3 = d\<^sub>\<kappa> z
                       \<and> (o\<^sub>1, o\<^sub>2, o\<^sub>3) \<in> ex3 r v"
    using assms by (auto simp: Semantics.T1_3)
  lemma Exe3S[meta_subst]:
    "[\<lparr>F,x,y,z\<rparr> in v] = (\<exists> r o\<^sub>1 o\<^sub>2 o\<^sub>3 . Some r = d\<^sub>3 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x
                                     \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y \<and> Some o\<^sub>3 = d\<^sub>\<kappa> z
                                     \<and> (o\<^sub>1, o\<^sub>2, o\<^sub>3) \<in> ex3 r v)"
    by (auto simp: Semantics.T1_3)

subsection\<open>Rules for Being Ordinary\<close>
text\<open>\label{TAO_MetaSolver_Ordinary}\<close>

  lemma OrdI[meta_intro]:
    assumes "\<exists> o\<^sub>1 y. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 = \<omega>\<nu> y"
    shows "[\<lparr>O!,x\<rparr> in v]"
    proof -
      have "IsProperInX (\<lambda>x. \<^bold>\<diamond>\<lparr>E!,x\<rparr>)"
        by show_proper
      moreover have "[\<^bold>\<diamond>\<lparr>E!,x\<rparr> in v]"
        apply meta_solver
        using ConcretenessSemantics1 propex\<^sub>1 assms by fast
      ultimately show "[\<lparr>O!,x\<rparr> in v]"
        unfolding Ordinary_def
        using D5_1 propex\<^sub>1 assms ConcretenessSemantics1 Exe1S
        by blast
    qed
  lemma OrdE[meta_elim]:
    assumes "[\<lparr>O!,x\<rparr> in v]"
    shows "\<exists> o\<^sub>1 y. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 = \<omega>\<nu> y"
    proof -
      have "\<exists>r o\<^sub>1. Some r = d\<^sub>1 O! \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 \<in> ex1 r v"
        using assms Exe1E by simp
      moreover have "IsProperInX (\<lambda>x. \<^bold>\<diamond>\<lparr>E!,x\<rparr>)"
        by show_proper
      ultimately have "[\<^bold>\<diamond>\<lparr>E!,x\<rparr> in v]"
        using D5_1 unfolding Ordinary_def by fast
      thus ?thesis
        apply - apply meta_solver
        using ConcretenessSemantics2 by blast
    qed
  lemma OrdS[meta_cong]:
    "[\<lparr>O!,x\<rparr> in v] = (\<exists> o\<^sub>1 y. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 = \<omega>\<nu> y)"
    using OrdI OrdE by blast

subsection\<open>Rules for Being Abstract\<close>
text\<open>\label{TAO_MetaSolver_Abstract}\<close>

  lemma AbsI[meta_intro]:
    assumes "\<exists> o\<^sub>1 y. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 = \<alpha>\<nu> y"
    shows "[\<lparr>A!,x\<rparr> in v]"
    proof -
      have "IsProperInX (\<lambda>x. \<^bold>\<not>\<^bold>\<diamond>\<lparr>E!,x\<rparr>)"
        by show_proper
      moreover have "[\<^bold>\<not>\<^bold>\<diamond>\<lparr>E!,x\<rparr> in v]"
        apply meta_solver
        using ConcretenessSemantics2 propex\<^sub>1 assms
        by (metis \<nu>.distinct(1) option.sel)
      ultimately show "[\<lparr>A!,x\<rparr> in v]"
        unfolding Abstract_def
        using D5_1 propex\<^sub>1 assms ConcretenessSemantics1 Exe1S
        by blast
    qed
  lemma AbsE[meta_elim]:
    assumes "[\<lparr>A!,x\<rparr> in v]"
    shows "\<exists> o\<^sub>1 y. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 = \<alpha>\<nu> y"
    proof -
      have 1: "IsProperInX (\<lambda>x. \<^bold>\<not>\<^bold>\<diamond>\<lparr>E!,x\<rparr>)"
        by show_proper
      have "\<exists>r o\<^sub>1. Some r = d\<^sub>1 A! \<and> Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 \<in> ex1 r v"
        using assms Exe1E by simp
      moreover hence "[\<^bold>\<not>\<^bold>\<diamond>\<lparr>E!,x\<rparr> in v]"
        using D5_1[OF 1]
        unfolding Abstract_def by fast
      ultimately show ?thesis
        apply - apply meta_solver
        using ConcretenessSemantics1 propex\<^sub>1
        by (metis \<nu>.exhaust)
    qed
  lemma AbsS[meta_cong]:
    "[\<lparr>A!,x\<rparr> in v] = (\<exists> o\<^sub>1 y. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 = \<alpha>\<nu> y)"
    using AbsI AbsE by blast

subsection\<open>Rules for Definite Descriptions\<close>
text\<open>\label{TAO_MetaSolver_DefiniteDescription}\<close>

  lemma TheEqI:
    assumes "\<And>x. [\<phi> x in dw] = [\<psi> x in dw]"
    shows "(\<^bold>\<iota>x. \<phi> x) = (\<^bold>\<iota>x. \<psi> x)"
    proof -
      have 1: "d\<^sub>\<kappa> (\<^bold>\<iota>x. \<phi> x) = d\<^sub>\<kappa> (\<^bold>\<iota>x. \<psi> x)"
        using assms D3 unfolding w\<^sub>0_def by simp
      {
        assume "\<exists> o\<^sub>1 . Some o\<^sub>1 = d\<^sub>\<kappa> (\<^bold>\<iota>x. \<phi> x)"
        hence ?thesis using 1 d\<^sub>\<kappa>_inject by force
      }
      moreover {
        assume "\<not>(\<exists> o\<^sub>1 . Some o\<^sub>1 = d\<^sub>\<kappa> (\<^bold>\<iota>x. \<phi> x))"
        hence ?thesis using 1 D3
        by (metis d\<^sub>\<kappa>.rep_eq eval\<kappa>_inverse)
      }
      ultimately show ?thesis by blast
    qed

subsection\<open>Rules for Identity\<close>
text\<open>\label{TAO_MetaSolver_Identity}\<close>

subsubsection\<open>Ordinary Objects\<close>
text\<open>\label{TAO_MetaSolver_Identity_Ordinary}\<close>

  lemma Eq\<^sub>EI[meta_intro]:
    assumes "\<exists> o\<^sub>1 o\<^sub>2. Some (\<omega>\<nu> o\<^sub>1) = d\<^sub>\<kappa> x \<and> Some (\<omega>\<nu> o\<^sub>2) = d\<^sub>\<kappa> y \<and> o\<^sub>1 = o\<^sub>2"
    shows "[x \<^bold>=\<^sub>E y in v]"
    proof -
      obtain o\<^sub>1 o\<^sub>2 where 1:
        "Some (\<omega>\<nu> o\<^sub>1) = d\<^sub>\<kappa> x \<and> Some (\<omega>\<nu> o\<^sub>2) = d\<^sub>\<kappa> y \<and> o\<^sub>1 = o\<^sub>2"
        using assms by auto
      obtain r where 2:
        "Some r = d\<^sub>2 basic_identity\<^sub>E"
        using propex\<^sub>2 by auto
      have "[\<lparr>O!,x\<rparr> \<^bold>& \<lparr>O!,y\<rparr> \<^bold>& \<^bold>\<box>(\<^bold>\<forall>F. \<lparr>F,x\<rparr> \<^bold>\<equiv> \<lparr>F,y\<rparr>) in v]"
        proof -
          have "[\<lparr>O!,x\<rparr> in v] \<and> [\<lparr>O!,y\<rparr> in v]"
            using OrdI 1 by blast
          moreover have "[\<^bold>\<box>(\<^bold>\<forall>F. \<lparr>F,x\<rparr> \<^bold>\<equiv> \<lparr>F,y\<rparr>) in v]"
            apply meta_solver using 1 by force
          ultimately show ?thesis using ConjI by simp
        qed
      moreover have "IsProperInXY (\<lambda> x y . \<lparr>O!,x\<rparr> \<^bold>& \<lparr>O!,y\<rparr> \<^bold>& \<^bold>\<box>(\<^bold>\<forall>F. \<lparr>F,x\<rparr> \<^bold>\<equiv> \<lparr>F,y\<rparr>))"
        by show_proper
      ultimately have "(\<omega>\<nu> o\<^sub>1, \<omega>\<nu> o\<^sub>2) \<in> ex2 r v"
        using D5_2 1 2
        unfolding basic_identity\<^sub>E_def by fast
      thus "[x \<^bold>=\<^sub>E y in v]"
        using Exe2I 1 2
        unfolding basic_identity\<^sub>E_infix_def basic_identity\<^sub>E_def
        by blast
    qed
  lemma Eq\<^sub>EE[meta_elim]:
    assumes "[x \<^bold>=\<^sub>E y in v]"
    shows "\<exists> o\<^sub>1 o\<^sub>2. Some (\<omega>\<nu> o\<^sub>1) = d\<^sub>\<kappa> x \<and> Some (\<omega>\<nu> o\<^sub>2) = d\<^sub>\<kappa> y \<and> o\<^sub>1 = o\<^sub>2"
  proof -
    have "IsProperInXY (\<lambda> x y . \<lparr>O!,x\<rparr> \<^bold>& \<lparr>O!,y\<rparr> \<^bold>& \<^bold>\<box>(\<^bold>\<forall>F. \<lparr>F,x\<rparr> \<^bold>\<equiv> \<lparr>F,y\<rparr>))"
      by show_proper
    hence 1: "[\<lparr>O!,x\<rparr> \<^bold>& \<lparr>O!,y\<rparr> \<^bold>& \<^bold>\<box>(\<^bold>\<forall> F. \<lparr>F,x\<rparr> \<^bold>\<equiv> \<lparr>F,y\<rparr>) in v]"
      using assms unfolding basic_identity\<^sub>E_def basic_identity\<^sub>E_infix_def
      using D4_2 T1_2 D5_2 by meson
    hence 2: "\<exists> o\<^sub>1 o\<^sub>2 . Some (\<omega>\<nu> o\<^sub>1) = d\<^sub>\<kappa> x
                     \<and> Some (\<omega>\<nu> o\<^sub>2) = d\<^sub>\<kappa> y"
      apply (subst (asm) ConjS)
      apply (subst (asm) ConjS)
      using OrdE by auto
    then obtain o\<^sub>1 o\<^sub>2 where 3:
      "Some (\<omega>\<nu> o\<^sub>1) = d\<^sub>\<kappa> x \<and> Some (\<omega>\<nu> o\<^sub>2) = d\<^sub>\<kappa> y"
      by auto
    have "\<exists> r . Some r = d\<^sub>1 (\<^bold>\<lambda> z . make\<o> (\<lambda> w s . d\<^sub>\<kappa> (z\<^sup>P) = Some (\<omega>\<nu> o\<^sub>1)))"
      using propex\<^sub>1 by auto
    then obtain r where 4:
      "Some r = d\<^sub>1 (\<^bold>\<lambda> z . make\<o> (\<lambda> w s . d\<^sub>\<kappa> (z\<^sup>P) = Some (\<omega>\<nu> o\<^sub>1)))"
      by auto
    hence 5: "r = (\<lambda>u s w. \<exists> x . \<nu>\<upsilon> x = u \<and> Some x = Some (\<omega>\<nu> o\<^sub>1))"
      unfolding lambdabinder1_def d\<^sub>1_def d\<^sub>\<kappa>_proper
      apply transfer
      by simp
    have "[\<^bold>\<box>(\<^bold>\<forall> F. \<lparr>F,x\<rparr> \<^bold>\<equiv> \<lparr>F,y\<rparr>) in v]"
      using 1 using ConjE by blast
    hence 6: "\<forall> v F . [\<lparr>F,x\<rparr> in v] \<longleftrightarrow> [\<lparr>F,y\<rparr> in v]"
      using BoxE EquivE AllE by fast
    hence "\<forall> v . ((\<omega>\<nu> o\<^sub>1) \<in> ex1 r v) = ((\<omega>\<nu> o\<^sub>2) \<in> ex1 r v)"
      using 2 4 unfolding valid_in_def
      by (metis "3" "6" d\<^sub>1.rep_eq d\<^sub>\<kappa>_inject d\<^sub>\<kappa>_proper ex1_def eval\<o>_inverse exe1.rep_eq
          mem_Collect_eq option.sel rep_proper_id \<nu>\<kappa>_proper valid_in.abs_eq)
    moreover have "(\<omega>\<nu> o\<^sub>1) \<in> ex1 r v"
      unfolding 5 ex1_def by simp
    ultimately have "(\<omega>\<nu> o\<^sub>2) \<in> ex1 r v"
      by auto
    hence "o\<^sub>1 = o\<^sub>2" unfolding 5 ex1_def by (auto simp: meta_aux)
    thus ?thesis
      using 3 by auto
  qed
  lemma Eq\<^sub>ES[meta_subst]:
    "[x \<^bold>=\<^sub>E y in v] = (\<exists> o\<^sub>1 o\<^sub>2. Some (\<omega>\<nu> o\<^sub>1) = d\<^sub>\<kappa> x \<and> Some (\<omega>\<nu> o\<^sub>2) = d\<^sub>\<kappa> y
                                \<and> o\<^sub>1 = o\<^sub>2)"
    using Eq\<^sub>EI Eq\<^sub>EE by blast

subsubsection\<open>Individuals\<close>
text\<open>\label{TAO_MetaSolver_Identity_Individual}\<close>

  lemma Eq\<kappa>I[meta_intro]:
    assumes "\<exists> o\<^sub>1 o\<^sub>2. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y \<and> o\<^sub>1 = o\<^sub>2"
    shows "[x \<^bold>=\<^sub>\<kappa> y in v]"
  proof -
    have "x = y" using assms d\<^sub>\<kappa>_inject by meson
    moreover have "[x \<^bold>=\<^sub>\<kappa> x in v]"
      unfolding basic_identity\<^sub>\<kappa>_def
      apply meta_solver
      by (metis (no_types, lifting) assms AbsI Exe1E \<nu>.exhaust)
    ultimately show ?thesis by auto
  qed
  lemma Eq\<kappa>_prop:
    assumes "[x \<^bold>=\<^sub>\<kappa> y in v]"
    shows "[\<phi> x in v] = [\<phi> y in v]"
  proof -
    have "[x \<^bold>=\<^sub>E y \<^bold>\<or> \<lparr>A!,x\<rparr> \<^bold>& \<lparr>A!,y\<rparr> \<^bold>& \<^bold>\<box>(\<^bold>\<forall> F. \<lbrace>x,F\<rbrace> \<^bold>\<equiv> \<lbrace>y,F\<rbrace>) in v]"
      using assms unfolding basic_identity\<^sub>\<kappa>_def by simp
    moreover {
      assume "[x \<^bold>=\<^sub>E y in v]"
      hence "(\<exists> o\<^sub>1 o\<^sub>2. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y \<and> o\<^sub>1 = o\<^sub>2)"
        using Eq\<^sub>EE by fast
    }
    moreover {
      assume 1: "[\<lparr>A!,x\<rparr> \<^bold>& \<lparr>A!,y\<rparr> \<^bold>& \<^bold>\<box>(\<^bold>\<forall> F. \<lbrace>x,F\<rbrace> \<^bold>\<equiv> \<lbrace>y,F\<rbrace>) in v]"
      hence 2: "(\<exists> o\<^sub>1 o\<^sub>2 X Y. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y
                              \<and> o\<^sub>1 = \<alpha>\<nu> X \<and> o\<^sub>2 = \<alpha>\<nu> Y)"
        using AbsE ConjE by meson
      moreover then obtain o\<^sub>1 o\<^sub>2 X Y where 3:
        "Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y \<and> o\<^sub>1 = \<alpha>\<nu> X \<and> o\<^sub>2 = \<alpha>\<nu> Y"
        by auto
      moreover have 4: "[\<^bold>\<box>(\<^bold>\<forall> F. \<lbrace>x,F\<rbrace> \<^bold>\<equiv> \<lbrace>y,F\<rbrace>) in v]"
        using 1 ConjE by blast
      hence 6: "\<forall> v F . [\<lbrace>x,F\<rbrace> in v] \<longleftrightarrow> [\<lbrace>y,F\<rbrace> in v]"
        using BoxE AllE EquivE by fast
      hence 7: "\<forall>v r. (\<exists> o\<^sub>1. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> o\<^sub>1 \<in> en r)
                    = (\<exists> o\<^sub>1. Some o\<^sub>1 = d\<^sub>\<kappa> y \<and> o\<^sub>1 \<in> en r)"
        apply - apply meta_solver
        using propex\<^sub>1 d\<^sub>1_inject apply simp
        apply transfer by simp
      hence 8: "\<forall> r. (o\<^sub>1 \<in> en r) = (o\<^sub>2 \<in> en r)"
        using 3 d\<^sub>\<kappa>_inject d\<^sub>\<kappa>_proper apply simp
        by (metis option.inject)
      hence "\<forall>r. (o\<^sub>1 \<in> r) = (o\<^sub>2 \<in> r)"
        unfolding en_def using 3
        by (metis Collect_cong Collect_mem_eq \<nu>.simps(6)
                  mem_Collect_eq make\<Pi>\<^sub>1_cases)
      hence "(o\<^sub>1 \<in> { x . o\<^sub>1 = x }) = (o\<^sub>2 \<in> { x . o\<^sub>1 = x })"
        by metis
      hence "o\<^sub>1 = o\<^sub>2" by simp
      hence "(\<exists> o\<^sub>1 o\<^sub>2. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y \<and> o\<^sub>1 = o\<^sub>2)"
        using 3 by auto
    }
    ultimately have "x = y"
      using DisjS using Semantics.d\<^sub>\<kappa>_inject by auto
    thus "(v \<Turnstile> (\<phi> x)) = (v \<Turnstile> (\<phi> y))" by simp
  qed
  lemma Eq\<kappa>E[meta_elim]:
    assumes "[x \<^bold>=\<^sub>\<kappa> y in v]"
    shows "\<exists> o\<^sub>1 o\<^sub>2. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y \<and> o\<^sub>1 = o\<^sub>2"
  proof -
    have "\<forall> \<phi> . (v \<Turnstile> \<phi> x) = (v \<Turnstile> \<phi> y)"
      using assms Eq\<kappa>_prop by blast
    moreover obtain \<phi> where \<phi>_prop:
      "\<phi> = (\<lambda> \<alpha> . make\<o> (\<lambda> w s . (\<exists> o\<^sub>1 o\<^sub>2. Some o\<^sub>1 = d\<^sub>\<kappa> x
                            \<and> Some o\<^sub>2 = d\<^sub>\<kappa> \<alpha> \<and> o\<^sub>1 = o\<^sub>2)))"
      by auto
    ultimately have "(v \<Turnstile> \<phi> x) = (v \<Turnstile> \<phi> y)" by metis
    moreover have "(v \<Turnstile> \<phi> x)"
      using assms unfolding \<phi>_prop basic_identity\<^sub>\<kappa>_def
      by (metis (mono_tags, lifting) AbsS ConjE DisjS
                Eq\<^sub>ES valid_in.abs_eq)
    ultimately have "(v \<Turnstile> \<phi> y)" by auto
    thus ?thesis
      unfolding \<phi>_prop
      by (simp add: valid_in_def meta_aux)
  qed
  lemma Eq\<kappa>S[meta_subst]:
    "[x \<^bold>=\<^sub>\<kappa> y in v] = (\<exists> o\<^sub>1 o\<^sub>2. Some o\<^sub>1 = d\<^sub>\<kappa> x \<and> Some o\<^sub>2 = d\<^sub>\<kappa> y \<and> o\<^sub>1 = o\<^sub>2)"
    using Eq\<kappa>I Eq\<kappa>E by blast

subsubsection\<open>One-Place Relations\<close>
text\<open>\label{TAO_MetaSolver_Identity_OnePlaceRelation}\<close>

  lemma Eq\<^sub>1I[meta_intro]: "F = G \<Longrightarrow> [F \<^bold>=\<^sub>1 G in v]"
    unfolding basic_identity\<^sub>1_def
    apply (rule BoxI, rule AllI, rule EquivI)
    by simp
  lemma Eq\<^sub>1E[meta_elim]: "[F \<^bold>=\<^sub>1 G in v] \<Longrightarrow> F = G"
    unfolding basic_identity\<^sub>1_def
    apply (drule BoxE, drule_tac x="(\<alpha>\<nu> { F })" in AllE, drule EquivE)
    apply (simp add: Semantics.T2)
    unfolding en_def d\<^sub>\<kappa>_def d\<^sub>1_def
    using \<nu>\<kappa>_proper rep_proper_id
    by (simp add: rep_def proper_def meta_aux \<nu>\<kappa>.rep_eq)
  lemma Eq\<^sub>1S[meta_subst]: "[F \<^bold>=\<^sub>1 G in v] = (F = G)"
    using Eq\<^sub>1I Eq\<^sub>1E by auto
  lemma Eq\<^sub>1_prop: "[F \<^bold>=\<^sub>1 G in v] \<Longrightarrow> [\<phi> F in v] = [\<phi> G in v]"
    using Eq\<^sub>1E by blast

subsubsection\<open>Two-Place Relations\<close>
text\<open>\label{TAO_MetaSolver_Identity_TwoPlaceRelation}\<close>

  lemma Eq\<^sub>2I[meta_intro]: "F = G \<Longrightarrow> [F \<^bold>=\<^sub>2 G in v]"
    unfolding basic_identity\<^sub>2_def
    apply (rule AllI, rule ConjI, (subst Eq\<^sub>1S)+)
    by simp

subsubsection\<open>Three-Place Relations\<close>
text\<open>\label{TAO_MetaSolver_Identity_ThreePlaceRelation}\<close>

  lemma Eq\<^sub>3I[meta_intro]: "F = G \<Longrightarrow> [F \<^bold>=\<^sub>3 G in v]"
    apply (simp add: meta_defs meta_aux conn_defs forall_\<nu>_def basic_identity\<^sub>3_def)
    using MetaSolver.Eq\<^sub>1I valid_in.rep_eq by auto
  lemma Eq\<^sub>3E[meta_elim]: "[F \<^bold>=\<^sub>3 G in v] \<Longrightarrow> F = G"
  proof -

    assume "[F \<^bold>=\<^sub>3 G in v]"
    hence 1: "[\<^bold>\<forall> x y. (\<^bold>\<lambda>z. \<lparr>F,x\<^sup>P,y\<^sup>P,z\<^sup>P\<rparr>) \<^bold>=\<^sub>1 (\<^bold>\<lambda>z. \<lparr>G,x\<^sup>P,y\<^sup>P,z\<^sup>P\<rparr>) in v]"
      unfolding basic_identity\<^sub>3_def
      apply - apply meta_solver by auto
    {
      fix u v r s w
      obtain x where x_def: "\<nu>\<upsilon> x = v" by (metis \<nu>\<upsilon>_surj surj_def)
      obtain y where y_def: "\<nu>\<upsilon> y = r" by (metis \<nu>\<upsilon>_surj surj_def)
      obtain a where a_def:
        "a = (\<lambda>u s w. \<exists>xa. \<nu>\<upsilon> xa = u \<and> eval\<Pi>\<^sub>3 F (\<nu>\<upsilon> x) (\<nu>\<upsilon> y) (\<nu>\<upsilon> xa) s w)"
        by auto
      obtain b where b_def:
        "b = (\<lambda>u s w. \<exists>xa. \<nu>\<upsilon> xa = u \<and> eval\<Pi>\<^sub>3 G (\<nu>\<upsilon> x) (\<nu>\<upsilon> y) (\<nu>\<upsilon> xa) s w)"
        by auto
      have "a = b" unfolding a_def b_def
          using 1 apply - apply meta_solver
          by (auto simp: meta_defs meta_aux make\<Pi>\<^sub>1_inject)
      hence "a u s w = b u s w" by auto
      hence "(eval\<Pi>\<^sub>3 F (\<nu>\<upsilon> x) (\<nu>\<upsilon> y) u s w) = (eval\<Pi>\<^sub>3 G (\<nu>\<upsilon> x) (\<nu>\<upsilon> y) u s w)"
        unfolding a_def b_def
        by (metis (no_types, hide_lams) \<nu>\<upsilon>_surj surj_def)
      hence "(eval\<Pi>\<^sub>3 F v r u s w) = (eval\<Pi>\<^sub>3 G v r u s w)"
        unfolding x_def y_def by auto
    }
    hence "(eval\<Pi>\<^sub>3 F) = (eval\<Pi>\<^sub>3 G)" by blast
    thus "F = G" by (simp add: eval\<Pi>\<^sub>3_inject)
  qed
  lemma Eq\<^sub>3S[meta_subst]: "[F \<^bold>=\<^sub>3 G in v] = (F = G)"
    using Eq\<^sub>3I Eq\<^sub>3E by auto
  lemma Eq\<^sub>3_prop: "[F \<^bold>=\<^sub>3 G in v] \<Longrightarrow> [\<phi> F in v] = [\<phi> G in v]"
    using Eq\<^sub>3E by blast

subsubsection\<open>Propositions\<close>
text\<open>\label{TAO_MetaSolver_Identity_Proposition}\<close>

  lemma Eq\<^sub>0I[meta_intro]: "x = y \<Longrightarrow> [x \<^bold>=\<^sub>0 y in v]"
    unfolding basic_identity\<^sub>0_def by (simp add: Eq\<^sub>1S)
  lemma Eq\<^sub>0E[meta_elim]: "[F \<^bold>=\<^sub>0 G in v] \<Longrightarrow> F = G"
    proof -
      assume "[F \<^bold>=\<^sub>0 G in v]"
      hence "[(\<^bold>\<lambda>y. F) \<^bold>=\<^sub>1 (\<^bold>\<lambda>y. G) in v]"
        unfolding basic_identity\<^sub>0_def by simp
      hence "(\<^bold>\<lambda>y. F) = (\<^bold>\<lambda>y. G)"
        using Eq\<^sub>1S by simp
      hence "(\<lambda>u s w. (\<exists>x. \<nu>\<upsilon> x = u) \<and> eval\<o> F s w)
           = (\<lambda>u s w. (\<exists>x. \<nu>\<upsilon> x = u) \<and> eval\<o> G s w)"
        apply (simp add: meta_defs meta_aux)
        by (metis (no_types, lifting) UNIV_I make\<Pi>\<^sub>1_inverse)
      hence "\<And>s w.(eval\<o> F s w) = (eval\<o> G s w)"
        by metis
      hence "(eval\<o> F) = (eval\<o> G)" by blast
      thus "F = G"
      by (metis eval\<o>_inverse)
    qed
  lemma Eq\<^sub>0S[meta_subst]: "[F \<^bold>=\<^sub>0 G in v] = (F = G)"
    using Eq\<^sub>0I Eq\<^sub>0E by auto
  lemma Eq\<^sub>0_prop: "[F \<^bold>=\<^sub>0 G in v] \<Longrightarrow> [\<phi> F in v] = [\<phi> G in v]"
    using Eq\<^sub>0E by blast

end

(*<*)
end
(*>*)


theory Approximation_Quickcheck_Ex
imports "../Approximation"
begin

lemma
  fixes x::real and y::real
  shows "sin x \<le> tan x"
  using [[quickcheck_approximation_custom_seed = 1]]
  quickcheck[approximation, expect=counterexample]
  oops

lemma "x \<le> y \<Longrightarrow> arctan y / y \<le> arctan x / x"
  using [[quickcheck_approximation_custom_seed = 1]]
  quickcheck[approximation, expect=counterexample]
  oops

lemma "0 < x \<Longrightarrow> x \<le> y \<Longrightarrow> arctan y / y \<le> arctan x / x"
  using [[quickcheck_approximation_custom_seed = 1]]
  quickcheck[approximation, expect=no_counterexample]
  by (rule arctan_divide_mono)

lemma
  fixes x::real
  shows "exp (exp x + exp y + sin x * sin y) - 0.4 > 0 \<or> 0.98 - sin x / (sin x * sin y + 2)^2 > 0"
  using [[quickcheck_approximation_custom_seed = 1]]
  quickcheck[approximation, expect=counterexample, size=10, iterations=1000, verbose]
  oops

lemma
  fixes x::real
  shows "x > 1 \<Longrightarrow> x \<le> 2 ^ 20 * log 2 x + 1 \<and> (sin x)\<^sup>2 + (cos x)\<^sup>2 = 1"
  using [[quickcheck_approximation_custom_seed = 1]]
  using [[quickcheck_approximation_epsilon = 0.00000001]]
    \<comment>\<open>avoids spurious counterexamples in approximate computation of @{term "(sin x)\<^sup>2 + (cos x)\<^sup>2"}
      and therefore avoids expensive failing attempts for certification\<close>
  quickcheck[approximation, expect=counterexample, size=20]
  oops

end


(*  Title:      HOL/IMPP/EvenOdd.thy
    Author:     David von Oheimb, TUM
*)

section {* Example of mutually recursive procedures verified with Hoare logic *}

theory EvenOdd
imports Main Misc
begin

axiomatization
  Even :: pname and
  Odd :: pname
where
  Even_neq_Odd: "Even ~= Odd" and
  Arg_neq_Res:  "Arg  ~= Res"

definition
  evn :: com where
 "evn = (IF (%s. s<Arg> = 0)
         THEN Loc Res:==(%s. 0)
         ELSE(Loc Res:=CALL Odd(%s. s<Arg> - 1);;
              Loc Arg:=CALL Odd(%s. s<Arg> - 1);;
              Loc Res:==(%s. s<Res> * s<Arg>)))"

definition
  odd :: com where
 "odd = (IF (%s. s<Arg> = 0)
         THEN Loc Res:==(%s. 1)
         ELSE(Loc Res:=CALL Even (%s. s<Arg> - 1)))"

defs
  bodies_def: "bodies == [(Even,evn),(Odd,odd)]"

definition
  Z_eq_Arg_plus :: "nat => nat assn" ("Z=Arg+_" [50]50) where
  "Z=Arg+n = (%Z s.      Z =  s<Arg>+n)"

definition
  Res_ok :: "nat assn" where
  "Res_ok = (%Z s. even Z = (s<Res> = 0))"

subsection "Arg, Res"

declare Arg_neq_Res [simp] Arg_neq_Res [THEN not_sym, simp]
declare Even_neq_Odd [simp] Even_neq_Odd [THEN not_sym, simp]

lemma Z_eq_Arg_plus_def2: "(Z=Arg+n) Z s = (Z = s<Arg>+n)"
apply (unfold Z_eq_Arg_plus_def)
apply (rule refl)
done

lemma Res_ok_def2: "Res_ok Z s = (even Z = (s<Res> = 0))"
apply (unfold Res_ok_def)
apply (rule refl)
done

lemmas Arg_Res_simps = Z_eq_Arg_plus_def2 Res_ok_def2

lemma body_Odd [simp]: "body Odd = Some odd"
apply (unfold body_def bodies_def)
apply auto
done

lemma body_Even [simp]: "body Even = Some evn"
apply (unfold body_def bodies_def)
apply auto
done

subsection "verification"

lemma Odd_lemma: "{{Z=Arg+0}. BODY Even .{Res_ok}}|-{Z=Arg+Suc 0}. odd .{Res_ok}"
apply (unfold odd_def)
apply (rule hoare_derivs.If)
apply (rule hoare_derivs.Ass [THEN conseq1])
apply  (clarsimp simp: Arg_Res_simps)
apply (rule export_s)
apply (rule hoare_derivs.Call [THEN conseq1])
apply  (rule_tac P = "Z=Arg+Suc (Suc 0) " in conseq12)
apply (rule single_asm)
apply (auto simp: Arg_Res_simps)
done

lemma Even_lemma: "{{Z=Arg+1}. BODY Odd .{Res_ok}}|-{Z=Arg+0}. evn .{Res_ok}"
apply (unfold evn_def)
apply (rule hoare_derivs.If)
apply (rule hoare_derivs.Ass [THEN conseq1])
apply  (clarsimp simp: Arg_Res_simps)
apply (rule hoare_derivs.Comp)
apply (rule_tac [2] hoare_derivs.Ass)
apply clarsimp
apply (rule_tac Q = "%Z s. ?P Z s & Res_ok Z s" in hoare_derivs.Comp)
apply (rule export_s)
apply  (rule_tac I1 = "%Z l. Z = l Arg & 0 < Z" and Q1 = "Res_ok" in Call_invariant [THEN conseq12])
apply (rule single_asm [THEN conseq2])
apply   (clarsimp simp: Arg_Res_simps)
apply  (force simp: Arg_Res_simps)
apply (rule export_s)
apply (rule_tac I1 = "%Z l. even Z = (l Res = 0) " and Q1 = "%Z s. even Z = (s<Arg> = 0) " in Call_invariant [THEN conseq12])
apply (rule single_asm [THEN conseq2])
apply  (clarsimp simp: Arg_Res_simps)
apply (force simp: Arg_Res_simps)
done

lemma Even_ok_N: "{}|-{Z=Arg+0}. BODY Even .{Res_ok}"
apply (rule BodyN)
apply (simp (no_asm))
apply (rule Even_lemma [THEN hoare_derivs.cut])
apply (rule BodyN)
apply (simp (no_asm))
apply (rule Odd_lemma [THEN thin])
apply (simp (no_asm))
done

lemma Even_ok_S: "{}|-{Z=Arg+0}. BODY Even .{Res_ok}"
apply (rule conseq1)
apply  (rule_tac Procs = "{Odd, Even}" and pn = "Even" and P = "%pn. Z=Arg+ (if pn = Odd then 1 else 0) " and Q = "%pn. Res_ok" in Body1)
apply    auto
apply (rule hoare_derivs.insert)
apply (rule Odd_lemma [THEN thin])
apply  (simp (no_asm))
apply (rule Even_lemma [THEN thin])
apply (simp (no_asm))
done

end


theory Kuratowski_Combinatorial
imports
  Planar_Complete
  Planar_Subdivision
  Planar_Subgraph
begin

theorem comb_planar_compat:
  assumes "comb_planar G"
  shows "kuratowski_planar G"
proof (rule ccontr)
  assume "\<not>?thesis"
  then obtain G0 rev_G0 K rev_K where sub: "subgraph G0 G" "subdivision (K, rev_K) (G0, rev_G0)"
      and is_kur: "K\<^bsub>3,3\<^esub> K \<or> K\<^bsub>5\<^esub> K"
    unfolding kuratowski_planar_def by auto

  have "comb_planar K" using sub assms
    by (metis subgraph_comb_planar subdivision_comb_planar subdivision_bidir)
  moreover
  have "\<not>comb_planar K" using is_kur by (metis K5_not_comb_planar K33_not_comb_planar)
  ultimately
  show False by contradiction
qed

end


theory Montanari_Basic_Contrasim_Game
imports
  Simple_Game
  Montanari_Weak_Relations
  Montanari_Weak_Transition_Systems
begin

subsection \<open>The Basic Contrasimulation Preorder Game\<close>

datatype ('s, 'a) c_basic_game_node =
  AttackerNode 's 's |
  DefenderNode "'a list" 's 's

fun (in lts_tau) c_game_moves ::
  \<open>('s, 'a) c_basic_game_node \<Rightarrow> ('s, 'a) c_basic_game_node \<Rightarrow> bool\<close> where

  simulation_challenge:
   \<open>c_game_moves (AttackerNode p q) (DefenderNode A p1 q0) =
     (p \<Rightarrow>$A p1 \<and> q = q0 \<and> (\<forall>a\<in>set A. a \<noteq> \<tau>))\<close> |

  simulation_answer:
    \<open>c_game_moves (DefenderNode A p1 q0) (AttackerNode q1 p10) =
      (q0 \<Rightarrow>$A q1 \<and> p1 = p10)\<close> |

  c_game_moves_no_step:
    \<open>c_game_moves _ _ = False\<close>

fun c_game_defender_node :: \<open>('s, 'a) c_basic_game_node \<Rightarrow> bool\<close> where
  \<open>c_game_defender_node (AttackerNode _ _) = False\<close> |
  \<open>c_game_defender_node (DefenderNode _ _ _) = True\<close>

subsection \<open>Contrasimulation Implies Winning Strategy (Completeness)\<close>

locale c_basic_game =
  lts_tau trans \<tau> +
  simple_game c_game_moves c_game_defender_node initial
for
  trans :: \<open>'s \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool\<close> and
  \<tau> :: \<open>'a\<close> and
  initial :: \<open>('s, 'a) c_basic_game_node\<close>
begin

fun strategy_from_contrasim :: \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s, 'a) c_basic_game_node strategy\<close> where
  \<open>strategy_from_contrasim R ((DefenderNode A p1 q0)#play) =
    (AttackerNode (SOME q1 . R q1 p1 \<and> q0 \<Rightarrow>$A q1) p1)\<close> |
  \<open>strategy_from_contrasim _ _ = undefined\<close>

lemma basic_defender_pred_is_attacker:
  assumes
    \<open>c_game_defender_node n0\<close>
    \<open>n0 = DefenderNode A p' q\<close>
    \<open>(n0#play) \<in> plays\<close>
    \<open>initial = AttackerNode p0 q0\<close>
  shows \<open>\<exists>p. (hd play) = AttackerNode p q \<and> c_game_moves (hd play) n0\<close>
proof -
  have \<open>n0 \<noteq> initial\<close> using assms (2, 4) by auto
  hence mov: \<open>c_game_moves (hd play) n0\<close> using assms(3)
    by (metis list.inject list.sel(1) plays.cases)
  hence \<open>\<exists>p. (hd play) = AttackerNode p q\<close> using assms(1 - 3)
    by (metis c_basic_game_node.inject(2) c_game_defender_node.simps(1) c_game_moves.elims(2))
  thus ?thesis using mov by auto
qed

lemma second_elem_in_play_set :
  assumes
    \<open>(n0#play) \<in> plays\<close>
    \<open>initial = AttackerNode p0 q0\<close>
    \<open>n0 = DefenderNode A p q\<close>
  shows \<open>hd play \<in> set (n0 # play)\<close>
proof -
  from assms(2, 3) have \<open>n0 \<noteq> initial\<close>by auto
  hence \<open>play \<in> plays\<close> using assms(1) plays.cases no_empty_plays by blast
  hence play_split: \<open>\<exists>x xs. play = x#xs\<close> using no_empty_plays
    using plays.cases by blast
  then obtain x where x_def: \<open>\<exists>xs. play = x#xs\<close> ..
  have x_in_set: \<open>x \<in> set (n0#play)\<close> using x_def by auto
  have \<open>x = hd play\<close> using x_def by auto
  with x_in_set show \<open>hd play \<in> set (n0 # play)\<close> by auto
qed

lemma basic_game_all_f_consistent_atk_pos_in_R:
  assumes
    \<open>contrasim R\<close>
    \<open>R p0 q0\<close>
    \<open>initial = AttackerNode p0 q0\<close>
    \<open>play \<in> plays_for_strategy (strategy_from_contrasim R)\<close>

shows \<open>((AttackerNode p q) \<in> set play) \<Longrightarrow> R p q\<close>
  using assms(4)
proof (induct arbitrary: p q rule: plays_for_strategy.induct[OF assms(4)])
  case 1
  fix p q
  assume  \<open>(AttackerNode p q) \<in> (set [initial])\<close>
  thus \<open>R p q\<close> using assms(3, 2) by simp
next
  case p0moved: (2 n0 play)
  hence IH:\<open>AttackerNode p q \<in> set (n0#play) \<Longrightarrow> R p q\<close> by simp
  from p0moved.prems have \<open>(AttackerNode p q) \<in> set ((strategy_from_contrasim R (n0 # play))#n0#play)\<close>
    by simp
  hence \<open>(AttackerNode p q = (strategy_from_contrasim R (n0 # play))) \<or> (AttackerNode p q \<in> set (n0#play))\<close>
    by simp
  thus \<open>R p q\<close>
  proof (rule disjE)
     assume \<open>AttackerNode p q \<in> set (n0#play)\<close>
     thus \<open>R p q\<close> using IH by simp
   next
     assume A: \<open>AttackerNode p q = (strategy_from_contrasim R (n0 # play))\<close>
     have \<open>\<exists>A ppred. n0 = (DefenderNode A q ppred)\<close> using p0moved.hyps(3)
       strategy_from_contrasim.simps(1)[of \<open>R\<close>]
       by (metis (no_types, lifting) A c_basic_game_node.inject(1) c_game_defender_node.elims(2))
     then obtain A ppred where n0_def: \<open>n0 = (DefenderNode A q ppred)\<close> \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close>
       by (metis assms(3) c_basic_game.basic_defender_pred_is_attacker simulation_challenge p0moved.hyps(1, 3) strategy_plays_subset)
     hence \<open>strategy_from_contrasim R (n0#play) = AttackerNode (SOME q1. R q1 q \<and> ppred \<Rightarrow>$ A  q1) q\<close>
       using n0_def strategy_from_contrasim.simps(1)[of \<open>R\<close> \<open>A\<close> \<open>q\<close> \<open>ppred\<close> \<open>play\<close>] by auto
     hence p_def: \<open>p = (SOME p1. R p1 q \<and> ppred \<Rightarrow>$ A p1)\<close> using A by auto
     have \<open>\<exists>qpred. hd play = (AttackerNode qpred ppred) \<and> c_game_moves (hd play) n0\<close>
       using basic_defender_pred_is_attacker strategy_plays_subset[OF p0moved.hyps(1)]
       by (simp add: assms(3) n0_def  p0moved.hyps(3))
     then obtain qpred where qpred_def: \<open>hd play = (AttackerNode qpred ppred)\<close>
       and qpred_move: \<open>c_game_moves (hd play) n0\<close> by auto
     have qpred_q_move: \<open>qpred \<Rightarrow>$A q\<close> using qpred_def qpred_move n0_def by simp
     have \<open>hd play \<in> set (n0 # play)\<close>
       using second_elem_in_play_set strategy_plays_subset[OF p0moved.hyps(1)] assms(3)
       by (auto simp add: n0_def)
     hence pred_R: \<open>R qpred ppred\<close>
       by (simp add: qpred_def p0moved.hyps(1) p0moved.hyps(2))
     have  \<open>\<exists> p1 . R p1 q \<and> ppred \<Rightarrow>$ A p1\<close>
      using qpred_q_move pred_R assms(1) \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close>
      unfolding contrasim_def by blast
    from someI_ex[OF this] show \<open>R p q\<close> unfolding p_def by blast
   qed
next
  case p1moved: (3 n1 play n1')
  from p1moved.hyps have IH:\<open>AttackerNode p q \<in> set (n1#play) \<Longrightarrow> R p q\<close> by simp
  assume  \<open>(AttackerNode p q) \<in> (set (n1'#n1#play))\<close>
  hence \<open>(AttackerNode p q = n1') \<or> (AttackerNode p q \<in> set (n1#play))\<close> by auto
  thus \<open>R p q\<close>
  proof (rule disjE)
    assume \<open>(AttackerNode p q \<in> set (n1#play))\<close>
    thus \<open>R p q\<close> using p1moved.hyps by auto
  next
   assume A: \<open>AttackerNode p q = n1'\<close>
   from p1moved.hyps have \<open>player1_position n1\<close> by simp
   hence \<open>c_game_defender_node n1'\<close>
     by (metis c_game_defender_node.simps(2) c_game_moves.elims(2) p1moved.hyps(4) player1_position_def)
   hence \<open>False\<close> using A by auto
   thus \<open>R p q\<close> ..
 qed
qed

lemma basic_contrasim_game_complete:
  assumes
    \<open>contrasim R\<close>
    \<open>R p q\<close>
    \<open>initial = AttackerNode p q\<close>
  shows \<open>player0_winning_strategy (strategy_from_contrasim R)\<close>
    unfolding player0_winning_strategy_def

proof (safe)
  fix play
  assume A1: \<open>play \<in> (plays_for_strategy (strategy_from_contrasim R))\<close>
  thus \<open>player1_wins play \<Longrightarrow> False\<close>
    unfolding player1_wins_def
  proof -
    assume A: \<open>c_game_defender_node (hd play) \<and> (\<nexists>p'. c_game_moves (hd play) p')\<close>
    have player0_has_succ_node: \<open>c_game_defender_node (hd play) \<Longrightarrow> \<exists>p'. c_game_moves (hd play) p'\<close>
    proof (induct rule: simple_game.plays_for_strategy.induct[OF A1])
      case init: 1
      from assms(3) have \<open>\<not>c_game_defender_node (hd [initial])\<close> by simp
      hence \<open>False\<close> using init.prems by simp
      then show ?case ..
    next
      case p0moved: (2 n0 play)
      from p0moved.hyps have \<open>c_game_defender_node n0\<close> by simp
      hence \<open>\<exists>A p1 q. n0 = (DefenderNode A p1 q)\<close>
        by (meson c_game_defender_node.elims(2))
      hence \<open>\<not>c_game_defender_node (strategy_from_contrasim R (n0#play))\<close>
        using p0moved.hyps(4) c_game_moves.elims(2)[of \<open>n0\<close> \<open>strategy_from_contrasim R (n0#play)\<close>]
        by force
      hence \<open>\<not>c_game_defender_node (hd (strategy_from_contrasim R (n0 # play) # n0 # play))\<close>
        by simp
      hence \<open>False\<close> using p0moved.prems ..
      then show ?case ..
    next
      case p1moved: (3 n1 play n1')
      hence \<open>\<not>c_game_defender_node n1\<close> using p1moved.hyps and player1_position_def by simp
      then obtain p q where n1_def: \<open>n1 = AttackerNode p q\<close>
        using c_game_defender_node.elims(3) by auto
      hence pq_in_R: \<open>R p q\<close>
        using basic_game_all_f_consistent_atk_pos_in_R[OF assms, of \<open>n1#play\<close>, OF p1moved.hyps(1)]
        by auto
      have is_def: \<open>c_game_defender_node n1'\<close> using p1moved.prems by auto
      then obtain A p1 q0 where n1'_def: \<open>n1' = DefenderNode A p1 q0\<close>
        using c_game_defender_node.elims(2)[OF is_def] by auto
      hence \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> using p1moved.hyps(4) n1_def by simp
      have Move_n1_n1': \<open>c_game_moves (AttackerNode p q) (DefenderNode A p1 q0)\<close>
        using p1moved.hyps n1_def n1'_def by auto
      hence same_q: \<open>q0 = q\<close> by auto
      from Move_n1_n1' have p_succ: \<open>p \<Rightarrow>$A p1\<close> by auto
      from assms(1) have Contra: \<open>\<And>p q p' A. (\<forall>a\<in>set A. a \<noteq> \<tau>) \<Longrightarrow> R p q \<Longrightarrow> p \<Rightarrow>$ A  p' \<Longrightarrow> (\<exists>q'. q \<Rightarrow>$ A  q' \<and> R q' p')\<close>
        unfolding contrasim_def by auto
      hence \<open>\<exists> q'. (q \<Rightarrow>$ A q')\<and> R q' p1\<close> using Contra[OF \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> pq_in_R p_succ] by auto
      hence \<open>\<exists> p1 q1. c_game_moves n1' (AttackerNode p1 q1)\<close> using same_q n1'_def by auto
      then show ?case by auto
    qed
    thus \<open>False\<close> using A by auto
  qed
qed

lemma strategy_from_contrasim_sound :
  assumes
    \<open>R p0 q0\<close>
    \<open>contrasim R\<close>
    \<open>initial = AttackerNode p0 q0\<close>
  shows
    \<open>sound_strategy (strategy_from_contrasim R)\<close>
  unfolding sound_strategy_def
proof (safe)
  fix n0 play
  assume A:
    \<open>n0 # play \<in> plays_for_strategy (strategy_from_contrasim R)\<close>
    \<open>c_game_defender_node n0\<close>
  then obtain A p1 q where n0_def: \<open>n0 = DefenderNode A p1 q\<close>
    using c_game_defender_node.elims(2) by blast
  then obtain p where p_def: \<open>hd play = AttackerNode p q\<close>
    using n0_def A basic_defender_pred_is_attacker assms(3) strategy_plays_subset by blast
  hence \<open>c_game_moves (AttackerNode p q) (DefenderNode A p1 q)\<close>
    using A n0_def by (metis assms(3) basic_defender_pred_is_attacker strategy_plays_subset)
  hence mov_p_p1: \<open>p \<Rightarrow>$A p1\<close> \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> by auto
  from p_def have \<open>R p q\<close>
    using basic_game_all_f_consistent_atk_pos_in_R A assms
      second_elem_in_play_set n0_def strategy_plays_subset
    by fastforce
  with mov_p_p1 have q1_def: \<open>\<exists>q1. R q1 p1 \<and> q \<Rightarrow>$A q1\<close>
    using assms(2) unfolding contrasim_def by blast
  from n0_def have \<open>strategy_from_contrasim R (n0 # play) = (AttackerNode (SOME q1 . R q1 p1 \<and> q \<Rightarrow>$A q1) p1)\<close>
    by auto
  then obtain q' where \<open>AttackerNode (SOME q1 . R q1 p1 \<and> q \<Rightarrow>$A q1) p1 = AttackerNode q' p1\<close> by blast
  hence q'_def: \<open>q' = (SOME q1 . R q1 p1 \<and> q \<Rightarrow>$A q1)\<close> by auto
  with someI_ex[OF q1_def] have \<open>R q' p1 \<and> q \<Rightarrow>$A q'\<close> by blast
  thus \<open>c_game_moves n0 (strategy_from_contrasim R (n0 # play))\<close> using q'_def by (simp add: n0_def)
qed

lemma basic_contrasim_game_sound:
  assumes
    \<open>player0_winning_strategy f\<close>
    \<open>sound_strategy f\<close>
  defines
    \<open>R == \<lambda> p q . (\<exists> play \<in> plays_for_strategy f . hd play = AttackerNode p q)\<close>
  shows
    \<open>contrasim R\<close>  unfolding contrasim_def
proof (safe)
  fix p q p1 A
  assume A1: \<open>p \<Rightarrow>$A p1\<close>
  assume A2: \<open>R p q\<close> \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close>
  hence \<open>\<exists> play . play \<in> plays_for_strategy f \<and> hd play = AttackerNode p q\<close> using R_def by auto
  from this obtain play where play_def: \<open>play \<in> plays_for_strategy f \<and> hd play = AttackerNode p q\<close> ..
  from assms(1) have \<open>\<not>player1_wins play\<close> using  player0_winning_strategy_def play_def by auto
  hence \<open>(c_game_defender_node (hd play) \<and> (\<nexists>p'. c_game_moves (hd play) p')) \<Longrightarrow> False\<close>
    using player1_wins_def by auto
  hence Def_not_stuck: \<open>c_game_defender_node (hd play) \<Longrightarrow> (\<nexists>p'. c_game_moves (hd play) p') \<Longrightarrow> False\<close>
    by auto
  have \<open>(p \<Rightarrow>$A p1) \<Longrightarrow> (((DefenderNode A p1 q)#play) \<in> plays_for_strategy f)\<close>
  proof -
    have \<open>\<exists>n0. n0 = DefenderNode A p1 q\<close> by auto
    from this obtain n0 where n0_def: \<open>n0 = DefenderNode A p1 q\<close> ..
    have play_split: \<open>play = (hd play)#(tl play)\<close>
      by (metis hd_Cons_tl play_def strategy_plays_subset no_empty_plays)
    hence inF:\<open>(hd play)#(tl play) \<in> plays_for_strategy f\<close> by (simp add: play_def)
    have pl1: \<open>player1_position (hd play)\<close> by (simp add: play_def player1_position_def)
    have mov0:\<open>c_game_moves (hd play) (DefenderNode A p1 q)\<close>
      using  \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> by (auto simp add: play_def A1)
    have \<open>(DefenderNode A p1 q)#(hd play)#(tl play) \<in> plays_for_strategy f\<close>
      using plays_for_strategy.p1move[OF inF pl1 mov0] .
    thus \<open>DefenderNode A p1 q#play \<in> plays_for_strategy f\<close> by (simp add: sym[OF play_split])
  qed

  hence def_in_f: \<open>(DefenderNode A p1 q)#play \<in> plays_for_strategy f\<close> by (simp add: A1)
  hence \<open>\<not>(player1_wins (DefenderNode A p1 q#play))\<close>
    using assms(1) player0_winning_strategy_def by auto
  hence \<open>\<exists>n1. c_game_moves (DefenderNode A p1 q) n1\<close> using player1_wins_def by auto
  have move_ex: \<open>c_game_moves (DefenderNode A p1 q) (f (DefenderNode A p1 q # play))\<close>
    using assms(2) def_in_f sound_strategy_def by auto
  hence  in_f: \<open>f ((DefenderNode A p1 q) # play) # (DefenderNode A p1 q) # play \<in> plays_for_strategy f\<close>
    using plays_for_strategy.p0move[OF def_in_f] by auto
  obtain n1 where n1_def: \<open>n1 = f (DefenderNode A p1 q # play)\<close>
    and n1_move: \<open>c_game_moves (DefenderNode A p1 q) n1\<close> using move_ex by auto
  hence \<open>\<exists>q1. n1 = (AttackerNode q1 p1)\<close>
    using c_game_moves.elims(2)[of \<open>DefenderNode A p1 q\<close> n1] by auto
  from this obtain q1 where q1_def: \<open>n1 = (AttackerNode q1 p1)\<close> ..
  have \<open>c_game_moves (DefenderNode A p1 q) (AttackerNode q1 p1)\<close> using q1_def move_ex n1_def by auto
  hence q1_succ: \<open>q \<Rightarrow>$A q1\<close> using c_game_moves.simps(2) by auto
  have def: \<open>c_game_defender_node (DefenderNode A p1 q)\<close> by simp
  hence \<open>(AttackerNode q1 p1)#(DefenderNode A p1 q)#play \<in> plays_for_strategy f\<close>
    using q1_def n1_def in_f by auto
  then obtain R_play where R_play_def: \<open>R_play = (AttackerNode q1 p1)#(DefenderNode A p1 q)#play\<close>
    and R_play_in_f: \<open>R_play \<in> plays_for_strategy f\<close> by simp
  hence \<open>(hd R_play) = AttackerNode q1 p1\<close> by (simp add: R_play_def)
  hence \<open>R q1 p1\<close> unfolding R_def using R_play_in_f by auto
  thus \<open>R p q \<Longrightarrow> p \<Rightarrow>$ A  p1 \<Longrightarrow> \<exists>q1. q \<Rightarrow>$ A  q1 \<and> R q1 p1\<close> using q1_succ by auto
qed

theorem winning_strategy_in_basic_game_iff_contrasim:
  assumes
    \<open>initial = AttackerNode p q\<close>
  shows
    \<open>(\<exists> f . player0_winning_strategy f \<and> sound_strategy f) = (\<exists> C. contrasim C \<and> C p q)\<close>
proof
  assume
    \<open>(\<exists>f. player0_winning_strategy f \<and> sound_strategy f)\<close>
  then obtain f where
    \<open>contrasim (\<lambda>p q. \<exists>play\<in>plays_for_strategy f. hd play = AttackerNode p q)\<close>
    using basic_contrasim_game_sound by blast
  moreover have \<open>(\<lambda>p q. \<exists>play\<in>plays_for_strategy f. hd play = AttackerNode p q) p q\<close>
    using assms plays_for_strategy.init[of f] by (meson list.sel(1))
  ultimately show \<open>\<exists> C. contrasim C \<and> C p q\<close> by blast
next
  assume
    \<open>\<exists> C. contrasim C \<and> C p q\<close>
  thus \<open>(\<exists>f. player0_winning_strategy f \<and> sound_strategy f)\<close>
    using basic_contrasim_game_complete[OF _ _ assms]
         strategy_from_contrasim_sound[OF _ _ assms] by blast
qed

end
end


(*  Title:      Glued Codes
    File:       CoW_Graph_Lemma.Glued_Codes
    Author:     Štěpán Holub, Charles University
    Author:     Martin Raška, Charles University

Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
*)

theory Glued_Codes
  imports Combinatorics_Words.Submonoids
begin

chapter "Glued codes"

section \<open>Lists that do not end with a fixed letter\<close>

lemma append_last_neq:
  "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> vs = \<epsilon> \<or> last vs \<noteq> w \<Longrightarrow> us \<cdot> vs = \<epsilon> \<or> last (us \<cdot> vs) \<noteq> w"
  by (auto simp only: last_append split: if_split)

lemma last_neq_induct [consumes 1, case_names emp hd_eq hd_neq]:
  assumes invariant: "us = \<epsilon> \<or> last us \<noteq> w"
      and emp: "P \<epsilon>"
      and hd_eq: "\<And>us. us \<noteq> \<epsilon> \<Longrightarrow> last us \<noteq> w \<Longrightarrow> P us \<Longrightarrow> P (w # us)"
      and hd_neq: "\<And>u us. u \<noteq> w \<Longrightarrow> us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> P us \<Longrightarrow> P (u # us)"
  shows "P us"
using invariant proof (induction us)
  case (Cons u us)
    have inv: "us = \<epsilon> \<or> last us \<noteq> w"
      using Cons.prems by (intro disjI) simp
    show "P (u # us)"
    proof (cases)
      assume "u = w"
      have *: "us \<noteq> \<epsilon>" and "last us \<noteq> w"
        using Cons.prems unfolding \<open>u = w\<close> by auto
      then show "P (u # us)" unfolding \<open>u = w\<close> using Cons.IH[OF inv] by (fact hd_eq)
    qed (use inv Cons.IH[OF inv] in \<open>fact hd_neq\<close>)
qed (rule \<open>P \<epsilon>\<close>)

lemma last_neq_blockE:
  assumes last_neq: "us \<noteq> \<epsilon>" and "last us \<noteq> w"
  obtains k u us' where "u \<noteq> w" and "us' = \<epsilon> \<or> last us' \<noteq> w" and "[w] \<^sup>@ k \<cdot> u # us' = us"
using disjI2[OF \<open>last us \<noteq> w\<close>] \<open>us \<noteq> \<epsilon>\<close> proof (induction us rule: last_neq_induct)
  case (hd_eq us)
    from \<open>us \<noteq> \<epsilon>\<close> show ?case
      by (rule hd_eq.IH[rotated]) (intro hd_eq.prems(1)[of _ _ "Suc _"], assumption+, simp)
next
  case (hd_neq u us)
    from hd_neq.hyps show ?case
     by (rule hd_neq.prems(1)[of _ _ 0]) simp
qed blast

lemma last_neq_block_induct [consumes 1, case_names emp block]:
  assumes last_neq: "us = \<epsilon> \<or> last us \<noteq> w"
      and emp: "P \<epsilon>"
      and block: "\<And>k u us. u \<noteq> w \<Longrightarrow> us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> P us \<Longrightarrow> P ([w] \<^sup>@ k \<cdot> (u # us))"
  shows "P us"
using last_neq proof (induction us rule: ssuf_induct)
  case (ssuf us)
    show ?case proof (cases "us = \<epsilon>")
      assume "us \<noteq> \<epsilon>"
      obtain k u us' where "u \<noteq> w" and "us' = \<epsilon> \<or> last us' \<noteq> w" and "[w] \<^sup>@ k \<cdot> u # us' = us"
        using \<open>us \<noteq> \<epsilon>\<close> \<open>us = \<epsilon> \<or> last us \<noteq> w\<close> by (elim last_neq_blockE) (simp add: \<open>us \<noteq> \<epsilon>\<close>)
      have "us' <s us" and "us' = \<epsilon> \<or> last us' \<noteq> w"
        using \<open>us = \<epsilon> \<or> last us \<noteq> w\<close> by (auto simp flip: \<open>[w] \<^sup>@ k \<cdot> u # us' = us\<close>)
      from \<open>u \<noteq> w\<close> \<open>us' = \<epsilon> \<or> last us' \<noteq> w\<close> ssuf.IH[OF this]
      show "P us" unfolding \<open>[w] \<^sup>@ k \<cdot> u # us' = us\<close>[symmetric] by (fact block)
    qed (simp only: emp)
qed

section \<open>Glue a list element with its successors/predecessors\<close>

function glue :: "'a list \<Rightarrow> 'a list list \<Rightarrow> 'a list list" where
  glue_emp:  "glue w \<epsilon> = \<epsilon>" |
  glue_Cons: "glue w (u # us) =
    (let glue_tl = glue w us in
      if u = w then (u \<cdot> hd glue_tl) # tl glue_tl
      else u # glue_tl)"
  unfolding prod_eq_iff prod.sel by (cases rule: list.exhaust[of "snd _"]) blast+
  termination by (relation "measure (length \<circ> snd)") simp_all

lemma no_gluing: "w \<notin> set us \<Longrightarrow> glue w us = us"
  by (induction us) auto

lemma glue_nemp [simp, intro!]: "us \<noteq> \<epsilon> \<Longrightarrow> glue w us \<noteq> \<epsilon>"
  by (elim hd_tlE) (auto simp only: glue.simps Let_def split!: if_split)

lemma glue_is_emp_iff [simp]: "glue w us = \<epsilon> \<longleftrightarrow> us = \<epsilon>"
  using glue_nemp glue_emp by blast

lemma len_glue: "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> \<^bold>|glue w us\<^bold>| + count_list us w = \<^bold>|us\<^bold>|"
  by (induction rule: last_neq_induct) (auto simp add: Let_def)

lemma len_glue_le: assumes "us = \<epsilon> \<or> last us \<noteq> w" shows "\<^bold>|glue w us\<^bold>| \<le> \<^bold>|us\<^bold>|"
  using len_glue[OF assms] unfolding nat_le_iff_add eq_commute[of "\<^bold>|us\<^bold>|"] by blast

lemma len_glue_less []: "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> w \<in> set us \<Longrightarrow> \<^bold>|glue w us\<^bold>| < \<^bold>|us\<^bold>|"
  by (simp add: count_list_gr_0_iff flip: len_glue[of us])

lemma assumes "us = \<epsilon> \<or> last us \<noteq> w" and "\<epsilon> \<notin> set us"
  shows emp_not_in_glue: "\<epsilon> \<notin> set (glue w us)"
    and glued_not_in_glue: "w \<notin> set (glue w us)"
  unfolding atomize_conj using assms by (induction us rule: last_neq_induct)
    (auto simp: Let_def dest!: tl_set lists_hd_in_set[OF glue_nemp[of _ w]])

lemma glue_glue: "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> \<epsilon> \<notin> set us \<Longrightarrow> glue w (glue w us) = glue w us"
  using no_gluing[OF glued_not_in_glue].

lemma glue_block_append: assumes "u \<noteq> w"
  shows "glue w ([w] \<^sup>@ k \<cdot> (u # us)) = (w \<^sup>@ k \<cdot> u) # glue w us"
  by (induction k) (simp_all add: \<open>u \<noteq> w\<close>)

lemma concat_glue [simp]: "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> concat (glue w us) = concat us"
  by (induction us rule: last_neq_block_induct) (simp_all add: glue_block_append)

lemma glue_append:
  "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> glue w (us \<cdot> vs) = glue w us \<cdot> glue w vs"
  by (induction us rule: last_neq_block_induct) (simp_all add: glue_block_append)

lemma glue_pow:
  assumes "us = \<epsilon> \<or> last us \<noteq> w"
  shows "glue w (us \<^sup>@ k) = (glue w us) \<^sup>@ k"
  by (induction k) (simp_all add: assms glue_append)

lemma glue_in_lists_hull [intro]:
  "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> us \<in> lists G \<Longrightarrow> glue w us \<in> lists \<langle>G\<rangle>"
  by (induction rule: last_neq_induct) (simp_all add: Let_def tl_in_lists prod_cl gen_in)

\<comment> \<open>Gluing from the right (gluing a letter with its predecessor)\<close>
function gluer :: "'a list \<Rightarrow> 'a list list \<Rightarrow> 'a list list" where
  gluer_emp:  "gluer w \<epsilon> = \<epsilon>" |
  gluer_Cons: "gluer w (u # us) =
    (let gluer_butlast = gluer w (butlast (u # us)) in
      if last (u # us) = w then (butlast gluer_butlast) \<cdot> [last gluer_butlast \<cdot> last (u # us)]
      else gluer_butlast \<cdot> [last (u # us)])"
  unfolding prod_eq_iff prod.sel by (cases rule: list.exhaust[of "snd _"]) blast+
  termination by (relation "measure (length \<circ> snd)") simp_all

lemma gluer_nemp_def: assumes "us \<noteq> \<epsilon>"
  shows "gluer w us =
    (let gluer_butlast = gluer w (butlast us) in
      if last us = w then (butlast gluer_butlast) \<cdot> [last gluer_butlast \<cdot> last us]
      else gluer_butlast \<cdot> [last us])"
  using gluer_Cons[of w "hd us" "tl us"] unfolding hd_Cons_tl[OF \<open>us \<noteq> \<epsilon>\<close>].

lemma gluer_nemp: assumes "us \<noteq> \<epsilon>" shows "gluer w us \<noteq> \<epsilon>"
  unfolding gluer_nemp_def[OF \<open>us \<noteq> \<epsilon>\<close>]
  by (simp only: Let_def split!: if_split)

lemma hd_neq_induct [consumes 1, case_names emp snoc_eq snoc_neq]:
  assumes invariant: "us = \<epsilon> \<or> hd us \<noteq> w"
      and emp: "P \<epsilon>"
      and snoc_eq: "\<And>us. us \<noteq> \<epsilon> \<Longrightarrow> hd us \<noteq> w \<Longrightarrow> P us \<Longrightarrow> P (us \<cdot> [w])"
      and snoc_neq: "\<And>u us. u \<noteq> w \<Longrightarrow> us = \<epsilon> \<or> hd us \<noteq> w \<Longrightarrow> P us \<Longrightarrow> P (us \<cdot> [u])"
  shows "P us"
using last_neq_induct[where P="\<lambda>x. P (rev x)" for P, reversed, unfolded rev_rev_ident, OF assms].

lemma gluer_rev [reversal_rule]: assumes "us = \<epsilon> \<or> last us \<noteq> w"
  shows "gluer (rev w) (rev (map rev us)) =  rev (map rev (glue w us))"
  using assms by (induction us rule: last_neq_induct)
    (simp_all add: gluer_nemp_def Let_def map_tl last_rev hd_map)

lemma glue_rev [reversal_rule]: assumes "us = \<epsilon> \<or> hd us \<noteq> w"
  shows "glue (rev w) (rev (map rev us)) =  rev (map rev (gluer w us))"
  using assms by (induction us rule: hd_neq_induct)
    (simp_all add: gluer_nemp_def Let_def map_tl last_rev hd_map)

section \<open>Generators with glued element\<close>

text \<open>The following set will turn out to be the generating set of all words whose
 decomposition into a generating code does not end with w\<close>

inductive_set glued_gens :: "'a list \<Rightarrow> 'a list set \<Rightarrow> 'a list set"
  for w G where
    other_gen: "g \<in> G \<Longrightarrow> g \<noteq> w \<Longrightarrow> g \<in> glued_gens w G"
  | glued [intro!]: "u \<in> glued_gens w G \<Longrightarrow>  w \<cdot> u \<in> glued_gens w G"

lemma in_glued_gensI: assumes "g \<in> G" "g \<noteq> w"
  shows "w \<^sup>@ k \<cdot> g = u \<Longrightarrow> u \<in> glued_gens w G"
  by (induction k arbitrary: u) (auto simp: other_gen[OF \<open>g \<in> G\<close> \<open>g \<noteq> w\<close>])

lemma in_glued_gensE:
  assumes "u \<in> glued_gens w G"
  obtains k g where "g \<in> G" and "g \<noteq> w" and "w \<^sup>@ k \<cdot> g = u"
using assms proof (induction)
  case (glued u)
    show ?case by (auto intro!: glued.IH[OF glued.prems[of _ "Suc _"]])
qed (use pow_zero in blast)

lemma glued_gens_alt_def: "glued_gens w C = {w \<^sup>@ k \<cdot> g | k g. g \<in> C \<and> g \<noteq> w}"
  by (blast elim!: in_glued_gensE intro: in_glued_gensI)

lemma glued_hull_sub_hull [simp, intro!]: "w \<in> G \<Longrightarrow> \<langle>glued_gens w G\<rangle> \<subseteq> \<langle>G\<rangle>"
  by (rule hull_mono') (auto elim!: in_glued_gensE)

lemma glued_hull_sub_hull': "w \<in> G \<Longrightarrow> u \<in> \<langle>glued_gens w G\<rangle> \<Longrightarrow> u \<in> \<langle>G\<rangle>"
  using set_mp[OF glued_hull_sub_hull].

lemma in_glued_hullE:
  assumes "w \<in> G" and "u \<in> \<langle>glued_gens w G\<rangle>"
  obtains us where "concat us = u" and "us \<in> lists G" and "us = \<epsilon> \<or> last us \<noteq> w"
using \<open>u \<in> \<langle>glued_gens w G\<rangle>\<close> proof (induction arbitrary: thesis)
  case (prod_cl v u)
    obtain k g where "g \<in> G" and "g \<noteq> w" and "concat ([w] \<^sup>@ k \<cdot> [g]) = v"
      using \<open>v \<in> glued_gens w G\<close> by (simp add: concat_pow) (elim in_glued_gensE)
    obtain us where u: "concat us = u" and "us \<in> lists G" and "(us = \<epsilon> \<or> last us \<noteq> w)" by fact
    have "concat ([w] \<^sup>@ k \<cdot> [g] \<cdot> us) = v \<cdot> u"
      by (simp flip: \<open>concat ([w] \<^sup>@ k \<cdot> [g]) = v\<close> \<open>concat us = u\<close>)
    with \<open>(us = \<epsilon> \<or> last us \<noteq> w)\<close> show thesis
      by (elim prod_cl.prems, intro lists.intros
          append_in_lists pow_in_lists \<open>w \<in> G\<close> \<open>g \<in> G\<close> \<open>us \<in> lists G\<close>)
         (auto simp: \<open>g \<noteq> w\<close>)
qed (use concat.simps(1) in blast)

lemma glue_in_lists [simp, intro!]:
  assumes "us = \<epsilon> \<or> last us \<noteq> w"
  shows "us \<in> lists G \<Longrightarrow> glue w us \<in> lists (glued_gens w G)"
  using assms by (induction rule: last_neq_block_induct)
    (auto simp: glue_block_append intro: in_glued_gensI)

lemma concat_in_glued_hull[intro]:
  "us \<in> lists G \<Longrightarrow> us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> concat us \<in> \<langle>glued_gens w G\<rangle>"
  unfolding concat_glue[symmetric] by (intro concat_in_hull' glue_in_lists)

lemma glued_hull_conv: assumes "w \<in> G"
  shows "\<langle>glued_gens w G\<rangle> = {concat us | us. us \<in> lists G \<and> (us = \<epsilon> \<or> last us \<noteq> w)}"
  by (blast elim!: in_glued_hullE[OF \<open>w \<in> G\<close>])

section \<open>Bounded gluing\<close>

lemma bounded_glue_in_lists:
  assumes "us = \<epsilon> \<or> last us \<noteq> w" and "\<not> [w] \<^sup>@ n \<le>f us"
  shows "us \<in> lists G \<Longrightarrow> glue w us \<in> lists {w \<^sup>@ k \<cdot> g | k g. g \<in> G \<and> g \<noteq> w \<and> k < n}"
using assms proof (induction us rule: last_neq_block_induct)
  case (block k u us)
    have "k < n" and "\<not> [w] \<^sup>@ n \<le>f us"
      using \<open>\<not> [w] \<^sup>@ n \<le>f [w] \<^sup>@ k \<cdot> u # us\<close>
      by (blast intro!: not_le_imp_less pref_ext le_exps_pref, blast intro!: fac_ext_pref fac_ext_hd)
    then show ?case
      using \<open>[w] \<^sup>@ k \<cdot> u # us \<in> lists G\<close> \<open>u \<noteq> w\<close> unfolding glue_block_append[OF \<open>u \<noteq> w\<close>]
      by (blast intro!: block.IH del: in_listsD in_listsI)
qed simp

subsection \<open>Gluing on binary alphabet\<close>

lemma bounded_bin_glue_in_lists: \<comment> \<open>meaning: a binary code\<close>
  assumes "us = \<epsilon> \<or> last us \<noteq> x"
      and "\<not> [x] \<^sup>@ n \<le>f us"
      and "us \<in> lists {x, y}"
  shows "glue x us \<in> lists {x \<^sup>@ k \<cdot> y | k. k < n}"
using bounded_glue_in_lists[OF assms] by blast

lemma single_bin_glue_in_lists: \<comment> \<open>meaning: a single occurrence\<close>
  assumes "us = \<epsilon> \<or> last us \<noteq> x"
      and "\<not> [x,x] \<le>f us"
      and "us \<in> lists {x, y}"
  shows "glue x us \<in> lists {x \<cdot> y, y}"
  using bounded_bin_glue_in_lists[of _ _ 2, simplified, OF assms] unfolding numeral_nat
  by (auto elim!: sub_lists_mono[rotated] less_SucE)

lemma count_list_single_bin_glue:
  assumes "x \<noteq> \<epsilon>" and "x \<noteq> y"
      and "us = \<epsilon> \<or> last us \<noteq> x"
      and "us \<in> lists {x,y}"
      and "\<not> [x,x] \<le>f us"
  shows "count_list (glue x us) (x \<cdot> y) = count_list us x"
    and "count_list (glue x us) y + count_list us x = count_list us y"
using assms(3-5) unfolding atomize_conj pow_Suc[symmetric]
proof (induction us rule: last_neq_block_induct)
  case (block k u us)
    have "u = y" using \<open>[x] \<^sup>@ k \<cdot> u # us \<in> lists {x, y}\<close> \<open>u \<noteq> x\<close> by simp
    have IH: "count_list (glue x us) (x \<cdot> y) = count_list us x \<and>
              count_list (glue x us) y + count_list us x = count_list us y"
      using block.prems by (intro block.IH) (simp, blast intro!: fac_ext_pref fac_ext_hd)
    have "\<not> [x] \<^sup>@ Suc (Suc 0) \<le>f [x] \<^sup>@ k \<cdot> u # us"
      using block.prems(2) by auto
    then have "k < Suc (Suc 0)"
      by (blast intro!: not_le_imp_less pref_ext le_exps_pref)
    then show ?case unfolding \<open>u = y\<close> glue_block_append[OF \<open>x \<noteq> y\<close>[symmetric]]
      by (elim less_SucE less_zeroE) (simp_all add: \<open>x \<noteq> y\<close> \<open>x \<noteq> y\<close>[symmetric] \<open>x \<noteq> \<epsilon>\<close> IH)
qed simp

section \<open>Code with glued element\<close>

context code
begin

text \<open>If the original generating set is a code, then also the glued generators form a code\<close>

lemma glued_hull_last_dec: assumes "w \<in> \<C>" and  "u \<in> \<langle>glued_gens w \<C>\<rangle>" and "u \<noteq> \<epsilon>"
  shows "last (Dec \<C> u) \<noteq> w"
  using \<open>u \<in> \<langle>glued_gens w \<C>\<rangle>\<close>
  by (elim in_glued_hullE[OF \<open>w \<in> \<C>\<close>]) (auto simp: code_unique_dec \<open>u \<noteq> \<epsilon>\<close>)

lemma in_glued_hullI [intro]:
  assumes "u \<in> \<langle>\<C>\<rangle>" and "(u = \<epsilon> \<or> last (Dec \<C> u) \<noteq> w)"
  shows "u \<in> \<langle>glued_gens w \<C>\<rangle>"
  using concat_in_glued_hull[OF dec_in_lists[OF \<open>u \<in> \<langle>\<C>\<rangle>\<close>], of w]
  by (simp add: \<open>u \<in> \<langle>\<C>\<rangle>\<close> \<open>u = \<epsilon> \<or> last (Dec \<C> u) \<noteq> w\<close>)

lemma code_glued_hull_conv: assumes "w \<in> \<C>"
  shows "\<langle>glued_gens w \<C>\<rangle> = {u \<in> \<langle>\<C>\<rangle>. u = \<epsilon> \<or> last (Dec \<C> u) \<noteq> w}"
proof
  show "\<langle>glued_gens w \<C>\<rangle> \<subseteq> {u \<in> \<langle>\<C>\<rangle>. u = \<epsilon> \<or> last (Dec \<C> u) \<noteq> w}"
    using glued_hull_sub_hull'[OF \<open>w \<in> \<C>\<close>] glued_hull_last_dec[OF \<open>w \<in> \<C>\<close>] by blast
  show "{u \<in> \<langle>\<C>\<rangle>. u = \<epsilon> \<or> last (Dec \<C> u) \<noteq> w} \<subseteq> \<langle>glued_gens w \<C>\<rangle>"
    using in_glued_hullI by blast
qed

lemma in_glued_hull_iff:
  assumes "w \<in> \<C>" and "u \<in> \<langle>\<C>\<rangle>"
  shows "u \<in> \<langle>glued_gens w \<C>\<rangle> \<longleftrightarrow> u = \<epsilon> \<or> last (Dec \<C> u) \<noteq> w"
  by (simp add: \<open>w \<in> \<C>\<close> \<open>u \<in> \<langle>\<C>\<rangle>\<close> code_glued_hull_conv)

lemma glued_not_in_glued_hull: "w \<in> \<C> \<Longrightarrow> w \<notin> \<langle>glued_gens w \<C>\<rangle>"
  unfolding in_glued_hull_iff[OF _ gen_in] code_el_dec
  by (simp add: in_code_nemp)

lemma glued_gens_nemp: assumes "u \<in> glued_gens w \<C>" shows "u \<noteq> \<epsilon>"
  using assms by (induction) (auto simp add: in_code_nemp)

lemma glued_gens_code: assumes "w \<in> \<C>" shows "code (glued_gens w \<C>)"
proof
  show "us = vs" if "us \<in> lists (glued_gens w \<C>)" and "vs \<in> lists (glued_gens w \<C>)"
    and "concat us = concat vs" for us vs
  using that proof (induction rule: list_induct2')
    case (4 u us v vs)
      have *: "us \<in> lists (glued_gens w \<C>) \<Longrightarrow> us \<in> lists \<langle>\<C>\<rangle>" for us
        using sub_lists_mono[OF subset_trans[OF genset_sub glued_hull_sub_hull[OF \<open>w \<in> \<C>\<close>]]].
      obtain k u' l v'
        where "u' \<in> \<C>" "u' \<noteq> w" "w \<^sup>@ k \<cdot> u' = u"
          and "v' \<in> \<C>" "v' \<noteq> w" "w \<^sup>@ l \<cdot> v' = v"
        using "4.prems"(1-2) by simp (elim conjE in_glued_gensE)
      from this(3, 6) "4.prems" \<open>w \<in> \<C>\<close>
      have "concat (([w] \<^sup>@ k \<cdot> [u']) \<cdot> (Ref \<C> us)) = concat (([w] \<^sup>@ l \<cdot> [v']) \<cdot> (Ref \<C> vs))"
        by (simp add: concat_ref * concat_pow lassoc)
      with \<open>w \<in> \<C>\<close> \<open>u' \<in> \<C>\<close> \<open>v' \<in> \<C>\<close> "4.prems"(1-2)
      have "[w] \<^sup>@ k \<cdot> [u'] \<bowtie> [w] \<^sup>@ l \<cdot> [v']"
        by (elim eqd_comp[OF is_code, rotated 2])
        (simp_all add: "*" pow_in_lists ref_in')
      with \<open>u' \<noteq> w\<close> \<open>v' \<noteq> w\<close> \<open>w \<^sup>@ k \<cdot> u' = u\<close> \<open>w \<^sup>@ l \<cdot> v' = v\<close>
      have "u = v"
        by (elim sing_pref_comp_mismatch[rotated 2, elim_format]) blast+
      then show "u # us = v # vs"
        using "4.IH" "4.prems"(1-3) by simp
  qed (auto dest!: glued_gens_nemp)
qed

text \<open>A crucial lemma showing the relation between gluing and the decomposition into generators\<close>

lemma dec_glued_gens: assumes "w \<in> \<C>" and "u \<in> \<langle>glued_gens w \<C>\<rangle>"
  shows "Dec (glued_gens w \<C>) u = glue w (Dec \<C> u)"
  using \<open>u \<in> \<langle>glued_gens w \<C>\<rangle>\<close> glued_hull_sub_hull'[OF \<open>w \<in> \<C>\<close> \<open>u \<in> \<langle>glued_gens w \<C>\<rangle>\<close>]
  by (intro code.code_unique_dec glued_gens_code)
     (simp_all add: in_glued_hull_iff \<open>w \<in> \<C>\<close>)

lemma ref_glue: "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> us \<in> lists \<C> \<Longrightarrow> Ref \<C> (glue w us) = us"
  by (intro refI glue_in_lists_hull) simp_all

end (* end of context code *)

theorem glued_code:
  assumes "code C" and "w \<in> C"
  shows "code {w \<^sup>@ k \<cdot> u |k u. u \<in> C \<and> u \<noteq> w}"
  using code.glued_gens_code[OF \<open>code C\<close> \<open>w \<in> C\<close>] unfolding glued_gens_alt_def.

section \<open>Gluing is primitivity preserving\<close>

text \<open>It is easy to obtain that gluing lists of code elements preserves primitivity.
We provide the result under weaker condition where glue blocks of the list
have unique concatenation.\<close>

lemma (in code) code_prim_glue:
  assumes last_neq: "us = \<epsilon> \<or> last us \<noteq> w"
      and "us \<in> lists \<C>"
  shows "primitive us \<Longrightarrow> primitive (glue w us)"
  using prim_map_prim[OF prim_concat_prim, of "decompose \<C>" "glue w us"]
  unfolding refine_def[symmetric] ref_glue[OF assms].

\<comment> \<open>In the context of code the inverse to the glue function is the @{const refine} function,
i.e. @{term "\<lambda>vs. concat (map (decompose \<C>) vs)"}, see @{thm code.ref_glue}.
The role of the @{const decompose} function outside the code context supply the 'unglue' function,
which maps glued blocks to its unique preimages (see below).\<close>

definition glue_block :: "'a list \<Rightarrow>'a list list \<Rightarrow> 'a list list \<Rightarrow> bool"
  where "glue_block w us bs =
    (\<exists>ps k u ss. (ps = \<epsilon> \<or> last ps \<noteq> w) \<and> u \<noteq> w \<and> ps \<cdot> [w] \<^sup>@ k \<cdot> u # ss = us \<and> [w] \<^sup>@ k \<cdot> [u] = bs)"

lemma glue_blockI [intro]:
  "ps = \<epsilon> \<or> last ps \<noteq> w \<Longrightarrow> u \<noteq> w \<Longrightarrow> ps \<cdot> [w] \<^sup>@ k \<cdot> u # ss = us \<Longrightarrow> [w] \<^sup>@ k \<cdot> [u] = bs
    \<Longrightarrow> glue_block w us bs"
  unfolding glue_block_def by (intro exI conjI)

lemma glue_blockE:
  assumes "glue_block w us bs"
  obtains ps k u ss where "ps = \<epsilon> \<or> last ps \<noteq> w" and "u \<noteq> w" "ps \<cdot> [w] \<^sup>@ k \<cdot> u # ss = us"
      and "[w] \<^sup>@ k \<cdot> [u] = bs"
  using assms unfolding glue_block_def by (elim exE conjE)

lemma assumes "glue_block w us bs"
  shows glue_block_of_appendL: "glue_block w (us \<cdot> vs) bs"
    and glue_block_of_appendR: "vs = \<epsilon> \<or> last vs \<noteq> w \<Longrightarrow> glue_block w (vs \<cdot> us) bs"
  using \<open>glue_block w us bs\<close> by (elim glue_blockE, use nothing in \<open>
    intro glue_blockI[of _ w _ _ "_ \<cdot> vs" "us \<cdot> vs" bs]
          glue_blockI[OF append_last_neq, of "vs"  w _ _ _ _ "vs \<cdot> us" bs],
    simp_all only: eq_commute[of _ us] rassoc append_Cons refl not_False_eq_True\<close>)+

lemma glue_block_of_block_append:
  "u \<noteq> w \<Longrightarrow> glue_block w us bs \<Longrightarrow> glue_block w ([w] \<^sup>@ k \<cdot> u # us) bs"
  by (simp only: hd_word[of _ us] lassoc) (elim glue_block_of_appendR, simp_all)

lemma in_set_glueE:
  assumes last_neq: "us = \<epsilon> \<or> last us \<noteq> w"
      and "b \<in> set (glue w us)"
  obtains bs where "glue_block w us bs" and "concat bs = b"
using assms proof (induction us rule: last_neq_block_induct)
  case (block k u us)
    show thesis using \<open>b \<in> set (glue w ([w] \<^sup>@ k \<cdot> u # us))\<close>
      proof (auto simp add: glue_block_append \<open>u \<noteq> w\<close>)
        show "b = w \<^sup>@ k \<cdot> u \<Longrightarrow> thesis"
          by (auto simp add: concat_pow intro!: block.prems(1) glue_blockI[OF _ \<open>u \<noteq> w\<close> _ refl])
        show "b \<in> set (glue w us) \<Longrightarrow> thesis"
          by (auto intro!: block.IH[OF block.prems(1)] glue_block_of_block_append \<open>u \<noteq> w\<close>)
      qed
qed simp

definition unglue :: "'a list \<Rightarrow> 'a list list \<Rightarrow> 'a list \<Rightarrow> 'a list list"
  where "unglue w us b = (THE bs. glue_block w us bs \<and> concat bs = b)"

lemma unglueI:
  assumes unique_blocks: "\<And>bs\<^sub>1 bs\<^sub>2. glue_block w us bs\<^sub>1 \<Longrightarrow> glue_block w us bs\<^sub>2
            \<Longrightarrow> concat bs\<^sub>1 = concat bs\<^sub>2 \<Longrightarrow> bs\<^sub>1 = bs\<^sub>2"
  shows "glue_block w us bs \<Longrightarrow> concat bs = b \<Longrightarrow> unglue w us b = bs"
  unfolding unglue_def by (blast intro: unique_blocks)

lemma concat_map_unglue_glue:
  assumes last_neq: "us = \<epsilon> \<or> last us \<noteq> w"
      and unique_blocks: "\<And>vs\<^sub>1 vs\<^sub>2. glue_block w us vs\<^sub>1 \<Longrightarrow> glue_block w us vs\<^sub>2
            \<Longrightarrow> concat vs\<^sub>1 = concat vs\<^sub>2 \<Longrightarrow> vs\<^sub>1 = vs\<^sub>2"
  shows "concat (map (unglue w us) (glue w us)) = us"
using assms proof (induction us rule: last_neq_block_induct)
  case (block k u us)
    have IH: "concat (map (unglue w us) (glue w us)) = us"
      using block.IH[OF block.prems] by (blast intro!: glue_block_of_block_append \<open>u \<noteq> w\<close>)
    have *: "map (unglue w ([w] \<^sup>@ k \<cdot> u # us)) (glue w us) = map (unglue w us) (glue w us)"
      by (auto simp only: map_eq_conv unglue_def del: the_equality
          elim!: in_set_glueE[OF \<open>us = \<epsilon> \<or> last us \<noteq> w\<close>], intro the_equality)
         (simp_all only: the_equality block.prems glue_block_of_block_append[OF \<open>u \<noteq> w\<close>])
    show "concat (map (unglue w ([w] \<^sup>@ k \<cdot> u # us)) (glue w ([w] \<^sup>@ k \<cdot> u # us))) = [w] \<^sup>@ k \<cdot> u # us"
      by (auto simp add: concat_pow glue_block_append[OF \<open>u \<noteq> w\<close>] * IH
          intro!: unglueI intro: glue_blockI[OF _ \<open>u \<noteq> w\<close>] block.prems)
qed simp

lemma prim_glue:
  assumes last_neq: "us = \<epsilon> \<or> last us \<noteq> w"
      and unique_blocks: "\<And>bs\<^sub>1 bs\<^sub>2. glue_block w us bs\<^sub>1 \<Longrightarrow> glue_block w us bs\<^sub>2
            \<Longrightarrow> concat bs\<^sub>1 = concat bs\<^sub>2 \<Longrightarrow> bs\<^sub>1 = bs\<^sub>2"
  shows "primitive us \<Longrightarrow> primitive (glue w us)"
  using prim_map_prim[OF prim_concat_prim, of "unglue w us" "glue w us"]
  by (simp only: concat_map_unglue_glue assms)

subsection \<open>Gluing on binary alphabet\<close>

lemma bin_glue_blockE:
  assumes "us \<in> lists {x, y}"
      and "glue_block x us bs"
  obtains k where "[x] \<^sup>@ k \<cdot> [y] = bs"
  using assms by (auto simp only: glue_block_def del: in_listsD)

lemma unique_bin_glue_blocks:
  assumes "us \<in> lists {x, y}" and "x \<noteq> \<epsilon>"
  shows "glue_block x us bs\<^sub>1 \<Longrightarrow> glue_block x us bs\<^sub>2 \<Longrightarrow> concat bs\<^sub>1 = concat bs\<^sub>2 \<Longrightarrow> bs\<^sub>1 = bs\<^sub>2"
  by (auto simp: concat_pow eq_pow_exp[OF \<open>x \<noteq> \<epsilon>\<close>] elim!: bin_glue_blockE[OF \<open>us \<in> lists {x, y}\<close>])

lemma prim_bin_glue:
  assumes "us \<in> lists {x, y}" and "x \<noteq> \<epsilon>"
      and "us = \<epsilon> \<or> last us \<noteq> x"
  shows "primitive us \<Longrightarrow> primitive (glue x us)"
  using prim_glue[OF \<open>us = \<epsilon> \<or> last us \<noteq> x\<close> unique_bin_glue_blocks[OF assms(1-2)]].

end